switch tests to hspec, improve error messages

Language/SQL/SimpleSQL/Lex.hs

@@ -74,7 +74,6 @@ try again to add annotation to the ast
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards   #-}
 {-# LANGUAGE TypeFamilies      #-}
-
 module Language.SQL.SimpleSQL.Lex
     (Token(..)
     ,WithPos(..)
@@ -111,21 +110,26 @@ import Text.Megaparsec
     ,pstateSourcePos
     ,statePosState
     ,mkPos
+    ,hidden
+    ,setErrorOffset
 
     ,choice
     ,satisfy
     ,takeWhileP
     ,takeWhile1P
-    ,(<?>)
     ,eof
     ,many
     ,try
     ,option
     ,(<|>)
     ,notFollowedBy
-    ,manyTill
-    ,anySingle
     ,lookAhead
+    ,match
+    ,optional
+    ,label
+    ,chunk
+    ,region
+    ,anySingle
     )
 import qualified Text.Megaparsec as M
 import Text.Megaparsec.Char
@@ -139,17 +143,17 @@ import qualified Data.List.NonEmpty as NE
 import Data.Proxy (Proxy(..))
 import Data.Void (Void)
 
-import Control.Applicative ((<**>))
 import Data.Char
     (isAlphaNum
     ,isAlpha
     ,isSpace
     ,isDigit
     )
-import Control.Monad (void, guard)
+import Control.Monad (void)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Maybe (fromMaybe)
+--import Text.Megaparsec.Debug (dbg)
 
 ------------------------------------------------------------------------------
 
@@ -189,16 +193,26 @@ data Token
     | LineComment Text
     -- | A block comment, \/* stuff *\/, includes the comment delimiters
     | BlockComment Text
+    -- | Used for generating better error messages when using the
+    --     output of the lexer in a parser
+    | InvalidToken Text
       deriving (Eq,Show,Ord)
 
 ------------------------------------------------------------------------------
 
 -- main api functions
 
--- | Lex some SQL to a list of tokens.
+-- | Lex some SQL to a list of tokens. The invalid token setting
+-- changes the behaviour so that if there's a parse error at the start
+-- of parsing an invalid token, it adds a final InvalidToken with the
+-- character to the result then stop parsing. This can then be used to
+-- produce a parse error with more context in the parser. Parse errors
+-- within tokens still produce Left errors.
 lexSQLWithPositions
     :: Dialect
     -- ^ dialect of SQL to use
+    -> Bool
+    -- ^ produce InvalidToken
     -> Text
     -- ^ filename to use in error messages
     -> Maybe (Int,Int)
@@ -207,13 +221,14 @@ lexSQLWithPositions
     -> Text
     -- ^ the SQL source to lex
     -> Either ParseError [WithPos Token]
-lexSQLWithPositions dialect fn p src = myParse fn p (many (sqlToken dialect) <* (eof <?> "")) src
+lexSQLWithPositions dialect pit fn p src = myParse fn p (tokens dialect pit) src
-
 
 -- | Lex some SQL to a list of tokens.
 lexSQL
     :: Dialect
     -- ^ dialect of SQL to use
+    -> Bool
+    -- ^ produce InvalidToken, see lexSQLWithPositions
     -> Text
     -- ^ filename to use in error messages
     -> Maybe (Int,Int)
@@ -222,8 +237,8 @@ lexSQL
     -> Text
     -- ^ the SQL source to lex
     -> Either ParseError [Token]
-lexSQL dialect fn p src =
+lexSQL dialect pit fn p src =
-    map tokenVal <$> lexSQLWithPositions dialect fn p src
+    map tokenVal <$> lexSQLWithPositions dialect pit fn p src
 
 myParse :: Text -> Maybe (Int,Int) -> Parser a -> Text -> Either ParseError a
 myParse name sp' p s =
@@ -271,6 +286,7 @@ prettyToken _ (SqlNumber r) = r
 prettyToken _ (Whitespace t) = t
 prettyToken _ (LineComment l) = l
 prettyToken _ (BlockComment c) = c
+prettyToken _ (InvalidToken t) = t
 
 prettyTokens :: Dialect -> [Token] -> Text
 prettyTokens d ts = T.concat $ map (prettyToken d) ts
@@ -281,24 +297,54 @@ prettyTokens d ts = T.concat $ map (prettyToken d) ts
 
 -- | parser for a sql token
 sqlToken :: Dialect -> Parser (WithPos Token)
-sqlToken d = (do
+sqlToken d =
-    -- possibly there's a more efficient way of doing the source positions?
+    withPos $ hidden $ choice $
+    [sqlString d
+    ,identifier d
+    ,lineComment d
+    ,blockComment d
+    ,sqlNumber d
+    ,positionalArg d
+    ,dontParseEndBlockComment d
+    ,prefixedVariable d
+    ,symbol d
+    ,sqlWhitespace d]
+
+--fakeSourcePos :: SourcePos
+--fakeSourcePos = SourcePos "" (mkPos 1) (mkPos 1)
+
+--------------------------------------
+
+-- position and error helpers
+
+withPos :: Parser a -> Parser (WithPos a)
+withPos p = do
     sp <- getSourcePos
     off <- getOffset
-    t <- choice
+    a <- p
-         [sqlString d
-         ,identifier d
-         ,lineComment d
-         ,blockComment d
-         ,sqlNumber d
-         ,positionalArg d
-         ,dontParseEndBlockComment d
-         ,prefixedVariable d
-         ,symbol d
-         ,sqlWhitespace d]
     off1 <- getOffset
     ep <- getSourcePos
-    pure $ WithPos sp ep (off1 - off) t) <?> "valid lexical token"
+    pure $ WithPos sp ep (off1 - off) a
+
+{-
+
+TODO: extend this idea, to recover to parsing regular tokens after an
+invalid one. This can then support resumption after error in the parser.
+This would also need something similar being done for parse errors
+within lexical tokens.
+
+-}
+invalidToken :: Dialect -> Parser (WithPos Token)
+invalidToken _ =
+    withPos $ (hidden eof *> fail "") <|> (InvalidToken . T.singleton <$> anySingle)
+
+tokens :: Dialect -> Bool -> Parser [WithPos Token]
+tokens d pit = do
+    x <- many (sqlToken d)
+    if pit
+        then choice [x <$ hidden eof
+                    ,(\y -> x ++ [y]) <$> hidden (invalidToken d)]
+        else x <$ hidden eof
 
 --------------------------------------
 
@@ -313,27 +359,38 @@ x'hexidecimal string'
 -}
 
 sqlString :: Dialect -> Parser Token
-sqlString d = dollarString <|> csString <|> normalString
+sqlString d =
+    (if (diDollarString d)
+     then (dollarString <|>)
+     else id) csString <|> normalString
   where
     dollarString = do
-        guard $ diDollarString d
         -- use try because of ambiguity with symbols and with
         -- positional arg
-        delim <- (\x -> T.concat ["$",x,"$"])
+        delim <- fstMatch (try (char '$' *> hoptional_ identifierString <* char '$'))
-                 <$> try (char '$' *> option "" identifierString <* char '$')
+        let moreDollarString =
-        SqlString delim delim . T.pack <$> manyTill anySingle (try $ string delim)
+                label (T.unpack delim) $ takeWhileP_ Nothing (/='$') *> checkDollar
-    normalString = SqlString "'" "'" <$> (char '\'' *> normalStringSuffix False "")
+            checkDollar = label (T.unpack delim) $ 
-    normalStringSuffix allowBackslash t = do
+                choice
-        s <- takeWhileP Nothing $ if allowBackslash
+                [lookAhead (chunk_ delim) *> pure () -- would be nice not to parse it twice?
-                                  then (`notElemChar` "'\\")
+                                                     -- but makes the whole match trick much less neat
-                                  else (/= '\'')
+                ,char_ '$' *> moreDollarString]
-        -- deal with '' or \' as literal quote character
+        str <- fstMatch moreDollarString
-        choice [do
+        chunk_ delim
-                ctu <- choice ["''" <$ try (string "''")
+        pure $ SqlString delim delim str
-                              ,"\\'" <$ string "\\'"
+    lq = label "'" $ char_ '\''
-                              ,"\\" <$ char '\\']
+    normalString = SqlString "'" "'" <$> (lq *> normalStringSuffix False)
-                normalStringSuffix allowBackslash $ T.concat [t,s,ctu]
+    normalStringSuffix allowBackslash = label "'" $ do
-               ,T.concat [t,s] <$ char '\'']
+        let regularChar = if allowBackslash
+                          then (\x -> x /= '\'' && x /='\\')
+                          else (\x -> x /= '\'')
+            nonQuoteStringChar = takeWhileP_ Nothing regularChar
+            nonRegularContinue = 
+                (hchunk_ "''" <|> hchunk_ "\\'" <|> hchar_ '\\')
+            moreChars = nonQuoteStringChar
+                *> (option () (nonRegularContinue *> moreChars))
+        fstMatch moreChars <* lq
+            
     -- try is used to to avoid conflicts with
     -- identifiers which can start with n,b,x,u
     -- once we read the quote type and the starting '
@@ -345,13 +402,13 @@ sqlString d = dollarString <|> csString <|> normalString
     csString
       | diEString d =
         choice [SqlString <$> try (string "e'" <|> string "E'")
-                          <*> pure "'" <*> normalStringSuffix True ""
+                          <*> pure "'" <*> normalStringSuffix True
                ,csString']
       | otherwise = csString'
     csString' = SqlString
                 <$> try cs
                 <*> pure "'"
-                <*> normalStringSuffix False ""
+                <*> normalStringSuffix False
     csPrefixes = map (`T.cons` "'") "nNbBxX" ++ ["u&'", "U&'"]
     cs :: Parser Text
     cs = choice $ map string csPrefixes
@@ -370,42 +427,49 @@ u&"unicode quoted identifier"
 
 identifier :: Dialect -> Parser Token
 identifier d =
-    choice
+    choice $
     [quotedIden
     ,unicodeQuotedIden
-    ,regularIden
+    ,regularIden]
-    ,guard (diBackquotedIden d) >> mySqlQuotedIden
+    ++ [mySqlQuotedIden | diBackquotedIden d]
-    ,guard (diSquareBracketQuotedIden d) >> sqlServerQuotedIden
+    ++ [sqlServerQuotedIden | diSquareBracketQuotedIden d]
-    ]
   where
     regularIden = Identifier Nothing <$> identifierString
-    quotedIden = Identifier (Just ("\"","\"")) <$> qidenPart
+    quotedIden = Identifier (Just ("\"","\"")) <$> qiden
-    mySqlQuotedIden = Identifier (Just ("`","`"))
+    failEmptyIden c = failOnThis (char_ c) "empty identifier"
-                      <$> (char '`' *> takeWhile1P Nothing (/='`') <* char '`')
+    mySqlQuotedIden =
-    sqlServerQuotedIden = Identifier (Just ("[","]"))
+        Identifier (Just ("`","`")) <$>
-                          <$> (char '[' *> takeWhile1P Nothing (`notElemChar` "[]") <* char ']')
+        (char_ '`' *>
+         (failEmptyIden '`'
+          <|> (takeWhile1P Nothing (/='`') <* char_ '`')))
+    sqlServerQuotedIden =
+        Identifier (Just ("[","]")) <$>
+        (char_ '[' *>
+         (failEmptyIden ']'
+         <|> (takeWhileP Nothing (`notElemChar` "[]")
+              <* choice [char_ ']'
+                         -- should probably do this error message as
+                         -- a proper unexpected message
+                         ,failOnThis (char_ '[') "unexpected ["])))
     -- try is used here to avoid a conflict with identifiers
     -- and quoted strings which also start with a 'u'
     unicodeQuotedIden = Identifier
                         <$> (f <$> try (oneOf "uU" <* string "&"))
-                        <*> qidenPart
+                        <*> qiden
       where f x = Just (T.cons x "&\"", "\"")
-    qidenPart = char '"' *> qidenSuffix ""
+    qiden =
-    qidenSuffix t = do
+        char_ '"' *> (failEmptyIden '"' <|> fstMatch moreQIden <* char_ '"')
-        s <- takeWhileP Nothing (/='"')
+    moreQIden =
-        void $ char '"'
+        label "\""
-        -- deal with "" as literal double quote character
+        (takeWhileP_ Nothing (/='"')
-        choice [do
+         *> hoptional_ (chunk "\"\"" *> moreQIden))
-                void $ char '"'
-                qidenSuffix $ T.concat [t,s,"\"\""]
-               ,pure $ T.concat [t,s]]
 
 identifierString :: Parser Text
-identifierString = (do
+identifierString = label "identifier" $ do
     c <- satisfy isFirstLetter
     choice
-        [T.cons c <$> takeWhileP (Just "identifier char") isIdentifierChar
+        [T.cons c <$> takeWhileP Nothing isIdentifierChar
-        ,pure $ T.singleton c]) <?> "identifier"
+        ,pure $ T.singleton c]
   where
      isFirstLetter c = c == '_' || isAlpha c
 
@@ -415,12 +479,11 @@ isIdentifierChar c = c == '_' || isAlphaNum c
 --------------------------------------
 
 lineComment :: Dialect -> Parser Token
-lineComment _ = do
+lineComment _ = LineComment <$> fstMatch (do
-    try (string_ "--") <?> ""
+    hidden (string_ "--")
-    rest <- takeWhileP (Just "non newline character") (/='\n')
+    takeWhileP_ Nothing (/='\n')
     -- can you optionally read the \n to terminate the takewhilep without reparsing it?
-    suf <- option "" ("\n" <$ char_ '\n')
+    hoptional_  $ char_ '\n')
-    pure $ LineComment $ T.concat ["--", rest, suf]
 
 --------------------------------------
 
@@ -428,28 +491,30 @@ lineComment _ = do
 -- I don't know any dialects that use this, but I think it's useful, if needed,
 -- add it back in under a dialect flag?
 blockComment :: Dialect -> Parser Token
-blockComment _ = (do
+blockComment _ = BlockComment <$> fstMatch bc
-    try $ string_ "/*"
-    BlockComment . T.concat . ("/*":) <$> more) <?> ""
   where
-    more = choice
+    bc = chunk_ "/*" *> moreBlockChars
-        [["*/"] <$ try (string_ "*/")  -- comment ended
+    regularBlockCommentChars = label "*/" $
-        ,char_ '*' *> (("*":) <$> more) -- comment contains * but this isn't the comment end token
+        takeWhileP_ Nothing (\x -> x /= '*' && x /= '/')
-        -- not sure if there's an easy optimisation here
+    continueBlockComment = label "*/" (char_ '*' <|> char_ '/') *> moreBlockChars
-        ,(:) <$> takeWhile1P (Just "non comment terminator text") (/= '*') <*> more]
+    endComment = label "*/" $ chunk_ "*/"
+    moreBlockChars = label "*/" $
+        regularBlockCommentChars
+        *> (endComment
+           <|> (label "*/" bc *> moreBlockChars) -- nest
+           <|> continueBlockComment)
 
 {-
 This is to improve user experience: provide an error if we see */
 outside a comment. This could potentially break postgres ops with */
-in them (which is a stupid thing to do). In other cases, the user
+in them (it is not sensible to use operators that contain this as a
-should write * / instead (I can't think of any cases when this would
+substring). In other cases, the user should write * / instead (I can't
-be valid syntax though).
+think of any cases when this would be valid syntax).
 -}
 
 dontParseEndBlockComment :: Dialect -> Parser Token
 dontParseEndBlockComment _ =
-    -- don't use try, then it should commit to the error
+    failOnThis (chunk_ "*/") "comment end without comment start"
-    try (string "*/") *> fail "comment end without comment start"
 
 --------------------------------------
 
@@ -482,63 +547,51 @@ followed by an optional exponent
 
 sqlNumber :: Dialect -> Parser Token
 sqlNumber d =
-    SqlNumber <$> completeNumber
+    SqlNumber <$> fstMatch
-    -- this is for definitely avoiding possibly ambiguous source
+    ((numStartingWithDigits <|> numStartingWithDot)
-    <* choice [-- special case to allow e.g. 1..2
+     *> hoptional_ expo *> trailingCheck)
-               guard (diPostgresSymbols d)
-               *> void (lookAhead $ try (string ".." <?> ""))
-                  <|> void (notFollowedBy (oneOf "eE."))
-              ,notFollowedBy (oneOf "eE.")
-              ]
   where
-    completeNumber =
+    numStartingWithDigits = digits_ *> hoptional_ (safeDot *> hoptional_ digits_)
-      (digits <??> (pp dot <??.> pp digits)
+    -- use try, so we don't commit to a number when there's a . with no following digit
-      -- try is used in case we read a dot
+    numStartingWithDot = try (safeDot *> digits_)
-      -- and it isn't part of a number
+    expo = (char_ 'e' <|> char_ 'E') *> optional_ (char_ '-' <|> char_ '+') *> digits_
-      -- if there are any following digits, then we commit
+    digits_ = label "digits" $ takeWhile1P_ Nothing isDigit
-      -- to it being a number and not something else
+    -- if there's a '..' next to the number, and it's a dialect that has .. as a
-      <|> try ((<>) <$> dot <*> digits))
+    -- lexical token, parse what we have so far and leave the dots in the chamber
-      <??> pp expon
+    -- otherwise, give an error
-
+    safeDot =
-    -- make sure we don't parse two adjacent dots in a number
+        if diPostgresSymbols d
-    -- special case for postgresql, we backtrack if we see two adjacent dots
+        then try (char_ '.' <* notFollowedBy (char_ '.'))
-    -- to parse 1..2, but in other dialects we commit to the failure
+        else char_ '.' <* notFollowedBy (char_ '.')
-    dot = let p = string "." <* notFollowedBy (char '.')
+    -- additional check to give an error if the number is immediately
-          in if diPostgresSymbols d
+    -- followed by e, E or . with an exception for .. if this symbol is supported
-             then try p
+    trailingCheck =
-             else p
+        if diPostgresSymbols d
-    expon = T.cons <$> oneOf "eE" <*> sInt
+        then -- special case to allow e.g. 1..2
-    sInt = (<>) <$> option "" (T.singleton <$> oneOf "+-") <*> digits
+             void (lookAhead $ hidden $ chunk_ "..")
-    pp = (<$$> (<>))
+             <|> void (notFollowedBy (oneOf "eE."))
-    p <??> q = p <**> option id q
+        else notFollowedBy (oneOf "eE.")
-    pa <$$> c = pa <**> pure (flip c)
-    pa <??.> pb =
-       let c = (<$>) . flip
-       in (.) `c` pa <*> option id pb
 
 digits :: Parser Text
-digits = takeWhile1P (Just "digit") isDigit
+digits = label "digits" $ takeWhile1P Nothing isDigit
 
 --------------------------------------
 
 positionalArg :: Dialect -> Parser Token
 positionalArg d =
-    guard (diPositionalArg d) >>
     -- use try to avoid ambiguities with other syntax which starts with dollar
-    PositionalArg <$> try (char_ '$' *> (read . T.unpack <$> digits))
+    choice [PositionalArg <$>
+            try (char_ '$' *> (read . T.unpack <$> digits)) | diPositionalArg d]
 
 --------------------------------------
 
 -- todo: I think the try here should read a prefix char, then a single valid
 -- identifier char, then commit
 prefixedVariable :: Dialect -> Parser Token
-prefixedVariable d = try $ choice
+prefixedVariable d = try $ choice $
-    [PrefixedVariable <$> char ':' <*> identifierString
+    [PrefixedVariable <$> char ':' <*> identifierString]
-    ,guard (diAtIdentifier d) >>
+    ++ [PrefixedVariable <$> char '@' <*> identifierString | diAtIdentifier d]
-     PrefixedVariable <$> char '@' <*> identifierString
+    ++ [PrefixedVariable <$> char '#' <*> identifierString | diHashIdentifier d]
-    ,guard (diHashIdentifier d) >>
-     PrefixedVariable <$> char '#' <*> identifierString
-    ]
 
 --------------------------------------
 
@@ -565,7 +618,7 @@ symbol d  = Symbol <$> choice (concat
     else basicAnsiOps
    ])
  where
-   dots = [takeWhile1P (Just "dot") (=='.')]
+   dots = [takeWhile1P Nothing (=='.')]
    odbcSymbol = [string "{", string "}"]
    postgresExtraSymbols =
        [try (string ":=")
@@ -670,7 +723,7 @@ generalizedPostgresqlOperator = [singlePlusMinus,opMoreChars]
 --------------------------------------
 
 sqlWhitespace :: Dialect -> Parser Token
-sqlWhitespace _ = Whitespace <$> takeWhile1P (Just "whitespace") isSpace <?> ""
+sqlWhitespace _ = Whitespace <$> takeWhile1P Nothing isSpace
 
 ----------------------------------------------------------------------------
 
@@ -679,6 +732,9 @@ sqlWhitespace _ = Whitespace <$> takeWhile1P (Just "whitespace") isSpace <?> ""
 char_ :: Char -> Parser ()
 char_ = void . char
 
+hchar_ :: Char -> Parser ()
+hchar_ = void . hidden . char
+
 string_ :: Text -> Parser ()
 string_ = void . string
 
@@ -688,6 +744,39 @@ oneOf = M.oneOf
 notElemChar :: Char -> [Char] -> Bool
 notElemChar a b = a `notElem` (b :: [Char])
 
+fstMatch :: Parser () -> Parser Text
+fstMatch x = fst <$> match x
+
+hoptional_ :: Parser a -> Parser ()
+hoptional_ = void . hoptional
+
+hoptional :: Parser a -> Parser (Maybe a)
+hoptional = hidden . optional
+
+optional_ :: Parser a -> Parser ()
+optional_ = void . optional
+
+--hoption :: a -> Parser a -> Parser a
+--hoption a p = hidden $ option a p
+
+takeWhileP_ :: Maybe String -> (Char -> Bool) -> Parser ()
+takeWhileP_ m p = void $ takeWhileP m p
+
+takeWhile1P_ :: Maybe String -> (Char -> Bool) -> Parser ()
+takeWhile1P_ m p = void $ takeWhile1P m p
+
+chunk_ :: Text -> Parser ()
+chunk_ = void . chunk
+
+hchunk_ :: Text -> Parser ()
+hchunk_ = void . hidden . chunk
+
+failOnThis :: Parser () -> Text -> Parser a
+failOnThis p msg = do
+    o <- getOffset
+    hidden p
+    region (setErrorOffset o) $ fail $ T.unpack msg
+
 ----------------------------------------------------------------------------
 
 

Language/SQL/SimpleSQL/Parse.hs

@@ -195,8 +195,8 @@ import Text.Megaparsec
 
     ,ParseErrorBundle(..)
     ,errorBundlePretty
-
+    ,hidden
-    ,(<?>)
+    
     ,(<|>)
     ,token
     ,choice
@@ -212,6 +212,7 @@ import Text.Megaparsec
     )
 import qualified Control.Monad.Combinators.Expr as E
 import qualified Control.Monad.Permutations as P
+import qualified Text.Megaparsec as M
 
 import Control.Monad.Reader
     (Reader
@@ -235,6 +236,8 @@ import qualified Data.Text as T
 import Language.SQL.SimpleSQL.Syntax 
 import Language.SQL.SimpleSQL.Dialect
 import qualified Language.SQL.SimpleSQL.Lex as L
+--import Text.Megaparsec.Debug (dbg)
+import Text.Read (readMaybe)
 
 ------------------------------------------------------------------------------
 
@@ -324,9 +327,9 @@ wrapParse :: Parser a
           -> Text
           -> Either ParseError a
 wrapParse parser d f p src = do
-    lx <- either (Left . LexError) Right $ L.lexSQLWithPositions d f p src
+    lx <- either (Left . LexError) Right $ L.lexSQLWithPositions d True f p src
     either (Left . ParseError) Right $ 
-        runReader (runParserT (parser <* (eof <?> "")) (T.unpack f)
+        runReader (runParserT (parser <* (hidden eof)) (T.unpack f)
                    $ L.SQLStream (T.unpack src) $ filter notSpace lx) d
   where
     notSpace = notSpace' . L.tokenVal
@@ -379,20 +382,20 @@ u&"example quoted"
 -}
 
 name :: Parser Name
-name = do
+name = label "name" $ do
     bl <- askDialect diKeywords
     uncurry Name <$> identifierTok bl
 
 -- todo: replace (:[]) with a named function all over
 
 names :: Parser [Name]
-names = reverse <$> (((:[]) <$> name) <??*> anotherName)
+names = label "name" (reverse <$> (((:[]) <$> name) <??*> anotherName))
   -- can't use a simple chain here since we
   -- want to wrap the . + name in a try
   -- this will change when this is left factored
   where
     anotherName :: Parser ([Name] -> [Name])
-    anotherName = try ((:) <$> ((symbol "." *> name) <?> ""))
+    anotherName = try ((:) <$> (hidden (symbol "." *> name)))
 
 {-
 = Type Names
@@ -501,36 +504,48 @@ a lob type name.
 
 Unfortunately, to improve the error messages, there is a lot of (left)
 factoring in this function, and it is a little dense.
+
+the hideArg is used when the typename is used as part of a typed
+literal expression, to hide what comes after the paren in
+'typename('. This is so 'arbitrary_fn(' gives an 'expecting expression',
+instead of 'expecting expression or number', which is odd.
+
 -}
 
 typeName :: Parser TypeName
-typeName =
+typeName = typeName' False
-    (rowTypeName <|> intervalTypeName <|> otherTypeName)
+
-    <??*> tnSuffix
+typeName' :: Bool -> Parser TypeName
+typeName' hideArg =
+    label "typename" (
+        (rowTypeName <|> intervalTypeName <|> otherTypeName)
+        <??*> tnSuffix)
   where
     rowTypeName =
-        RowTypeName <$> (keyword_ "row" *> parens (commaSep1 rowField))
+        RowTypeName <$> (hidden (keyword_ "row") *> parens (commaSep1 rowField))
     rowField = (,) <$> name <*> typeName
     ----------------------------
     intervalTypeName =
-        keyword_ "interval" *>
+        hidden (keyword_ "interval") *>
         (uncurry IntervalTypeName <$> intervalQualifier)
     ----------------------------
     otherTypeName =
         nameOfType <**>
             (typeNameWithParens
-             <|> pure Nothing <**> (timeTypeName <|> charTypeName)
+             <|> pure Nothing <**> (hidden timeTypeName <|> hidden charTypeName)
              <|> pure TypeName)
     nameOfType = reservedTypeNames <|> names
     charTypeName = charSet <**> (option [] tcollate <$$$$> CharTypeName)
                    <|> pure [] <**> (tcollate <$$$$> CharTypeName)
     typeNameWithParens =
-        (openParen *> unsignedInteger)
+        (hidden openParen *> (if hideArg then hidden unsignedInteger else unsignedInteger))
-        <**> (closeParen *> precMaybeSuffix
+        <**> (closeParen *> hidden precMaybeSuffix
-              <|> (precScaleTypeName <|> precLengthTypeName) <* closeParen)
+              <|> hidden (precScaleTypeName <|> precLengthTypeName) <* closeParen)
     precMaybeSuffix = (. Just) <$> (timeTypeName <|> charTypeName)
                       <|> pure (flip PrecTypeName)
-    precScaleTypeName = (comma *> unsignedInteger) <$$$> PrecScaleTypeName
+    precScaleTypeName =
+        (hidden comma *> (if hideArg then hidden unsignedInteger else unsignedInteger))
+        <$$$> PrecScaleTypeName
     precLengthTypeName =
         Just <$> lobPrecSuffix
         <**> (optional lobUnits <$$$$> PrecLengthTypeName)
@@ -609,7 +624,7 @@ parameter = choice
     [Parameter <$ questionMark
     ,HostParameter
      <$> hostParamTok
-     <*> optional (keyword "indicator" *> hostParamTok)]
+     <*> hoptional (keyword "indicator" *> hostParamTok)]
 
 -- == positional arg
 
@@ -734,11 +749,12 @@ this. also fix the monad -> applicative
 -}
 
 intervalLit :: Parser ScalarExpr
-intervalLit = try (keyword_ "interval" >> do
+intervalLit =
-    s <- optional $ choice [Plus <$ symbol_ "+"
+    label "interval literal" $ try (keyword_ "interval" >> do
-                              ,Minus <$ symbol_ "-"]
+    s <- hoptional $ choice [Plus <$ symbol_ "+"
+                           ,Minus <$ symbol_ "-"]
     lit <- singleQuotesOnlyStringTok
-    q <- optional intervalQualifier
+    q <- hoptional intervalQualifier
     mkIt s lit q)
   where
     mkIt Nothing val Nothing = pure $ TypedLit (TypeName [Name Nothing "interval"]) val
@@ -764,23 +780,41 @@ all the scalar expressions which start with an identifier
 
 idenExpr :: Parser ScalarExpr
 idenExpr =
-    -- todo: work out how to left factor this
+    -- todo: try reversing these
-    try (TypedLit <$> typeName <*> singleQuotesOnlyStringTok)
+    -- then if it parses as a typename as part of a typed literal
-    <|> (names <**> option Iden app)
+    -- and not a regularapplike, then you'll get a better error message
-    <|> keywordFunctionOrIden
+    try typedLiteral <|> regularAppLike
   where
-    -- special cases for keywords that can be parsed as an iden or app
+    -- parse regular iden or app
-    keywordFunctionOrIden = try $ do
+    -- if it could potentially be a typed literal typename 'literaltext'
-        x <- unquotedIdentifierTok [] Nothing
+    -- optionally try to parse that
+    regularAppLike = do
+        e <- (keywordFunctionOrIden <|> (names <**> hoption Iden app))
+        let getInt s = readMaybe (T.unpack s)
+        case e of
+            Iden nm -> tryTypedLiteral (TypeName nm) <|> pure e
+            App nm [NumLit prec]
+                | Just prec' <- getInt prec ->
+                tryTypedLiteral (PrecTypeName nm prec') <|> pure e
+            App nm [NumLit prec,NumLit scale]
+                | Just prec' <- getInt prec
+                , Just scale' <- getInt scale ->
+                tryTypedLiteral (PrecScaleTypeName nm prec' scale') <|> pure e
+            _ -> pure e
+    tryTypedLiteral tn =
+        TypedLit tn <$> hidden singleQuotesOnlyStringTok
+    typedLiteral = TypedLit <$> hidden (typeName' True) <*> singleQuotesOnlyStringTok
+    keywordFunctionOrIden = do
         d <- askDialect id
+        x <- hidden (keywordTok (diIdentifierKeywords d ++ diAppKeywords d))
         let i = T.toLower x `elem` diIdentifierKeywords d
             a = T.toLower x `elem` diAppKeywords d
         case () of
-            _  | i && a -> pure [Name Nothing x] <**> option Iden app
+            _ | i && a -> pure [Name Nothing x] <**> hoption Iden app
-               | i -> pure (Iden [Name Nothing x])
+              | i -> pure (Iden [Name Nothing x])
-               | a -> pure [Name Nothing x] <**> app
+              | a -> pure [Name Nothing x] <**> app
-               | otherwise -> fail ""
+              | otherwise -> -- shouldn't get here
-
+                    fail $ "unexpected keyword: " <> T.unpack x
 
 {-
 === special
@@ -814,7 +848,7 @@ specialOpK opName firstArg kws =
               case (e,kws) of
                   (Iden [Name Nothing i], (k,_):_)
                       | T.toLower i == k ->
-                          fail $ "cannot use keyword here: " ++ T.unpack i
+                          fail $ "unexpected " ++ T.unpack i
                   _ -> pure ()
               pure e
     fa <- case firstArg of
@@ -921,24 +955,24 @@ together.
 
 app :: Parser ([Name] -> ScalarExpr)
 app =
-    openParen *> choice
+    hidden openParen *> choice
-    [duplicates
+    [hidden duplicates
      <**> (commaSep1 scalarExpr
-           <**> ((option [] orderBy <* closeParen)
+           <**> ((hoption [] orderBy <* closeParen)
-                 <**> (optional afilter <$$$$$> AggregateApp)))
+                 <**> (hoptional afilter <$$$$$> AggregateApp)))
      -- separate cases with no all or distinct which must have at
      -- least one scalar expr
     ,commaSep1 scalarExpr
      <**> choice
-          [closeParen *> choice
+          [closeParen *> hidden (choice
                          [window
                          ,withinGroup
                          ,(Just <$> afilter) <$$$> aggAppWithoutDupeOrd
-                         ,pure (flip App)]
+                         ,pure (flip App)])
-          ,orderBy <* closeParen
+          ,hidden orderBy <* closeParen
-           <**> (optional afilter <$$$$> aggAppWithoutDupe)]
+           <**> (hoptional afilter <$$$$> aggAppWithoutDupe)]
      -- no scalarExprs: duplicates and order by not allowed
-    ,([] <$ closeParen) <**> option (flip App) (window <|> withinGroup)
+    ,([] <$ closeParen) <**> hoption (flip App) (window <|> withinGroup)
     ]
   where
     aggAppWithoutDupeOrd n es f = AggregateApp n SQDefault es [] f
@@ -970,8 +1004,11 @@ window =
   <**> (option [] orderBy
         <**> ((optional frameClause <* closeParen) <$$$$$> WindowApp))
   where
-    partitionBy = keywords_ ["partition","by"] *> commaSep1 scalarExpr
+    partitionBy =
+        label "partition by" $
+        keywords_ ["partition","by"] *> commaSep1 scalarExpr
     frameClause =
+        label "frame clause" $
         frameRowsRange -- TODO: this 'and' could be an issue
         <**> choice [(keyword_ "between" *> frameLimit True)
                       <**> ((keyword_ "and" *> frameLimit True)
@@ -1128,8 +1165,8 @@ scalar expressions (the other is a variation on joins)
 
 
 odbcExpr :: Parser ScalarExpr
-odbcExpr = between (symbol "{") (symbol "}")
+odbcExpr =
-           (odbcTimeLit <|> odbcFunc)
+    braces (odbcTimeLit <|> odbcFunc)
   where
     odbcTimeLit =
         OdbcLiteral <$> choice [OLDate <$ keyword "d"
@@ -1232,33 +1269,33 @@ opTable bExpr =
 
        ]
   where
-    binarySymL nm = E.InfixL (mkBinOp nm <$ symbol_ nm)
+    binarySymL nm = E.InfixL (hidden $ mkBinOp nm <$ symbol_ nm)
-    binarySymR nm = E.InfixR (mkBinOp nm <$ symbol_ nm)
+    binarySymR nm = E.InfixR (hidden $ mkBinOp nm <$ symbol_ nm)
-    binarySymN nm = E.InfixN (mkBinOp nm <$ symbol_ nm)
+    binarySymN nm = E.InfixN (hidden $ mkBinOp nm <$ symbol_ nm)
-    binaryKeywordN nm = E.InfixN (mkBinOp nm <$ keyword_ nm)
+    binaryKeywordN nm = E.InfixN (hidden $ mkBinOp nm <$ keyword_ nm)
-    binaryKeywordL nm = E.InfixL (mkBinOp nm <$ keyword_ nm)
+    binaryKeywordL nm = E.InfixL (hidden $ mkBinOp nm <$ keyword_ nm)
     mkBinOp nm a b = BinOp a (mkNm nm) b
-    prefixSym  nm = prefix (PrefixOp (mkNm nm) <$ symbol_ nm)
+    prefixSym  nm = prefix (hidden $ PrefixOp (mkNm nm) <$ symbol_ nm)
-    prefixKeyword  nm = prefix (PrefixOp (mkNm nm) <$ keyword_ nm)
+    prefixKeyword  nm = prefix (hidden $ PrefixOp (mkNm nm) <$ keyword_ nm)
     mkNm nm = [Name Nothing nm]
     binaryKeywordsN p =
-        E.InfixN (do
+        E.InfixN (hidden $ do
                  o <- try p
                  pure (\a b -> BinOp a [Name Nothing $ T.unwords o] b))
-    multisetBinOp = E.InfixL (do
+    multisetBinOp = E.InfixL (hidden $ do
         keyword_ "multiset"
         o <- choice [Union <$ keyword_ "union"
                     ,Intersect <$ keyword_ "intersect"
                     ,Except <$ keyword_ "except"]
-        d <- option SQDefault duplicates
+        d <- hoption SQDefault duplicates
         pure (\a b -> MultisetBinOp a o d b))
     postfixKeywords p =
-      postfix $ do
+      postfix $ hidden $ do
           o <- try p
           pure $ PostfixOp [Name Nothing $ T.unwords o]
     -- parse repeated prefix or postfix operators
-    postfix p = E.Postfix $ foldr1 (flip (.)) <$> some p
+    postfix p = E.Postfix $ foldr1 (flip (.)) <$> some (hidden p)
-    prefix p = E.Prefix $ foldr1 (.) <$> some p
+    prefix p = E.Prefix $ foldr1 (.) <$> some (hidden p)
 
 {-
 == scalar expression top level
@@ -1271,31 +1308,32 @@ documenting/fixing.
 -}
 
 scalarExpr :: Parser ScalarExpr
-scalarExpr = E.makeExprParser term (opTable False)
+scalarExpr = label "expression" $ E.makeExprParser term (opTable False)
 
 term :: Parser ScalarExpr
-term = choice [simpleLiteral
+term = label "expression" $
-              ,parameter
+    choice
-              ,positionalArg
+    [simpleLiteral
-              ,star
+    ,parameter
-              ,parensExpr
+    ,positionalArg
-              ,caseExpr
+    ,star
-              ,cast
+    ,parensExpr
-              ,convertSqlServer
+    ,caseExpr
-              ,arrayCtor
+    ,cast
-              ,multisetCtor
+    ,convertSqlServer
-              ,nextValueFor
+    ,arrayCtor
-              ,subquery
+    ,multisetCtor
-              ,intervalLit
+    ,nextValueFor
-              ,specialOpKs
+    ,subquery
-              ,idenExpr
+    ,intervalLit
-              ,odbcExpr]
+    ,specialOpKs
-       <?> "scalar expression"
+    ,idenExpr
+    ,odbcExpr]
 
 -- expose the b expression for window frame clause range between
 
 scalarExprB :: Parser ScalarExpr
-scalarExprB = E.makeExprParser term (opTable True)
+scalarExprB = label "expression" $ E.makeExprParser term (opTable True)
 
 {-
 == helper parsers
@@ -1321,9 +1359,10 @@ use a data type for the datetime field?
 -}
 
 datetimeField :: Parser Text
-datetimeField = choice (map keyword ["year","month","day"
+datetimeField =
-                                    ,"hour","minute","second"])
+    choice (map keyword ["year","month","day"
-                <?> "datetime field"
+                        ,"hour","minute","second"])
+    <?> "datetime field"
 
 {-
 This is used in multiset operations (scalar expr), selects (query expr)
@@ -1344,8 +1383,8 @@ duplicates =
 -}
 
 selectItem :: Parser (ScalarExpr,Maybe Name)
-selectItem = (,) <$> scalarExpr <*> optional als
+selectItem = label "select item" ((,) <$> scalarExpr <*> optional als)
-  where als = optional (keyword_ "as") *> name
+  where als = label "alias" $ optional (keyword_ "as") *> name
 
 selectList :: Parser [(ScalarExpr,Maybe Name)]
 selectList = commaSep1 selectItem
@@ -1366,33 +1405,33 @@ aliases.
 -}
 
 from :: Parser [TableRef]
-from = keyword_ "from" *> commaSep1 tref
+from = label "from" (keyword_ "from" *> commaSep1 tref)
   where
     -- TODO: use P (a->) for the join tref suffix
     -- chainl or buildexpressionparser
-    tref = (nonJoinTref <?> "table ref") >>= optionSuffix joinTrefSuffix
+    tref = (nonJoinTref <?> "table ref") >>= hoptionSuffix joinTrefSuffix
     nonJoinTref = choice
-        [parens $ choice
+        [hidden $ parens $ choice
              [TRQueryExpr <$> queryExpr
              ,TRParens <$> tref]
-        ,TRLateral <$> (keyword_ "lateral"
+        ,TRLateral <$> (hidden (keyword_ "lateral")
                         *> nonJoinTref)
         ,do
          n <- names
          choice [TRFunction n
-                 <$> parens (commaSep scalarExpr)
+                 <$> hidden (parens (commaSep scalarExpr))
                 ,pure $ TRSimple n]
          -- todo: I think you can only have outer joins inside the oj,
          -- not sure.
-        ,TROdbc <$> (symbol "{" *> keyword_ "oj" *> tref <* symbol "}")
+        ,TROdbc <$> (hidden (braces (keyword_ "oj" *> tref)))
         ] <??> aliasSuffix
-    aliasSuffix = fromAlias <$$> TRAlias
+    aliasSuffix = hidden (fromAlias <$$> TRAlias)
     joinTrefSuffix t =
         ((TRJoin t <$> option False (True <$ keyword_ "natural")
                   <*> joinType
                   <*> nonJoinTref
-                  <*> optional joinCondition)
+                  <*> hoptional joinCondition)
-        >>= optionSuffix joinTrefSuffix) <?> ""
+        >>= hoptionSuffix joinTrefSuffix)
 
 {-
 TODO: factor the join stuff to produce better error messages (and make
@@ -1422,8 +1461,8 @@ joinCondition = choice
 fromAlias :: Parser Alias
 fromAlias = Alias <$> tableAlias <*> columnAliases
   where
-    tableAlias = optional (keyword_ "as") *> name
+    tableAlias = hoptional (keyword_ "as") *> name
-    columnAliases = optional $ parens $ commaSep1 name
+    columnAliases = hoptional $ parens $ commaSep1 name
 
 {-
 == simple other parts
@@ -1433,10 +1472,11 @@ pretty trivial.
 -}
 
 whereClause :: Parser ScalarExpr
-whereClause = keyword_ "where" *> scalarExpr
+whereClause = label "where" (keyword_ "where" *> scalarExpr)
 
 groupByClause :: Parser [GroupingExpr]
-groupByClause = keywords_ ["group","by"] *> commaSep1 groupingExpression
+groupByClause =
+    label "group by" (keywords_ ["group","by"] *> commaSep1 groupingExpression)
   where
     groupingExpression = choice
       [keyword_ "cube" >>
@@ -1450,16 +1490,16 @@ groupByClause = keywords_ ["group","by"] *> commaSep1 groupingExpression
       ]
 
 having :: Parser ScalarExpr
-having = keyword_ "having" *> scalarExpr
+having = label "having" (keyword_ "having" *> scalarExpr)
 
 orderBy :: Parser [SortSpec]
-orderBy = keywords_ ["order","by"] *> commaSep1 ob
+orderBy = label "order by" (keywords_ ["order","by"] *> commaSep1 ob)
   where
     ob = SortSpec
          <$> scalarExpr
-         <*> option DirDefault (choice [Asc <$ keyword_ "asc"
+         <*> hoption DirDefault (choice [Asc <$ keyword_ "asc"
                                        ,Desc <$ keyword_ "desc"])
-         <*> option NullsOrderDefault
+         <*> hoption NullsOrderDefault
              -- todo: left factor better
              (keyword_ "nulls" >>
                     choice [NullsFirst <$ keyword "first"
@@ -1477,9 +1517,9 @@ offsetFetch =
     maybePermutation p = P.toPermutationWithDefault Nothing (Just <$> p)
 
 offset :: Parser ScalarExpr
-offset = keyword_ "offset" *> scalarExpr
+offset = label "offset" (keyword_ "offset" *> scalarExpr
          <* option () (choice [keyword_ "rows"
-                              ,keyword_ "row"])
+                              ,keyword_ "row"]))
 
 fetch :: Parser ScalarExpr
 fetch = fetchFirst <|> limit
@@ -1496,13 +1536,13 @@ fetch = fetchFirst <|> limit
 
 with :: Parser QueryExpr
 with = keyword_ "with" >>
-    With <$> option False (True <$ keyword_ "recursive")
+    With <$> hoption False (True <$ keyword_ "recursive")
          <*> commaSep1 withQuery <*> queryExpr
   where
     withQuery = (,) <$> (withAlias <* keyword_ "as")
                     <*> parens queryExpr
     withAlias = Alias <$> name <*> columnAliases
-    columnAliases = optional $ parens $ commaSep1 name
+    columnAliases = hoptional $ parens $ commaSep1 name
 
 
 {-
@@ -1513,15 +1553,15 @@ and union, etc..
 -}
 
 queryExpr :: Parser QueryExpr
-queryExpr = E.makeExprParser qeterm qeOpTable
+queryExpr = label "query expr" $ E.makeExprParser qeterm qeOpTable
   where
-    qeterm = with <|> select <|> table <|> values
+    qeterm = label "query expr" (with <|> select <|> table <|> values)
     
     select = keyword_ "select" >>
         mkSelect
-        <$> option SQDefault duplicates
+        <$> hoption SQDefault duplicates
         <*> selectList
-        <*> optional tableExpression <?> "table expression"
+        <*> optional tableExpression
     mkSelect d sl Nothing =
         toQueryExpr $ makeSelect {msSetQuantifier = d, msSelectList = sl}
     mkSelect d sl (Just (TableExpression f w g h od ofs fe)) =
@@ -1535,12 +1575,12 @@ queryExpr = E.makeExprParser qeterm qeOpTable
         ,[E.InfixL $ setOp Except "except"
          ,E.InfixL $ setOp Union "union"]]
     setOp :: SetOperatorName -> Text -> Parser (QueryExpr -> QueryExpr -> QueryExpr)
-    setOp ctor opName = (cq
+    setOp ctor opName = hidden (cq
         <$> (ctor <$ keyword_ opName)
-        <*> option SQDefault duplicates
+        <*> hoption SQDefault duplicates
-        <*> corr) <?> ""
+        <*> corr)
     cq o d c q0 q1 = QueryExprSetOp q0 o d c q1
-    corr = option Respectively (Corresponding <$ keyword_ "corresponding")
+    corr = hoption Respectively (Corresponding <$ keyword_ "corresponding")
 
     
 {-
@@ -1560,12 +1600,15 @@ data TableExpression
       ,_teFetchFirst :: Maybe ScalarExpr}
 
 tableExpression :: Parser TableExpression
-tableExpression = mkTe <$> (from <?> "from clause")
+tableExpression =
-                       <*> (optional whereClause <?> "where clause")
+    label "from" $
-                       <*> (option [] groupByClause <?> "group by clause")
+    mkTe
-                       <*> (optional having <?> "having clause")
+    <$> from
-                       <*> (option [] orderBy <?> "order by clause")
+    <*> optional whereClause
-                       <*> (offsetFetch <?> "")
+    <*> option [] groupByClause
+    <*> optional having
+    <*> option [] orderBy
+    <*> (hidden offsetFetch)
  where
     mkTe f w g h od (ofs,fe) =
         TableExpression f w g h od ofs fe
@@ -1589,7 +1632,8 @@ topLevelStatement = statement
 -}
 
 statementWithoutSemicolon :: Parser Statement
-statementWithoutSemicolon = choice
+statementWithoutSemicolon =
+    label "statement" $ choice
     [keyword_ "create" *> choice [createSchema
                                  ,createTable
                                  ,createIndex
@@ -1623,7 +1667,7 @@ statementWithoutSemicolon = choice
     ]
 
 statement :: Parser Statement
-statement = statementWithoutSemicolon <* optional semi <|> EmptyStatement <$ semi
+statement = statementWithoutSemicolon <* optional semi <|> EmptyStatement <$ hidden semi
 
 createSchema :: Parser Statement
 createSchema = keyword_ "schema" >>
@@ -1638,7 +1682,7 @@ createTable = do
     separator = if diNonCommaSeparatedConstraints d
       then optional comma
       else Just <$> comma
-    constraints = sepBy parseConstraintDef separator
+    constraints = sepBy parseConstraintDef (hidden separator)
     entries = ((:) <$> parseColumnDef <*> ((comma >> entries) <|> pure [])) <|> constraints
 
   keyword_ "table" >>
@@ -1660,7 +1704,7 @@ columnDef = ColumnDef <$> name <*> typeName
             <*> optional defaultClause
             <*> option [] (some colConstraintDef)
   where
-    defaultClause = choice [
+    defaultClause = label "column default clause" $ choice [
         keyword_ "default" >>
         DefaultClause <$> scalarExpr
         -- todo: left factor
@@ -1689,12 +1733,12 @@ tableConstraintDef =
         (\cs ft ftcs m (u,d) -> TableReferencesConstraint cs ft ftcs m u d)
         <$> parens (commaSep1 name)
         <*> (keyword_ "references" *> names)
-        <*> optional (parens $ commaSep1 name)
+        <*> hoptional (parens $ commaSep1 name)
         <*> refMatch
         <*> refActions
 
 refMatch :: Parser ReferenceMatch
-refMatch = option DefaultReferenceMatch
+refMatch = hoption DefaultReferenceMatch
             (keyword_ "match" *>
              choice [MatchFull <$ keyword_ "full"
                     ,MatchPartial <$ keyword_ "partial"
@@ -1833,11 +1877,11 @@ dropTable = keyword_ "table" >>
 createView :: Parser Statement
 createView =
     CreateView
-    <$> (option False (True <$ keyword_ "recursive") <* keyword_ "view")
+    <$> (hoption False (True <$ keyword_ "recursive") <* keyword_ "view")
     <*> names
     <*> optional (parens (commaSep1 name))
     <*> (keyword_ "as" *> queryExpr)
-    <*> optional (choice [
+    <*> hoptional (choice [
             -- todo: left factor
             DefaultCheckOption <$ try (keywords_ ["with", "check", "option"])
            ,CascadedCheckOption <$ try (keywords_ ["with", "cascaded", "check", "option"])
@@ -1852,7 +1896,7 @@ createDomain :: Parser Statement
 createDomain = keyword_ "domain" >>
     CreateDomain
     <$> names
-    <*> (optional (keyword_ "as") *> typeName)
+    <*> ((optional (keyword_ "as") *> typeName) <?> "alias")
     <*> optional (keyword_ "default" *> scalarExpr)
     <*> many con
   where
@@ -1930,7 +1974,7 @@ insert :: Parser Statement
 insert = keywords_ ["insert", "into"] >>
     Insert
     <$> names
-    <*> optional (parens $ commaSep1 name)
+    <*> label "parens column names" (optional (parens $ commaSep1 name))
     <*> (DefaultInsertValues <$ keywords_ ["default", "values"]
          <|> InsertQuery <$> queryExpr)
 
@@ -1938,7 +1982,7 @@ update :: Parser Statement
 update = keywords_ ["update"] >>
     Update
     <$> names
-    <*> optional (optional (keyword_ "as") *> name)
+    <*> label "alias" (optional (optional (keyword_ "as") *> name))
     <*> (keyword_ "set" *> commaSep1 setClause)
     <*> optional (keyword_ "where" *> scalarExpr)
   where
@@ -1974,10 +2018,10 @@ releaseSavepoint = keywords_ ["release","savepoint"] >>
     ReleaseSavepoint <$> name
 
 commit :: Parser Statement
-commit = Commit <$ keyword_ "commit" <* optional (keyword_ "work")
+commit = Commit <$ keyword_ "commit" <* hoptional (keyword_ "work")
 
 rollback :: Parser Statement
-rollback = keyword_ "rollback" >> optional (keyword_ "work") >>
+rollback = keyword_ "rollback" >> hoptional (keyword_ "work") >>
     Rollback <$> optional (keywords_ ["to", "savepoint"] *> name)
 
 
@@ -2091,6 +2135,7 @@ thick.
 
 makeKeywordTree :: [Text] -> Parser [Text]
 makeKeywordTree sets =
+    label (T.intercalate ", " sets) $
     parseTrees (sort $ map T.words sets)
   where
     parseTrees :: [[Text]] -> Parser [Text]
@@ -2116,24 +2161,20 @@ makeKeywordTree sets =
 
 -- parser helpers
 
-(<$$>) :: Applicative f =>
+(<$$>) :: Parser b -> (a -> b -> c) -> Parser (a -> c)
-      f b -> (a -> b -> c) -> f (a -> c)
 (<$$>) pa c = pa <**> pure (flip c)
 
-(<$$$>) :: Applicative f =>
+(<$$$>) :: Parser c -> (a -> b -> c -> t) -> Parser (b -> a -> t)
-          f c -> (a -> b -> c -> t) -> f (b -> a -> t)
 p <$$$> c = p <**> pure (flip3 c)
 
-(<$$$$>) :: Applicative f =>
+(<$$$$>) :: Parser d -> (a -> b -> c -> d -> t) -> Parser (c -> b -> a -> t)
-          f d -> (a -> b -> c -> d -> t) -> f (c -> b -> a -> t)
 p <$$$$> c = p <**> pure (flip4 c)
 
-(<$$$$$>) :: Applicative f =>
+(<$$$$$>) :: Parser e -> (a -> b -> c -> d -> e -> t) -> Parser (d -> c -> b -> a -> t)
-          f e -> (a -> b -> c -> d -> e -> t) -> f (d -> c -> b -> a -> t)
 p <$$$$$> c = p <**> pure (flip5 c)
 
-optionSuffix :: (a -> Parser a) -> a -> Parser a
+hoptionSuffix :: (a -> Parser a) -> a -> Parser a
-optionSuffix p a = option a (p a)
+hoptionSuffix p a = hoption a (p a)
 
 {-
 parses an optional postfix element and applies its result to its left
@@ -2144,12 +2185,12 @@ other operators so it can be used nicely
 -}
 
 (<??>) :: Parser a -> Parser (a -> a) -> Parser a
-p <??> q = p <**> option id q
+p <??> q = p <**> hoption id q
 
 -- 0 to many repeated applications of suffix parser
 
 (<??*>) :: Parser a -> Parser (a -> a) -> Parser a
-p <??*> q = foldr ($) <$> p <*> (reverse <$> many q)
+p <??*> q = foldr ($) <$> p <*> (reverse <$> many (hidden q))
 
 {-
 These are to help with left factored parsers:
@@ -2177,7 +2218,7 @@ unsignedInteger = read . T.unpack <$> sqlNumberTok True <?> "natural number"
 -- todo: work out the symbol parsing better
 
 symbol :: Text -> Parser Text
-symbol s = symbolTok (Just s) <?> T.unpack s
+symbol s = symbolTok (Just s) <?> s
 
 singleCharSymbol :: Char -> Parser Char
 singleCharSymbol c = c <$ symbol (T.singleton c)
@@ -2185,44 +2226,39 @@ singleCharSymbol c = c <$ symbol (T.singleton c)
 questionMark :: Parser Char
 questionMark = singleCharSymbol '?' <?> "question mark"
 
-openParen :: Parser Char
+openParen :: Parser ()
-openParen = singleCharSymbol '('
+openParen = void $ singleCharSymbol '('
-
-closeParen :: Parser Char
-closeParen = singleCharSymbol ')'
-
-openBracket :: Parser Char
-openBracket = singleCharSymbol '['
-
-closeBracket :: Parser Char
-closeBracket = singleCharSymbol ']'
 
+closeParen :: Parser ()
+closeParen = void $ singleCharSymbol ')'
 
 comma :: Parser Char
-comma = singleCharSymbol ',' <?> ""
+comma = singleCharSymbol ','
 
 semi :: Parser Char
-semi = singleCharSymbol ';' <?> ""
+semi = singleCharSymbol ';'
 
 -- = helper functions
 
 keyword :: Text -> Parser Text
-keyword k = unquotedIdentifierTok [] (Just k) <?> T.unpack k
+keyword k = keywordTok [k] <?> k
 
 -- helper function to improve error messages
 
 keywords_ :: [Text] -> Parser ()
-keywords_ ks = mapM_ keyword_ ks <?> T.unpack (T.unwords ks)
+keywords_ ks = label (T.unwords ks) $ mapM_ keyword_ ks
-
 
 parens :: Parser a -> Parser a
 parens = between openParen closeParen
 
 brackets :: Parser a -> Parser a
-brackets = between openBracket closeBracket
+brackets = between (singleCharSymbol '[') (singleCharSymbol ']')
+
+braces :: Parser a -> Parser a
+braces = between (singleCharSymbol '{') (singleCharSymbol '}')
 
 commaSep :: Parser a -> Parser [a]
-commaSep = (`sepBy` comma)
+commaSep = (`sepBy` hidden comma)
 
 keyword_ :: Text -> Parser ()
 keyword_ = void . keyword
@@ -2231,7 +2267,19 @@ symbol_ :: Text -> Parser ()
 symbol_ = void . symbol
 
 commaSep1 :: Parser a -> Parser [a]
-commaSep1 = (`sepBy1` comma)
+commaSep1 = (`sepBy1` hidden comma)
+
+hoptional :: Parser a -> Parser (Maybe a)
+hoptional = hidden . optional
+
+hoption :: a -> Parser a -> Parser a
+hoption a p = hidden $ option a p
+
+label :: Text -> Parser a -> Parser a
+label x = M.label (T.unpack x)
+
+(<?>) :: Parser a -> Text -> Parser a
+(<?>) p a = (M.<?>) p (T.unpack a)
 
 ------------------------------------------------------------------------------
 
@@ -2277,25 +2325,25 @@ stringTokExtend = do
         ]
 
 hostParamTok :: Parser Text
-hostParamTok = token test Set.empty <?> ""
+hostParamTok = token test Set.empty <?> "host param"
   where
     test (L.WithPos _ _ _ (L.PrefixedVariable c p)) = Just $ T.cons c p
     test _ = Nothing
 
 positionalArgTok :: Parser Int
-positionalArgTok = token test Set.empty <?> ""
+positionalArgTok = token test Set.empty <?> "positional arg"
   where
     test (L.WithPos _ _ _ (L.PositionalArg p)) = Just p
     test _ = Nothing
 
 sqlNumberTok :: Bool -> Parser Text
-sqlNumberTok intOnly = token test Set.empty <?> ""
+sqlNumberTok intOnly = token test Set.empty <?> "number"
   where
     test (L.WithPos _ _ _ (L.SqlNumber p)) | not intOnly || T.all isDigit p = Just p
     test _ = Nothing
 
 symbolTok :: Maybe Text -> Parser Text
-symbolTok sym = token test Set.empty <?> ""
+symbolTok sym = token test Set.empty <?> lbl
   where
     test (L.WithPos _ _ _ (L.Symbol p)) =
         case sym of
@@ -2303,6 +2351,9 @@ symbolTok sym = token test Set.empty <?> ""
             Just sym' | sym' == p -> Just p
             _ -> Nothing
     test _ = Nothing
+    lbl = case sym of
+              Nothing -> "symbol"
+              Just p -> p
 
 {-
 The blacklisted names are mostly needed when we parse something with
@@ -2341,21 +2392,19 @@ will likely mean many things don't parse anymore.
 -}
 
 identifierTok :: [Text] -> Parser (Maybe (Text,Text), Text)
-identifierTok blackList = token test Set.empty <?> ""
+identifierTok blackList = do
+    token test Set.empty <?> "identifier"
   where
     test (L.WithPos _ _ _ (L.Identifier q@(Just {}) p)) = Just (q,p)
-    test (L.WithPos _ _ _ (L.Identifier q p))
+    test (L.WithPos _ _ _ (L.Identifier q@Nothing p))
         | T.toLower p `notElem` blackList = Just (q,p)
     test _ = Nothing
 
-unquotedIdentifierTok :: [Text] -> Maybe Text -> Parser Text
+keywordTok :: [Text] -> Parser Text
-unquotedIdentifierTok blackList kw = token test Set.empty <?> ""
+keywordTok allowed = do
-  where
+    token test Set.empty  where
-    test (L.WithPos _ _ _ (L.Identifier Nothing p)) =
+    test (L.WithPos _ _ _ (L.Identifier Nothing p))
-        case kw of
+        | T.toLower p `elem` allowed = Just p
-            Nothing | T.toLower p `notElem` blackList -> Just p
-            Just k | k == T.toLower p -> Just p
-            _ -> Nothing
     test _ = Nothing
 
 ------------------------------------------------------------------------------

Makefile

@@ -11,7 +11,11 @@ build :
 
 .PHONY : test
 test :
-	cabal run test:Tests -- --hide-successes --ansi-tricks=false
+	cabal run test:Tests -- -f failed-examples +RTS -N
+
+.PHONY : fast-test
+fast-test :
+	cabal run test:Tests -- -f failed-examples --skip ansiLexerTests --skip postgresLexerTests +RTS -N
 
 .PHONY : test-coverage
 test-coverage :
@@ -67,7 +71,9 @@ build/test_cases.html : website/RenderTestCases.hs website/template1.pandoc
 	# no idea why not using --disable-optimisation on cabal build, but putting -O0
 	# in the cabal file (and then cabal appears to say it's still using -O1
 	# is faster
+	echo Entering directory \`website/\'
 	cd website/ && cabal build RenderTestCases && cabal run RenderTestCases | pandoc -s -N --template template1.pandoc -V toc-title:"Simple SQL Parser test case examples" -c main1.css -f markdown  -t html --toc=true --metadata title="Simple SQL Parse test case examples" > ../build/test_cases.html
+	echo Leaving directory \`website/\'
 
 # works here, but not in a recipe. amazing
 # GHC_VER="$(shell ghc --numeric-version)"

changelog

@@ -1,3 +1,8 @@
+0.8.0   (not yet released)
+        lexer has new option to output an invalid token on some kinds of
+          parse errors
+        switch tests to hspec
+        improve parse error messages
 0.7.1   fix error message source quoting
 0.7.0   support autoincrement for sqlite
 	support table constraints without separating comma for sqlite

examples/ErrorMessagesTool.hs

@@ -0,0 +1,514 @@
+{-
+
+tool to compare before and after on error messages, suggested use:
+add any extra parse error examples below
+run it on baseline code
+run it on the modified code
+use meld on the two resulting csvs
+  bear in mind that " will appear as "" because of csv escaping
+
+this is how to generate a csv of errors:
+
+cabal -ftestexe build error-messages-tool && cabal -ftestexe run error-messages-tool -- generate | cabal -ftestexe run error-messages-tool -- test > res.csv
+
+TODO:
+think about making a regression test with this
+can add some more tools:
+there's a join mode to join two sets of results, could add a filter
+  to remove rows that are the same
+  but finding the different rows in meld seems to work well enough
+figure out if you can display visual diffs between pairs of cells in localc
+implement the tagging feature, one idea for working with it:
+you generate a bunch of error messages
+you eyeball the list, and mark some as good, some as bad
+then when you update, you can do a compare which filters
+  to keep any errors that have changed, and any that haven't
+  changed but are not marked as good
+etc.
+
+-}
+
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE LambdaCase #-}
+
+import Data.Text (Text)
+import qualified Data.Text as T
+
+import Text.Show.Pretty (ppShow)
+import qualified Text.RawString.QQ as R
+
+import Language.SQL.SimpleSQL.Parse
+    (prettyError
+    ,parseQueryExpr
+    ,parseScalarExpr
+--    ,parseStatement
+--    ,parseStatements
+    ,ansi2011
+--    ,ParseError(..)
+    )
+--import qualified Language.SQL.SimpleSQL.Lex as L
+
+import Language.SQL.SimpleSQL.Dialect
+    (postgres
+    ,Dialect(..)
+    ,sqlserver
+    ,mysql
+    )
+
+import System.Environment (getArgs)
+import Data.Csv
+    (encode
+    ,decode
+    ,HasHeader(..))
+
+import qualified Data.ByteString.Lazy as B hiding (pack)
+import Data.ByteString.Lazy (ByteString)
+import qualified Data.ByteString.Lazy.Char8 as B (putStrLn)
+import qualified Data.Vector as V
+import Data.Vector (Vector)
+
+import           Database.SQLite.Simple
+    (open
+    ,execute_
+    ,executeMany
+    ,query_
+    )
+
+main :: IO ()
+main = do
+
+    as <- getArgs
+    case as of
+        ["generate"] -> B.putStrLn generateData
+        ["test"] -> do
+            txt <- B.getContents
+            B.putStrLn $ runTests txt
+        ["compare", f1, f2] -> do
+            c1 <- B.readFile f1
+            c2 <- B.readFile f2
+            B.putStrLn =<< compareFiles c1 c2
+        _ -> error $ "unsupported arguments: " <> show as
+
+------------------------------------------------------------------------------
+
+-- compare two files
+{-
+
+take two inputs
+assume they have (testrunid, parser, dialect, src, res,tags) lines
+do a full outer join between them, on
+  parser,dialect,src
+so you have
+parser,dialect,src,res a, tags a, res b, tags b
+
+then output this as the result
+
+see what happens if you highlight the differences in localc, edit some
+tags, then save as csv - does the highlighting just disappear leaving
+the interesting data only?
+
+-}
+    
+
+compareFiles :: ByteString -> ByteString -> IO ByteString
+compareFiles csva csvb = do
+    let data1 :: [(Text,Text,Text,Text,Text,Text)]
+        data1 = either (error . show) V.toList $ decode NoHeader csva
+        data2 :: [(Text,Text,Text,Text,Text,Text)]
+        data2 = either (error . show) V.toList $ decode NoHeader csvb
+    conn <- open ":memory:"
+    execute_ conn [R.r|
+create table data1 (
+    testrunida text,
+    parser text,
+    dialect text,
+    source text,
+    result_a text,
+    tags_a text)|]
+    execute_ conn [R.r|
+create table data2 (
+    testrunidb text,
+    parser text,
+    dialect text,
+    source text,
+    result_b text,
+    tags_b text)|]
+    
+    executeMany conn "insert into data1 values (?,?,?,?,?,?)" data1
+    executeMany conn "insert into data2 values (?,?,?,?,?,?)" data2
+    r <- query_ conn [R.r|
+select
+   parser, dialect, source, result_a, tags_a, result_b, tags_b
+from data1 natural full outer join data2|] :: IO [(Text,Text,Text,Text,Text,Text,Text)]
+
+    pure $ encode r
+
+------------------------------------------------------------------------------
+
+-- running tests
+
+runTests :: ByteString -> ByteString
+runTests csvsrc =
+    let csv :: Vector (Text,Text,Text)
+        csv = either (error . show) id $ decode NoHeader csvsrc
+
+        testrunid = ("0" :: Text)
+    
+        testLine (parser,dialect,src) =
+            let d = case dialect of
+                    "ansi2011" -> ansi2011
+                    "postgres" -> postgres
+                    "sqlserver" -> sqlserver
+                    "mysql" -> mysql
+                    "params" -> ansi2011{diAtIdentifier=True, diHashIdentifier= True}
+                    "odbc" -> ansi2011{diOdbc=True}
+                    _ -> error $ "unknown dialect: " <> T.unpack dialect
+                res = case parser of
+                        "queryExpr" ->
+                            either prettyError (T.pack . ppShow)
+                            $ parseQueryExpr d "" Nothing src
+                        "scalarExpr" ->
+                            either prettyError (T.pack . ppShow)
+                            $ parseScalarExpr d "" Nothing src
+                        _ -> error $ "unknown parser: " <> T.unpack parser
+                -- prepend a newline to multi line fields, so they show
+                -- nice in a diff in meld or similar
+                resadj = if '\n' `T.elem` res
+                         then T.cons '\n' res
+                         else res
+            in (testrunid, parser, dialect, src, resadj,"" :: Text)
+
+        allres = V.map testLine csv
+    in encode $ V.toList allres
+                
+------------------------------------------------------------------------------
+
+-- generating data
+
+generateData :: ByteString
+generateData =
+    encode $ concat
+    [simpleExpressions1
+    ,pgExprs
+    ,sqlServerIden
+    ,mysqliden
+    ,paramvariations
+    ,odbcexpr
+    ,odbcqexpr
+    ,otherParseErrorExamples]
+
+--------------------------------------
+
+-- example data
+
+parseExampleStrings :: Text -> [Text]
+parseExampleStrings = filter (not . T.null) . map T.strip . T.splitOn ";"
+
+simpleExpressions1 :: [(Text,Text,Text)]
+simpleExpressions1 =
+    concat $ flip map (parseExampleStrings simpleExprData) $ \e ->
+    [("scalarExpr", "ansi2011", e)
+    ,("queryExpr", "ansi2011", "select " <> e)
+    ,("queryExpr", "ansi2011", "select " <> e <> ",")
+    ,("queryExpr", "ansi2011", "select " <> e <> " from")]
+  where
+    simpleExprData = [R.r|
+'test
+;
+'test''t
+;
+'test''
+;
+3.23e-
+;
+.
+;
+3.23e
+;
+a.3
+;
+3.a
+;
+3.2a
+;
+4iden
+;
+4iden.
+;
+iden.4iden
+;
+4iden.*
+;
+from
+;
+from.a
+;
+a.from
+;
+not
+;
+4 +
+;
+4 + from
+;
+(5
+;
+(5 +
+;
+(5 + 6
+;
+(5 + from)
+;
+case
+;
+case a
+;
+case a when b c end
+;
+case a when b then c
+;
+case a else d end
+;
+case a from c end
+;
+case a when from then to end
+;
+/* blah
+;
+/* blah /* stuff */
+;
+/* *
+;
+/* /
+;
+$$something$
+;
+$$something
+;
+$$something
+x
+;
+$a$something$b$
+;
+$a$
+;
+'''
+;
+'''''
+;
+"a
+;
+"a""
+;
+"""
+;
+"""""
+;
+""
+;
+*/
+;
+:3
+;
+@3
+;
+#3
+;
+:::
+;
+|||
+;
+...
+;
+"
+;
+]
+;
+)
+;
+[test
+;
+[]
+;
+[[test]]
+;
+`open
+;
+```
+;
+``
+;
+}
+;
+mytype(4 '4';
+;
+app(3
+;
+app(
+;
+app(something
+;
+count(*
+;
+count(* filter (where something > 5)
+;
+count(*) filter (where something > 5
+;
+count(*) filter (
+;
+sum(a over (order by b)
+;
+sum(a) over (order by b
+;
+sum(a) over (
+;
+rank(a,c within group (order by b)
+;
+rank(a,c) within group (order by b
+;
+rank(a,c) within group (
+;
+array[
+;
+|]
+
+pgExprs :: [(Text,Text,Text)]
+pgExprs = flip map (parseExampleStrings src) $ \e ->
+    ("scalarExpr", "postgres", e)
+  where src = [R.r|
+$$something$
+;
+$$something
+;
+$$something
+x
+;
+$a$something$b$
+;
+$a$
+;
+:::
+;
+|||
+;
+...
+;
+
+|]
+
+sqlServerIden :: [(Text,Text,Text)]
+sqlServerIden = flip map (parseExampleStrings src) $ \e ->
+    ("scalarExpr", "sqlserver", e)
+  where src = [R.r|
+]
+;
+[test
+;
+[]
+;
+[[test]]
+
+|]
+
+mysqliden :: [(Text,Text,Text)]
+mysqliden = flip map (parseExampleStrings src) $ \e ->
+    ("scalarExpr", "mysql", e)
+  where src = [R.r|
+`open
+;
+```
+;
+``
+
+|]
+
+paramvariations :: [(Text,Text,Text)]
+paramvariations = flip map (parseExampleStrings src) $ \e ->
+    ("scalarExpr", "params", e)
+  where src = [R.r|
+:3
+;
+@3
+;
+#3
+
+|]
+
+
+odbcexpr :: [(Text,Text,Text)]
+odbcexpr = flip map (parseExampleStrings src) $ \e ->
+    ("scalarExpr", "odbc", e)
+  where src = [R.r|
+{d '2000-01-01'
+;
+{fn CHARACTER_LENGTH(string_exp)
+
+|]
+
+odbcqexpr :: [(Text,Text,Text)]
+odbcqexpr = flip map (parseExampleStrings src) $ \e ->
+    ("queryExpr", "odbc", e)
+  where src = [R.r|
+select * from {oj t1 left outer join t2 on expr
+
+|]
+
+
+    
+otherParseErrorExamples :: [(Text,Text,Text)]
+otherParseErrorExamples = flip map (parseExampleStrings src) $ \e ->
+    ("queryExpr", "ansi2011", e)
+  where src = [R.r|
+select a select
+;
+select a from t,
+;
+select a from t select
+;
+select a from t(a)
+;
+select a from (t
+;
+select a from (t having
+;
+select a from t a b
+;
+select a from t as
+;
+select a from t as having
+;
+select a from (1234)
+;
+select a from (1234
+;
+select a from a wrong join b
+;
+select a from a natural wrong join b
+;
+select a from a left wrong join b
+;
+select a from a left wrong join b
+;
+select a from a join b select
+;
+select a from a join b on select
+;
+select a from a join b on (1234
+;
+select a from a join b using(a
+;
+select a from a join b using(a,
+;
+select a from a join b using(a,)
+;
+select a from a join b using(1234
+;
+select a from t order no a
+;
+select a from t order by a where c
+;
+select 'test
+'
+
+|]

examples/SimpleSQLParserTool.hs

@@ -89,7 +89,7 @@ lexCommand =
       (f,src) <- getInput args
       either (error . T.unpack . L.prettyError)
              (putStrLn . intercalate ",\n" . map show)
-             $ L.lexSQL ansi2011 (T.pack f) Nothing (T.pack src)
+             $ L.lexSQL ansi2011 False (T.pack f) Nothing (T.pack src)
   )
 
 

simple-sql-parser.cabal

@@ -1,7 +1,7 @@
 cabal-version:       2.2
 
 name:                simple-sql-parser
-version:             0.7.1
+version:             0.8.0
 synopsis:            A parser for SQL.
 
 description:         A parser for SQL. Parses most SQL:2011
@@ -29,6 +29,11 @@ Flag parserexe
   Description: Build SimpleSQLParserTool exe
   Default:     False
 
+Flag testexe
+  Description: Build Testing exe
+  Default:     False
+
+
 common shared-properties
   default-language:    Haskell2010
   build-depends:       base >=4 && <5,
@@ -56,8 +61,10 @@ Test-Suite Tests
   main-is:             RunTests.hs
   hs-source-dirs:      tests
   Build-Depends:       simple-sql-parser,
-                       tasty >= 1.1 && < 1.6,
+                       hspec,
-                       tasty-hunit >= 0.9 && < 0.11
+                       hspec-megaparsec,
+                       hspec-expectations,
+                       raw-strings-qq,
 
   Other-Modules:       Language.SQL.SimpleSQL.ErrorMessages,
                        Language.SQL.SimpleSQL.FullQueries,
@@ -82,6 +89,8 @@ Test-Suite Tests
                        Language.SQL.SimpleSQL.CustomDialect,
                        Language.SQL.SimpleSQL.EmptyStatement,
                        Language.SQL.SimpleSQL.CreateIndex
+                       Language.SQL.SimpleSQL.Expectations
+                       Language.SQL.SimpleSQL.TestRunners
                        
   ghc-options:         -threaded
 
@@ -95,3 +104,23 @@ executable SimpleSQLParserTool
     buildable:         True
   else
     buildable:         False
+
+executable error-messages-tool
+  import:              shared-properties
+  main-is:             ErrorMessagesTool.hs
+  hs-source-dirs:      examples
+  Build-Depends:       base,
+                       text,
+                       raw-strings-qq,
+                       containers,
+                       megaparsec,
+                       simple-sql-parser,
+                       pretty-show,
+                       bytestring,
+                       cassava,
+                       vector,
+                       sqlite-simple,
+  if flag(testexe)
+    buildable:         True
+  else
+    buildable:         False

tests/Language/SQL/SimpleSQL/CreateIndex.hs

@@ -4,15 +4,19 @@ module Language.SQL.SimpleSQL.CreateIndex where
 
 import Language.SQL.SimpleSQL.Syntax
 import Language.SQL.SimpleSQL.TestTypes
+import Language.SQL.SimpleSQL.TestRunners
+import Data.Text (Text)
 
 createIndexTests :: TestItem
 createIndexTests = Group "create index tests"
-    [TestStatement ansi2011 "create index a on tbl(c1)"
+    [s "create index a on tbl(c1)"
       $ CreateIndex False [nm "a"] [nm "tbl"] [nm "c1"]
-    ,TestStatement ansi2011 "create index a.b on sc.tbl (c1, c2)"
+    ,s "create index a.b on sc.tbl (c1, c2)"
       $ CreateIndex False [nm "a", nm "b"] [nm "sc", nm "tbl"] [nm "c1", nm "c2"]
-    ,TestStatement ansi2011 "create unique index a on tbl(c1)"
+    ,s "create unique index a on tbl(c1)"
       $ CreateIndex True [nm "a"] [nm "tbl"] [nm "c1"]
     ]
   where
     nm = Name Nothing
+    s :: HasCallStack => Text -> Statement -> TestItem
+    s src ast = testStatement ansi2011 src ast

tests/Language/SQL/SimpleSQL/CustomDialect.hs

@@ -3,26 +3,30 @@
 module Language.SQL.SimpleSQL.CustomDialect (customDialectTests) where
 
 import Language.SQL.SimpleSQL.TestTypes
+import Language.SQL.SimpleSQL.TestRunners
+import Data.Text (Text)
 
 customDialectTests :: TestItem
-customDialectTests = Group "custom dialect tests" (map (uncurry ParseQueryExpr) passTests
+customDialectTests = Group "custom dialect tests" $
-    ++ map (uncurry ParseScalarExprFails) failTests )
+    [q ansi2011 "SELECT a b"
+    ,q noDateKeyword "SELECT DATE('2000-01-01')"
+    ,q noDateKeyword "SELECT DATE"
+    ,q dateApp "SELECT DATE('2000-01-01')"
+    ,q dateIden "SELECT DATE"
+    ,f ansi2011 "SELECT DATE('2000-01-01')"
+    ,f ansi2011 "SELECT DATE"
+    ,f dateApp "SELECT DATE"
+    ,f dateIden "SELECT DATE('2000-01-01')"
+    -- show this never being allowed as an alias
+    ,f ansi2011 "SELECT a date"
+    ,f dateApp "SELECT a date"
+    ,f dateIden "SELECT a date"
+    ]
   where
-    failTests = [(ansi2011,"SELECT DATE('2000-01-01')")
-                ,(ansi2011,"SELECT DATE")
-                ,(dateApp,"SELECT DATE")
-                ,(dateIden,"SELECT DATE('2000-01-01')")
-                -- show this never being allowed as an alias
-                ,(ansi2011,"SELECT a date")
-                ,(dateApp,"SELECT a date")
-                ,(dateIden,"SELECT a date")
-                ]
-    passTests = [(ansi2011,"SELECT a b")
-                ,(noDateKeyword,"SELECT DATE('2000-01-01')")
-                ,(noDateKeyword,"SELECT DATE")
-                ,(dateApp,"SELECT DATE('2000-01-01')")
-                ,(dateIden,"SELECT DATE")
-                ]
     noDateKeyword = ansi2011 {diKeywords = filter (/="date") (diKeywords ansi2011)}
     dateIden = ansi2011 {diIdentifierKeywords = "date" : diIdentifierKeywords ansi2011}
     dateApp = ansi2011 {diAppKeywords = "date" : diAppKeywords ansi2011}
+    q :: HasCallStack => Dialect -> Text -> TestItem
+    q d src = testParseQueryExpr d src
+    f :: HasCallStack => Dialect -> Text -> TestItem
+    f d src = testParseQueryExprFails d src

tests/Language/SQL/SimpleSQL/EmptyStatement.hs

@@ -3,19 +3,26 @@ module Language.SQL.SimpleSQL.EmptyStatement where
 
 import Language.SQL.SimpleSQL.Syntax
 import Language.SQL.SimpleSQL.TestTypes
+import Language.SQL.SimpleSQL.TestRunners
+import Data.Text (Text)
 
 emptyStatementTests :: TestItem
 emptyStatementTests = Group "empty statement"
-  [ TestStatement ansi2011 ";" EmptyStatement
+  [ s ";" EmptyStatement
-  , TestStatements ansi2011 ";" [EmptyStatement]
+  , t ";" [EmptyStatement]
-  , TestStatements ansi2011 ";;" [EmptyStatement, EmptyStatement]
+  , t ";;" [EmptyStatement, EmptyStatement]
-  , TestStatements ansi2011 ";;;" [EmptyStatement, EmptyStatement, EmptyStatement]
+  , t ";;;" [EmptyStatement, EmptyStatement, EmptyStatement]
-  , TestStatement ansi2011 "/* comment */ ;" EmptyStatement
+  , s "/* comment */ ;" EmptyStatement
-  , TestStatements ansi2011 "" []
+  , t "" []
-  , TestStatements ansi2011 "/* comment */" []
+  , t "/* comment */" []
-  , TestStatements ansi2011 "/* comment */ ;" [EmptyStatement]
+  , t "/* comment */ ;" [EmptyStatement]
-  , TestStatements ansi2011 "/* comment */ ; /* comment */ ;"
+  , t "/* comment */ ; /* comment */ ;"
       [EmptyStatement, EmptyStatement]
-  , TestStatements ansi2011 "/* comment */ ; /* comment */ ; /* comment */ ;"
+  , t "/* comment */ ; /* comment */ ; /* comment */ ;"
       [EmptyStatement, EmptyStatement, EmptyStatement]
   ]
+  where
+    s :: HasCallStack => Text -> Statement -> TestItem
+    s src a = testStatement ansi2011 src a
+    t :: HasCallStack => Text -> [Statement] -> TestItem
+    t src a = testStatements ansi2011 src a

tests/Language/SQL/SimpleSQL/ErrorMessages.hs

@@ -1,156 +1,82 @@
 
 {-
-Want to work on the error messages. Ultimately, parsec won't give the
+See the file examples/ErrorMessagesTool.hs for some work on this
-best error message for a parser combinator library in haskell. Should
-check out the alternatives such as polyparse and uu-parsing.
 
-For now the plan is to try to get the best out of parsec. Skip heavy
-work on this until the parser is more left factored?
-
-Ideas:
-
-1. generate large lists of invalid syntax
-2. create table of the sql source and the error message
-3. save these tables and compare from version to version. Want to
-   catch improvements and regressions and investigate. Have to do this
-   manually
-
-= generating bad sql source
-
-take good sql statements or expressions. Convert them into sequences
-of tokens - want to preserve the whitespace and comments perfectly
-here. Then modify these lists by either adding a token, removing a
-token, or modifying a token (including creating bad tokens of raw
-strings which don't represent anything than can be tokenized.
-
-Now can see the error message for all of these bad strings. Probably
-have to generate and prune this list manually in stages since there
-will be too many.
-
-Contexts:
-
-another area to focus on is contexts: for instance, we have a set of
-e.g. 1000 bad scalar expressions with error messages. Now can put
-those bad scalar expressions into various contexts and see that the
-error messages are still good.
-
-plan:
-
-1. create a list of all the value expression, with some variations for
-   each
-2. manually create some error variations for each expression
-3. create a renderer which will create a csv of the expressions and
-   the errors
-   this is to load as a spreadsheet to investigate more
-4. create a renderer for the csv which will create a markdown file for
-   the website. this is to demonstrate the error messages in the
-   documentation
-
-Then create some contexts for all of these: inside another value
-expression, or inside a query expression. Do the same: render and
-review the error messages.
-
-Then, create some query expressions to focus on the non value
-expression parts.
--}
-
-
-module Language.SQL.SimpleSQL.ErrorMessages where
-
-{-import Language.SQL.SimpleSQL.Parser
-import Data.List
-import Text.Groom
-
-valueExpressions :: [String]
-valueExpressions =
-    ["10.."
-    ,"..10"
-    ,"10e1e2"
-    ,"10e--3"
-    ,"1a"
-    ,"1%"
-
-    ,"'b'ad'"
-    ,"'bad"
-    ,"bad'"
-
-    ,"interval '5' ay"
-    ,"interval '5' day (4.4)"
-    ,"interval '5' day (a)"
-    ,"intervala '5' day"
-    ,"interval 'x' day (3"
-    ,"interval 'x' day 3)"
-
-    ,"1badiden"
-    ,"$"
-    ,"!"
-    ,"*.a"
-
-    ,"??"
-    ,"3?"
-    ,"?a"
-
-    ,"row"
-    ,"row 1,2"
-    ,"row(1,2"
-    ,"row 1,2)"
-    ,"row(1 2)"
-
-    ,"f("
-    ,"f)"
-
-    ,"f(a"
-    ,"f a)"
-    ,"f(a b)"
-
-{-
 TODO:
-case
-operators
--}
 
-   ,"a + (b + c"
+add simple test to check the error and quoting on later line in multi
+line input for lexing and parsing; had a regression here that made it
+to a release
 
-{-
-casts
-subqueries: + whole set of parentheses use
-in list
-'keyword' functions
-aggregates
-window functions
 -}
 
 
-   ]
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+module Language.SQL.SimpleSQL.ErrorMessages
+    (errorMessageTests
+    ) where
 
-queryExpressions :: [String]
+import Language.SQL.SimpleSQL.TestTypes
-queryExpressions =
+import Language.SQL.SimpleSQL.Parse
-    map sl1 valueExpressions
+import qualified Language.SQL.SimpleSQL.Lex as L
-    ++ map sl2 valueExpressions
+import Language.SQL.SimpleSQL.TestRunners
-    ++ map sl3 valueExpressions
+--import Language.SQL.SimpleSQL.Syntax
-    ++
+import Language.SQL.SimpleSQL.Expectations
-    ["select a from t inner jin u"]
+import Test.Hspec (it)
+import Debug.Trace
+
+import Data.Text (Text)
+import qualified Data.Text as T
+
+import qualified Text.RawString.QQ as R
+
+errorMessageTests :: TestItem
+errorMessageTests = Group "error messages"
+    [gp (parseQueryExpr ansi2011 "" Nothing) prettyError [R.r|
+
+select
+a
+from t
+where
+  something
+order by 1,2,3 where
+
+        |]
+        [R.r|8:16:
+  |
+8 | order by 1,2,3 where
+  |                ^^^^^
+unexpected where
+|]
+   ,gp (L.lexSQL ansi2011 False "" Nothing)  L.prettyError [R.r|
+           
+select
+a
+from t
+where
+  something
+order by 1,2,3 $@
+
+        |]
+        [R.r|8:16:
+  |
+8 | order by 1,2,3 $@
+  |                ^
+unexpected '$'
+|]
+        ]
   where
-    sl1 x = "select " ++ x ++ " from t"
+    
-    sl2 x = "select " ++ x ++ ", y from t"
+    gp :: (Show a, HasCallStack) => (Text -> Either e a) -> (e -> Text) -> Text -> Text -> TestItem
-    sl3 x = "select " ++ x ++ " fom t"
+    gp parse pret src err =
-
+        GeneralParseFailTest src err $
-valExprs :: [String] -> [(String,String)]
+           it (T.unpack src) $
-valExprs = map parseOne
+           let f1 = parse src
-  where
+               ex = shouldFailWith pret
-    parseOne x = let p = parseValueExpr "" Nothing x
+               quickTrace =
-                 in (x,either peFormattedError (\x -> "ERROR: parsed ok " ++ groom x) p)
+                   case f1 of
-
+                       Left f | pret f /= err ->
-
+                            trace (T.unpack ("check\n[" <> pret f <>"]\n["<> err <> "]\n"))
-queryExprs :: [String] -> [(String,String)]
+                       _ -> id
-queryExprs = map parseOne
+           in quickTrace (f1 `ex` err)
-  where
-    parseOne x = let p = parseQueryExpr "" Nothing x
-                 in (x,either peFormattedError (\x -> "ERROR: parsed ok " ++ groom x) p)
-
-
-pExprs :: [String] -> [String] -> String
-pExprs x y =
-    let l = valExprs x ++ queryExprs y
-    in intercalate "\n\n\n\n" $ map (\(a,b) -> a ++ "\n" ++ b) l
--}

tests/Language/SQL/SimpleSQL/Expectations.hs

@@ -0,0 +1,61 @@
+
+module Language.SQL.SimpleSQL.Expectations
+    (shouldParseA
+    ,shouldParseL
+    ,shouldParse1
+    ,shouldFail
+    ,shouldSucceed
+    ,shouldFailWith
+    ) where
+
+
+import Language.SQL.SimpleSQL.Parse
+import qualified Language.SQL.SimpleSQL.Lex as Lex
+
+import qualified Data.Text as T
+import Data.Text (Text)
+
+import Test.Hspec.Expectations
+    (Expectation
+    ,HasCallStack
+    ,expectationFailure
+    )
+
+import Test.Hspec
+    (shouldBe
+    )
+
+shouldParseA :: (HasCallStack,Eq a, Show a) => Either ParseError a -> a -> Expectation
+shouldParseA = shouldParse1 (T.unpack . prettyError)
+
+shouldParseL :: (HasCallStack,Eq a, Show a) => Either Lex.ParseError a -> a -> Expectation
+shouldParseL = shouldParse1 (T.unpack . Lex.prettyError)
+
+shouldParse1 :: (HasCallStack, Show a, Eq a) =>
+               (e -> String)
+            -> Either e a
+            -> a
+            -> Expectation    
+shouldParse1 prettyErr r v = case r of
+  Left e ->
+    expectationFailure $
+      "expected: "
+        ++ show v
+        ++ "\nbut parsing failed with error:\n"
+        ++ prettyErr e
+  Right x -> x `shouldBe` v
+
+shouldFail :: (HasCallStack, Show a) => Either e a -> Expectation    
+shouldFail r = case r of
+  Left _ -> (1 :: Int) `shouldBe` 1
+  Right a -> expectationFailure $ "expected parse failure, but succeeded with " <> show a
+
+shouldFailWith :: (HasCallStack, Show a) => (e -> Text) -> Either e a -> Text -> Expectation    
+shouldFailWith p r e = case r of
+  Left e1 -> p e1 `shouldBe` e
+  Right a -> expectationFailure $ "expected parse failure, but succeeded with " <> show a
+
+shouldSucceed :: (HasCallStack) => (e -> String) -> Either e a -> Expectation
+shouldSucceed pe r = case r of
+  Left e -> expectationFailure $ "expected parse success, but got: " <> pe e
+  Right _ -> (1 :: Int) `shouldBe` 1

tests/Language/SQL/SimpleSQL/FullQueries.hs

@@ -6,24 +6,24 @@ module Language.SQL.SimpleSQL.FullQueries (fullQueriesTests) where
 
 import Language.SQL.SimpleSQL.TestTypes
 import Language.SQL.SimpleSQL.Syntax
-
+import Language.SQL.SimpleSQL.TestRunners
+import Data.Text (Text)
 
 fullQueriesTests :: TestItem
-fullQueriesTests = Group "queries" $ map (uncurry (TestQueryExpr ansi2011))
+fullQueriesTests = Group "queries" $
-    [("select count(*) from t"
+    [q "select count(*) from t"
-     ,toQueryExpr $ makeSelect
+     $ toQueryExpr $ makeSelect
       {msSelectList = [(App [Name Nothing "count"] [Star], Nothing)]
       ,msFrom = [TRSimple [Name Nothing "t"]]
       }
-     )
 
-    ,("select a, sum(c+d) as s\n\
+    ,q "select a, sum(c+d) as s\n\
       \  from t,u\n\
       \  where a > 5\n\
       \  group by a\n\
       \  having count(1) > 5\n\
       \  order by s"
-     ,toQueryExpr $ makeSelect
+     $ toQueryExpr $ makeSelect
       {msSelectList = [(Iden [Name Nothing "a"], Nothing)
                       ,(App [Name Nothing "sum"]
                         [BinOp (Iden [Name Nothing "c"])
@@ -36,5 +36,8 @@ fullQueriesTests = Group "queries" $ map (uncurry (TestQueryExpr ansi2011))
                                [Name Nothing ">"] (NumLit "5")
       ,msOrderBy = [SortSpec (Iden [Name Nothing "s"]) DirDefault NullsOrderDefault]
       }
-     )
+     
     ]
+  where
+    q :: HasCallStack => Text -> QueryExpr -> TestItem
+    q src a = testQueryExpr ansi2011 src a

tests/Language/SQL/SimpleSQL/GroupBy.hs

@@ -6,6 +6,8 @@ module Language.SQL.SimpleSQL.GroupBy (groupByTests) where
 
 import Language.SQL.SimpleSQL.TestTypes
 import Language.SQL.SimpleSQL.Syntax
+import Language.SQL.SimpleSQL.TestRunners
+import Data.Text (Text)
 
 
 groupByTests :: TestItem
@@ -15,23 +17,31 @@ groupByTests = Group "groupByTests"
     ,randomGroupBy
     ]
 
+q :: HasCallStack => Text -> QueryExpr -> TestItem
+q src a = testQueryExpr ansi2011 src a
+
+p :: HasCallStack => Text -> TestItem
+p src = testParseQueryExpr ansi2011 src
+
+
+
 simpleGroupBy :: TestItem
-simpleGroupBy = Group "simpleGroupBy" $ map (uncurry (TestQueryExpr ansi2011))
+simpleGroupBy = Group "simpleGroupBy"
-    [("select a,sum(b) from t group by a"
+    [q "select a,sum(b) from t group by a"
-     ,toQueryExpr $ makeSelect {msSelectList = [(Iden [Name Nothing "a"],Nothing)
+     $ toQueryExpr $ makeSelect {msSelectList = [(Iden [Name Nothing "a"],Nothing)
                                  ,(App [Name Nothing "sum"] [Iden [Name Nothing "b"]],Nothing)]
                  ,msFrom = [TRSimple [Name Nothing "t"]]
                  ,msGroupBy = [SimpleGroup $ Iden [Name Nothing "a"]]
-                 })
+                 }
 
-    ,("select a,b,sum(c) from t group by a,b"
+    ,q "select a,b,sum(c) from t group by a,b"
-     ,toQueryExpr $ makeSelect {msSelectList = [(Iden [Name Nothing "a"],Nothing)
+     $ toQueryExpr $ makeSelect {msSelectList = [(Iden [Name Nothing "a"],Nothing)
                                  ,(Iden [Name Nothing "b"],Nothing)
                                  ,(App [Name Nothing "sum"] [Iden [Name Nothing "c"]],Nothing)]
                  ,msFrom = [TRSimple [Name Nothing "t"]]
                  ,msGroupBy = [SimpleGroup $ Iden [Name Nothing "a"]
                               ,SimpleGroup $ Iden [Name Nothing "b"]]
-                 })
+                 }
     ]
 
 {-
@@ -40,15 +50,15 @@ sure which sql version they were introduced, 1999 or 2003 I think).
 -}
 
 newGroupBy :: TestItem
-newGroupBy = Group "newGroupBy" $ map (uncurry (TestQueryExpr ansi2011))
+newGroupBy = Group "newGroupBy"
-    [("select * from t group by ()", ms [GroupingParens []])
+    [q "select * from t group by ()" $ ms [GroupingParens []]
-    ,("select * from t group by grouping sets ((), (a))"
+    ,q "select * from t group by grouping sets ((), (a))"
-     ,ms [GroupingSets [GroupingParens []
+     $ ms [GroupingSets [GroupingParens []
-                       ,GroupingParens [SimpleGroup $ Iden [Name Nothing "a"]]]])
+                       ,GroupingParens [SimpleGroup $ Iden [Name Nothing "a"]]]]
-    ,("select * from t group by cube(a,b)"
+    ,q "select * from t group by cube(a,b)"
-     ,ms [Cube [SimpleGroup $ Iden [Name Nothing "a"], SimpleGroup $ Iden [Name Nothing "b"]]])
+     $ ms [Cube [SimpleGroup $ Iden [Name Nothing "a"], SimpleGroup $ Iden [Name Nothing "b"]]]
-    ,("select * from t group by rollup(a,b)"
+    ,q "select * from t group by rollup(a,b)"
-     ,ms [Rollup [SimpleGroup $ Iden [Name Nothing "a"], SimpleGroup $ Iden [Name Nothing "b"]]])
+     $ ms [Rollup [SimpleGroup $ Iden [Name Nothing "a"], SimpleGroup $ Iden [Name Nothing "b"]]]
     ]
   where
     ms g = toQueryExpr $ makeSelect {msSelectList = [(Star,Nothing)]
@@ -56,21 +66,21 @@ newGroupBy = Group "newGroupBy" $ map (uncurry (TestQueryExpr ansi2011))
                       ,msGroupBy = g}
 
 randomGroupBy :: TestItem
-randomGroupBy = Group "randomGroupBy" $ map (ParseQueryExpr ansi2011)
+randomGroupBy = Group "randomGroupBy"
-    ["select * from t GROUP BY a"
+    [p "select * from t GROUP BY a"
-    ,"select * from t GROUP BY GROUPING SETS((a))"
+    ,p "select * from t GROUP BY GROUPING SETS((a))"
-    ,"select * from t GROUP BY a,b,c"
+    ,p "select * from t GROUP BY a,b,c"
-    ,"select * from t GROUP BY GROUPING SETS((a,b,c))"
+    ,p "select * from t GROUP BY GROUPING SETS((a,b,c))"
-    ,"select * from t GROUP BY ROLLUP(a,b)"
+    ,p "select * from t GROUP BY ROLLUP(a,b)"
-    ,"select * from t GROUP BY GROUPING SETS((a,b),\n\
+    ,p "select * from t GROUP BY GROUPING SETS((a,b),\n\
      \(a),\n\
      \() )"
-    ,"select * from t GROUP BY ROLLUP(b,a)"
+    ,p "select * from t GROUP BY ROLLUP(b,a)"
-    ,"select * from t GROUP BY GROUPING SETS((b,a),\n\
+    ,p "select * from t GROUP BY GROUPING SETS((b,a),\n\
      \(b),\n\
      \() )"
-    ,"select * from t GROUP BY CUBE(a,b,c)"
+    ,p "select * from t GROUP BY CUBE(a,b,c)"
-    ,"select * from t GROUP BY GROUPING SETS((a,b,c),\n\
+    ,p "select * from t GROUP BY GROUPING SETS((a,b,c),\n\
      \(a,b),\n\
      \(a,c),\n\
      \(b,c),\n\
@@ -78,33 +88,33 @@ randomGroupBy = Group "randomGroupBy" $ map (ParseQueryExpr ansi2011)
      \(b),\n\
      \(c),\n\
      \() )"
-    ,"select * from t GROUP BY ROLLUP(Province, County, City)"
+    ,p "select * from t GROUP BY ROLLUP(Province, County, City)"
-    ,"select * from t GROUP BY ROLLUP(Province, (County, City))"
+    ,p "select * from t GROUP BY ROLLUP(Province, (County, City))"
-    ,"select * from t GROUP BY ROLLUP(Province, (County, City))"
+    ,p "select * from t GROUP BY ROLLUP(Province, (County, City))"
-    ,"select * from t GROUP BY GROUPING SETS((Province, County, City),\n\
+    ,p "select * from t GROUP BY GROUPING SETS((Province, County, City),\n\
      \(Province),\n\
      \() )"
-    ,"select * from t GROUP BY GROUPING SETS((Province, County, City),\n\
+    ,p "select * from t GROUP BY GROUPING SETS((Province, County, City),\n\
      \(Province, County),\n\
      \(Province),\n\
      \() )"
-    ,"select * from t GROUP BY a, ROLLUP(b,c)"
+    ,p "select * from t GROUP BY a, ROLLUP(b,c)"
-    ,"select * from t GROUP BY GROUPING SETS((a,b,c),\n\
+    ,p "select * from t GROUP BY GROUPING SETS((a,b,c),\n\
      \(a,b),\n\
      \(a) )"
-    ,"select * from t GROUP BY a, b, ROLLUP(c,d)"
+    ,p "select * from t GROUP BY a, b, ROLLUP(c,d)"
-    ,"select * from t GROUP BY GROUPING SETS((a,b,c,d),\n\
+    ,p "select * from t GROUP BY GROUPING SETS((a,b,c,d),\n\
      \(a,b,c),\n\
      \(a,b) )"
-    ,"select * from t GROUP BY ROLLUP(a), ROLLUP(b,c)"
+    ,p "select * from t GROUP BY ROLLUP(a), ROLLUP(b,c)"
-    ,"select * from t GROUP BY GROUPING SETS((a,b,c),\n\
+    ,p "select * from t GROUP BY GROUPING SETS((a,b,c),\n\
      \(a,b),\n\
      \(a),\n\
      \(b,c),\n\
      \(b),\n\
      \() )"
-    ,"select * from t GROUP BY ROLLUP(a), CUBE(b,c)"
+    ,p "select * from t GROUP BY ROLLUP(a), CUBE(b,c)"
-    ,"select * from t GROUP BY GROUPING SETS((a,b,c),\n\
+    ,p "select * from t GROUP BY GROUPING SETS((a,b,c),\n\
      \(a,b),\n\
      \(a,c),\n\
      \(a),\n\
@@ -112,8 +122,8 @@ randomGroupBy = Group "randomGroupBy" $ map (ParseQueryExpr ansi2011)
      \(b),\n\
      \(c),\n\
      \() )"
-    ,"select * from t GROUP BY CUBE(a,b), ROLLUP(c,d)"
+    ,p "select * from t GROUP BY CUBE(a,b), ROLLUP(c,d)"
-    ,"select * from t GROUP BY GROUPING SETS((a,b,c,d),\n\
+    ,p "select * from t GROUP BY GROUPING SETS((a,b,c,d),\n\
      \(a,b,c),\n\
      \(a,b),\n\
      \(a,c,d),\n\
@@ -125,16 +135,16 @@ randomGroupBy = Group "randomGroupBy" $ map (ParseQueryExpr ansi2011)
      \(c,d),\n\
      \(c),\n\
      \() )"
-    ,"select * from t GROUP BY a, ROLLUP(a,b)"
+    ,p "select * from t GROUP BY a, ROLLUP(a,b)"
-    ,"select * from t GROUP BY GROUPING SETS((a,b),\n\
+    ,p "select * from t GROUP BY GROUPING SETS((a,b),\n\
      \(a) )"
-    ,"select * from t GROUP BY Region,\n\
+    ,p "select * from t GROUP BY Region,\n\
      \ROLLUP(Sales_Person, WEEK(Sales_Date)),\n\
      \CUBE(YEAR(Sales_Date), MONTH (Sales_Date))"
-    ,"select * from t GROUP BY ROLLUP (Region, Sales_Person, WEEK(Sales_Date),\n\
+    ,p "select * from t GROUP BY ROLLUP (Region, Sales_Person, WEEK(Sales_Date),\n\
      \YEAR(Sales_Date), MONTH(Sales_Date) )"
 
-    ,"SELECT WEEK(SALES_DATE) AS WEEK,\n\
+    ,p "SELECT WEEK(SALES_DATE) AS WEEK,\n\
      \DAYOFWEEK(SALES_DATE) AS DAY_WEEK,\n\
      \SALES_PERSON, SUM(SALES) AS UNITS_SOLD\n\
      \FROM SALES\n\
@@ -142,7 +152,7 @@ randomGroupBy = Group "randomGroupBy" $ map (ParseQueryExpr ansi2011)
      \GROUP BY WEEK(SALES_DATE), DAYOFWEEK(SALES_DATE), SALES_PERSON\n\
      \ORDER BY WEEK, DAY_WEEK, SALES_PERSON"
 
-    ,"SELECT WEEK(SALES_DATE) AS WEEK,\n\
+    ,p "SELECT WEEK(SALES_DATE) AS WEEK,\n\
      \DAYOFWEEK(SALES_DATE) AS DAY_WEEK,\n\
      \SALES_PERSON, SUM(SALES) AS UNITS_SOLD\n\
      \FROM SALES\n\
@@ -151,7 +161,7 @@ randomGroupBy = Group "randomGroupBy" $ map (ParseQueryExpr ansi2011)
      \(DAYOFWEEK(SALES_DATE), SALES_PERSON))\n\
      \ORDER BY WEEK, DAY_WEEK, SALES_PERSON"
 
-    ,"SELECT WEEK(SALES_DATE) AS WEEK,\n\
+    ,p "SELECT WEEK(SALES_DATE) AS WEEK,\n\
      \DAYOFWEEK(SALES_DATE) AS DAY_WEEK,\n\
      \SALES_PERSON, SUM(SALES) AS UNITS_SOLD\n\
      \FROM SALES\n\
@@ -159,7 +169,7 @@ randomGroupBy = Group "randomGroupBy" $ map (ParseQueryExpr ansi2011)
      \GROUP BY ROLLUP ( WEEK(SALES_DATE), DAYOFWEEK(SALES_DATE), SALES_PERSON )\n\
      \ORDER BY WEEK, DAY_WEEK, SALES_PERSON"
 
-    ,"SELECT WEEK(SALES_DATE) AS WEEK,\n\
+    ,p "SELECT WEEK(SALES_DATE) AS WEEK,\n\
      \DAYOFWEEK(SALES_DATE) AS DAY_WEEK,\n\
      \SALES_PERSON, SUM(SALES) AS UNITS_SOLD\n\
      \FROM SALES\n\
@@ -167,7 +177,7 @@ randomGroupBy = Group "randomGroupBy" $ map (ParseQueryExpr ansi2011)
      \GROUP BY CUBE ( WEEK(SALES_DATE), DAYOFWEEK(SALES_DATE), SALES_PERSON )\n\
      \ORDER BY WEEK, DAY_WEEK, SALES_PERSON"
 
-    ,"SELECT SALES_PERSON,\n\
+    ,p "SELECT SALES_PERSON,\n\
      \MONTH(SALES_DATE) AS MONTH,\n\
      \SUM(SALES) AS UNITS_SOLD\n\
      \FROM SALES\n\
@@ -176,21 +186,21 @@ randomGroupBy = Group "randomGroupBy" $ map (ParseQueryExpr ansi2011)
      \)\n\
      \ORDER BY SALES_PERSON, MONTH"
 
-    ,"SELECT WEEK(SALES_DATE) AS WEEK,\n\
+    ,p "SELECT WEEK(SALES_DATE) AS WEEK,\n\
      \DAYOFWEEK(SALES_DATE) AS DAY_WEEK,\n\
      \SUM(SALES) AS UNITS_SOLD\n\
      \FROM SALES\n\
      \GROUP BY ROLLUP ( WEEK(SALES_DATE), DAYOFWEEK(SALES_DATE) )\n\
      \ORDER BY WEEK, DAY_WEEK"
 
-    ,"SELECT MONTH(SALES_DATE) AS MONTH,\n\
+    ,p "SELECT MONTH(SALES_DATE) AS MONTH,\n\
      \REGION,\n\
      \SUM(SALES) AS UNITS_SOLD\n\
      \FROM SALES\n\
      \GROUP BY ROLLUP ( MONTH(SALES_DATE), REGION )\n\
      \ORDER BY MONTH, REGION"
 
-    ,"SELECT WEEK(SALES_DATE) AS WEEK,\n\
+    ,p "SELECT WEEK(SALES_DATE) AS WEEK,\n\
      \DAYOFWEEK(SALES_DATE) AS DAY_WEEK,\n\
      \MONTH(SALES_DATE) AS MONTH,\n\
      \REGION,\n\
@@ -200,7 +210,7 @@ randomGroupBy = Group "randomGroupBy" $ map (ParseQueryExpr ansi2011)
      \ROLLUP( MONTH(SALES_DATE), REGION ) )\n\
      \ORDER BY WEEK, DAY_WEEK, MONTH, REGION"
 
-    ,"SELECT R1, R2,\n\
+    ,p "SELECT R1, R2,\n\
      \WEEK(SALES_DATE) AS WEEK,\n\
      \DAYOFWEEK(SALES_DATE) AS DAY_WEEK,\n\
      \MONTH(SALES_DATE) AS MONTH,\n\
@@ -211,7 +221,7 @@ randomGroupBy = Group "randomGroupBy" $ map (ParseQueryExpr ansi2011)
      \(R2,ROLLUP( MONTH(SALES_DATE), REGION ) ))\n\
      \ORDER BY WEEK, DAY_WEEK, MONTH, REGION"
 
-    {-,"SELECT COALESCE(R1,R2) AS GROUP,\n\
+    {-,p "SELECT COALESCE(R1,R2) AS GROUP,\n\
      \WEEK(SALES_DATE) AS WEEK,\n\
      \DAYOFWEEK(SALES_DATE) AS DAY_WEEK,\n\
      \MONTH(SALES_DATE) AS MONTH,\n\
@@ -226,7 +236,7 @@ randomGroupBy = Group "randomGroupBy" $ map (ParseQueryExpr ansi2011)
     -- decimal as a function not allowed due to the reserved keyword
     -- handling: todo, review if this is ansi standard function or
     -- if there are places where reserved keywords can still be used
-    ,"SELECT MONTH(SALES_DATE) AS MONTH,\n\
+    ,p "SELECT MONTH(SALES_DATE) AS MONTH,\n\
      \REGION,\n\
      \SUM(SALES) AS UNITS_SOLD,\n\
      \MAX(SALES) AS BEST_SALE,\n\

tests/Language/SQL/SimpleSQL/LexerTests.hs

@@ -23,6 +23,7 @@ import Language.SQL.SimpleSQL.Lex
     (Token(..)
     ,tokenListWillPrintAndLex
     )
+import Language.SQL.SimpleSQL.TestRunners
 
 import qualified Data.Text as T
 import Data.Text (Text)
@@ -39,50 +40,57 @@ lexerTests = Group "lexerTests" $
     ,sqlServerLexerTests
     ,oracleLexerTests
     ,mySqlLexerTests
-    ,odbcLexerTests]
+    ,odbcLexerTests
+    ]
 
 -- quick sanity tests to see something working
 bootstrapTests :: TestItem
-bootstrapTests = Group "bootstrap tests" [Group "bootstrap tests" $
+bootstrapTests = Group "bootstrap tests" $
-    map (uncurry (LexTest ansi2011)) (
+    [t "iden" [Identifier Nothing "iden"]
-    [("iden", [Identifier Nothing "iden"])
-    ,("'string'", [SqlString "'" "'" "string"])
 
-    ,("  ", [Whitespace "  "])
+    ,t "\"a1normal \"\" iden\"" [Identifier (Just ("\"","\"")) "a1normal \"\" iden"]
-    ,("\t  ", [Whitespace "\t  "])
-    ,("  \n  ", [Whitespace "  \n  "])
 
-    ,("--", [LineComment "--"])
+    ,t "'string'" [SqlString "'" "'" "string"]
-    ,("--\n", [LineComment "--\n"])
-    ,("--stuff", [LineComment "--stuff"])
-    ,("-- stuff", [LineComment "-- stuff"])
-    ,("-- stuff\n", [LineComment "-- stuff\n"])
-    ,("--\nstuff", [LineComment "--\n", Identifier Nothing "stuff"])
-    ,("-- com \nstuff", [LineComment "-- com \n", Identifier Nothing "stuff"])
 
-    ,("/*test1*/", [BlockComment "/*test1*/"])
+    ,t "  " [Whitespace "  "]
-    ,("/**/", [BlockComment "/**/"])
+    ,t "\t  " [Whitespace "\t  "]
-    ,("/***/", [BlockComment "/***/"])
+    ,t "  \n  " [Whitespace "  \n  "]
-    ,("/* * */", [BlockComment "/* * */"])
+    
-    ,("/*test*/", [BlockComment "/*test*/"])
+    ,t "--" [LineComment "--"]
-    ,("/*te/*st*/", [BlockComment "/*te/*st*/"])
+    ,t "--\n" [LineComment "--\n"]
-    ,("/*te*st*/", [BlockComment "/*te*st*/"])
+    ,t "--stuff" [LineComment "--stuff"]
-    ,("/*lines\nmore lines*/", [BlockComment "/*lines\nmore lines*/"])
+    ,t "-- stuff" [LineComment "-- stuff"]
-    ,("/*test1*/\n", [BlockComment "/*test1*/", Whitespace "\n"])
+    ,t "-- stuff\n" [LineComment "-- stuff\n"]
-    ,("/*test1*/stuff", [BlockComment "/*test1*/", Identifier Nothing "stuff"])
+    ,t "--\nstuff" [LineComment "--\n", Identifier Nothing "stuff"]
+    ,t "-- com \nstuff" [LineComment "-- com \n", Identifier Nothing "stuff"]
 
-    ,("1", [SqlNumber "1"])
+    ,t "/*test1*/" [BlockComment "/*test1*/"]
-    ,("42", [SqlNumber "42"])
+    ,t "/**/" [BlockComment "/**/"]
+    ,t "/***/" [BlockComment "/***/"]
+    ,t "/* * */" [BlockComment "/* * */"]
+    ,t "/*test*/" [BlockComment "/*test*/"]
+    ,t "/*te/*st*/*/" [BlockComment "/*te/*st*/*/"]
+    ,t "/*te*st*/" [BlockComment "/*te*st*/"]
+    ,t "/*lines\nmore lines*/" [BlockComment "/*lines\nmore lines*/"]
+    ,t "/*test1*/\n" [BlockComment "/*test1*/", Whitespace "\n"]
+    ,t "/*test1*/stuff" [BlockComment "/*test1*/", Identifier Nothing "stuff"]
 
-    -- have to fix the dialect handling in the tests
+    ,t "1" [SqlNumber "1"]
-    --,("$1", [PositionalArg 1])
+    ,t "42" [SqlNumber "42"]
-    --,("$200", [PositionalArg 200])
 
-    ,(":test", [PrefixedVariable ':' "test"])
+    ,tp "$1" [PositionalArg 1]
+    ,tp "$200" [PositionalArg 200]
 
-    ] ++ map (\a -> (a, [Symbol a])) (
+    ,t ":test" [PrefixedVariable ':' "test"]
+       
+    ] ++ map (\a -> t a [Symbol a]) (
      ["!=", "<>", ">=", "<=", "||"]
-     ++ map T.singleton ("(),-+*/<>=." :: [Char])))]
+     ++ map T.singleton ("(),-+*/<>=." :: [Char]))
+  where
+    t :: HasCallStack => Text -> [Token] -> TestItem
+    t src ast = testLex ansi2011 src ast
+    tp :: HasCallStack => Text -> [Token] -> TestItem
+    tp src ast = testLex ansi2011{diPositionalArg=True} src ast
 
 
 ansiLexerTable :: [(Text,[Token])]
@@ -103,7 +111,7 @@ ansiLexerTable =
        )
     -- quoted identifiers with embedded double quotes
     -- the lexer doesn't unescape the quotes
-    ++ [("\"normal \"\" iden\"", [Identifier (Just ("\"","\"")) "normal \"\" iden"])]
+    ++ [("\"anormal \"\" iden\"", [Identifier (Just ("\"","\"")) "anormal \"\" iden"])]
     -- strings
     -- the lexer doesn't apply escapes at all
     ++ [("'string'", [SqlString "'" "'" "string"])
@@ -137,39 +145,44 @@ ansiLexerTable =
 
 ansiLexerTests :: TestItem
 ansiLexerTests = Group "ansiLexerTests" $
-    [Group "ansi lexer token tests" $ [LexTest ansi2011 s t |  (s,t) <- ansiLexerTable]
+    [Group "ansi lexer token tests" $ [l s t |  (s,t) <- ansiLexerTable]
     ,Group "ansi generated combination lexer tests" $
-    [ LexTest ansi2011 (s <> s1) (t <> t1)
+        [ l (s <> s1) (t <> t1)
-    | (s,t) <- ansiLexerTable
+        | (s,t) <- ansiLexerTable
-    , (s1,t1) <- ansiLexerTable
+        , (s1,t1) <- ansiLexerTable
-    , tokenListWillPrintAndLex ansi2011 $ t <> t1
+        , tokenListWillPrintAndLex ansi2011 $ t <> t1
 
-    ]
+        ]
     ,Group "ansiadhoclexertests" $
-       map (uncurry $ LexTest ansi2011)
+        [l "" []
-       [("", [])
+        ,l "-- line com\nstuff"  [LineComment "-- line com\n",Identifier Nothing "stuff"]
-       ,("-- line com\nstuff", [LineComment "-- line com\n",Identifier Nothing "stuff"])
+        ] ++
-       ] ++
+        [-- want to make sure this gives a parse error
-       [-- want to make sure this gives a parse error
+         f "*/"
-        LexFails ansi2011 "*/"
+         -- combinations of pipes: make sure they fail because they could be
-        -- combinations of pipes: make sure they fail because they could be
+         -- ambiguous and it is really unclear when they are or not, and
-        -- ambiguous and it is really unclear when they are or not, and
+         -- what the result is even when they are not ambiguous
-        -- what the result is even when they are not ambiguous
+        ,f "|||"
-       ,LexFails ansi2011 "|||"
+        ,f "||||"
-       ,LexFails ansi2011 "||||"
+        ,f "|||||"
-       ,LexFails ansi2011 "|||||"
+         -- another user experience thing: make sure extra trailing
-       -- another user experience thing: make sure extra trailing
+         -- number chars are rejected rather than attempting to parse
-       -- number chars are rejected rather than attempting to parse
+         -- if the user means to write something that is rejected by this code,
-       -- if the user means to write something that is rejected by this code,
+         -- then they can use whitespace to make it clear and then it will parse
-       -- then they can use whitespace to make it clear and then it will parse
+        ,f "12e3e4"
-       ,LexFails ansi2011 "12e3e4"
+        ,f "12e3e4"
-       ,LexFails ansi2011 "12e3e4"
+        ,f "12e3e4"
-       ,LexFails ansi2011 "12e3e4"
+        ,f "12e3.4"
-       ,LexFails ansi2011 "12e3.4"
+        ,f "12.4.5"
-       ,LexFails ansi2011 "12.4.5"
+        ,f "12.4e5.6"
-       ,LexFails ansi2011 "12.4e5.6"
+        ,f "12.4e5e7"]
-       ,LexFails ansi2011 "12.4e5e7"]
+    ]
-     ]
+  where
+    l :: HasCallStack => Text -> [Token] -> TestItem
+    l src ast = testLex ansi2011 src ast
+    f :: HasCallStack => Text -> TestItem
+    f src = lexFails ansi2011 src
+
 
 {-
 todo: lexing tests
@@ -303,22 +316,21 @@ somePostgresOpsWhichWontAddTrailingPlusMinus l =
        , not (T.last x `T.elem` "+-")
        ]
 
-
 postgresLexerTests :: TestItem
 postgresLexerTests = Group "postgresLexerTests" $
     [Group "postgres lexer token tests" $
-     [LexTest postgres s t | (s,t) <- postgresLexerTable]
+     [l s t | (s,t) <- postgresLexerTable]
     ,Group "postgres generated lexer token tests" $
-     [LexTest postgres s t | (s,t) <- postgresShortOperatorTable ++ postgresExtraOperatorTable]
+     [l s t | (s,t) <- postgresShortOperatorTable ++ postgresExtraOperatorTable]
     ,Group "postgres generated combination lexer tests" $
-    [ LexTest postgres (s <> s1) (t <> t1)
+    [ l (s <> s1) (t <> t1)
     | (s,t) <- postgresLexerTable ++ postgresShortOperatorTable
     , (s1,t1) <- postgresLexerTable ++ postgresShortOperatorTable
     , tokenListWillPrintAndLex postgres $ t ++ t1
 
     ]
     ,Group "generated postgres edgecase lexertests" $
-     [LexTest postgres s t
+     [l s t
      | (s,t) <- edgeCaseCommentOps
                 ++ edgeCasePlusMinusOps
                 ++ edgeCasePlusMinusComments]
@@ -326,22 +338,23 @@ postgresLexerTests = Group "postgresLexerTests" $
     ,Group "adhoc postgres lexertests" $
       -- need more tests for */ to make sure it is caught if it is in the middle of a
       -- sequence of symbol letters
-        [LexFails postgres "*/"
+        [f "*/"
-        ,LexFails postgres ":::"
+        ,f ":::"
-        ,LexFails postgres "::::"
+        ,f "::::"
-        ,LexFails postgres ":::::"
+        ,f ":::::"
-        ,LexFails postgres "@*/"
+        ,f "@*/"
-        ,LexFails postgres "-*/"
+        ,f "-*/"
-        ,LexFails postgres "12e3e4"
+        ,f "12e3e4"
-        ,LexFails postgres "12e3e4"
+        ,f "12e3e4"
-        ,LexFails postgres "12e3e4"
+        ,f "12e3e4"
-        ,LexFails postgres "12e3.4"
+        ,f "12e3.4"
-        ,LexFails postgres "12.4.5"
+        ,f "12.4.5"
-        ,LexFails postgres "12.4e5.6"
+        ,f "12.4e5.6"
-        ,LexFails postgres "12.4e5e7"
+        ,f "12.4e5e7"
          -- special case allow this to lex to 1 .. 2
          -- this is for 'for loops' in plpgsql
-        ,LexTest postgres "1..2" [SqlNumber "1", Symbol "..", SqlNumber "2"]]
+        ,l "1..2" [SqlNumber "1", Symbol "..", SqlNumber "2"]
+        ]
     ]
  where
    edgeCaseCommentOps =
@@ -365,14 +378,21 @@ postgresLexerTests = Group "postgresLexerTests" $
      ,("-/**/", [Symbol "-", BlockComment "/**/"])
      ,("+/**/", [Symbol "+", BlockComment "/**/"])
      ]
+   l :: HasCallStack => Text -> [Token] -> TestItem
+   l src ast = testLex postgres src ast
+   f :: HasCallStack => Text -> TestItem
+   f src = lexFails postgres src
 
 sqlServerLexerTests :: TestItem
 sqlServerLexerTests = Group "sqlServerLexTests" $
-    [ LexTest sqlserver s t | (s,t) <-
+    [l s t | (s,t) <-
     [("@variable", [(PrefixedVariable '@' "variable")])
     ,("#variable", [(PrefixedVariable '#' "variable")])
     ,("[quoted identifier]", [(Identifier (Just ("[", "]")) "quoted identifier")])
     ]]
+ where
+    l :: HasCallStack => Text -> [Token] -> TestItem
+    l src ast = testLex sqlserver src ast
 
 oracleLexerTests :: TestItem
 oracleLexerTests = Group "oracleLexTests" $
@@ -380,19 +400,29 @@ oracleLexerTests = Group "oracleLexTests" $
 
 mySqlLexerTests :: TestItem
 mySqlLexerTests = Group "mySqlLexerTests" $
-    [ LexTest mysql s t | (s,t) <-
+    [ l s t | (s,t) <-
     [("`quoted identifier`", [(Identifier (Just ("`", "`")) "quoted identifier")])
     ]
     ]
+ where
+    l :: HasCallStack => Text -> [Token] -> TestItem
+    l src ast = testLex mysql src ast
 
 odbcLexerTests :: TestItem
 odbcLexerTests = Group "odbcLexTests" $
-    [ LexTest sqlserver {diOdbc = True} s t | (s,t) <-
+    [ lo s t | (s,t) <-
     [("{}", [Symbol "{", Symbol "}"])
     ]]
-    ++ [LexFails sqlserver {diOdbc = False} "{"
+    ++ [lno "{"
-       ,LexFails sqlserver {diOdbc = False} "}"]
+       ,lno "}"]
+ where
+    lo :: HasCallStack => Text -> [Token] -> TestItem
+    lo src ast = testLex (sqlserver {diOdbc = True}) src ast
+    lno :: HasCallStack => Text -> TestItem
+    lno src = lexFails (sqlserver{diOdbc = False}) src
+
 
 combos :: [Char] -> Int -> [Text]
 combos _ 0 = [T.empty]
 combos l n = [ T.cons x tl | x <- l, tl <- combos l (n - 1) ]
+

tests/Language/SQL/SimpleSQL/MySQL.hs

@@ -6,6 +6,7 @@ module Language.SQL.SimpleSQL.MySQL (mySQLTests) where
 
 import Language.SQL.SimpleSQL.TestTypes
 import Language.SQL.SimpleSQL.Syntax
+import Language.SQL.SimpleSQL.TestRunners
 
 mySQLTests :: TestItem
 mySQLTests = Group "mysql dialect"
@@ -21,21 +22,16 @@ limit syntax
 -}
 
 backtickQuotes :: TestItem
-backtickQuotes = Group "backtickQuotes" (map (uncurry (TestScalarExpr mysql))
+backtickQuotes = Group "backtickQuotes"
-    [("`test`", Iden [Name (Just ("`","`")) "test"])
+    [testScalarExpr mysql "`test`" $ Iden [Name (Just ("`","`")) "test"]
-    ]
+    ,testParseScalarExprFails ansi2011 "`test`"]
-    ++ [ParseScalarExprFails ansi2011 "`test`"]
-    )
 
 limit :: TestItem
-limit = Group "queries" ( map (uncurry (TestQueryExpr mysql))
+limit = Group "queries"
-    [("select * from t limit 5"
+    [testQueryExpr mysql "select * from t limit 5"
-     ,toQueryExpr $ sel {msFetchFirst = Just (NumLit "5")}
+     $ toQueryExpr $ sel {msFetchFirst = Just (NumLit "5")}
-     )
+    ,testParseQueryExprFails mysql "select a from t fetch next 10 rows only;"
-    ]
+    ,testParseQueryExprFails ansi2011 "select * from t limit 5"]
-    ++ [ParseQueryExprFails mysql "select a from t fetch next 10 rows only;"
-       ,ParseQueryExprFails ansi2011 "select * from t limit 5"]
-    )
   where
     sel = makeSelect
           {msSelectList = [(Star, Nothing)]

tests/Language/SQL/SimpleSQL/Odbc.hs

@@ -4,6 +4,8 @@ module Language.SQL.SimpleSQL.Odbc (odbcTests) where
 
 import Language.SQL.SimpleSQL.TestTypes
 import Language.SQL.SimpleSQL.Syntax
+import Language.SQL.SimpleSQL.TestRunners
+import Data.Text (Text)
 
 odbcTests :: TestItem
 odbcTests = Group "odbc" [
@@ -30,14 +32,14 @@ odbcTests = Group "odbc" [
               ,iden "SQL_DATE"])
             ]
        ,Group "outer join" [
-             TestQueryExpr ansi2011 {diOdbc=True}
+             q
              "select * from {oj t1 left outer join t2 on expr}"
              $ toQueryExpr $ makeSelect
                    {msSelectList = [(Star,Nothing)]
                    ,msFrom = [TROdbc $ TRJoin (TRSimple [Name Nothing "t1"]) False JLeft (TRSimple [Name Nothing "t2"])
                                          (Just $ JoinOn $ Iden [Name Nothing "expr"])]}]
        ,Group "check parsing bugs" [
-             TestQueryExpr ansi2011 {diOdbc=True}
+             q
              "select {fn CONVERT(cint,SQL_BIGINT)} from t;"
              $ toQueryExpr $ makeSelect
                    {msSelectList = [(OdbcFunc (ap "CONVERT"
@@ -46,7 +48,12 @@ odbcTests = Group "odbc" [
                    ,msFrom = [TRSimple [Name Nothing "t"]]}]
        ]
   where
-    e = TestScalarExpr ansi2011 {diOdbc = True}
+    e :: HasCallStack => Text -> ScalarExpr -> TestItem
+    e src ast = testScalarExpr ansi2011{diOdbc = True} src ast
+
+    q :: HasCallStack => Text -> QueryExpr -> TestItem
+    q src ast = testQueryExpr ansi2011{diOdbc = True} src ast
+
     --tsql = ParseProcSql defaultParseFlags {pfDialect=sqlServerDialect}
     ap n = App [Name Nothing n]
     iden n = Iden [Name Nothing n]

tests/Language/SQL/SimpleSQL/Oracle.hs

@@ -6,6 +6,7 @@ module Language.SQL.SimpleSQL.Oracle (oracleTests) where
 
 import Language.SQL.SimpleSQL.TestTypes
 import Language.SQL.SimpleSQL.Syntax
+import Language.SQL.SimpleSQL.TestRunners
 
 oracleTests :: TestItem
 oracleTests = Group "oracle dialect"
@@ -13,18 +14,18 @@ oracleTests = Group "oracle dialect"
 
 
 oracleLobUnits :: TestItem
-oracleLobUnits = Group "oracleLobUnits" (map (uncurry (TestScalarExpr oracle))
+oracleLobUnits = Group "oracleLobUnits"
-    [("cast (a as varchar2(3 char))"
+    [testScalarExpr oracle "cast (a as varchar2(3 char))"
-     ,Cast (Iden [Name Nothing "a"]) (
+     $ Cast (Iden [Name Nothing "a"]) (
-         PrecLengthTypeName [Name Nothing "varchar2"] 3 Nothing (Just PrecCharacters)))
+         PrecLengthTypeName [Name Nothing "varchar2"] 3 Nothing (Just PrecCharacters))
-     ,("cast (a as varchar2(3 byte))"
+    ,testScalarExpr oracle "cast (a as varchar2(3 byte))"
-     ,Cast (Iden [Name Nothing "a"]) (
+     $ Cast (Iden [Name Nothing "a"]) (
-         PrecLengthTypeName [Name Nothing "varchar2"] 3 Nothing (Just PrecOctets)))
+         PrecLengthTypeName [Name Nothing "varchar2"] 3 Nothing (Just PrecOctets))
-     ]
+    ,testStatement oracle
-    ++ [TestStatement oracle
       "create table t (a varchar2(55 BYTE));"
      $ CreateTable [Name Nothing "t"]
        [TableColumnDef $ ColumnDef (Name Nothing "a")
         (PrecLengthTypeName [Name Nothing "varchar2"] 55 Nothing (Just PrecOctets))
-        Nothing []]]
+        Nothing []]
-    )
+    ]
+    

tests/Language/SQL/SimpleSQL/Postgres.hs

@@ -9,9 +9,11 @@ revisited when the dialect support is added.
 module Language.SQL.SimpleSQL.Postgres (postgresTests) where
 
 import Language.SQL.SimpleSQL.TestTypes
+import Language.SQL.SimpleSQL.TestRunners
+import Data.Text (Text)
 
 postgresTests :: TestItem
-postgresTests = Group "postgresTests" $ map (ParseQueryExpr ansi2011)
+postgresTests = Group "postgresTests"
 
 {-
 lexical syntax section
@@ -22,129 +24,129 @@ TODO: get all the commented out tests working
     [-- "SELECT 'foo'\n\
     -- \'bar';" -- this should parse as select 'foobar'
     -- ,
-     "SELECT name, (SELECT max(pop) FROM cities\n\
+     t "SELECT name, (SELECT max(pop) FROM cities\n\
      \ WHERE cities.state = states.name)\n\
      \    FROM states;"
-    ,"SELECT ROW(1,2.5,'this is a test');"
+    ,t "SELECT ROW(1,2.5,'this is a test');"
 
-    ,"SELECT ROW(t.*, 42) FROM t;"
+    ,t "SELECT ROW(t.*, 42) FROM t;"
-    ,"SELECT ROW(t.f1, t.f2, 42) FROM t;"
+    ,t "SELECT ROW(t.f1, t.f2, 42) FROM t;"
-    ,"SELECT getf1(CAST(ROW(11,'this is a test',2.5) AS myrowtype));"
+    ,t "SELECT getf1(CAST(ROW(11,'this is a test',2.5) AS myrowtype));"
 
-    ,"SELECT ROW(1,2.5,'this is a test') = ROW(1, 3, 'not the same');"
+    ,t "SELECT ROW(1,2.5,'this is a test') = ROW(1, 3, 'not the same');"
 
     -- table is a reservered keyword?
-    --,"SELECT ROW(table.*) IS NULL FROM table;"
+    --,t "SELECT ROW(table.*) IS NULL FROM table;"
-    ,"SELECT ROW(tablex.*) IS NULL FROM tablex;"
+    ,t "SELECT ROW(tablex.*) IS NULL FROM tablex;"
 
-    ,"SELECT true OR somefunc();"
+    ,t "SELECT true OR somefunc();"
 
-    ,"SELECT somefunc() OR true;"
+    ,t "SELECT somefunc() OR true;"
 
 -- queries section
 
-    ,"SELECT * FROM t1 CROSS JOIN t2;"
+    ,t "SELECT * FROM t1 CROSS JOIN t2;"
-    ,"SELECT * FROM t1 INNER JOIN t2 ON t1.num = t2.num;"
+    ,t "SELECT * FROM t1 INNER JOIN t2 ON t1.num = t2.num;"
-    ,"SELECT * FROM t1 INNER JOIN t2 USING (num);"
+    ,t "SELECT * FROM t1 INNER JOIN t2 USING (num);"
-    ,"SELECT * FROM t1 NATURAL INNER JOIN t2;"
+    ,t "SELECT * FROM t1 NATURAL INNER JOIN t2;"
-    ,"SELECT * FROM t1 LEFT JOIN t2 ON t1.num = t2.num;"
+    ,t "SELECT * FROM t1 LEFT JOIN t2 ON t1.num = t2.num;"
-    ,"SELECT * FROM t1 LEFT JOIN t2 USING (num);"
+    ,t "SELECT * FROM t1 LEFT JOIN t2 USING (num);"
-    ,"SELECT * FROM t1 RIGHT JOIN t2 ON t1.num = t2.num;"
+    ,t "SELECT * FROM t1 RIGHT JOIN t2 ON t1.num = t2.num;"
-    ,"SELECT * FROM t1 FULL JOIN t2 ON t1.num = t2.num;"
+    ,t "SELECT * FROM t1 FULL JOIN t2 ON t1.num = t2.num;"
-    ,"SELECT * FROM t1 LEFT JOIN t2 ON t1.num = t2.num AND t2.value = 'xxx';"
+    ,t "SELECT * FROM t1 LEFT JOIN t2 ON t1.num = t2.num AND t2.value = 'xxx';"
-    ,"SELECT * FROM t1 LEFT JOIN t2 ON t1.num = t2.num WHERE t2.value = 'xxx';"
+    ,t "SELECT * FROM t1 LEFT JOIN t2 ON t1.num = t2.num WHERE t2.value = 'xxx';"
 
-    ,"SELECT * FROM some_very_long_table_name s\n\
+    ,t "SELECT * FROM some_very_long_table_name s\n\
      \JOIN another_fairly_long_name a ON s.id = a.num;"
-    ,"SELECT * FROM people AS mother JOIN people AS child\n\
+    ,t "SELECT * FROM people AS mother JOIN people AS child\n\
      \ ON mother.id = child.mother_id;"
-    ,"SELECT * FROM my_table AS a CROSS JOIN my_table AS b;"
+    ,t "SELECT * FROM my_table AS a CROSS JOIN my_table AS b;"
-    ,"SELECT * FROM (my_table AS a CROSS JOIN my_table) AS b;"
+    ,t "SELECT * FROM (my_table AS a CROSS JOIN my_table) AS b;"
-    ,"SELECT * FROM getfoo(1) AS t1;"
+    ,t "SELECT * FROM getfoo(1) AS t1;"
-    ,"SELECT * FROM foo\n\
+    ,t "SELECT * FROM foo\n\
      \    WHERE foosubid IN (\n\
      \                        SELECT foosubid\n\
      \                        FROM getfoo(foo.fooid) z\n\
      \                        WHERE z.fooid = foo.fooid\n\
      \                      );"
-    {-,"SELECT *\n\
+    {-,t "SELECT *\n\
      \    FROM dblink('dbname=mydb', 'SELECT proname, prosrc FROM pg_proc')\n\
      \      AS t1(proname name, prosrc text)\n\
      \    WHERE proname LIKE 'bytea%';"-} -- types in the alias??
 
-    ,"SELECT * FROM foo, LATERAL (SELECT * FROM bar WHERE bar.id = foo.bar_id) ss;"
+    ,t "SELECT * FROM foo, LATERAL (SELECT * FROM bar WHERE bar.id = foo.bar_id) ss;"
-    ,"SELECT * FROM foo, bar WHERE bar.id = foo.bar_id;"
+    ,t "SELECT * FROM foo, bar WHERE bar.id = foo.bar_id;"
 
-    {-,"SELECT p1.id, p2.id, v1, v2\n\
+    {-,t "SELECT p1.id, p2.id, v1, v2\n\
      \FROM polygons p1, polygons p2,\n\
      \     LATERAL vertices(p1.poly) v1,\n\
      \     LATERAL vertices(p2.poly) v2\n\
      \WHERE (v1 <-> v2) < 10 AND p1.id != p2.id;"-} -- <-> operator?
 
-    {-,"SELECT p1.id, p2.id, v1, v2\n\
+    {-,t "SELECT p1.id, p2.id, v1, v2\n\
      \FROM polygons p1 CROSS JOIN LATERAL vertices(p1.poly) v1,\n\
      \     polygons p2 CROSS JOIN LATERAL vertices(p2.poly) v2\n\
      \WHERE (v1 <-> v2) < 10 AND p1.id != p2.id;"-}
 
-    ,"SELECT m.name\n\
+    ,t "SELECT m.name\n\
      \FROM manufacturers m LEFT JOIN LATERAL get_product_names(m.id) pname ON true\n\
      \WHERE pname IS NULL;"
 
 
-    ,"SELECT * FROM fdt WHERE c1 > 5"
+    ,t "SELECT * FROM fdt WHERE c1 > 5"
 
-    ,"SELECT * FROM fdt WHERE c1 IN (1, 2, 3)"
+    ,t "SELECT * FROM fdt WHERE c1 IN (1, 2, 3)"
 
-    ,"SELECT * FROM fdt WHERE c1 IN (SELECT c1 FROM t2)"
+    ,t "SELECT * FROM fdt WHERE c1 IN (SELECT c1 FROM t2)"
 
-    ,"SELECT * FROM fdt WHERE c1 IN (SELECT c3 FROM t2 WHERE c2 = fdt.c1 + 10)"
+    ,t "SELECT * FROM fdt WHERE c1 IN (SELECT c3 FROM t2 WHERE c2 = fdt.c1 + 10)"
 
-    ,"SELECT * FROM fdt WHERE c1 BETWEEN \n\
+    ,t "SELECT * FROM fdt WHERE c1 BETWEEN \n\
      \    (SELECT c3 FROM t2 WHERE c2 = fdt.c1 + 10) AND 100"
 
-    ,"SELECT * FROM fdt WHERE EXISTS (SELECT c1 FROM t2 WHERE c2 > fdt.c1)"
+    ,t "SELECT * FROM fdt WHERE EXISTS (SELECT c1 FROM t2 WHERE c2 > fdt.c1)"
 
-    ,"SELECT * FROM test1;"
+    ,t "SELECT * FROM test1;"
 
-    ,"SELECT x FROM test1 GROUP BY x;"
+    ,t "SELECT x FROM test1 GROUP BY x;"
-    ,"SELECT x, sum(y) FROM test1 GROUP BY x;"
+    ,t "SELECT x, sum(y) FROM test1 GROUP BY x;"
     -- s.date changed to s.datex because of reserved keyword
     -- handling, not sure if this is correct or not for ansi sql
-    ,"SELECT product_id, p.name, (sum(s.units) * p.price) AS sales\n\
+    ,t "SELECT product_id, p.name, (sum(s.units) * p.price) AS sales\n\
      \    FROM products p LEFT JOIN sales s USING (product_id)\n\
      \    GROUP BY product_id, p.name, p.price;"
 
-    ,"SELECT x, sum(y) FROM test1 GROUP BY x HAVING sum(y) > 3;"
+    ,t "SELECT x, sum(y) FROM test1 GROUP BY x HAVING sum(y) > 3;"
-    ,"SELECT x, sum(y) FROM test1 GROUP BY x HAVING x < 'c';"
+    ,t "SELECT x, sum(y) FROM test1 GROUP BY x HAVING x < 'c';"
-    ,"SELECT product_id, p.name, (sum(s.units) * (p.price - p.cost)) AS profit\n\
+    ,t "SELECT product_id, p.name, (sum(s.units) * (p.price - p.cost)) AS profit\n\
      \    FROM products p LEFT JOIN sales s USING (product_id)\n\
      \    WHERE s.datex > CURRENT_DATE - INTERVAL '4 weeks'\n\
      \    GROUP BY product_id, p.name, p.price, p.cost\n\
      \    HAVING sum(p.price * s.units) > 5000;"
 
-    ,"SELECT a, b, c FROM t"
+    ,t "SELECT a, b, c FROM t"
 
-    ,"SELECT tbl1.a, tbl2.a, tbl1.b FROM t"
+    ,t "SELECT tbl1.a, tbl2.a, tbl1.b FROM t"
 
-    ,"SELECT tbl1.*, tbl2.a FROM t"
+    ,t "SELECT tbl1.*, tbl2.a FROM t"
 
-    ,"SELECT a AS value, b + c AS sum FROM t"
+    ,t "SELECT a AS value, b + c AS sum FROM t"
 
-    ,"SELECT a \"value\", b + c AS sum FROM t"
+    ,t "SELECT a \"value\", b + c AS sum FROM t"
 
-    ,"SELECT DISTINCT select_list t"
+    ,t "SELECT DISTINCT select_list t"
 
-    ,"VALUES (1, 'one'), (2, 'two'), (3, 'three');"
+    ,t "VALUES (1, 'one'), (2, 'two'), (3, 'three');"
 
-    ,"SELECT 1 AS column1, 'one' AS column2\n\
+    ,t "SELECT 1 AS column1, 'one' AS column2\n\
      \UNION ALL\n\
      \SELECT 2, 'two'\n\
      \UNION ALL\n\
      \SELECT 3, 'three';"
 
-    ,"SELECT * FROM (VALUES (1, 'one'), (2, 'two'), (3, 'three')) AS t (num,letter);"
+    ,t "SELECT * FROM (VALUES (1, 'one'), (2, 'two'), (3, 'three')) AS t (num,letter);"
 
-    ,"WITH regional_sales AS (\n\
+    ,t "WITH regional_sales AS (\n\
      \        SELECT region, SUM(amount) AS total_sales\n\
      \        FROM orders\n\
      \        GROUP BY region\n\
@@ -161,14 +163,14 @@ TODO: get all the commented out tests working
      \WHERE region IN (SELECT region FROM top_regions)\n\
      \GROUP BY region, product;"
 
-    ,"WITH RECURSIVE t(n) AS (\n\
+    ,t "WITH RECURSIVE t(n) AS (\n\
      \    VALUES (1)\n\
      \  UNION ALL\n\
      \    SELECT n+1 FROM t WHERE n < 100\n\
      \)\n\
      \SELECT sum(n) FROM t"
 
-    ,"WITH RECURSIVE included_parts(sub_part, part, quantity) AS (\n\
+    ,t "WITH RECURSIVE included_parts(sub_part, part, quantity) AS (\n\
      \    SELECT sub_part, part, quantity FROM parts WHERE part = 'our_product'\n\
      \  UNION ALL\n\
      \    SELECT p.sub_part, p.part, p.quantity\n\
@@ -179,7 +181,7 @@ TODO: get all the commented out tests working
      \FROM included_parts\n\
      \GROUP BY sub_part"
 
-    ,"WITH RECURSIVE search_graph(id, link, data, depth) AS (\n\
+    ,t "WITH RECURSIVE search_graph(id, link, data, depth) AS (\n\
      \        SELECT g.id, g.link, g.data, 1\n\
      \        FROM graph g\n\
      \      UNION ALL\n\
@@ -189,7 +191,7 @@ TODO: get all the commented out tests working
      \)\n\
      \SELECT * FROM search_graph;"
 
-    {-,"WITH RECURSIVE search_graph(id, link, data, depth, path, cycle) AS (\n\
+    {-,t "WITH RECURSIVE search_graph(id, link, data, depth, path, cycle) AS (\n\
      \        SELECT g.id, g.link, g.data, 1,\n\
      \          ARRAY[g.id],\n\
      \          false\n\
@@ -203,7 +205,7 @@ TODO: get all the commented out tests working
      \)\n\
      \SELECT * FROM search_graph;"-} -- ARRAY
 
-    {-,"WITH RECURSIVE search_graph(id, link, data, depth, path, cycle) AS (\n\
+    {-,t "WITH RECURSIVE search_graph(id, link, data, depth, path, cycle) AS (\n\
      \        SELECT g.id, g.link, g.data, 1,\n\
      \          ARRAY[ROW(g.f1, g.f2)],\n\
      \          false\n\
@@ -217,7 +219,7 @@ TODO: get all the commented out tests working
      \)\n\
      \SELECT * FROM search_graph;"-} -- ARRAY
 
-    ,"WITH RECURSIVE t(n) AS (\n\
+    ,t "WITH RECURSIVE t(n) AS (\n\
      \    SELECT 1\n\
      \  UNION ALL\n\
      \    SELECT n+1 FROM t\n\
@@ -226,19 +228,19 @@ TODO: get all the commented out tests working
 
 -- select page reference
 
-    ,"SELECT f.title, f.did, d.name, f.date_prod, f.kind\n\
+    ,t "SELECT f.title, f.did, d.name, f.date_prod, f.kind\n\
      \    FROM distributors d, films f\n\
      \    WHERE f.did = d.did"
 
-    ,"SELECT kind, sum(len) AS total\n\
+    ,t "SELECT kind, sum(len) AS total\n\
      \    FROM films\n\
      \    GROUP BY kind\n\
      \    HAVING sum(len) < interval '5 hours';"
 
-    ,"SELECT * FROM distributors ORDER BY name;"
+    ,t "SELECT * FROM distributors ORDER BY name;"
-    ,"SELECT * FROM distributors ORDER BY 2;"
+    ,t "SELECT * FROM distributors ORDER BY 2;"
 
-    ,"SELECT distributors.name\n\
+    ,t "SELECT distributors.name\n\
      \    FROM distributors\n\
      \    WHERE distributors.name LIKE 'W%'\n\
      \UNION\n\
@@ -246,14 +248,14 @@ TODO: get all the commented out tests working
      \    FROM actors\n\
      \    WHERE actors.name LIKE 'W%';"
 
-    ,"WITH t AS (\n\
+    ,t "WITH t AS (\n\
      \    SELECT random() as x FROM generate_series(1, 3)\n\
      \  )\n\
      \SELECT * FROM t\n\
      \UNION ALL\n\
      \SELECT * FROM t"
 
-    ,"WITH RECURSIVE employee_recursive(distance, employee_name, manager_name) AS (\n\
+    ,t "WITH RECURSIVE employee_recursive(distance, employee_name, manager_name) AS (\n\
      \    SELECT 1, employee_name, manager_name\n\
      \    FROM employee\n\
      \    WHERE manager_name = 'Mary'\n\
@@ -264,16 +266,19 @@ TODO: get all the commented out tests working
      \  )\n\
      \SELECT distance, employee_name FROM employee_recursive;"
 
-    ,"SELECT m.name AS mname, pname\n\
+    ,t "SELECT m.name AS mname, pname\n\
      \FROM manufacturers m, LATERAL get_product_names(m.id) pname;"
 
-    ,"SELECT m.name AS mname, pname\n\
+    ,t "SELECT m.name AS mname, pname\n\
      \FROM manufacturers m LEFT JOIN LATERAL get_product_names(m.id) pname ON true;"
 
-    ,"SELECT 2+2;"
+    ,t "SELECT 2+2;"
 
     -- simple-sql-parser doesn't support where without from
     -- this can be added for the postgres dialect when it is written
-    --,"SELECT distributors.* WHERE distributors.name = 'Westward';"
+    --,t "SELECT distributors.* WHERE distributors.name = 'Westward';"
 
     ]
+  where
+    t :: HasCallStack => Text -> TestItem
+    t src = testParseQueryExpr postgres src

tests/Language/SQL/SimpleSQL/QueryExprComponents.hs

@@ -12,7 +12,8 @@ module Language.SQL.SimpleSQL.QueryExprComponents (queryExprComponentTests) wher
 
 import Language.SQL.SimpleSQL.TestTypes
 import Language.SQL.SimpleSQL.Syntax
-
+import Language.SQL.SimpleSQL.TestRunners
+import Data.Text (Text)
 
 queryExprComponentTests :: TestItem
 queryExprComponentTests = Group "queryExprComponentTests"
@@ -31,10 +32,10 @@ queryExprComponentTests = Group "queryExprComponentTests"
 
 
 duplicates :: TestItem
-duplicates = Group "duplicates" $ map (uncurry (TestQueryExpr ansi2011))
+duplicates = Group "duplicates"
-    [("select a from t" ,ms SQDefault)
+    [q "select a from t" $ ms SQDefault
-    ,("select all a from t" ,ms All)
+    ,q "select all a from t" $ ms All
-    ,("select distinct a from t", ms Distinct)
+    ,q "select distinct a from t" $ ms Distinct
     ]
  where
    ms d = toQueryExpr $ makeSelect
@@ -43,77 +44,77 @@ duplicates = Group "duplicates" $ map (uncurry (TestQueryExpr ansi2011))
           ,msFrom = [TRSimple [Name Nothing "t"]]}
 
 selectLists :: TestItem
-selectLists = Group "selectLists" $ map (uncurry (TestQueryExpr ansi2011))
+selectLists = Group "selectLists"
-    [("select 1",
+    [q "select 1"
-      toQueryExpr $ makeSelect {msSelectList = [(NumLit "1",Nothing)]})
+     $ toQueryExpr $ makeSelect {msSelectList = [(NumLit "1",Nothing)]}
 
-    ,("select a"
+    ,q "select a"
-     ,toQueryExpr $ makeSelect {msSelectList = [(Iden [Name Nothing "a"],Nothing)]})
+     $ toQueryExpr $ makeSelect {msSelectList = [(Iden [Name Nothing "a"],Nothing)]}
 
-    ,("select a,b"
+    ,q "select a,b"
-     ,toQueryExpr $ makeSelect {msSelectList = [(Iden [Name Nothing "a"],Nothing)
+     $ toQueryExpr $ makeSelect {msSelectList = [(Iden [Name Nothing "a"],Nothing)
-                                 ,(Iden [Name Nothing "b"],Nothing)]})
+                                 ,(Iden [Name Nothing "b"],Nothing)]}
 
-    ,("select 1+2,3+4"
+    ,q "select 1+2,3+4"
-     ,toQueryExpr $ makeSelect {msSelectList =
+     $ toQueryExpr $ makeSelect {msSelectList =
                      [(BinOp (NumLit "1") [Name Nothing "+"] (NumLit "2"),Nothing)
-                     ,(BinOp (NumLit "3") [Name Nothing "+"] (NumLit "4"),Nothing)]})
+                     ,(BinOp (NumLit "3") [Name Nothing "+"] (NumLit "4"),Nothing)]}
 
-    ,("select a as a, /*comment*/ b as b"
+    ,q "select a as a, /*comment*/ b as b"
-     ,toQueryExpr $ makeSelect {msSelectList = [(Iden [Name Nothing "a"], Just $ Name Nothing "a")
+     $ toQueryExpr $ makeSelect {msSelectList = [(Iden [Name Nothing "a"], Just $ Name Nothing "a")
-                                 ,(Iden [Name Nothing "b"], Just $ Name Nothing "b")]})
+                                 ,(Iden [Name Nothing "b"], Just $ Name Nothing "b")]}
 
-    ,("select a a, b b"
+    ,q "select a a, b b"
-     ,toQueryExpr $ makeSelect {msSelectList = [(Iden [Name Nothing "a"], Just $ Name Nothing "a")
+     $ toQueryExpr $ makeSelect {msSelectList = [(Iden [Name Nothing "a"], Just $ Name Nothing "a")
-                                 ,(Iden [Name Nothing "b"], Just $ Name Nothing "b")]})
+                                 ,(Iden [Name Nothing "b"], Just $ Name Nothing "b")]}
 
-    ,("select a + b * c"
+    ,q "select a + b * c"
-     ,toQueryExpr $ makeSelect {msSelectList =
+     $ toQueryExpr $ makeSelect {msSelectList =
       [(BinOp (Iden [Name Nothing "a"]) [Name Nothing "+"]
         (BinOp (Iden [Name Nothing "b"]) [Name Nothing "*"] (Iden [Name Nothing "c"]))
-       ,Nothing)]})
+       ,Nothing)]}
 
     ]
 
 whereClause :: TestItem
-whereClause = Group "whereClause" $ map (uncurry (TestQueryExpr ansi2011))
+whereClause = Group "whereClause"
-    [("select a from t where a = 5"
+    [q "select a from t where a = 5"
-     ,toQueryExpr $ makeSelect {msSelectList = [(Iden [Name Nothing "a"],Nothing)]
+     $ toQueryExpr $ makeSelect {msSelectList = [(Iden [Name Nothing "a"],Nothing)]
                  ,msFrom = [TRSimple [Name Nothing "t"]]
-                 ,msWhere = Just $ BinOp (Iden [Name Nothing "a"]) [Name Nothing "="] (NumLit "5")})
+                 ,msWhere = Just $ BinOp (Iden [Name Nothing "a"]) [Name Nothing "="] (NumLit "5")}
     ]
 
 having :: TestItem
-having = Group "having" $ map (uncurry (TestQueryExpr ansi2011))
+having = Group "having"
-    [("select a,sum(b) from t group by a having sum(b) > 5"
+    [q "select a,sum(b) from t group by a having sum(b) > 5"
-     ,toQueryExpr $ makeSelect {msSelectList = [(Iden [Name Nothing "a"],Nothing)
+     $ toQueryExpr $ makeSelect {msSelectList = [(Iden [Name Nothing "a"],Nothing)
                                  ,(App [Name Nothing "sum"] [Iden [Name Nothing "b"]],Nothing)]
                  ,msFrom = [TRSimple [Name Nothing "t"]]
                  ,msGroupBy = [SimpleGroup $ Iden [Name Nothing "a"]]
                  ,msHaving = Just $ BinOp (App [Name Nothing "sum"] [Iden [Name Nothing "b"]])
                                           [Name Nothing ">"] (NumLit "5")
-                 })
+                 }
     ]
 
 orderBy :: TestItem
-orderBy = Group "orderBy" $ map (uncurry (TestQueryExpr ansi2011))
+orderBy = Group "orderBy"
-    [("select a from t order by a"
+    [q "select a from t order by a"
-     ,ms [SortSpec (Iden [Name Nothing "a"]) DirDefault NullsOrderDefault])
+     $ ms [SortSpec (Iden [Name Nothing "a"]) DirDefault NullsOrderDefault]
 
-    ,("select a from t order by a, b"
+    ,q "select a from t order by a, b"
-     ,ms [SortSpec (Iden [Name Nothing "a"]) DirDefault NullsOrderDefault
+     $ ms [SortSpec (Iden [Name Nothing "a"]) DirDefault NullsOrderDefault
-         ,SortSpec (Iden [Name Nothing "b"]) DirDefault NullsOrderDefault])
+         ,SortSpec (Iden [Name Nothing "b"]) DirDefault NullsOrderDefault]
 
-    ,("select a from t order by a asc"
+    ,q "select a from t order by a asc"
-     ,ms [SortSpec (Iden [Name Nothing "a"]) Asc NullsOrderDefault])
+     $ ms [SortSpec (Iden [Name Nothing "a"]) Asc NullsOrderDefault]
 
-    ,("select a from t order by a desc, b desc"
+    ,q "select a from t order by a desc, b desc"
-     ,ms [SortSpec (Iden [Name Nothing "a"]) Desc NullsOrderDefault
+     $ ms [SortSpec (Iden [Name Nothing "a"]) Desc NullsOrderDefault
-         ,SortSpec (Iden [Name Nothing "b"]) Desc NullsOrderDefault])
+         ,SortSpec (Iden [Name Nothing "b"]) Desc NullsOrderDefault]
 
-    ,("select a from t order by a desc nulls first, b desc nulls last"
+    ,q "select a from t order by a desc nulls first, b desc nulls last"
-     ,ms [SortSpec (Iden [Name Nothing "a"]) Desc NullsFirst
+     $ ms [SortSpec (Iden [Name Nothing "a"]) Desc NullsFirst
-         ,SortSpec (Iden [Name Nothing "b"]) Desc NullsLast])
+         ,SortSpec (Iden [Name Nothing "b"]) Desc NullsLast]
 
     ]
   where
@@ -122,20 +123,20 @@ orderBy = Group "orderBy" $ map (uncurry (TestQueryExpr ansi2011))
                       ,msOrderBy = o}
 
 offsetFetch :: TestItem
-offsetFetch = Group "offsetFetch" $ map (uncurry (TestQueryExpr ansi2011))
+offsetFetch = Group "offsetFetch"
     [-- ansi standard
-     ("select a from t offset 5 rows fetch next 10 rows only"
+     q "select a from t offset 5 rows fetch next 10 rows only"
-     ,ms (Just $ NumLit "5") (Just $ NumLit "10"))
+     $ ms (Just $ NumLit "5") (Just $ NumLit "10")
-    ,("select a from t offset 5 rows;"
+    ,q "select a from t offset 5 rows;"
-     ,ms (Just $ NumLit "5") Nothing)
+     $ ms (Just $ NumLit "5") Nothing
-    ,("select a from t fetch next 10 row only;"
+    ,q "select a from t fetch next 10 row only;"
-     ,ms Nothing (Just $ NumLit "10"))
+     $ ms Nothing (Just $ NumLit "10")
-    ,("select a from t offset 5 row fetch first 10 row only"
+    ,q "select a from t offset 5 row fetch first 10 row only"
-     ,ms (Just $ NumLit "5") (Just $ NumLit "10"))
+     $ ms (Just $ NumLit "5") (Just $ NumLit "10")
      -- postgres: disabled, will add back when postgres
      -- dialect is added
-    --,("select a from t limit 10 offset 5"
+    --,q "select a from t limit 10 offset 5"
-    -- ,ms (Just $ NumLit "5") (Just $ NumLit "10"))
+    -- $ ms (Just $ NumLit "5") (Just $ NumLit "10"))
     ]
   where
     ms o l = toQueryExpr $ makeSelect
@@ -145,23 +146,23 @@ offsetFetch = Group "offsetFetch" $ map (uncurry (TestQueryExpr ansi2011))
              ,msFetchFirst = l}
 
 combos :: TestItem
-combos = Group "combos" $ map (uncurry (TestQueryExpr ansi2011))
+combos = Group "combos"
-    [("select a from t union select b from u"
+    [q "select a from t union select b from u"
-     ,QueryExprSetOp mst Union SQDefault Respectively msu)
+     $ QueryExprSetOp mst Union SQDefault Respectively msu
 
-    ,("select a from t intersect select b from u"
+    ,q "select a from t intersect select b from u"
-     ,QueryExprSetOp mst Intersect SQDefault Respectively msu)
+     $ QueryExprSetOp mst Intersect SQDefault Respectively msu
 
-    ,("select a from t except all select b from u"
+    ,q "select a from t except all select b from u"
-     ,QueryExprSetOp mst Except All Respectively msu)
+     $ QueryExprSetOp mst Except All Respectively msu
 
-    ,("select a from t union distinct corresponding \
+    ,q "select a from t union distinct corresponding \
       \select b from u"
-     ,QueryExprSetOp mst Union Distinct Corresponding msu)
+     $ QueryExprSetOp mst Union Distinct Corresponding msu
 
-    ,("select a from t union select a from t union select a from t"
+    ,q "select a from t union select a from t union select a from t"
-     ,QueryExprSetOp (QueryExprSetOp mst Union SQDefault Respectively mst)
+     $ QueryExprSetOp (QueryExprSetOp mst Union SQDefault Respectively mst)
-       Union SQDefault Respectively mst)
+       Union SQDefault Respectively mst
     ]
   where
     mst = toQueryExpr $ makeSelect
@@ -173,20 +174,20 @@ combos = Group "combos" $ map (uncurry (TestQueryExpr ansi2011))
 
 
 withQueries :: TestItem
-withQueries = Group "with queries" $ map (uncurry (TestQueryExpr ansi2011))
+withQueries = Group "with queries"
-    [("with u as (select a from t) select a from u"
+    [q "with u as (select a from t) select a from u"
-     ,With False [(Alias (Name Nothing "u") Nothing, ms1)] ms2)
+     $ With False [(Alias (Name Nothing "u") Nothing, ms1)] ms2
 
-    ,("with u(b) as (select a from t) select a from u"
+    ,q "with u(b) as (select a from t) select a from u"
-     ,With False [(Alias (Name Nothing "u") (Just [Name Nothing "b"]), ms1)] ms2)
+     $ With False [(Alias (Name Nothing "u") (Just [Name Nothing "b"]), ms1)] ms2
 
-    ,("with x as (select a from t),\n\
+    ,q "with x as (select a from t),\n\
       \     u as (select a from x)\n\
       \select a from u"
-     ,With False [(Alias (Name Nothing "x") Nothing, ms1), (Alias (Name Nothing "u") Nothing,ms3)] ms2)
+     $ With False [(Alias (Name Nothing "x") Nothing, ms1), (Alias (Name Nothing "u") Nothing,ms3)] ms2
 
-    ,("with recursive u as (select a from t) select a from u"
+    ,q "with recursive u as (select a from t) select a from u"
-     ,With True [(Alias (Name Nothing "u") Nothing, ms1)] ms2)
+     $ With True [(Alias (Name Nothing "u") Nothing, ms1)] ms2
     ]
  where
    ms c t = toQueryExpr $ makeSelect
@@ -197,13 +198,16 @@ withQueries = Group "with queries" $ map (uncurry (TestQueryExpr ansi2011))
    ms3 = ms "a" "x"
 
 values :: TestItem
-values = Group "values" $ map (uncurry (TestQueryExpr ansi2011))
+values = Group "values"
-    [("values (1,2),(3,4)"
+    [q "values (1,2),(3,4)"
-      ,Values [[NumLit "1", NumLit "2"]
+     $ Values [[NumLit "1", NumLit "2"]
-              ,[NumLit "3", NumLit "4"]])
+              ,[NumLit "3", NumLit "4"]]
     ]
 
 tables :: TestItem
-tables = Group "tables" $ map (uncurry (TestQueryExpr ansi2011))
+tables = Group "tables"
-    [("table tbl", Table [Name Nothing "tbl"])
+    [q "table tbl" $ Table [Name Nothing "tbl"]
     ]
+
+q :: HasCallStack => Text -> QueryExpr -> TestItem
+q src ast = testQueryExpr ansi2011 src ast

tests/Language/SQL/SimpleSQL/QueryExprs.hs

@@ -9,19 +9,23 @@ module Language.SQL.SimpleSQL.QueryExprs (queryExprsTests) where
 
 import Language.SQL.SimpleSQL.TestTypes
 import Language.SQL.SimpleSQL.Syntax
+import Language.SQL.SimpleSQL.TestRunners
+import Data.Text (Text)
 
 queryExprsTests :: TestItem
-queryExprsTests = Group "query exprs" $ map (uncurry (TestStatements ansi2011))
+queryExprsTests = Group "query exprs"
-    [("select 1",[ms])
+    [q "select 1" [ms]
-    ,("select 1;",[ms])
+    ,q "select 1;" [ms]
-    ,("select 1;select 1",[ms,ms])
+    ,q "select 1;select 1" [ms,ms]
-    ,(" select 1;select 1; ",[ms,ms])
+    ,q " select 1;select 1; " [ms,ms]
-    ,("SELECT CURRENT_TIMESTAMP;"
+    ,q "SELECT CURRENT_TIMESTAMP;"
-     ,[SelectStatement $ toQueryExpr $ makeSelect
+      [SelectStatement $ toQueryExpr $ makeSelect
-      {msSelectList = [(Iden [Name Nothing "CURRENT_TIMESTAMP"],Nothing)]}])
+      {msSelectList = [(Iden [Name Nothing "CURRENT_TIMESTAMP"],Nothing)]}]
-    ,("SELECT \"CURRENT_TIMESTAMP\";"
+    ,q "SELECT \"CURRENT_TIMESTAMP\";"
-     ,[SelectStatement $ toQueryExpr $ makeSelect
+      [SelectStatement $ toQueryExpr $ makeSelect
-      {msSelectList = [(Iden [Name (Just ("\"","\"")) "CURRENT_TIMESTAMP"],Nothing)]}])
+      {msSelectList = [(Iden [Name (Just ("\"","\"")) "CURRENT_TIMESTAMP"],Nothing)]}]
     ]
   where
     ms = SelectStatement $ toQueryExpr $ makeSelect {msSelectList = [(NumLit "1",Nothing)]}
+    q :: HasCallStack => Text -> [Statement] -> TestItem
+    q src ast = testStatements ansi2011 src ast

tests/Language/SQL/SimpleSQL/SQL2011AccessControl.hs

@@ -11,6 +11,8 @@ module Language.SQL.SimpleSQL.SQL2011AccessControl (sql2011AccessControlTests) w
 
 import Language.SQL.SimpleSQL.TestTypes
 import Language.SQL.SimpleSQL.Syntax
+import Language.SQL.SimpleSQL.TestRunners
+import Data.Text (Text)
 
 sql2011AccessControlTests :: TestItem
 sql2011AccessControlTests = Group "sql 2011 access control tests" [
@@ -78,128 +80,107 @@ sql2011AccessControlTests = Group "sql 2011 access control tests" [
   | CURRENT_ROLE
 -}
 
-     (TestStatement ansi2011
+     s "grant all privileges on tbl1 to role1"
-      "grant all privileges on tbl1 to role1"
      $ GrantPrivilege [PrivAll]
        (PrivTable [Name Nothing "tbl1"])
-       [Name Nothing "role1"] WithoutGrantOption)
+       [Name Nothing "role1"] WithoutGrantOption
 
 
-    ,(TestStatement ansi2011
+    ,s "grant all privileges on tbl1 to role1,role2"
-      "grant all privileges on tbl1 to role1,role2"
      $ GrantPrivilege [PrivAll]
        (PrivTable [Name Nothing "tbl1"])
-       [Name Nothing "role1",Name Nothing "role2"] WithoutGrantOption)
+       [Name Nothing "role1",Name Nothing "role2"] WithoutGrantOption
 
-    ,(TestStatement ansi2011
+    ,s "grant all privileges on tbl1 to role1 with grant option"
-      "grant all privileges on tbl1 to role1 with grant option"
      $ GrantPrivilege [PrivAll]
        (PrivTable [Name Nothing "tbl1"])
-       [Name Nothing "role1"] WithGrantOption)
+       [Name Nothing "role1"] WithGrantOption
 
-    ,(TestStatement ansi2011
+    ,s "grant all privileges on table tbl1 to role1"
-      "grant all privileges on table tbl1 to role1"
      $ GrantPrivilege [PrivAll]
        (PrivTable [Name Nothing "tbl1"])
-       [Name Nothing "role1"] WithoutGrantOption)
+       [Name Nothing "role1"] WithoutGrantOption
 
-    ,(TestStatement ansi2011
+    ,s "grant all privileges on domain mydom to role1"
-      "grant all privileges on domain mydom to role1"
      $ GrantPrivilege [PrivAll]
        (PrivDomain [Name Nothing "mydom"])
-       [Name Nothing "role1"] WithoutGrantOption)
+       [Name Nothing "role1"] WithoutGrantOption
 
-    ,(TestStatement ansi2011
+    ,s "grant all privileges on type t1 to role1"
-      "grant all privileges on type t1 to role1"
      $ GrantPrivilege [PrivAll]
        (PrivType [Name Nothing "t1"])
-       [Name Nothing "role1"] WithoutGrantOption)
+       [Name Nothing "role1"] WithoutGrantOption
 
-    ,(TestStatement ansi2011
+    ,s "grant all privileges on sequence s1 to role1"
-      "grant all privileges on sequence s1 to role1"
      $ GrantPrivilege [PrivAll]
        (PrivSequence [Name Nothing "s1"])
-       [Name Nothing "role1"] WithoutGrantOption)
+       [Name Nothing "role1"] WithoutGrantOption
 
-
+    ,s "grant select on table t1 to role1"
-    ,(TestStatement ansi2011
-      "grant select on table t1 to role1"
      $ GrantPrivilege [PrivSelect []]
        (PrivTable [Name Nothing "t1"])
-       [Name Nothing "role1"] WithoutGrantOption)
+       [Name Nothing "role1"] WithoutGrantOption
 
-    ,(TestStatement ansi2011
+    ,s "grant select(a,b) on table t1 to role1"
-      "grant select(a,b) on table t1 to role1"
      $ GrantPrivilege [PrivSelect [Name Nothing "a", Name Nothing "b"]]
        (PrivTable [Name Nothing "t1"])
-       [Name Nothing "role1"] WithoutGrantOption)
+       [Name Nothing "role1"] WithoutGrantOption
 
-    ,(TestStatement ansi2011
+    ,s "grant delete on table t1 to role1"
-      "grant delete on table t1 to role1"
      $ GrantPrivilege [PrivDelete]
        (PrivTable [Name Nothing "t1"])
-       [Name Nothing "role1"] WithoutGrantOption)
+       [Name Nothing "role1"] WithoutGrantOption
 
-    ,(TestStatement ansi2011
+    ,s "grant insert on table t1 to role1"
-      "grant insert on table t1 to role1"
      $ GrantPrivilege [PrivInsert []]
        (PrivTable [Name Nothing "t1"])
-       [Name Nothing "role1"] WithoutGrantOption)
+       [Name Nothing "role1"] WithoutGrantOption
 
-    ,(TestStatement ansi2011
+    ,s "grant insert(a,b) on table t1 to role1"
-      "grant insert(a,b) on table t1 to role1"
      $ GrantPrivilege [PrivInsert [Name Nothing "a", Name Nothing "b"]]
        (PrivTable [Name Nothing "t1"])
-       [Name Nothing "role1"] WithoutGrantOption)
+       [Name Nothing "role1"] WithoutGrantOption
 
-    ,(TestStatement ansi2011
+    ,s "grant update on table t1 to role1"
-      "grant update on table t1 to role1"
      $ GrantPrivilege [PrivUpdate []]
        (PrivTable [Name Nothing "t1"])
-       [Name Nothing "role1"] WithoutGrantOption)
+       [Name Nothing "role1"] WithoutGrantOption
 
-    ,(TestStatement ansi2011
+    ,s "grant update(a,b) on table t1 to role1"
-      "grant update(a,b) on table t1 to role1"
      $ GrantPrivilege [PrivUpdate [Name Nothing "a", Name Nothing "b"]]
        (PrivTable [Name Nothing "t1"])
-       [Name Nothing "role1"] WithoutGrantOption)
+       [Name Nothing "role1"] WithoutGrantOption
 
-    ,(TestStatement ansi2011
+    ,s "grant references on table t1 to role1"
-      "grant references on table t1 to role1"
      $ GrantPrivilege [PrivReferences []]
        (PrivTable [Name Nothing "t1"])
-       [Name Nothing "role1"] WithoutGrantOption)
+       [Name Nothing "role1"] WithoutGrantOption
 
-    ,(TestStatement ansi2011
+    ,s "grant references(a,b) on table t1 to role1"
-      "grant references(a,b) on table t1 to role1"
      $ GrantPrivilege [PrivReferences [Name Nothing "a", Name Nothing "b"]]
        (PrivTable [Name Nothing "t1"])
-       [Name Nothing "role1"] WithoutGrantOption)
+       [Name Nothing "role1"] WithoutGrantOption
 
-    ,(TestStatement ansi2011
+    ,s "grant usage on table t1 to role1"
-      "grant usage on table t1 to role1"
      $ GrantPrivilege [PrivUsage]
        (PrivTable [Name Nothing "t1"])
-       [Name Nothing "role1"] WithoutGrantOption)
+       [Name Nothing "role1"] WithoutGrantOption
 
-    ,(TestStatement ansi2011
+    ,s "grant trigger on table t1 to role1"
-      "grant trigger on table t1 to role1"
      $ GrantPrivilege [PrivTrigger]
        (PrivTable [Name Nothing "t1"])
-       [Name Nothing "role1"] WithoutGrantOption)
+       [Name Nothing "role1"] WithoutGrantOption
 
 
-    ,(TestStatement ansi2011
+    ,s "grant execute on specific function f to role1"
-      "grant execute on specific function f to role1"
      $ GrantPrivilege [PrivExecute]
        (PrivFunction [Name Nothing "f"])
-       [Name Nothing "role1"] WithoutGrantOption)
+       [Name Nothing "role1"] WithoutGrantOption
 
-    ,(TestStatement ansi2011
+    ,s "grant select,delete on table t1 to role1"
-      "grant select,delete on table t1 to role1"
      $ GrantPrivilege [PrivSelect [], PrivDelete]
        (PrivTable [Name Nothing "t1"])
-       [Name Nothing "role1"] WithoutGrantOption)
+       [Name Nothing "role1"] WithoutGrantOption
 
 {-
 skipping for now:
@@ -224,9 +205,8 @@ functions, etc., by argument types since they can be overloaded
   CREATE ROLE <role name> [ WITH ADMIN <grantor> ]
 -}
 
-    ,(TestStatement ansi2011
+    ,s "create role rolee"
-      "create role rolee"
+     $ CreateRole (Name Nothing "rolee")
-     $ CreateRole (Name Nothing "rolee"))
 
 
 {-
@@ -242,18 +222,15 @@ functions, etc., by argument types since they can be overloaded
   <role name>
 -}
 
-    ,(TestStatement ansi2011
+    ,s "grant role1 to public"
-      "grant role1 to public"
+     $ GrantRole [Name Nothing "role1"] [Name Nothing "public"] WithoutAdminOption
-     $ GrantRole [Name Nothing "role1"] [Name Nothing "public"] WithoutAdminOption)
 
-    ,(TestStatement ansi2011
+    ,s "grant role1,role2 to role3,role4"
-      "grant role1,role2 to role3,role4"
      $ GrantRole [Name Nothing "role1",Name Nothing "role2"]
-                 [Name Nothing "role3", Name Nothing "role4"] WithoutAdminOption)
+                 [Name Nothing "role3", Name Nothing "role4"] WithoutAdminOption
 
-    ,(TestStatement ansi2011
+    ,s "grant role1 to role3 with admin option"
-      "grant role1 to role3 with admin option"
+     $ GrantRole [Name Nothing "role1"] [Name Nothing "role3"] WithAdminOption
-     $ GrantRole [Name Nothing "role1"] [Name Nothing "role3"] WithAdminOption)
 
 
 {-
@@ -263,9 +240,8 @@ functions, etc., by argument types since they can be overloaded
   DROP ROLE <role name>
 -}
 
-    ,(TestStatement ansi2011
+    ,s "drop role rolee"
-      "drop role rolee"
+     $ DropRole (Name Nothing "rolee")
-     $ DropRole (Name Nothing "rolee"))
 
 
 {-
@@ -287,17 +263,16 @@ functions, etc., by argument types since they can be overloaded
 -}
 
 
-    ,(TestStatement ansi2011
+    ,s "revoke select on t1 from role1"
-      "revoke select on t1 from role1"
      $ RevokePrivilege NoGrantOptionFor [PrivSelect []]
               (PrivTable [Name Nothing "t1"])
-              [Name Nothing "role1"] DefaultDropBehaviour)
+              [Name Nothing "role1"] DefaultDropBehaviour
 
-    ,(TestStatement ansi2011
+    ,s
       "revoke grant option for select on t1 from role1,role2 cascade"
      $ RevokePrivilege GrantOptionFor [PrivSelect []]
                        (PrivTable [Name Nothing "t1"])
-              [Name Nothing "role1",Name Nothing "role2"] Cascade)
+              [Name Nothing "role1",Name Nothing "role2"] Cascade
 
 
 {-
@@ -311,20 +286,19 @@ functions, etc., by argument types since they can be overloaded
   <role name>
 -}
 
-    ,(TestStatement ansi2011
+    ,s "revoke role1 from role2"
-      "revoke role1 from role2"
      $ RevokeRole NoAdminOptionFor [Name Nothing "role1"]
-                  [Name Nothing "role2"] DefaultDropBehaviour)
+                  [Name Nothing "role2"] DefaultDropBehaviour
 
-    ,(TestStatement ansi2011
+    ,s "revoke role1,role2 from role3,role4"
-      "revoke role1,role2 from role3,role4"
      $ RevokeRole NoAdminOptionFor [Name Nothing "role1",Name Nothing "role2"]
-                  [Name Nothing "role3",Name Nothing "role4"] DefaultDropBehaviour)
+                  [Name Nothing "role3",Name Nothing "role4"] DefaultDropBehaviour
 
 
-    ,(TestStatement ansi2011
+    ,s "revoke admin option for role1 from role2 cascade"
-      "revoke admin option for role1 from role2 cascade"
+     $ RevokeRole AdminOptionFor [Name Nothing "role1"] [Name Nothing "role2"] Cascade
-     $ RevokeRole AdminOptionFor [Name Nothing "role1"] [Name Nothing "role2"] Cascade)
-
 
    ]
+
+s :: HasCallStack => Text -> Statement -> TestItem
+s src ast = testStatement ansi2011 src ast

tests/Language/SQL/SimpleSQL/SQL2011Bits.hs

@@ -12,6 +12,8 @@ module Language.SQL.SimpleSQL.SQL2011Bits (sql2011BitsTests) where
 
 import Language.SQL.SimpleSQL.TestTypes
 import Language.SQL.SimpleSQL.Syntax
+import Language.SQL.SimpleSQL.TestRunners
+import Data.Text (Text)
 
 sql2011BitsTests :: TestItem
 sql2011BitsTests = Group "sql 2011 bits tests" [
@@ -27,10 +29,8 @@ sql2011BitsTests = Group "sql 2011 bits tests" [
 BEGIN is not in the standard!
 -}
 
-     (TestStatement ansi2011
+     s "start transaction" StartTransaction
-      "start transaction"
+     
-     $ StartTransaction)
-
 {-
 17.2 <set transaction statement>
 
@@ -84,9 +84,8 @@ BEGIN is not in the standard!
   <savepoint name>
 -}
 
-    ,(TestStatement ansi2011
+    ,s "savepoint difficult_bit"
-      "savepoint difficult_bit"
+     $ Savepoint $ Name Nothing "difficult_bit"
-     $ Savepoint $ Name Nothing "difficult_bit")
 
 
 {-
@@ -96,9 +95,8 @@ BEGIN is not in the standard!
   RELEASE SAVEPOINT <savepoint specifier>
 -}
 
-    ,(TestStatement ansi2011
+    ,s "release savepoint difficult_bit"
-      "release savepoint difficult_bit"
+     $ ReleaseSavepoint $ Name Nothing "difficult_bit"
-     $ ReleaseSavepoint $ Name Nothing "difficult_bit")
 
 
 {-
@@ -108,13 +106,9 @@ BEGIN is not in the standard!
   COMMIT [ WORK ] [ AND [ NO ] CHAIN ]
 -}
 
-    ,(TestStatement ansi2011
+    ,s "commit" Commit
-      "commit"
-     $ Commit)
 
-    ,(TestStatement ansi2011
+    ,s "commit work" Commit
-      "commit work"
-     $ Commit)
 
 
 {-
@@ -127,17 +121,12 @@ BEGIN is not in the standard!
   TO SAVEPOINT <savepoint specifier>
 -}
 
-    ,(TestStatement ansi2011
+    ,s "rollback" $ Rollback Nothing
-      "rollback"
-     $ Rollback Nothing)
 
-    ,(TestStatement ansi2011
+    ,s "rollback work" $ Rollback Nothing
-      "rollback work"
-     $ Rollback Nothing)
 
-    ,(TestStatement ansi2011
+    ,s "rollback to savepoint difficult_bit"
-      "rollback to savepoint difficult_bit"
+       $ Rollback $ Just $ Name Nothing "difficult_bit"
-     $ Rollback $ Just $ Name Nothing "difficult_bit")
 
 
 {-
@@ -232,3 +221,6 @@ BEGIN is not in the standard!
 -}
 
    ]
+
+s :: HasCallStack => Text -> Statement -> TestItem
+s src ast = testStatement ansi2011 src ast

tests/Language/SQL/SimpleSQL/SQL2011DataManipulation.hs

@@ -7,6 +7,8 @@ module Language.SQL.SimpleSQL.SQL2011DataManipulation (sql2011DataManipulationTe
 
 import Language.SQL.SimpleSQL.TestTypes
 import Language.SQL.SimpleSQL.Syntax
+import Language.SQL.SimpleSQL.TestRunners
+import Data.Text (Text)
 
 sql2011DataManipulationTests :: TestItem
 sql2011DataManipulationTests = Group "sql 2011 data manipulation tests"
@@ -111,20 +113,20 @@ sql2011DataManipulationTests = Group "sql 2011 data manipulation tests"
       [ WHERE <search condition> ]
 -}
 
-     (TestStatement ansi2011 "delete from t"
+     s "delete from t"
-     $ Delete [Name Nothing "t"] Nothing Nothing)
+     $ Delete [Name Nothing "t"] Nothing Nothing
 
-    ,(TestStatement ansi2011 "delete from t as u"
+    ,s "delete from t as u"
-     $ Delete [Name Nothing "t"] (Just (Name Nothing "u")) Nothing)
+     $ Delete [Name Nothing "t"] (Just (Name Nothing "u")) Nothing
 
-    ,(TestStatement ansi2011 "delete from t where x = 5"
+    ,s "delete from t where x = 5"
      $ Delete [Name Nothing "t"] Nothing
-       (Just $ BinOp (Iden [Name Nothing "x"]) [Name Nothing "="] (NumLit "5")))
+       (Just $ BinOp (Iden [Name Nothing "x"]) [Name Nothing "="] (NumLit "5"))
 
 
-    ,(TestStatement ansi2011 "delete from t as u where u.x = 5"
+    ,s "delete from t as u where u.x = 5"
      $ Delete [Name Nothing "t"] (Just (Name Nothing "u"))
-       (Just $ BinOp (Iden [Name Nothing "u", Name Nothing "x"]) [Name Nothing "="] (NumLit "5")))
+       (Just $ BinOp (Iden [Name Nothing "u", Name Nothing "x"]) [Name Nothing "="] (NumLit "5"))
 
 {-
 14.10 <truncate table statement>
@@ -137,14 +139,14 @@ sql2011DataManipulationTests = Group "sql 2011 data manipulation tests"
   | RESTART IDENTITY
 -}
 
-    ,(TestStatement ansi2011 "truncate table t"
+    ,s "truncate table t"
-     $ Truncate [Name Nothing "t"] DefaultIdentityRestart)
+     $ Truncate [Name Nothing "t"] DefaultIdentityRestart
 
-    ,(TestStatement ansi2011 "truncate table t continue identity"
+    ,s "truncate table t continue identity"
-     $ Truncate [Name Nothing "t"] ContinueIdentity)
+     $ Truncate [Name Nothing "t"] ContinueIdentity
 
-    ,(TestStatement ansi2011 "truncate table t restart identity"
+    ,s "truncate table t restart identity"
-     $ Truncate [Name Nothing "t"] RestartIdentity)
+     $ Truncate [Name Nothing "t"] RestartIdentity
 
 
 {-
@@ -182,37 +184,37 @@ sql2011DataManipulationTests = Group "sql 2011 data manipulation tests"
   <column name list>
 -}
 
-    ,(TestStatement ansi2011 "insert into t select * from u"
+    ,s "insert into t select * from u"
      $ Insert [Name Nothing "t"] Nothing
        $ InsertQuery $ toQueryExpr $ makeSelect
          {msSelectList = [(Star, Nothing)]
-         ,msFrom = [TRSimple [Name Nothing "u"]]})
+         ,msFrom = [TRSimple [Name Nothing "u"]]}
 
-    ,(TestStatement ansi2011 "insert into t(a,b,c) select * from u"
+    ,s "insert into t(a,b,c) select * from u"
      $ Insert [Name Nothing "t"] (Just [Name Nothing "a", Name Nothing "b", Name Nothing "c"])
        $ InsertQuery $ toQueryExpr $ makeSelect
          {msSelectList = [(Star, Nothing)]
-         ,msFrom = [TRSimple [Name Nothing "u"]]})
+         ,msFrom = [TRSimple [Name Nothing "u"]]}
 
-    ,(TestStatement ansi2011 "insert into t default values"
+    ,s "insert into t default values"
-     $ Insert [Name Nothing "t"] Nothing DefaultInsertValues)
+     $ Insert [Name Nothing "t"] Nothing DefaultInsertValues
 
-    ,(TestStatement ansi2011 "insert into t values(1,2)"
+    ,s "insert into t values(1,2)"
      $ Insert [Name Nothing "t"] Nothing
-       $ InsertQuery $ Values [[NumLit "1", NumLit "2"]])
+       $ InsertQuery $ Values [[NumLit "1", NumLit "2"]]
 
-    ,(TestStatement ansi2011 "insert into t values (1,2),(3,4)"
+    ,s "insert into t values (1,2),(3,4)"
      $ Insert [Name Nothing "t"] Nothing
        $ InsertQuery $ Values [[NumLit "1", NumLit "2"]
-                              ,[NumLit "3", NumLit "4"]])
+                              ,[NumLit "3", NumLit "4"]]
 
-    ,(TestStatement ansi2011
+    ,s
       "insert into t values (default,null,array[],multiset[])"
      $ Insert [Name Nothing "t"] Nothing
        $ InsertQuery $ Values [[Iden [Name Nothing "default"]
                                ,Iden [Name Nothing "null"]
                                ,Array (Iden [Name Nothing "array"]) []
-                               ,MultisetCtor []]])
+                               ,MultisetCtor []]]
 
 
 {-
@@ -456,32 +458,32 @@ FROM CentralOfficeAccounts;
 -}
 
 
-    ,(TestStatement ansi2011 "update t set a=b"
+    ,s "update t set a=b"
      $ Update [Name Nothing "t"] Nothing
-       [Set [Name Nothing "a"] (Iden [Name Nothing "b"])] Nothing)
+       [Set [Name Nothing "a"] (Iden [Name Nothing "b"])] Nothing
 
-    ,(TestStatement ansi2011 "update t set a=b, c=5"
+    ,s "update t set a=b, c=5"
      $ Update [Name Nothing "t"] Nothing
        [Set [Name Nothing "a"] (Iden [Name Nothing "b"])
-       ,Set [Name Nothing "c"] (NumLit "5")] Nothing)
+       ,Set [Name Nothing "c"] (NumLit "5")] Nothing
 
 
-    ,(TestStatement ansi2011 "update t set a=b where a>5"
+    ,s "update t set a=b where a>5"
      $ Update [Name Nothing "t"] Nothing
        [Set [Name Nothing "a"] (Iden [Name Nothing "b"])]
-       $ Just $ BinOp (Iden [Name Nothing "a"]) [Name Nothing ">"] (NumLit "5"))
+       $ Just $ BinOp (Iden [Name Nothing "a"]) [Name Nothing ">"] (NumLit "5")
 
 
-    ,(TestStatement ansi2011 "update t as u set a=b where u.a>5"
+    ,s "update t as u set a=b where u.a>5"
      $ Update [Name Nothing "t"] (Just $ Name Nothing "u")
        [Set [Name Nothing "a"] (Iden [Name Nothing "b"])]
        $ Just $ BinOp (Iden [Name Nothing "u",Name Nothing "a"])
-                      [Name Nothing ">"] (NumLit "5"))
+                      [Name Nothing ">"] (NumLit "5")
 
-    ,(TestStatement ansi2011 "update t set (a,b)=(3,5)"
+    ,s "update t set (a,b)=(3,5)"
      $ Update [Name Nothing "t"] Nothing
        [SetMultiple [[Name Nothing "a"],[Name Nothing "b"]]
-                    [NumLit "3", NumLit "5"]] Nothing)
+                    [NumLit "3", NumLit "5"]] Nothing
 
 
 
@@ -553,3 +555,6 @@ declare local temporary table t (a int) [on commit {preserve | delete} rows]
 
 
    ]
+
+s :: HasCallStack => Text -> Statement -> TestItem
+s src ast = testStatement ansi2011 src ast

tests/Language/SQL/SimpleSQL/SQL2011Queries.hs

@@ -37,6 +37,7 @@ import Language.SQL.SimpleSQL.TestTypes
 import Language.SQL.SimpleSQL.Syntax
 
 import Data.Text (Text)
+import Language.SQL.SimpleSQL.TestRunners
 
 sql2011QueryTests :: TestItem
 sql2011QueryTests = Group "sql 2011 query tests"
@@ -515,19 +516,19 @@ generalLiterals = Group "general literals"
 
 characterStringLiterals :: TestItem
 characterStringLiterals = Group "character string literals"
-    $ map (uncurry (TestScalarExpr ansi2011))
+    $
-    [("'a regular string literal'"
+    [e "'a regular string literal'"
-     ,StringLit "'" "'" "a regular string literal")
+     $ StringLit "'" "'" "a regular string literal"
-    ,("'something' ' some more' 'and more'"
+    ,e "'something' ' some more' 'and more'"
-     ,StringLit "'" "'" "something some moreand more")
+     $ StringLit "'" "'" "something some moreand more"
-    ,("'something' \n ' some more' \t 'and more'"
+    ,e "'something' \n ' some more' \t 'and more'"
-     ,StringLit "'" "'" "something some moreand more")
+     $ StringLit "'" "'" "something some moreand more"
-    ,("'something' -- a comment\n ' some more' /*another comment*/ 'and more'"
+    ,e "'something' -- a comment\n ' some more' /*another comment*/ 'and more'"
-     ,StringLit "'" "'" "something some moreand more")
+     $ StringLit "'" "'" "something some moreand more"
-    ,("'a quote: '', stuff'"
+    ,e "'a quote: '', stuff'"
-     ,StringLit "'" "'" "a quote: '', stuff")
+     $ StringLit "'" "'" "a quote: '', stuff"
-    ,("''"
+    ,e "''"
-     ,StringLit "'" "'" "")
+     $ StringLit "'" "'" ""
 
 {-
 I'm not sure how this should work. Maybe the parser should reject non
@@ -535,8 +536,8 @@ ascii characters in strings and identifiers unless the current SQL
 character set allows them.
 -}
 
-    ,("_francais 'français'"
+    ,e "_francais 'français'"
-     ,TypedLit (TypeName [Name Nothing "_francais"]) "français")
+     $ TypedLit (TypeName [Name Nothing "_francais"]) "français"
     ]
 
 {-
@@ -547,9 +548,9 @@ character set allows them.
 
 nationalCharacterStringLiterals :: TestItem
 nationalCharacterStringLiterals = Group "national character string literals"
-    $ map (uncurry (TestScalarExpr ansi2011))
+    $
-    [("N'something'", StringLit "N'" "'" "something")
+    [e "N'something'" $ StringLit "N'" "'" "something"
-    ,("n'something'", StringLit "n'" "'" "something")
+    ,e "n'something'" $ StringLit "n'" "'" "something"
     ]
 
 {-
@@ -566,8 +567,8 @@ nationalCharacterStringLiterals = Group "national character string literals"
 
 unicodeCharacterStringLiterals :: TestItem
 unicodeCharacterStringLiterals = Group "unicode character string literals"
-    $ map (uncurry (TestScalarExpr ansi2011))
+    $
-    [("U&'something'", StringLit "U&'" "'" "something")
+    [e "U&'something'" $ StringLit "U&'" "'" "something"
     {-,("u&'something' escape ="
      ,Escape (StringLit "u&'" "'" "something") '=')
     ,("u&'something' uescape ="
@@ -587,9 +588,9 @@ TODO: unicode escape
 
 binaryStringLiterals :: TestItem
 binaryStringLiterals = Group "binary string literals"
-    $ map (uncurry (TestScalarExpr ansi2011))
+    $
     [--("B'101010'", CSStringLit "B" "101010")
-     ("X'7f7f7f'", StringLit "X'" "'" "7f7f7f")
+     e "X'7f7f7f'" $ StringLit "X'" "'" "7f7f7f"
     --,("X'7f7f7f' escape z", Escape (StringLit "X'" "'" "7f7f7f") 'z')
     ]
 
@@ -619,33 +620,32 @@ binaryStringLiterals = Group "binary string literals"
 
 numericLiterals :: TestItem
 numericLiterals = Group "numeric literals"
-    $ map (uncurry (TestScalarExpr ansi2011))
+    [e "11" $ NumLit "11"
-    [("11", NumLit "11")
+    ,e "11.11" $ NumLit "11.11"
-    ,("11.11", NumLit "11.11")
 
-    ,("11E23", NumLit "11E23")
+    ,e "11E23" $ NumLit "11E23"
-    ,("11E+23", NumLit "11E+23")
+    ,e "11E+23" $ NumLit "11E+23"
-    ,("11E-23", NumLit "11E-23")
+    ,e "11E-23" $ NumLit "11E-23"
 
-    ,("11.11E23", NumLit "11.11E23")
+    ,e "11.11E23" $ NumLit "11.11E23"
-    ,("11.11E+23", NumLit "11.11E+23")
+    ,e "11.11E+23" $ NumLit "11.11E+23"
-    ,("11.11E-23", NumLit "11.11E-23")
+    ,e "11.11E-23" $ NumLit "11.11E-23"
 
-    ,("+11E23", PrefixOp [Name Nothing "+"] $ NumLit "11E23")
+    ,e "+11E23" $ PrefixOp [Name Nothing "+"] $ NumLit "11E23"
-    ,("+11E+23", PrefixOp [Name Nothing "+"] $ NumLit "11E+23")
+    ,e "+11E+23" $ PrefixOp [Name Nothing "+"] $ NumLit "11E+23"
-    ,("+11E-23", PrefixOp [Name Nothing "+"] $ NumLit "11E-23")
+    ,e "+11E-23" $ PrefixOp [Name Nothing "+"] $ NumLit "11E-23"
-    ,("+11.11E23", PrefixOp [Name Nothing "+"] $ NumLit "11.11E23")
+    ,e "+11.11E23" $ PrefixOp [Name Nothing "+"] $ NumLit "11.11E23"
-    ,("+11.11E+23", PrefixOp [Name Nothing "+"] $ NumLit "11.11E+23")
+    ,e "+11.11E+23" $ PrefixOp [Name Nothing "+"] $ NumLit "11.11E+23"
-    ,("+11.11E-23", PrefixOp [Name Nothing "+"] $ NumLit "11.11E-23")
+    ,e "+11.11E-23" $ PrefixOp [Name Nothing "+"] $ NumLit "11.11E-23"
 
-    ,("-11E23", PrefixOp [Name Nothing "-"] $ NumLit "11E23")
+    ,e "-11E23" $ PrefixOp [Name Nothing "-"] $ NumLit "11E23"
-    ,("-11E+23", PrefixOp [Name Nothing "-"] $ NumLit "11E+23")
+    ,e "-11E+23" $ PrefixOp [Name Nothing "-"] $ NumLit "11E+23"
-    ,("-11E-23", PrefixOp [Name Nothing "-"] $ NumLit "11E-23")
+    ,e "-11E-23" $ PrefixOp [Name Nothing "-"] $ NumLit "11E-23"
-    ,("-11.11E23", PrefixOp [Name Nothing "-"] $ NumLit "11.11E23")
+    ,e "-11.11E23" $ PrefixOp [Name Nothing "-"] $ NumLit "11.11E23"
-    ,("-11.11E+23", PrefixOp [Name Nothing "-"] $ NumLit "11.11E+23")
+    ,e "-11.11E+23" $ PrefixOp [Name Nothing "-"] $ NumLit "11.11E+23"
-    ,("-11.11E-23", PrefixOp [Name Nothing "-"] $ NumLit "11.11E-23")
+    ,e "-11.11E-23" $ PrefixOp [Name Nothing "-"] $ NumLit "11.11E-23"
 
-    ,("11.11e23", NumLit "11.11e23")
+    ,e "11.11e23" $ NumLit "11.11e23"
 
     ]
 
@@ -729,33 +729,30 @@ dateTimeLiterals = Group "datetime literals"
 
 intervalLiterals :: TestItem
 intervalLiterals = Group "intervalLiterals literals"
-    $ map (uncurry (TestScalarExpr ansi2011))
+    [e "interval '1'" $ TypedLit (TypeName [Name Nothing "interval"]) "1"
-    [("interval '1'", TypedLit (TypeName [Name Nothing "interval"]) "1")
+    ,e "interval '1' day"
-    ,("interval '1' day"
+     $ IntervalLit Nothing "1" (Itf "day" Nothing) Nothing
-     ,IntervalLit Nothing "1" (Itf "day" Nothing) Nothing)
+    ,e "interval '1' day(3)"
-    ,("interval '1' day(3)"
+     $ IntervalLit Nothing "1" (Itf "day" $ Just (3,Nothing)) Nothing
-     ,IntervalLit Nothing "1" (Itf "day" $ Just (3,Nothing)) Nothing)
+    ,e "interval + '1' day(3)"
-    ,("interval + '1' day(3)"
+     $ IntervalLit (Just Plus) "1" (Itf "day" $ Just (3,Nothing)) Nothing
-     ,IntervalLit (Just Plus) "1" (Itf "day" $ Just (3,Nothing)) Nothing)
+    ,e "interval - '1' second(2,2)"
-    ,("interval - '1' second(2,2)"
+     $ IntervalLit (Just Minus) "1" (Itf "second" $ Just (2,Just 2)) Nothing
-     ,IntervalLit (Just Minus) "1" (Itf "second" $ Just (2,Just 2)) Nothing)
+    ,e "interval '1' year to month"
-    ,("interval '1' year to month"
+     $ IntervalLit Nothing "1" (Itf "year" Nothing)
-     ,IntervalLit Nothing "1" (Itf "year" Nothing)
+                                  (Just $ Itf "month" Nothing)
-                                  (Just $ Itf "month" Nothing))
+    ,e "interval '1' year(4) to second(2,3) "
-
+     $ IntervalLit Nothing "1" (Itf "year" $ Just (4,Nothing))
-    ,("interval '1' year(4) to second(2,3) "
+                            (Just $ Itf "second" $ Just (2, Just 3))
-     ,IntervalLit Nothing "1" (Itf "year" $ Just (4,Nothing))
-                            (Just $ Itf "second" $ Just (2, Just 3)))
     ]
 
 -- <boolean literal> ::= TRUE | FALSE | UNKNOWN
 
 booleanLiterals :: TestItem
 booleanLiterals = Group "boolean literals"
-    $ map (uncurry (TestScalarExpr ansi2011))
+    [e "true" $ Iden [Name Nothing "true"]
-    [("true", Iden [Name Nothing "true"])
+    ,e "false" $ Iden [Name Nothing "false"]
-    ,("false", Iden [Name Nothing "false"])
+    ,e "unknown" $ Iden [Name Nothing "unknown"]
-    ,("unknown", Iden [Name Nothing "unknown"])
     ]
 
 {-
@@ -774,16 +771,15 @@ Specify names.
 
 identifiers :: TestItem
 identifiers = Group "identifiers"
-    $ map (uncurry (TestScalarExpr ansi2011))
+    [e "test" $ Iden [Name Nothing "test"]
-    [("test",Iden [Name Nothing "test"])
+    ,e "_test" $ Iden [Name Nothing "_test"]
-    ,("_test",Iden [Name Nothing "_test"])
+    ,e "t1" $ Iden [Name Nothing "t1"]
-    ,("t1",Iden [Name Nothing "t1"])
+    ,e "a.b" $ Iden [Name Nothing "a", Name Nothing "b"]
-    ,("a.b",Iden [Name Nothing "a", Name Nothing "b"])
+    ,e "a.b.c" $ Iden [Name Nothing "a", Name Nothing "b", Name Nothing "c"]
-    ,("a.b.c",Iden [Name Nothing "a", Name Nothing "b", Name Nothing "c"])
+    ,e "\"quoted iden\"" $ Iden [Name (Just ("\"", "\"")) "quoted iden"]
-    ,("\"quoted iden\"", Iden [Name (Just ("\"","\"")) "quoted iden"])
+    ,e "\"quoted \"\" iden\"" $ Iden [Name (Just ("\"", "\"")) "quoted \"\" iden"]
-    ,("\"quoted \"\" iden\"", Iden [Name (Just ("\"","\"")) "quoted \"\" iden"])
+    ,e "U&\"quoted iden\"" $ Iden [Name (Just ("U&\"", "\"")) "quoted iden"]
-    ,("U&\"quoted iden\"", Iden [Name (Just ("U&\"","\"")) "quoted iden"])
+    ,e "U&\"quoted \"\" iden\"" $ Iden [Name (Just ("U&\"", "\"")) "quoted \"\" iden"]
-    ,("U&\"quoted \"\" iden\"", Iden [Name (Just ("U&\"","\"")) "quoted \"\" iden"])
     ]
 
 {-
@@ -1220,11 +1216,11 @@ expression
 
 typeNameTests :: TestItem
 typeNameTests = Group "type names"
-    [Group "type names" $ map (uncurry (TestScalarExpr ansi2011))
+    [Group "type names" $ map (uncurry (testScalarExpr ansi2011))
                           $ concatMap makeSimpleTests $ fst typeNames
-    ,Group "generated casts" $ map (uncurry (TestScalarExpr ansi2011))
+    ,Group "generated casts" $ map (uncurry (testScalarExpr ansi2011))
                           $ concatMap makeCastTests $ fst typeNames
-    ,Group "generated typename" $ map (uncurry (TestScalarExpr ansi2011))
+    ,Group "generated typename" $ map (uncurry (testScalarExpr ansi2011))
                           $ concatMap makeTests $ snd typeNames]
   where
     makeSimpleTests (ctn, stn) =
@@ -1247,12 +1243,10 @@ Define a field of a row type.
 
 fieldDefinition :: TestItem
 fieldDefinition = Group "field definition"
-    $ map (uncurry (TestScalarExpr ansi2011))
+    [e "cast('(1,2)' as row(a int,b char))"
-    [("cast('(1,2)' as row(a int,b char))"
+     $ Cast (StringLit "'" "'" "(1,2)")
-     ,Cast (StringLit "'" "'" "(1,2)")
      $ RowTypeName [(Name Nothing "a", TypeName [Name Nothing "int"])
-                   ,(Name Nothing "b", TypeName [Name Nothing "char"])])]
+                   ,(Name Nothing "b", TypeName [Name Nothing "char"])]]
-
 {-
 == 6.3 <value expression primary>
 
@@ -1329,9 +1323,8 @@ valueExpressions = Group "value expressions"
 
 parenthesizedScalarExpression :: TestItem
 parenthesizedScalarExpression = Group "parenthesized value expression"
-    $ map (uncurry (TestScalarExpr ansi2011))
+    [e "(3)" $ Parens (NumLit "3")
-    [("(3)", Parens (NumLit "3"))
+    ,e "((3))" $ Parens $ Parens (NumLit "3")
-    ,("((3))", Parens $ Parens (NumLit "3"))
     ]
 
 {-
@@ -1367,8 +1360,7 @@ Specify one or more values, host parameters, SQL parameters, dynamic parameters,
 
 generalValueSpecification :: TestItem
 generalValueSpecification = Group "general value specification"
-    $ map (uncurry (TestScalarExpr ansi2011)) $
+    $ map mkIden ["CURRENT_DEFAULT_TRANSFORM_GROUP"
-    map mkIden ["CURRENT_DEFAULT_TRANSFORM_GROUP"
                ,"CURRENT_PATH"
                ,"CURRENT_ROLE"
                ,"CURRENT_USER"
@@ -1377,7 +1369,7 @@ generalValueSpecification = Group "general value specification"
                ,"USER"
                ,"VALUE"]
   where
-    mkIden nm = (nm,Iden [Name Nothing nm])
+    mkIden nm = e nm $ Iden [Name Nothing nm]
 
 {-
 TODO: add the missing bits
@@ -1423,12 +1415,11 @@ TODO: add the missing bits
 
 parameterSpecification :: TestItem
 parameterSpecification = Group "parameter specification"
-    $ map (uncurry (TestScalarExpr ansi2011))
+    [e ":hostparam" $ HostParameter ":hostparam" Nothing
-    [(":hostparam", HostParameter ":hostparam" Nothing)
+    ,e ":hostparam indicator :another_host_param"
-    ,(":hostparam indicator :another_host_param"
+     $ HostParameter ":hostparam" $ Just ":another_host_param"
-     ,HostParameter ":hostparam" $ Just ":another_host_param")
+    ,e "?" $ Parameter
-    ,("?", Parameter)
+    ,e ":h[3]" $ Array (HostParameter ":h" Nothing) [NumLit "3"]
-    ,(":h[3]", Array (HostParameter ":h" Nothing) [NumLit "3"])
     ]
 
 {-
@@ -1462,11 +1453,10 @@ Specify a value whose data type is to be inferred from its context.
 contextuallyTypedValueSpecification :: TestItem
 contextuallyTypedValueSpecification =
     Group "contextually typed value specification"
-    $ map (uncurry (TestScalarExpr ansi2011))
+    [e "null" $ Iden [Name Nothing "null"]
-    [("null", Iden [Name Nothing "null"])
+    ,e "array[]" $ Array (Iden [Name Nothing "array"]) []
-    ,("array[]", Array (Iden [Name Nothing "array"]) [])
+    ,e "multiset[]" $ MultisetCtor []
-    ,("multiset[]", MultisetCtor [])
+    ,e "default" $ Iden [Name Nothing "default"]
-    ,("default", Iden [Name Nothing "default"])
     ]
 
 {-
@@ -1482,8 +1472,7 @@ Disambiguate a <period>-separated chain of identifiers.
 
 identifierChain :: TestItem
 identifierChain = Group "identifier chain"
-    $ map (uncurry (TestScalarExpr ansi2011))
+    [e "a.b" $ Iden [Name Nothing "a",Name Nothing "b"]]
-    [("a.b", Iden [Name Nothing "a",Name Nothing "b"])]
 
 {-
 == 6.7 <column reference>
@@ -1498,8 +1487,7 @@ Reference a column.
 
 columnReference :: TestItem
 columnReference = Group "column reference"
-    $ map (uncurry (TestScalarExpr ansi2011))
+    [e "module.a.b" $ Iden [Name Nothing "module",Name Nothing "a",Name Nothing "b"]]
-    [("module.a.b", Iden [Name Nothing "module",Name Nothing "a",Name Nothing "b"])]
 
 {-
 == 6.8 <SQL parameter reference>
@@ -1523,19 +1511,19 @@ Specify a value derived by the application of a function to an argument.
 
 setFunctionSpecification :: TestItem
 setFunctionSpecification = Group "set function specification"
-    $ map (uncurry (TestQueryExpr ansi2011))
+    $
-    [("SELECT SalesQuota, SUM(SalesYTD) TotalSalesYTD,\n\
+    [q "SELECT SalesQuota, SUM(SalesYTD) TotalSalesYTD,\n\
       \   GROUPING(SalesQuota) AS Grouping\n\
       \FROM Sales.SalesPerson\n\
       \GROUP BY ROLLUP(SalesQuota);"
-     ,toQueryExpr $ makeSelect
+     $ toQueryExpr $ makeSelect
       {msSelectList = [(Iden [Name Nothing "SalesQuota"],Nothing)
                       ,(App [Name Nothing "SUM"] [Iden [Name Nothing "SalesYTD"]]
                        ,Just (Name Nothing "TotalSalesYTD"))
                       ,(App [Name Nothing "GROUPING"] [Iden [Name Nothing "SalesQuota"]]
                        ,Just (Name Nothing "Grouping"))]
       ,msFrom = [TRSimple [Name Nothing "Sales",Name Nothing "SalesPerson"]]
-      ,msGroupBy = [Rollup [SimpleGroup (Iden [Name Nothing "SalesQuota"])]]})
+      ,msGroupBy = [Rollup [SimpleGroup (Iden [Name Nothing "SalesQuota"])]]}
     ]
 
 {-
@@ -1732,9 +1720,8 @@ Specify a data conversion.
 
 castSpecification :: TestItem
 castSpecification = Group "cast specification"
-    $ map (uncurry (TestScalarExpr ansi2011))
+    [e "cast(a as int)"
-    [("cast(a as int)"
+     $ Cast (Iden [Name Nothing "a"]) (TypeName [Name Nothing "int"])
-     ,Cast (Iden [Name Nothing "a"]) (TypeName [Name Nothing "int"]))
     ]
 
 {-
@@ -1748,8 +1735,7 @@ Return the next value of a sequence generator.
 
 nextScalarExpression :: TestItem
 nextScalarExpression = Group "next value expression"
-    $ map (uncurry (TestScalarExpr ansi2011))
+    [e "next value for a.b" $ NextValueFor [Name Nothing "a", Name Nothing "b"]
-    [("next value for a.b", NextValueFor [Name Nothing "a", Name Nothing "b"])
     ]
 
 {-
@@ -1763,11 +1749,10 @@ Reference a field of a row value.
 
 fieldReference :: TestItem
 fieldReference = Group "field reference"
-    $ map (uncurry (TestScalarExpr ansi2011))
+    [e "f(something).a"
-    [("f(something).a"
+      $ BinOp (App [Name Nothing "f"] [Iden [Name Nothing "something"]])
-      ,BinOp (App [Name Nothing "f"] [Iden [Name Nothing "something"]])
        [Name Nothing "."]
-       (Iden [Name Nothing "a"]))
+       (Iden [Name Nothing "a"])
     ]
 
 {-
@@ -1889,17 +1874,16 @@ Return an element of an array.
 
 arrayElementReference :: TestItem
 arrayElementReference = Group "array element reference"
-    $ map (uncurry (TestScalarExpr ansi2011))
+    [e "something[3]"
-    [("something[3]"
+      $ Array (Iden [Name Nothing "something"]) [NumLit "3"]
-     ,Array (Iden [Name Nothing "something"]) [NumLit "3"])
+    ,e "(something(a))[x]"
-    ,("(something(a))[x]"
+      $ Array (Parens (App [Name Nothing "something"] [Iden [Name Nothing "a"]]))
-      ,Array (Parens (App [Name Nothing "something"] [Iden [Name Nothing "a"]]))
+        [Iden [Name Nothing "x"]]
-        [Iden [Name Nothing "x"]])
+    ,e "(something(a))[x][y] "
-    ,("(something(a))[x][y] "
+      $ Array (
-      ,Array (
         Array (Parens (App [Name Nothing "something"] [Iden [Name Nothing "a"]]))
         [Iden [Name Nothing "x"]])
-        [Iden [Name Nothing "y"]])
+        [Iden [Name Nothing "y"]]
     ]
 
 {-
@@ -1914,9 +1898,8 @@ Return the sole element of a multiset of one element.
 
 multisetElementReference :: TestItem
 multisetElementReference = Group "multisetElementReference"
-    $ map (uncurry (TestScalarExpr ansi2011))
+    [e "element(something)"
-    [("element(something)"
+     $ App [Name Nothing "element"] [Iden [Name Nothing "something"]]
-     ,App [Name Nothing "element"] [Iden [Name Nothing "something"]])
     ]
 
 {-
@@ -1966,13 +1949,12 @@ Specify a numeric value.
 
 numericScalarExpression :: TestItem
 numericScalarExpression = Group "numeric value expression"
-    $ map (uncurry (TestScalarExpr ansi2011))
+    [e "a + b" $ binOp "+"
-    [("a + b", binOp "+")
+    ,e "a - b" $ binOp "-"
-    ,("a - b", binOp "-")
+    ,e "a * b" $ binOp "*"
-    ,("a * b", binOp "*")
+    ,e "a / b" $ binOp "/"
-    ,("a / b", binOp "/")
+    ,e "+a" $ prefOp "+"
-    ,("+a", prefOp "+")
+    ,e "-a" $ prefOp "-"
-    ,("-a", prefOp "-")
     ]
   where
     binOp o = BinOp (Iden [Name Nothing "a"]) [Name Nothing o] (Iden [Name Nothing "b"])
@@ -2439,17 +2421,16 @@ Specify a boolean value.
 
 booleanScalarExpression :: TestItem
 booleanScalarExpression = Group "booleab value expression"
-    $ map (uncurry (TestScalarExpr ansi2011))
+    [e "a or b" $ BinOp a [Name Nothing "or"] b
-    [("a or b", BinOp a [Name Nothing "or"] b)
+    ,e "a and b" $ BinOp a [Name Nothing "and"] b
-    ,("a and b", BinOp a [Name Nothing "and"] b)
+    ,e "not a" $ PrefixOp [Name Nothing "not"] a
-    ,("not a", PrefixOp [Name Nothing "not"] a)
+    ,e "a is true" $ postfixOp "is true"
-    ,("a is true", postfixOp "is true")
+    ,e "a is false" $ postfixOp "is false"
-    ,("a is false", postfixOp "is false")
+    ,e "a is unknown" $ postfixOp "is unknown"
-    ,("a is unknown", postfixOp "is unknown")
+    ,e "a is not true" $ postfixOp "is not true"
-    ,("a is not true", postfixOp "is not true")
+    ,e "a is not false" $ postfixOp "is not false"
-    ,("a is not false", postfixOp "is not false")
+    ,e "a is not unknown" $ postfixOp "is not unknown"
-    ,("a is not unknown", postfixOp "is not unknown")
+    ,e "(a or b)" $ Parens $ BinOp a [Name Nothing "or"] b
-    ,("(a or b)", Parens $ BinOp a [Name Nothing "or"] b)
     ]
   where
     a = Iden [Name Nothing "a"]
@@ -2520,23 +2501,22 @@ Specify construction of an array.
 
 arrayValueConstructor :: TestItem
 arrayValueConstructor = Group "array value constructor"
-    $ map (uncurry (TestScalarExpr ansi2011))
+    [e "array[1,2,3]"
-    [("array[1,2,3]"
+     $ Array (Iden [Name Nothing "array"])
-     ,Array (Iden [Name Nothing "array"])
+      [NumLit "1", NumLit "2", NumLit "3"]
-      [NumLit "1", NumLit "2", NumLit "3"])
+    ,e "array[a,b,c]"
-    ,("array[a,b,c]"
+     $ Array (Iden [Name Nothing "array"])
-     ,Array (Iden [Name Nothing "array"])
+      [Iden [Name Nothing "a"], Iden [Name Nothing "b"], Iden [Name Nothing "c"]]
-      [Iden [Name Nothing "a"], Iden [Name Nothing "b"], Iden [Name Nothing "c"]])
+    ,e "array(select * from t)"
-    ,("array(select * from t)"
+      $ ArrayCtor (toQueryExpr $ makeSelect
-      ,ArrayCtor (toQueryExpr $ makeSelect
                   {msSelectList = [(Star,Nothing)]
-                  ,msFrom = [TRSimple [Name Nothing "t"]]}))
+                  ,msFrom = [TRSimple [Name Nothing "t"]]})
-    ,("array(select * from t order by a)"
+    ,e "array(select * from t order by a)"
-      ,ArrayCtor (toQueryExpr $ makeSelect
+      $ ArrayCtor (toQueryExpr $ makeSelect
                   {msSelectList = [(Star,Nothing)]
                   ,msFrom = [TRSimple [Name Nothing "t"]]
                   ,msOrderBy = [SortSpec (Iden [Name Nothing "a"])
-                                    DirDefault NullsOrderDefault]}))
+                                    DirDefault NullsOrderDefault]})
     ]
 
 
@@ -2560,7 +2540,7 @@ Specify a multiset value.
 
 multisetScalarExpression :: TestItem
 multisetScalarExpression = Group "multiset value expression"
-   $ map (uncurry (TestScalarExpr ansi2011))
+   $ map (uncurry (testScalarExpr ansi2011))
    [("a multiset union b"
     ,MultisetBinOp (Iden [Name Nothing "a"]) Union SQDefault (Iden [Name Nothing "b"]))
    ,("a multiset union all b"
@@ -2592,7 +2572,7 @@ special case term.
 
 multisetValueFunction :: TestItem
 multisetValueFunction = Group "multiset value function"
-   $ map (uncurry (TestScalarExpr ansi2011))
+   $ map (uncurry (testScalarExpr ansi2011))
    [("set(a)", App [Name Nothing "set"] [Iden [Name Nothing "a"]])
    ]
 
@@ -2622,7 +2602,7 @@ Specify construction of a multiset.
 
 multisetValueConstructor :: TestItem
 multisetValueConstructor = Group "multiset value constructor"
-   $ map (uncurry (TestScalarExpr ansi2011))
+   $ map (uncurry (testScalarExpr ansi2011))
    [("multiset[a,b,c]", MultisetCtor[Iden [Name Nothing "a"]
                                     ,Iden [Name Nothing "b"], Iden [Name Nothing "c"]])
    ,("multiset(select * from t)", MultisetQueryCtor ms)
@@ -2702,7 +2682,7 @@ Specify a value or list of values to be constructed into a row.
 
 rowValueConstructor :: TestItem
 rowValueConstructor = Group "row value constructor"
-    $ map (uncurry (TestScalarExpr ansi2011))
+    $ map (uncurry (testScalarExpr ansi2011))
     [("(a,b)"
      ,SpecialOp [Name Nothing "rowctor"] [Iden [Name Nothing "a"], Iden [Name Nothing "b"]])
     ,("row(1)",App [Name Nothing "row"] [NumLit "1"])
@@ -2755,7 +2735,7 @@ Specify a set of <row value expression>s to be constructed into a table.
 
 tableValueConstructor :: TestItem
 tableValueConstructor = Group "table value constructor"
-    $ map (uncurry (TestQueryExpr ansi2011))
+    $ map (uncurry (testQueryExpr ansi2011))
     [("values (1,2), (a+b,(select count(*) from t));"
      ,Values [[NumLit "1", NumLit "2"]
              ,[BinOp (Iden [Name Nothing "a"]) [Name Nothing "+"]
@@ -2792,7 +2772,7 @@ Specify a table derived from one or more tables.
 
 fromClause :: TestItem
 fromClause = Group "fromClause"
-    $ map (uncurry (TestQueryExpr ansi2011))
+    $ map (uncurry (testQueryExpr ansi2011))
     [("select * from tbl1,tbl2"
      ,toQueryExpr $ makeSelect
       {msSelectList = [(Star, Nothing)]
@@ -2809,7 +2789,7 @@ Reference a table.
 
 tableReference :: TestItem
 tableReference = Group "table reference"
-    $ map (uncurry (TestQueryExpr ansi2011))
+    $ map (uncurry (testQueryExpr ansi2011))
     [("select * from t", toQueryExpr sel)
 
 {-
@@ -2994,7 +2974,7 @@ Specify a table derived from a Cartesian product, inner join, or outer join.
 
 joinedTable :: TestItem
 joinedTable = Group "joined table"
-    $ map (uncurry (TestQueryExpr ansi2011))
+    $ map (uncurry (testQueryExpr ansi2011))
     [("select * from a cross join b"
      ,sel $ TRJoin a False JCross b Nothing)
     ,("select * from a join b on true"
@@ -3053,7 +3033,7 @@ the result of the preceding <from clause>.
 
 whereClause :: TestItem
 whereClause = Group "where clause"
-    $ map (uncurry (TestQueryExpr ansi2011))
+    $ map (uncurry (testQueryExpr ansi2011))
     [("select * from t where a = 5"
     ,toQueryExpr $ makeSelect
      {msSelectList = [(Star,Nothing)]
@@ -3115,7 +3095,7 @@ clause> to the result of the previously specified clause.
 
 groupByClause :: TestItem
 groupByClause = Group "group by clause"
-    $ map (uncurry (TestQueryExpr ansi2011))
+    $ map (uncurry (testQueryExpr ansi2011))
     [("select a,sum(x) from t group by a"
      ,toQueryExpr $ ms [SimpleGroup $ Iden [Name Nothing "a"]])
      ,("select a,sum(x) from t group by a collate c"
@@ -3170,7 +3150,7 @@ not satisfy a <search condition>.
 
 havingClause :: TestItem
 havingClause = Group "having clause"
-    $ map (uncurry (TestQueryExpr ansi2011))
+    $ map (uncurry (testQueryExpr ansi2011))
     [("select a,sum(x) from t group by a having sum(x) > 1000"
      ,toQueryExpr $ makeSelect
       {msSelectList = [(Iden [Name Nothing "a"], Nothing)
@@ -3297,7 +3277,7 @@ Specify a table derived from the result of a <table expression>.
 
 querySpecification :: TestItem
 querySpecification = Group "query specification"
-    $ map (uncurry (TestQueryExpr ansi2011))
+    $ map (uncurry (testQueryExpr ansi2011))
     [("select a from t",toQueryExpr ms)
     ,("select all a from t",toQueryExpr $ ms {msSetQuantifier = All})
     ,("select distinct a from t",toQueryExpr $ ms {msSetQuantifier = Distinct})
@@ -3369,7 +3349,7 @@ withQueryExpression= Group "with query expression"
 
 setOpQueryExpression :: TestItem
 setOpQueryExpression= Group "set operation query expression"
-    $ map (uncurry (TestQueryExpr ansi2011))
+    $ map (uncurry (testQueryExpr ansi2011))
     -- todo: complete setop query expression tests
     [{-("select * from t union select * from t"
      ,undefined)
@@ -3408,7 +3388,7 @@ everywhere
 
 explicitTableQueryExpression :: TestItem
 explicitTableQueryExpression= Group "explicit table query expression"
-    $ map (uncurry (TestQueryExpr ansi2011))
+    $ map (uncurry (testQueryExpr ansi2011))
     [("table t", Table [Name Nothing "t"])
     ]
 
@@ -3432,7 +3412,7 @@ explicitTableQueryExpression= Group "explicit table query expression"
 
 orderOffsetFetchQueryExpression :: TestItem
 orderOffsetFetchQueryExpression = Group "order, offset, fetch query expression"
-    $ map (uncurry (TestQueryExpr ansi2011))
+    $ map (uncurry (testQueryExpr ansi2011))
     [-- todo: finish tests for order offset and fetch
      ("select a from t order by a"
      ,toQueryExpr $ ms {msOrderBy = [SortSpec (Iden [Name Nothing "a"])
@@ -3597,7 +3577,7 @@ Specify a comparison of two row values.
 
 comparisonPredicates :: TestItem
 comparisonPredicates = Group "comparison predicates"
-    $ map (uncurry (TestScalarExpr ansi2011))
+    $ map (uncurry (testScalarExpr ansi2011))
     $ map mkOp ["=", "<>", "<", ">", "<=", ">="]
     <> [("ROW(a) = ROW(b)"
         ,BinOp (App [Name Nothing "ROW"] [a])
@@ -3815,7 +3795,7 @@ Specify a quantified comparison.
 
 quantifiedComparisonPredicate :: TestItem
 quantifiedComparisonPredicate = Group "quantified comparison predicate"
-    $ map (uncurry (TestScalarExpr ansi2011))
+    $ map (uncurry (testScalarExpr ansi2011))
 
     [("a = any (select * from t)"
      ,QuantifiedComparison (Iden [Name Nothing "a"]) [Name Nothing "="] CPAny ms)
@@ -3844,7 +3824,7 @@ Specify a test for a non-empty set.
 
 existsPredicate :: TestItem
 existsPredicate = Group "exists predicate"
-    $ map (uncurry (TestScalarExpr ansi2011))
+    $ map (uncurry (testScalarExpr ansi2011))
     [("exists(select * from t where a = 4)"
      ,SubQueryExpr SqExists
       $ toQueryExpr $ makeSelect
@@ -3865,7 +3845,7 @@ Specify a test for the absence of duplicate rows.
 
 uniquePredicate :: TestItem
 uniquePredicate = Group "unique predicate"
-    $ map (uncurry (TestScalarExpr ansi2011))
+    $ map (uncurry (testScalarExpr ansi2011))
     [("unique(select * from t where a = 4)"
      ,SubQueryExpr SqUnique
       $ toQueryExpr $ makeSelect
@@ -3905,7 +3885,7 @@ Specify a test for matching rows.
 
 matchPredicate :: TestItem
 matchPredicate = Group "match predicate"
-    $ map (uncurry (TestScalarExpr ansi2011))
+    $ map (uncurry (testScalarExpr ansi2011))
     [("a match (select a from t)"
      ,Match (Iden [Name Nothing "a"]) False $ toQueryExpr ms)
     ,("(a,b) match (select a,b from t)"
@@ -4273,7 +4253,7 @@ Specify a default collation.
 
 collateClause :: TestItem
 collateClause = Group "collate clause"
-    $ map (uncurry (TestScalarExpr ansi2011))
+    $ map (uncurry (testScalarExpr ansi2011))
     [("a collate my_collation"
      ,Collate (Iden [Name Nothing "a"]) [Name Nothing "my_collation"])]
 
@@ -4386,7 +4366,7 @@ Specify a value computed from a collection of rows.
 
 aggregateFunction :: TestItem
 aggregateFunction = Group "aggregate function"
-    $ map (uncurry (TestScalarExpr ansi2011)) $
+    $ map (uncurry (testScalarExpr ansi2011)) $
     [("count(*)",App [Name Nothing "count"] [Star])
     ,("count(*) filter (where something > 5)"
      ,AggregateApp [Name Nothing "count"] SQDefault [Star] [] fil)
@@ -4483,7 +4463,7 @@ Specify a sort order.
 
 sortSpecificationList :: TestItem
 sortSpecificationList = Group "sort specification list"
-    $ map (uncurry (TestQueryExpr ansi2011))
+    $ map (uncurry (testQueryExpr ansi2011))
     [("select * from t order by a"
      ,toQueryExpr $ ms {msOrderBy = [SortSpec (Iden [Name Nothing "a"])
                            DirDefault NullsOrderDefault]})
@@ -4518,3 +4498,10 @@ sortSpecificationList = Group "sort specification list"
     ms = makeSelect
          {msSelectList = [(Star,Nothing)]
          ,msFrom = [TRSimple [Name Nothing "t"]]}
+
+
+q :: HasCallStack => Text -> QueryExpr -> TestItem
+q src ast = testQueryExpr ansi2011 src ast
+
+e :: HasCallStack => Text -> ScalarExpr -> TestItem
+e src ast = testScalarExpr ansi2011 src ast

tests/Language/SQL/SimpleSQL/SQL2011Schema.hs

@@ -10,6 +10,8 @@ module Language.SQL.SimpleSQL.SQL2011Schema (sql2011SchemaTests) where
 
 import Language.SQL.SimpleSQL.TestTypes
 import Language.SQL.SimpleSQL.Syntax
+import Language.SQL.SimpleSQL.TestRunners
+import Data.Text (Text)
 
 sql2011SchemaTests :: TestItem
 sql2011SchemaTests = Group "sql 2011 schema tests"
@@ -25,8 +27,8 @@ sql2011SchemaTests = Group "sql 2011 schema tests"
       [ <schema element>... ]
 -}
 
-     (TestStatement ansi2011 "create schema my_schema"
+     s "create schema my_schema"
-     $ CreateSchema [Name Nothing "my_schema"])
+     $ CreateSchema [Name Nothing "my_schema"]
 
 {-
 todo: schema name can have .
@@ -86,12 +88,12 @@ add schema element support:
 -}
 
 
-    ,(TestStatement ansi2011 "drop schema my_schema"
+    ,s "drop schema my_schema"
-     $ DropSchema [Name Nothing "my_schema"] DefaultDropBehaviour)
+     $ DropSchema [Name Nothing "my_schema"] DefaultDropBehaviour
-    ,(TestStatement ansi2011 "drop schema my_schema cascade"
+    ,s "drop schema my_schema cascade"
-     $ DropSchema [Name Nothing "my_schema"] Cascade)
+     $ DropSchema [Name Nothing "my_schema"] Cascade
-    ,(TestStatement ansi2011 "drop schema my_schema restrict"
+    ,s "drop schema my_schema restrict"
-     $ DropSchema [Name Nothing "my_schema"] Restrict)
+     $ DropSchema [Name Nothing "my_schema"] Restrict
 
 {-
 11.3 <table definition>
@@ -103,10 +105,10 @@ add schema element support:
       [ ON COMMIT <table commit action> ROWS ]
 -}
 
-    ,(TestStatement ansi2011 "create table t (a int, b int);"
+    ,s "create table t (a int, b int);"
      $ CreateTable [Name Nothing "t"]
        [TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing []
-       ,TableColumnDef $ ColumnDef (Name Nothing "b") (TypeName [Name Nothing "int"]) Nothing []])
+       ,TableColumnDef $ ColumnDef (Name Nothing "b") (TypeName [Name Nothing "int"]) Nothing []]
 
 
 {-
@@ -321,35 +323,35 @@ todo: constraint characteristics
 -}
 
 
-    ,(TestStatement ansi2011
+    ,s
       "create table t (a int not null);"
      $ CreateTable [Name Nothing "t"]
        [TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing
-        [ColConstraintDef Nothing ColNotNullConstraint]])
+        [ColConstraintDef Nothing ColNotNullConstraint]]
 
-    ,(TestStatement ansi2011
+    ,s
       "create table t (a int constraint a_not_null not null);"
      $ CreateTable [Name Nothing "t"]
        [TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing
-        [ColConstraintDef (Just [Name Nothing "a_not_null"]) ColNotNullConstraint]])
+        [ColConstraintDef (Just [Name Nothing "a_not_null"]) ColNotNullConstraint]]
 
-    ,(TestStatement ansi2011
+    ,s
       "create table t (a int unique);"
      $ CreateTable [Name Nothing "t"]
        [TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing
-        [ColConstraintDef Nothing ColUniqueConstraint]])
+        [ColConstraintDef Nothing ColUniqueConstraint]]
 
-    ,(TestStatement ansi2011
+    ,s
       "create table t (a int primary key);"
      $ CreateTable [Name Nothing "t"]
        [TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing
-        [ColConstraintDef Nothing (ColPrimaryKeyConstraint False)]])
+        [ColConstraintDef Nothing (ColPrimaryKeyConstraint False)]]
 
-    ,(TestStatement ansi2011 { diAutoincrement = True }
+    ,testStatement ansi2011{ diAutoincrement = True }
       "create table t (a int primary key autoincrement);"
      $ CreateTable [Name Nothing "t"]
        [TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing
-        [ColConstraintDef Nothing (ColPrimaryKeyConstraint True)]])
+        [ColConstraintDef Nothing (ColPrimaryKeyConstraint True)]]
 
 {-
 references t(a,b)
@@ -358,102 +360,102 @@ references t(a,b)
          on delete ""
 -}
 
-    ,(TestStatement ansi2011
+    ,s
       "create table t (a int references u);"
      $ CreateTable [Name Nothing "t"]
        [TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing
         [ColConstraintDef Nothing $ ColReferencesConstraint
          [Name Nothing "u"] Nothing DefaultReferenceMatch
-         DefaultReferentialAction DefaultReferentialAction]])
+         DefaultReferentialAction DefaultReferentialAction]]
 
-    ,(TestStatement ansi2011
+    ,s
       "create table t (a int references u(a));"
      $ CreateTable [Name Nothing "t"]
        [TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing
         [ColConstraintDef Nothing $ ColReferencesConstraint
          [Name Nothing "u"] (Just $ Name Nothing "a") DefaultReferenceMatch
-         DefaultReferentialAction DefaultReferentialAction]])
+         DefaultReferentialAction DefaultReferentialAction]]
 
-    ,(TestStatement ansi2011
+    ,s
       "create table t (a int references u match full);"
      $ CreateTable [Name Nothing "t"]
        [TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing
         [ColConstraintDef Nothing $ ColReferencesConstraint
          [Name Nothing "u"] Nothing MatchFull
-         DefaultReferentialAction DefaultReferentialAction]])
+         DefaultReferentialAction DefaultReferentialAction]]
 
-    ,(TestStatement ansi2011
+    ,s
       "create table t (a int references u match partial);"
      $ CreateTable [Name Nothing "t"]
        [TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing
         [ColConstraintDef Nothing $ ColReferencesConstraint
          [Name Nothing "u"] Nothing MatchPartial
-         DefaultReferentialAction DefaultReferentialAction]])
+         DefaultReferentialAction DefaultReferentialAction]]
 
-    ,(TestStatement ansi2011
+    ,s
       "create table t (a int references u match simple);"
      $ CreateTable [Name Nothing "t"]
        [TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing
         [ColConstraintDef Nothing $ ColReferencesConstraint
          [Name Nothing "u"] Nothing MatchSimple
-         DefaultReferentialAction DefaultReferentialAction]])
+         DefaultReferentialAction DefaultReferentialAction]]
 
-    ,(TestStatement ansi2011
+    ,s
       "create table t (a int references u on update cascade );"
      $ CreateTable [Name Nothing "t"]
        [TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing
         [ColConstraintDef Nothing $ ColReferencesConstraint
          [Name Nothing "u"] Nothing DefaultReferenceMatch
-         RefCascade DefaultReferentialAction]])
+         RefCascade DefaultReferentialAction]]
 
-    ,(TestStatement ansi2011
+    ,s
       "create table t (a int references u on update set null );"
      $ CreateTable [Name Nothing "t"]
        [TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing
         [ColConstraintDef Nothing $ ColReferencesConstraint
          [Name Nothing "u"] Nothing DefaultReferenceMatch
-         RefSetNull DefaultReferentialAction]])
+         RefSetNull DefaultReferentialAction]]
 
-    ,(TestStatement ansi2011
+    ,s
       "create table t (a int references u on update set default );"
      $ CreateTable [Name Nothing "t"]
        [TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing
         [ColConstraintDef Nothing $ ColReferencesConstraint
          [Name Nothing "u"] Nothing DefaultReferenceMatch
-         RefSetDefault DefaultReferentialAction]])
+         RefSetDefault DefaultReferentialAction]]
 
-    ,(TestStatement ansi2011
+    ,s
       "create table t (a int references u on update no action );"
      $ CreateTable [Name Nothing "t"]
        [TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing
         [ColConstraintDef Nothing $ ColReferencesConstraint
          [Name Nothing "u"] Nothing DefaultReferenceMatch
-         RefNoAction DefaultReferentialAction]])
+         RefNoAction DefaultReferentialAction]]
 
-    ,(TestStatement ansi2011
+    ,s
       "create table t (a int references u on delete cascade );"
      $ CreateTable [Name Nothing "t"]
        [TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing
         [ColConstraintDef Nothing $ ColReferencesConstraint
          [Name Nothing "u"] Nothing DefaultReferenceMatch
-         DefaultReferentialAction RefCascade]])
+         DefaultReferentialAction RefCascade]]
 
 
-    ,(TestStatement ansi2011
+    ,s
       "create table t (a int references u on update cascade on delete restrict );"
      $ CreateTable [Name Nothing "t"]
        [TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing
         [ColConstraintDef Nothing $ ColReferencesConstraint
          [Name Nothing "u"] Nothing DefaultReferenceMatch
-         RefCascade RefRestrict]])
+         RefCascade RefRestrict]]
 
-    ,(TestStatement ansi2011
+    ,s
       "create table t (a int references u on delete restrict on update cascade );"
      $ CreateTable [Name Nothing "t"]
        [TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing
         [ColConstraintDef Nothing $ ColReferencesConstraint
          [Name Nothing "u"] Nothing DefaultReferenceMatch
-         RefCascade RefRestrict]])
+         RefCascade RefRestrict]]
 
 {-
 TODO: try combinations and permutations of column constraints and
@@ -461,12 +463,12 @@ options
 -}
 
 
-    ,(TestStatement ansi2011
+    ,s
       "create table t (a int check (a>5));"
      $ CreateTable [Name Nothing "t"]
        [TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing
         [ColConstraintDef Nothing
-         (ColCheckConstraint $ BinOp (Iden [Name Nothing "a"]) [Name Nothing ">"] (NumLit "5"))]])
+         (ColCheckConstraint $ BinOp (Iden [Name Nothing "a"]) [Name Nothing ">"] (NumLit "5"))]]
 
 
 
@@ -478,18 +480,18 @@ options
       [ <left paren> <common sequence generator options> <right paren> ]
 -}
 
-    ,(TestStatement ansi2011 "create table t (a int generated always as identity);"
+    ,s "create table t (a int generated always as identity);"
      $ CreateTable [Name Nothing "t"]
        [TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"])
-        (Just $ IdentityColumnSpec GeneratedAlways []) []])
+        (Just $ IdentityColumnSpec GeneratedAlways []) []]
 
-    ,(TestStatement ansi2011 "create table t (a int generated by default as identity);"
+    ,s "create table t (a int generated by default as identity);"
      $ CreateTable [Name Nothing "t"]
        [TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"])
-        (Just $ IdentityColumnSpec GeneratedByDefault []) []])
+        (Just $ IdentityColumnSpec GeneratedByDefault []) []]
 
 
-    ,(TestStatement ansi2011
+    ,s
       "create table t (a int generated always as identity\n\
       \  ( start with 5 increment by 5 maxvalue 500 minvalue 5 cycle ));"
      $ CreateTable [Name Nothing "t"]
@@ -499,9 +501,9 @@ options
          ,SGOIncrementBy 5
          ,SGOMaxValue 500
          ,SGOMinValue 5
-         ,SGOCycle]) []])
+         ,SGOCycle]) []]
 
-    ,(TestStatement ansi2011
+    ,s
       "create table t (a int generated always as identity\n\
       \  ( start with -4 no maxvalue no minvalue no cycle ));"
      $ CreateTable [Name Nothing "t"]
@@ -510,7 +512,7 @@ options
          [SGOStartWith (-4)
          ,SGONoMaxValue
          ,SGONoMinValue
-         ,SGONoCycle]) []])
+         ,SGONoCycle]) []]
 
 {-
 I think <common sequence generator options> is supposed to just
@@ -531,14 +533,14 @@ generated always (valueexpr)
   <left paren> <value expression> <right paren>
 -}
 
-    ,(TestStatement ansi2011
+    ,s
       "create table t (a int, \n\
       \                a2 int generated always as (a * 2));"
      $ CreateTable [Name Nothing "t"]
        [TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing []
        ,TableColumnDef $ ColumnDef (Name Nothing "a2") (TypeName [Name Nothing "int"])
         (Just $ GenerationClause
-         (BinOp (Iden [Name Nothing "a"]) [Name Nothing "*"] (NumLit "2"))) []])
+         (BinOp (Iden [Name Nothing "a"]) [Name Nothing "*"] (NumLit "2"))) []]
 
 
 
@@ -563,10 +565,10 @@ generated always (valueexpr)
 -}
 
 
-    ,(TestStatement ansi2011 "create table t (a int default 0);"
+    ,s "create table t (a int default 0);"
      $ CreateTable [Name Nothing "t"]
        [TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"])
-        (Just $ DefaultClause $ NumLit "0") []])
+        (Just $ DefaultClause $ NumLit "0") []]
 
 
 
@@ -597,40 +599,40 @@ generated always (valueexpr)
   <column name list>
 -}
 
-    ,(TestStatement ansi2011
+    ,s
       "create table t (a int, unique (a));"
      $ CreateTable [Name Nothing "t"]
        [TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing []
        ,TableConstraintDef Nothing $ TableUniqueConstraint [Name Nothing "a"]
-        ])
+        ]
 
-    ,(TestStatement ansi2011
+    ,s
       "create table t (a int, constraint a_unique unique (a));"
      $ CreateTable [Name Nothing "t"]
        [TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing []
        ,TableConstraintDef (Just [Name Nothing "a_unique"]) $
             TableUniqueConstraint [Name Nothing "a"]
-        ])
+        ]
 
 -- todo: test permutations of column defs and table constraints
 
-    ,(TestStatement ansi2011
+    ,s
       "create table t (a int, b int, unique (a,b));"
      $ CreateTable [Name Nothing "t"]
        [TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing []
        ,TableColumnDef $ ColumnDef (Name Nothing "b") (TypeName [Name Nothing "int"]) Nothing []
        ,TableConstraintDef Nothing $
             TableUniqueConstraint [Name Nothing "a", Name Nothing "b"]
-        ])
+        ]
 
-    ,(TestStatement ansi2011
+    ,s
       "create table t (a int, b int, primary key (a,b));"
      $ CreateTable [Name Nothing "t"]
        [TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing []
        ,TableColumnDef $ ColumnDef (Name Nothing "b") (TypeName [Name Nothing "int"]) Nothing []
        ,TableConstraintDef Nothing $
             TablePrimaryKeyConstraint [Name Nothing "a", Name Nothing "b"]
-        ])
+        ]
 
 
 {-
@@ -649,7 +651,7 @@ defintely skip
 -}
 
 
-    ,(TestStatement ansi2011
+    ,s
       "create table t (a int, b int,\n\
       \                foreign key (a,b) references u(c,d) match full on update cascade on delete restrict );"
      $ CreateTable [Name Nothing "t"]
@@ -661,9 +663,9 @@ defintely skip
                 [Name Nothing "u"]
                 (Just [Name Nothing "c", Name Nothing "d"])
                 MatchFull RefCascade RefRestrict
-       ])
+       ]
 
-    ,(TestStatement ansi2011
+    ,s
       "create table t (a int,\n\
       \                constraint tfku1 foreign key (a) references u);"
      $ CreateTable [Name Nothing "t"]
@@ -674,9 +676,9 @@ defintely skip
                 [Name Nothing "u"]
                 Nothing DefaultReferenceMatch
                 DefaultReferentialAction DefaultReferentialAction
-       ])
+       ]
 
-    ,(TestStatement ansi2011 { diNonCommaSeparatedConstraints = True }
+    ,testStatement ansi2011{ diNonCommaSeparatedConstraints = True }
       "create table t (a int, b int,\n\
       \                foreign key (a) references u(c)\n\
       \                foreign key (b) references v(d));"
@@ -697,7 +699,7 @@ defintely skip
                 (Just [Name Nothing "d"])
                 DefaultReferenceMatch
                 DefaultReferentialAction DefaultReferentialAction
-       ])
+       ]
 
 
 {-
@@ -755,7 +757,7 @@ defintely skip
      CHECK <left paren> <search condition> <right paren>
 -}
 
-    ,(TestStatement ansi2011
+    ,s
       "create table t (a int, b int, \n\
       \                check (a > b));"
      $ CreateTable [Name Nothing "t"]
@@ -764,10 +766,10 @@ defintely skip
        ,TableConstraintDef Nothing $
             TableCheckConstraint
             (BinOp (Iden [Name Nothing "a"]) [Name Nothing ">"] (Iden [Name Nothing "b"]))
-       ])
+       ]
 
 
-    ,(TestStatement ansi2011
+    ,s
       "create table t (a int, b int, \n\
       \                constraint agtb check (a > b));"
      $ CreateTable [Name Nothing "t"]
@@ -776,7 +778,7 @@ defintely skip
        ,TableConstraintDef (Just [Name Nothing "agtb"]) $
             TableCheckConstraint
             (BinOp (Iden [Name Nothing "a"]) [Name Nothing ">"] (Iden [Name Nothing "b"]))
-       ])
+       ]
 
 
 {-
@@ -810,11 +812,10 @@ alter table t add a int
 alter table t add a int unique not null check (a>0)
 -}
 
-    ,(TestStatement ansi2011
+    ,s
       "alter table t add column a int"
      $ AlterTable [Name Nothing "t"] $ AddColumnDef
        $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing []
-       )
 
 {-
 todo: more add column
@@ -844,10 +845,10 @@ todo: more add column
 -}
 
 
-    ,(TestStatement ansi2011
+    ,s
       "alter table t alter column c set default 0"
      $ AlterTable [Name Nothing "t"] $ AlterColumnSetDefault (Name Nothing "c")
-       $ NumLit "0")
+       $ NumLit "0"
 
 {-
 11.14 <drop column default clause>
@@ -856,9 +857,9 @@ todo: more add column
   DROP DEFAULT
 -}
 
-    ,(TestStatement ansi2011
+    ,s
       "alter table t alter column c drop default"
-     $ AlterTable [Name Nothing "t"] $ AlterColumnDropDefault (Name Nothing "c"))
+     $ AlterTable [Name Nothing "t"] $ AlterColumnDropDefault (Name Nothing "c")
 
 
 {-
@@ -868,9 +869,9 @@ todo: more add column
   SET NOT NULL
 -}
 
-    ,(TestStatement ansi2011
+    ,s
       "alter table t alter column c set not null"
-     $ AlterTable [Name Nothing "t"] $ AlterColumnSetNotNull (Name Nothing "c"))
+     $ AlterTable [Name Nothing "t"] $ AlterColumnSetNotNull (Name Nothing "c")
 
 {-
 11.16 <drop column not null clause>
@@ -879,9 +880,9 @@ todo: more add column
   DROP NOT NULL
 -}
 
-    ,(TestStatement ansi2011
+    ,s
       "alter table t alter column c drop not null"
-     $ AlterTable [Name Nothing "t"] $ AlterColumnDropNotNull (Name Nothing "c"))
+     $ AlterTable [Name Nothing "t"] $ AlterColumnDropNotNull (Name Nothing "c")
 
 {-
 11.17 <add column scope clause>
@@ -900,10 +901,10 @@ todo: more add column
   SET DATA TYPE <data type>
 -}
 
-    ,(TestStatement ansi2011
+    ,s
       "alter table t alter column c set data type int;"
      $ AlterTable [Name Nothing "t"] $
-       AlterColumnSetDataType (Name Nothing "c") (TypeName [Name Nothing "int"]))
+       AlterColumnSetDataType (Name Nothing "c") (TypeName [Name Nothing "int"])
 
 
 
@@ -1001,20 +1002,20 @@ included in the generated plan above
   DROP [ COLUMN ] <column name> <drop behavior>
 -}
 
-    ,(TestStatement ansi2011
+    ,s
       "alter table t drop column c"
      $ AlterTable [Name Nothing "t"] $
-       DropColumn (Name Nothing "c") DefaultDropBehaviour)
+       DropColumn (Name Nothing "c") DefaultDropBehaviour
 
-    ,(TestStatement ansi2011
+    ,s
       "alter table t drop c cascade"
      $ AlterTable [Name Nothing "t"] $
-       DropColumn (Name Nothing "c") Cascade)
+       DropColumn (Name Nothing "c") Cascade
 
-    ,(TestStatement ansi2011
+    ,s
       "alter table t drop c restrict"
      $ AlterTable [Name Nothing "t"] $
-       DropColumn (Name Nothing "c") Restrict)
+       DropColumn (Name Nothing "c") Restrict
 
 
 
@@ -1025,17 +1026,17 @@ included in the generated plan above
   ADD <table constraint definition>
 -}
 
-    ,(TestStatement ansi2011
+    ,s
       "alter table t add constraint c unique (a,b)"
      $ AlterTable [Name Nothing "t"] $
        AddTableConstraintDef (Just [Name Nothing "c"])
-            $ TableUniqueConstraint [Name Nothing "a", Name Nothing "b"])
+            $ TableUniqueConstraint [Name Nothing "a", Name Nothing "b"]
 
-    ,(TestStatement ansi2011
+    ,s
       "alter table t add unique (a,b)"
      $ AlterTable [Name Nothing "t"] $
        AddTableConstraintDef Nothing
-            $ TableUniqueConstraint [Name Nothing "a", Name Nothing "b"])
+            $ TableUniqueConstraint [Name Nothing "a", Name Nothing "b"]
 
 
 {-
@@ -1051,15 +1052,15 @@ todo
   DROP CONSTRAINT <constraint name> <drop behavior>
 -}
 
-    ,(TestStatement ansi2011
+    ,s
       "alter table t drop constraint c"
      $ AlterTable [Name Nothing "t"] $
-       DropTableConstraintDef [Name Nothing "c"] DefaultDropBehaviour)
+       DropTableConstraintDef [Name Nothing "c"] DefaultDropBehaviour
 
-    ,(TestStatement ansi2011
+    ,s
       "alter table t drop constraint c restrict"
      $ AlterTable [Name Nothing "t"] $
-       DropTableConstraintDef [Name Nothing "c"] Restrict)
+       DropTableConstraintDef [Name Nothing "c"] Restrict
 
 {-
 11.27 <add table period definition>
@@ -1111,13 +1112,13 @@ defintely skip
   DROP TABLE <table name> <drop behavior>
 -}
 
-    ,(TestStatement ansi2011
+    ,s
       "drop table t"
-     $ DropTable [Name Nothing "t"] DefaultDropBehaviour)
+     $ DropTable [Name Nothing "t"] DefaultDropBehaviour
 
-    ,(TestStatement ansi2011
+    ,s
       "drop table t restrict"
-     $ DropTable [Name Nothing "t"] Restrict)
+     $ DropTable [Name Nothing "t"] Restrict
 
 
 {-
@@ -1159,51 +1160,51 @@ defintely skip
   <column name list>
 -}
 
-    ,(TestStatement ansi2011
+    ,s
       "create view v as select * from t"
      $ CreateView False [Name Nothing "v"] Nothing (toQueryExpr $ makeSelect
          {msSelectList = [(Star, Nothing)]
          ,msFrom = [TRSimple [Name Nothing "t"]]
-         }) Nothing)
+         }) Nothing
 
 
-    ,(TestStatement ansi2011
+    ,s
       "create recursive view v as select * from t"
      $ CreateView True [Name Nothing "v"] Nothing (toQueryExpr $ makeSelect
          {msSelectList = [(Star, Nothing)]
          ,msFrom = [TRSimple [Name Nothing "t"]]
-         }) Nothing)
+         }) Nothing
 
-    ,(TestStatement ansi2011
+    ,s
       "create view v(a,b) as select * from t"
      $ CreateView False [Name Nothing "v"] (Just [Name Nothing "a", Name Nothing "b"])
          (toQueryExpr $ makeSelect
          {msSelectList = [(Star, Nothing)]
          ,msFrom = [TRSimple [Name Nothing "t"]]
-         }) Nothing)
+         }) Nothing
 
 
-    ,(TestStatement ansi2011
+    ,s
       "create view v as select * from t with check option"
      $ CreateView False [Name Nothing "v"] Nothing (toQueryExpr $ makeSelect
          {msSelectList = [(Star, Nothing)]
          ,msFrom = [TRSimple [Name Nothing "t"]]
-         }) (Just DefaultCheckOption))
+         }) (Just DefaultCheckOption)
 
-    ,(TestStatement ansi2011
+    ,s
       "create view v as select * from t with cascaded check option"
      $ CreateView False [Name Nothing "v"] Nothing (toQueryExpr $ makeSelect
          {msSelectList = [(Star, Nothing)]
          ,msFrom = [TRSimple [Name Nothing "t"]]
-         }) (Just CascadedCheckOption))
+         }) (Just CascadedCheckOption)
 
-    ,(TestStatement ansi2011
+    ,s
       "create view v as select * from t with local check option"
      $ CreateView False [Name Nothing "v"] Nothing
          (toQueryExpr $ makeSelect
          {msSelectList = [(Star, Nothing)]
          ,msFrom = [TRSimple [Name Nothing "t"]]
-         }) (Just LocalCheckOption))
+         }) (Just LocalCheckOption)
 
 
 {-
@@ -1214,13 +1215,13 @@ defintely skip
 -}
 
 
-    ,(TestStatement ansi2011
+    ,s
       "drop view v"
-     $ DropView [Name Nothing "v"] DefaultDropBehaviour)
+     $ DropView [Name Nothing "v"] DefaultDropBehaviour
 
-    ,(TestStatement ansi2011
+    ,s
       "drop view v cascade"
-     $ DropView [Name Nothing "v"] Cascade)
+     $ DropView [Name Nothing "v"] Cascade
 
 
 {-
@@ -1237,37 +1238,37 @@ defintely skip
       <constraint characteristics> ]
 -}
 
-    ,(TestStatement ansi2011
+    ,s
       "create domain my_int int"
      $ CreateDomain [Name Nothing "my_int"]
           (TypeName [Name Nothing "int"])
-          Nothing [])
+          Nothing []
 
-    ,(TestStatement ansi2011
+    ,s
       "create domain my_int as int"
      $ CreateDomain [Name Nothing "my_int"]
           (TypeName [Name Nothing "int"])
-          Nothing [])
+          Nothing []
 
-    ,(TestStatement ansi2011
+    ,s
       "create domain my_int int default 0"
      $ CreateDomain [Name Nothing "my_int"]
           (TypeName [Name Nothing "int"])
-          (Just (NumLit "0")) [])
+          (Just (NumLit "0")) []
 
-    ,(TestStatement ansi2011
+    ,s
       "create domain my_int int check (value > 5)"
      $ CreateDomain [Name Nothing "my_int"]
           (TypeName [Name Nothing "int"])
           Nothing [(Nothing
-                   ,BinOp (Iden [Name Nothing "value"]) [Name Nothing ">"] (NumLit "5"))])
+                   ,BinOp (Iden [Name Nothing "value"]) [Name Nothing ">"] (NumLit "5"))]
 
-    ,(TestStatement ansi2011
+    ,s
       "create domain my_int int constraint gt5 check (value > 5)"
      $ CreateDomain [Name Nothing "my_int"]
           (TypeName [Name Nothing "int"])
           Nothing [(Just [Name Nothing "gt5"]
-                   ,BinOp (Iden [Name Nothing "value"]) [Name Nothing ">"] (NumLit "5"))])
+                   ,BinOp (Iden [Name Nothing "value"]) [Name Nothing ">"] (NumLit "5"))]
 
 
 
@@ -1289,10 +1290,10 @@ defintely skip
   SET <default clause>
 -}
 
-    ,(TestStatement ansi2011
+    ,s
       "alter domain my_int set default 0"
      $ AlterDomain [Name Nothing "my_int"]
-       $ ADSetDefault $ NumLit "0")
+       $ ADSetDefault $ NumLit "0"
 
 
 {-
@@ -1302,10 +1303,10 @@ defintely skip
   DROP DEFAULT
 -}
 
-    ,(TestStatement ansi2011
+    ,s
       "alter domain my_int drop default"
      $ AlterDomain [Name Nothing "my_int"]
-       $ ADDropDefault)
+       $ ADDropDefault
 
 
 {-
@@ -1315,17 +1316,17 @@ defintely skip
   ADD <domain constraint>
 -}
 
-    ,(TestStatement ansi2011
+    ,s
       "alter domain my_int add check (value > 6)"
      $ AlterDomain [Name Nothing "my_int"]
        $ ADAddConstraint Nothing
-         $ BinOp (Iden [Name Nothing "value"]) [Name Nothing ">"] (NumLit "6"))
+         $ BinOp (Iden [Name Nothing "value"]) [Name Nothing ">"] (NumLit "6")
 
-    ,(TestStatement ansi2011
+    ,s
       "alter domain my_int add constraint gt6 check (value > 6)"
      $ AlterDomain [Name Nothing "my_int"]
        $ ADAddConstraint (Just [Name Nothing "gt6"])
-         $ BinOp (Iden [Name Nothing "value"]) [Name Nothing ">"] (NumLit "6"))
+         $ BinOp (Iden [Name Nothing "value"]) [Name Nothing ">"] (NumLit "6")
 
 
 {-
@@ -1335,10 +1336,10 @@ defintely skip
   DROP CONSTRAINT <constraint name>
 -}
 
-    ,(TestStatement ansi2011
+    ,s
       "alter domain my_int drop constraint gt6"
      $ AlterDomain [Name Nothing "my_int"]
-       $ ADDropConstraint [Name Nothing "gt6"])
+       $ ADDropConstraint [Name Nothing "gt6"]
 
 {-
 11.40 <drop domain statement>
@@ -1347,13 +1348,13 @@ defintely skip
   DROP DOMAIN <domain name> <drop behavior>
 -}
 
-    ,(TestStatement ansi2011
+    ,s
       "drop domain my_int"
-     $ DropDomain [Name Nothing "my_int"] DefaultDropBehaviour)
+     $ DropDomain [Name Nothing "my_int"] DefaultDropBehaviour
 
-    ,(TestStatement ansi2011
+    ,s
       "drop domain my_int cascade"
-     $ DropDomain [Name Nothing "my_int"] Cascade)
+     $ DropDomain [Name Nothing "my_int"] Cascade
 
 
 
@@ -1425,7 +1426,7 @@ defintely skip
          [ <constraint characteristics> ]
 -}
 
-    ,(TestStatement ansi2011
+    ,s
       "create assertion t1_not_empty CHECK ((select count(*) from t1) > 0);"
      $ CreateAssertion [Name Nothing "t1_not_empty"]
         $ BinOp (SubQueryExpr SqSq $
@@ -1433,7 +1434,7 @@ defintely skip
                  {msSelectList = [(App [Name Nothing "count"] [Star],Nothing)]
                  ,msFrom = [TRSimple [Name Nothing "t1"]]
                  })
-                [Name Nothing ">"] (NumLit "0"))
+                [Name Nothing ">"] (NumLit "0")
 
 {-
 11.48 <drop assertion statement>
@@ -1442,13 +1443,13 @@ defintely skip
   DROP ASSERTION <constraint name> [ <drop behavior> ]
 -}
 
-    ,(TestStatement ansi2011
+    ,s
       "drop assertion t1_not_empty;"
-     $ DropAssertion [Name Nothing "t1_not_empty"] DefaultDropBehaviour)
+     $ DropAssertion [Name Nothing "t1_not_empty"] DefaultDropBehaviour
 
-    ,(TestStatement ansi2011
+    ,s
       "drop assertion t1_not_empty cascade;"
-     $ DropAssertion [Name Nothing "t1_not_empty"] Cascade)
+     $ DropAssertion [Name Nothing "t1_not_empty"] Cascade
 
 
 {-
@@ -2085,21 +2086,21 @@ defintely skip
   | NO CYCLE
 -}
 
-    ,(TestStatement ansi2011
+    ,s
       "create sequence seq"
-     $ CreateSequence [Name Nothing "seq"] [])
+     $ CreateSequence [Name Nothing "seq"] []
 
-    ,(TestStatement ansi2011
+    ,s
       "create sequence seq as bigint"
      $ CreateSequence [Name Nothing "seq"]
-        [SGODataType $ TypeName [Name Nothing "bigint"]])
+        [SGODataType $ TypeName [Name Nothing "bigint"]]
 
-    ,(TestStatement ansi2011
+    ,s
       "create sequence seq as bigint start with 5"
      $ CreateSequence [Name Nothing "seq"]
         [SGOStartWith 5
         ,SGODataType $ TypeName [Name Nothing "bigint"]
-        ])
+        ]
 
 
 {-
@@ -2122,21 +2123,21 @@ defintely skip
   <signed numeric literal>
 -}
 
-    ,(TestStatement ansi2011
+    ,s
       "alter sequence seq restart"
      $ AlterSequence [Name Nothing "seq"]
-        [SGORestart Nothing])
+        [SGORestart Nothing]
 
-    ,(TestStatement ansi2011
+    ,s
       "alter sequence seq restart with 5"
      $ AlterSequence [Name Nothing "seq"]
-        [SGORestart $ Just 5])
+        [SGORestart $ Just 5]
 
-    ,(TestStatement ansi2011
+    ,s
       "alter sequence seq restart with 5 increment by 5"
      $ AlterSequence [Name Nothing "seq"]
         [SGORestart $ Just 5
-        ,SGOIncrementBy 5])
+        ,SGOIncrementBy 5]
 
 
 {-
@@ -2146,13 +2147,16 @@ defintely skip
   DROP SEQUENCE <sequence generator name> <drop behavior>
 -}
 
-    ,(TestStatement ansi2011
+    ,s
       "drop sequence seq"
-     $ DropSequence [Name Nothing "seq"] DefaultDropBehaviour)
+     $ DropSequence [Name Nothing "seq"] DefaultDropBehaviour
 
-    ,(TestStatement ansi2011
+    ,s
       "drop sequence seq restrict"
-     $ DropSequence [Name Nothing "seq"] Restrict)
+     $ DropSequence [Name Nothing "seq"] Restrict
 
 
     ]
+
+s :: HasCallStack => Text -> Statement -> TestItem
+s src ast = testStatement ansi2011 src ast

tests/Language/SQL/SimpleSQL/ScalarExprs.hs

@@ -6,6 +6,9 @@ module Language.SQL.SimpleSQL.ScalarExprs (scalarExprTests) where
 
 import Language.SQL.SimpleSQL.TestTypes
 import Language.SQL.SimpleSQL.Syntax
+import Language.SQL.SimpleSQL.TestRunners
+
+import Data.Text (Text)
 
 scalarExprTests :: TestItem
 scalarExprTests = Group "scalarExprTests"
@@ -25,101 +28,108 @@ scalarExprTests = Group "scalarExprTests"
     ,functionsWithReservedNames
     ]
 
-literals :: TestItem
+t :: HasCallStack => Text -> ScalarExpr -> TestItem
-literals = Group "literals" $ map (uncurry (TestScalarExpr ansi2011))
+t src ast = testScalarExpr ansi2011 src ast
-    [("3", NumLit "3")
-     ,("3.", NumLit "3.")
-     ,("3.3", NumLit "3.3")
-     ,(".3", NumLit ".3")
-     ,("3.e3", NumLit "3.e3")
-     ,("3.3e3", NumLit "3.3e3")
-     ,(".3e3", NumLit ".3e3")
-     ,("3e3", NumLit "3e3")
-     ,("3e+3", NumLit "3e+3")
-     ,("3e-3", NumLit "3e-3")
-     ,("'string'", StringLit "'" "'" "string")
-     ,("'string with a '' quote'", StringLit "'" "'" "string with a '' quote")
-     ,("'1'", StringLit "'" "'" "1")
-     ,("interval '3' day"
-      ,IntervalLit Nothing "3" (Itf "day" Nothing) Nothing)
-     ,("interval '3' day (3)"
-      ,IntervalLit Nothing "3" (Itf "day" $ Just (3,Nothing)) Nothing)
-     ,("interval '3 weeks'", TypedLit (TypeName [Name Nothing "interval"]) "3 weeks")
-    ]
 
+td :: HasCallStack => Dialect -> Text -> ScalarExpr -> TestItem
+td d src ast = testScalarExpr d src ast
+
+
+
+literals :: TestItem
+literals = Group "literals"
+    [t "3" $ NumLit "3"
+    ,t "3." $ NumLit "3."
+    ,t "3.3" $ NumLit "3.3"
+    ,t ".3" $ NumLit ".3"
+    ,t "3.e3" $ NumLit "3.e3"
+    ,t "3.3e3" $ NumLit "3.3e3"
+    ,t ".3e3" $ NumLit ".3e3"
+    ,t "3e3" $ NumLit "3e3"
+    ,t "3e+3" $ NumLit "3e+3"
+    ,t "3e-3" $ NumLit "3e-3"
+    ,t "'string'" $ StringLit "'" "'" "string"
+    ,t "'string with a '' quote'" $ StringLit "'" "'" "string with a '' quote"
+    ,t "'1'" $ StringLit "'" "'" "1"
+    ,t "interval '3' day"
+        $ IntervalLit Nothing "3" (Itf "day" Nothing) Nothing
+    ,t "interval '3' day (3)"
+        $ IntervalLit Nothing "3" (Itf "day" $ Just (3,Nothing)) Nothing
+    ,t "interval '3 weeks'" $ TypedLit (TypeName [Name Nothing "interval"]) "3 weeks"
+    ]
+      
 identifiers :: TestItem
-identifiers = Group "identifiers" $ map (uncurry (TestScalarExpr ansi2011))
+identifiers = Group "identifiers"
-    [("iden1", Iden [Name Nothing "iden1"])
+    [t "iden1" $ Iden [Name Nothing "iden1"]
     --,("t.a", Iden2 "t" "a")
-    ,("\"quoted identifier\"", Iden [Name (Just ("\"","\"")) "quoted identifier"])
+    ,t "\"quoted identifier\"" $ Iden [Name (Just ("\"","\"")) "quoted identifier"]
-    ,("\"from\"", Iden [Name (Just ("\"","\"")) "from"])
+    ,t "\"from\"" $ Iden [Name (Just ("\"","\"")) "from"]
     ]
 
 star :: TestItem
-star = Group "star" $ map (uncurry (TestScalarExpr ansi2011))
+star = Group "star"
-    [("*", Star)
+    [t "*" Star
     --,("t.*", Star2 "t")
     --,("ROW(t.*,42)", App "ROW" [Star2 "t", NumLit "42"])
     ]
 
 parameter :: TestItem
 parameter = Group "parameter"
-    [TestScalarExpr ansi2011 "?" Parameter
+    [td ansi2011 "?" Parameter
-    ,TestScalarExpr postgres "$13" $ PositionalArg 13]
+    ,td postgres "$13" $ PositionalArg 13]
-
 
 dots :: TestItem
-dots = Group "dot" $ map (uncurry (TestScalarExpr ansi2011))
+dots = Group "dot"
-    [("t.a", Iden [Name Nothing "t",Name Nothing "a"])
+    [t "t.a" $ Iden [Name Nothing "t",Name Nothing "a"]
-    ,("t.*", BinOp (Iden [Name Nothing "t"]) [Name Nothing "."] Star)
+    ,t "t.*" $ BinOp (Iden [Name Nothing "t"]) [Name Nothing "."] Star
-    ,("a.b.c", Iden [Name Nothing "a",Name Nothing "b",Name Nothing "c"])
+    ,t "a.b.c" $ Iden [Name Nothing "a",Name Nothing "b",Name Nothing "c"]
-    ,("ROW(t.*,42)", App [Name Nothing "ROW"] [BinOp (Iden [Name Nothing "t"]) [Name Nothing "."] Star, NumLit "42"])
+    ,t "ROW(t.*,42)"
+        $ App [Name Nothing "ROW"] [BinOp (Iden [Name Nothing "t"]) [Name Nothing "."] Star, NumLit "42"]
     ]
 
 app :: TestItem
-app = Group "app" $ map (uncurry (TestScalarExpr ansi2011))
+app = Group "app"
-    [("f()", App [Name Nothing "f"] [])
+    [t "f()" $ App [Name Nothing "f"] []
-    ,("f(a)", App [Name Nothing "f"] [Iden [Name Nothing "a"]])
+    ,t "f(a)" $ App [Name Nothing "f"] [Iden [Name Nothing "a"]]
-    ,("f(a,b)", App [Name Nothing "f"] [Iden [Name Nothing "a"], Iden [Name Nothing "b"]])
+    ,t "f(a,b)" $ App [Name Nothing "f"] [Iden [Name Nothing "a"], Iden [Name Nothing "b"]]
     ]
 
 caseexp :: TestItem
-caseexp = Group "caseexp" $ map (uncurry (TestScalarExpr ansi2011))
+caseexp = Group "caseexp"
-    [("case a when 1 then 2 end"
+    [t "case a when 1 then 2 end"
-     ,Case (Just $ Iden [Name Nothing "a"]) [([NumLit "1"]
+     $ Case (Just $ Iden [Name Nothing "a"]) [([NumLit "1"]
-                              ,NumLit "2")] Nothing)
+                              ,NumLit "2")] Nothing
 
-    ,("case a when 1 then 2 when 3 then 4 end"
+    ,t "case a when 1 then 2 when 3 then 4 end"
-     ,Case (Just $ Iden [Name Nothing "a"]) [([NumLit "1"], NumLit "2")
+     $ Case (Just $ Iden [Name Nothing "a"]) [([NumLit "1"], NumLit "2")
-                             ,([NumLit "3"], NumLit "4")] Nothing)
+                             ,([NumLit "3"], NumLit "4")] Nothing
 
-    ,("case a when 1 then 2 when 3 then 4 else 5 end"
+    ,t "case a when 1 then 2 when 3 then 4 else 5 end"
-     ,Case (Just $ Iden [Name Nothing "a"]) [([NumLit "1"], NumLit "2")
+     $ Case (Just $ Iden [Name Nothing "a"]) [([NumLit "1"], NumLit "2")
                              ,([NumLit "3"], NumLit "4")]
-                             (Just $ NumLit "5"))
+                             (Just $ NumLit "5")
 
-    ,("case when a=1 then 2 when a=3 then 4 else 5 end"
+    ,t "case when a=1 then 2 when a=3 then 4 else 5 end"
-     ,Case Nothing [([BinOp (Iden [Name Nothing "a"]) [Name Nothing "="] (NumLit "1")], NumLit "2")
+     $ Case Nothing [([BinOp (Iden [Name Nothing "a"]) [Name Nothing "="] (NumLit "1")], NumLit "2")
                    ,([BinOp (Iden [Name Nothing "a"]) [Name Nothing "="] (NumLit "3")], NumLit "4")]
-                   (Just $ NumLit "5"))
+                   (Just $ NumLit "5")
 
-    ,("case a when 1,2 then 10 when 3,4 then 20 end"
+    ,t "case a when 1,2 then 10 when 3,4 then 20 end"
-     ,Case (Just $ Iden [Name Nothing "a"]) [([NumLit "1",NumLit "2"]
+     $ Case (Just $ Iden [Name Nothing "a"]) [([NumLit "1",NumLit "2"]
                                ,NumLit "10")
                              ,([NumLit "3",NumLit "4"]
                                ,NumLit "20")]
-                             Nothing)
+                             Nothing
-
     ]
 
 convertfun :: TestItem 
-convertfun = Group "convert" $ map (uncurry (TestScalarExpr sqlserver))
+convertfun = Group "convert"
-    [("CONVERT(varchar, 25.65)"
+    [td sqlserver "CONVERT(varchar, 25.65)"
-     ,Convert (TypeName [Name Nothing "varchar"]) (NumLit "25.65") Nothing)
+     $ Convert (TypeName [Name Nothing "varchar"]) (NumLit "25.65") Nothing
-    ,("CONVERT(datetime, '2017-08-25')"
+    ,td sqlserver "CONVERT(datetime, '2017-08-25')"
-     ,Convert (TypeName [Name Nothing "datetime"]) (StringLit "'" "'" "2017-08-25") Nothing)
+     $ Convert (TypeName [Name Nothing "datetime"]) (StringLit "'" "'" "2017-08-25") Nothing
-    ,("CONVERT(varchar, '2017-08-25', 101)"
+    ,td sqlserver "CONVERT(varchar, '2017-08-25', 101)"
-     ,Convert (TypeName [Name Nothing "varchar"]) (StringLit "'" "'" "2017-08-25") (Just 101))
+     $ Convert (TypeName [Name Nothing "varchar"]) (StringLit "'" "'" "2017-08-25") (Just 101)
     ]
 
 operators :: TestItem
@@ -130,70 +140,69 @@ operators = Group "operators"
     ,miscOps]
 
 binaryOperators :: TestItem
-binaryOperators = Group "binaryOperators" $ map (uncurry (TestScalarExpr ansi2011))
+binaryOperators = Group "binaryOperators"
-    [("a + b", BinOp (Iden [Name Nothing "a"]) [Name Nothing "+"] (Iden [Name Nothing "b"]))
+    [t "a + b" $ BinOp (Iden [Name Nothing "a"]) [Name Nothing "+"] (Iden [Name Nothing "b"])
      -- sanity check fixities
      -- todo: add more fixity checking
 
-    ,("a + b * c"
+    ,t "a + b * c"
-     ,BinOp  (Iden [Name Nothing "a"]) [Name Nothing "+"]
+     $ BinOp  (Iden [Name Nothing "a"]) [Name Nothing "+"]
-             (BinOp (Iden [Name Nothing "b"]) [Name Nothing "*"] (Iden [Name Nothing "c"])))
+             (BinOp (Iden [Name Nothing "b"]) [Name Nothing "*"] (Iden [Name Nothing "c"]))
 
-    ,("a * b + c"
+    ,t "a * b + c"
-     ,BinOp (BinOp (Iden [Name Nothing "a"]) [Name Nothing "*"] (Iden [Name Nothing "b"]))
+     $ BinOp (BinOp (Iden [Name Nothing "a"]) [Name Nothing "*"] (Iden [Name Nothing "b"]))
-            [Name Nothing "+"] (Iden [Name Nothing "c"]))
+            [Name Nothing "+"] (Iden [Name Nothing "c"])
     ]
 
 unaryOperators :: TestItem
-unaryOperators = Group "unaryOperators" $ map (uncurry (TestScalarExpr ansi2011))
+unaryOperators = Group "unaryOperators"
-    [("not a", PrefixOp [Name Nothing "not"] $ Iden [Name Nothing "a"])
+    [t "not a" $ PrefixOp [Name Nothing "not"] $ Iden [Name Nothing "a"]
-    ,("not not a", PrefixOp [Name Nothing "not"] $ PrefixOp [Name Nothing "not"] $ Iden [Name Nothing "a"])
+    ,t "not not a" $ PrefixOp [Name Nothing "not"] $ PrefixOp [Name Nothing "not"] $ Iden [Name Nothing "a"]
-    ,("+a", PrefixOp [Name Nothing "+"] $ Iden [Name Nothing "a"])
+    ,t "+a" $ PrefixOp [Name Nothing "+"] $ Iden [Name Nothing "a"]
-    ,("-a", PrefixOp [Name Nothing "-"] $ Iden [Name Nothing "a"])
+    ,t "-a" $ PrefixOp [Name Nothing "-"] $ Iden [Name Nothing "a"]
     ]
 
 
 casts :: TestItem
-casts = Group "operators" $ map (uncurry (TestScalarExpr ansi2011))
+casts = Group "operators"
-    [("cast('1' as int)"
+    [t "cast('1' as int)"
-     ,Cast (StringLit "'" "'" "1") $ TypeName [Name Nothing "int"])
+     $ Cast (StringLit "'" "'" "1") $ TypeName [Name Nothing "int"]
 
-    ,("int '3'"
+    ,t "int '3'"
-     ,TypedLit (TypeName [Name Nothing "int"]) "3")
+     $ TypedLit (TypeName [Name Nothing "int"]) "3"
 
-    ,("cast('1' as double precision)"
+    ,t "cast('1' as double precision)"
-     ,Cast (StringLit "'" "'" "1") $ TypeName [Name Nothing "double precision"])
+     $ Cast (StringLit "'" "'" "1") $ TypeName [Name Nothing "double precision"]
 
-    ,("cast('1' as float(8))"
+    ,t "cast('1' as float(8))"
-     ,Cast (StringLit "'" "'" "1") $ PrecTypeName [Name Nothing "float"] 8)
+     $ Cast (StringLit "'" "'" "1") $ PrecTypeName [Name Nothing "float"] 8
 
-    ,("cast('1' as decimal(15,2))"
+    ,t "cast('1' as decimal(15,2))"
-     ,Cast (StringLit "'" "'" "1") $ PrecScaleTypeName [Name Nothing "decimal"] 15 2)
+     $ Cast (StringLit "'" "'" "1") $ PrecScaleTypeName [Name Nothing "decimal"] 15 2
 
-
+    ,t "double precision '3'"
-    ,("double precision '3'"
+     $ TypedLit (TypeName [Name Nothing "double precision"]) "3"
-     ,TypedLit (TypeName [Name Nothing "double precision"]) "3")
     ]
 
 subqueries :: TestItem
-subqueries = Group "unaryOperators" $ map (uncurry (TestScalarExpr ansi2011))
+subqueries = Group "unaryOperators"
-    [("exists (select a from t)", SubQueryExpr SqExists ms)
+    [t "exists (select a from t)" $ SubQueryExpr SqExists ms
-    ,("(select a from t)", SubQueryExpr SqSq ms)
+    ,t "(select a from t)" $ SubQueryExpr SqSq ms
 
-    ,("a in (select a from t)"
+    ,t "a in (select a from t)"
-     ,In True (Iden [Name Nothing "a"]) (InQueryExpr ms))
+      $ In True (Iden [Name Nothing "a"]) (InQueryExpr ms)
 
-    ,("a not in (select a from t)"
+    ,t "a not in (select a from t)"
-     ,In False (Iden [Name Nothing "a"]) (InQueryExpr ms))
+     $ In False (Iden [Name Nothing "a"]) (InQueryExpr ms)
 
-    ,("a > all (select a from t)"
+    ,t "a > all (select a from t)"
-     ,QuantifiedComparison (Iden [Name Nothing "a"]) [Name Nothing ">"] CPAll ms)
+     $ QuantifiedComparison (Iden [Name Nothing "a"]) [Name Nothing ">"] CPAll ms
 
-    ,("a = some (select a from t)"
+    ,t "a = some (select a from t)"
-     ,QuantifiedComparison (Iden [Name Nothing "a"]) [Name Nothing "="] CPSome ms)
+     $ QuantifiedComparison (Iden [Name Nothing "a"]) [Name Nothing "="] CPSome ms
 
-    ,("a <= any (select a from t)"
+    ,t "a <= any (select a from t)"
-     ,QuantifiedComparison (Iden [Name Nothing "a"]) [Name Nothing "<="] CPAny ms)
+     $ QuantifiedComparison (Iden [Name Nothing "a"]) [Name Nothing "<="] CPAny ms
     ]
   where
     ms = toQueryExpr $ makeSelect
@@ -202,94 +211,93 @@ subqueries = Group "unaryOperators" $ map (uncurry (TestScalarExpr ansi2011))
          }
 
 miscOps :: TestItem
-miscOps = Group "unaryOperators" $ map (uncurry (TestScalarExpr ansi2011))
+miscOps = Group "unaryOperators"
-    [("a in (1,2,3)"
+    [t "a in (1,2,3)"
-     ,In True (Iden [Name Nothing "a"]) $ InList $ map NumLit ["1","2","3"])
+     $ In True (Iden [Name Nothing "a"]) $ InList $ map NumLit ["1","2","3"]
 
-    ,("a is null", PostfixOp [Name Nothing "is null"] (Iden [Name Nothing "a"]))
+    ,t "a is null" $ PostfixOp [Name Nothing "is null"] (Iden [Name Nothing "a"])
-    ,("a is not null", PostfixOp [Name Nothing "is not null"] (Iden [Name Nothing "a"]))
+    ,t "a is not null" $ PostfixOp [Name Nothing "is not null"] (Iden [Name Nothing "a"])
-    ,("a is true", PostfixOp [Name Nothing "is true"] (Iden [Name Nothing "a"]))
+    ,t "a is true" $ PostfixOp [Name Nothing "is true"] (Iden [Name Nothing "a"])
-    ,("a is not true", PostfixOp [Name Nothing "is not true"] (Iden [Name Nothing "a"]))
+    ,t "a is not true" $ PostfixOp [Name Nothing "is not true"] (Iden [Name Nothing "a"])
-    ,("a is false", PostfixOp [Name Nothing "is false"] (Iden [Name Nothing "a"]))
+    ,t "a is false" $ PostfixOp [Name Nothing "is false"] (Iden [Name Nothing "a"])
-    ,("a is not false", PostfixOp [Name Nothing "is not false"] (Iden [Name Nothing "a"]))
+    ,t "a is not false" $ PostfixOp [Name Nothing "is not false"] (Iden [Name Nothing "a"])
-    ,("a is unknown", PostfixOp [Name Nothing "is unknown"] (Iden [Name Nothing "a"]))
+    ,t "a is unknown" $ PostfixOp [Name Nothing "is unknown"] (Iden [Name Nothing "a"])
-    ,("a is not unknown", PostfixOp [Name Nothing "is not unknown"] (Iden [Name Nothing "a"]))
+    ,t "a is not unknown" $ PostfixOp [Name Nothing "is not unknown"] (Iden [Name Nothing "a"])
-    ,("a is distinct from b", BinOp (Iden [Name Nothing "a"]) [Name Nothing "is distinct from"] (Iden [Name Nothing "b"]))
+    ,t "a is distinct from b" $ BinOp (Iden [Name Nothing "a"]) [Name Nothing "is distinct from"] (Iden [Name Nothing "b"])
 
-    ,("a is not distinct from b"
+    ,t "a is not distinct from b"
-     ,BinOp (Iden [Name Nothing "a"]) [Name Nothing "is not distinct from"] (Iden [Name Nothing "b"]))
+     $ BinOp (Iden [Name Nothing "a"]) [Name Nothing "is not distinct from"] (Iden [Name Nothing "b"])
 
-    ,("a like b", BinOp (Iden [Name Nothing "a"]) [Name Nothing "like"] (Iden [Name Nothing "b"]))
+    ,t "a like b" $ BinOp (Iden [Name Nothing "a"]) [Name Nothing "like"] (Iden [Name Nothing "b"])
-    ,("a not like b", BinOp (Iden [Name Nothing "a"]) [Name Nothing "not like"] (Iden [Name Nothing "b"]))
+    ,t "a not like b" $ BinOp (Iden [Name Nothing "a"]) [Name Nothing "not like"] (Iden [Name Nothing "b"])
-    ,("a is similar to b", BinOp (Iden [Name Nothing "a"]) [Name Nothing "is similar to"] (Iden [Name Nothing "b"]))
+    ,t "a is similar to b"$  BinOp (Iden [Name Nothing "a"]) [Name Nothing "is similar to"] (Iden [Name Nothing "b"])
 
-    ,("a is not similar to b"
+    ,t "a is not similar to b"
-     ,BinOp (Iden [Name Nothing "a"]) [Name Nothing "is not similar to"] (Iden [Name Nothing "b"]))
+     $ BinOp (Iden [Name Nothing "a"]) [Name Nothing "is not similar to"] (Iden [Name Nothing "b"])
-
-    ,("a overlaps b", BinOp (Iden [Name Nothing "a"]) [Name Nothing "overlaps"] (Iden [Name Nothing "b"]))
 
+    ,t "a overlaps b" $ BinOp (Iden [Name Nothing "a"]) [Name Nothing "overlaps"] (Iden [Name Nothing "b"])
 
 -- special operators
 
-    ,("a between b and c", SpecialOp [Name Nothing "between"] [Iden [Name Nothing "a"]
+    ,t "a between b and c" $ SpecialOp [Name Nothing "between"] [Iden [Name Nothing "a"]
                                                ,Iden [Name Nothing "b"]
-                                               ,Iden [Name Nothing "c"]])
+                                               ,Iden [Name Nothing "c"]]
 
-    ,("a not between b and c", SpecialOp [Name Nothing "not between"] [Iden [Name Nothing "a"]
+    ,t "a not between b and c" $ SpecialOp [Name Nothing "not between"] [Iden [Name Nothing "a"]
                                                        ,Iden [Name Nothing "b"]
-                                                       ,Iden [Name Nothing "c"]])
+                                                       ,Iden [Name Nothing "c"]]
-    ,("(1,2)"
+    ,t "(1,2)"
-     ,SpecialOp [Name Nothing "rowctor"] [NumLit "1", NumLit "2"])
+     $ SpecialOp [Name Nothing "rowctor"] [NumLit "1", NumLit "2"]
 
 
 -- keyword special operators
 
-    ,("extract(day from t)"
+    ,t "extract(day from t)"
-     , SpecialOpK [Name Nothing "extract"] (Just $ Iden [Name Nothing "day"]) [("from", Iden [Name Nothing "t"])])
+     $ SpecialOpK [Name Nothing "extract"] (Just $ Iden [Name Nothing "day"]) [("from", Iden [Name Nothing "t"])]
 
-    ,("substring(x from 1 for 2)"
+    ,t "substring(x from 1 for 2)"
-     ,SpecialOpK [Name Nothing "substring"] (Just $ Iden [Name Nothing "x"]) [("from", NumLit "1")
+     $ SpecialOpK [Name Nothing "substring"] (Just $ Iden [Name Nothing "x"]) [("from", NumLit "1")
-                                               ,("for", NumLit "2")])
+                                               ,("for", NumLit "2")]
 
-    ,("substring(x from 1)"
+    ,t "substring(x from 1)"
-     ,SpecialOpK [Name Nothing "substring"] (Just $ Iden [Name Nothing "x"]) [("from", NumLit "1")])
+     $ SpecialOpK [Name Nothing "substring"] (Just $ Iden [Name Nothing "x"]) [("from", NumLit "1")]
 
-    ,("substring(x for 2)"
+    ,t "substring(x for 2)"
-     ,SpecialOpK [Name Nothing "substring"] (Just $ Iden [Name Nothing "x"]) [("for", NumLit "2")])
+     $ SpecialOpK [Name Nothing "substring"] (Just $ Iden [Name Nothing "x"]) [("for", NumLit "2")]
 
-    ,("substring(x from 1 for 2 collate C)"
+    ,t "substring(x from 1 for 2 collate C)"
-     ,SpecialOpK [Name Nothing "substring"] (Just $ Iden [Name Nothing "x"])
+     $ SpecialOpK [Name Nothing "substring"] (Just $ Iden [Name Nothing "x"])
           [("from", NumLit "1")
-          ,("for", Collate (NumLit "2") [Name Nothing "C"])])
+          ,("for", Collate (NumLit "2") [Name Nothing "C"])]
 
 -- this doesn't work because of a overlap in the 'in' parser
 
-    ,("POSITION( string1 IN string2 )"
+    ,t "POSITION( string1 IN string2 )"
-     ,SpecialOpK [Name Nothing "position"] (Just $ Iden [Name Nothing "string1"]) [("in", Iden [Name Nothing "string2"])])
+     $ SpecialOpK [Name Nothing "position"] (Just $ Iden [Name Nothing "string1"]) [("in", Iden [Name Nothing "string2"])]
 
-    ,("CONVERT(char_value USING conversion_char_name)"
+    ,t "CONVERT(char_value USING conversion_char_name)"
-     ,SpecialOpK [Name Nothing "convert"] (Just $ Iden [Name Nothing "char_value"])
+     $ SpecialOpK [Name Nothing "convert"] (Just $ Iden [Name Nothing "char_value"])
-          [("using", Iden [Name Nothing "conversion_char_name"])])
+          [("using", Iden [Name Nothing "conversion_char_name"])]
 
-    ,("TRANSLATE(char_value USING translation_name)"
+    ,t "TRANSLATE(char_value USING translation_name)"
-     ,SpecialOpK [Name Nothing "translate"] (Just $ Iden [Name Nothing "char_value"])
+     $ SpecialOpK [Name Nothing "translate"] (Just $ Iden [Name Nothing "char_value"])
-          [("using", Iden [Name Nothing "translation_name"])])
+          [("using", Iden [Name Nothing "translation_name"])]
 
 {-
 OVERLAY(string PLACING embedded_string FROM start
 [FOR length])
 -}
 
-    ,("OVERLAY(string PLACING embedded_string FROM start)"
+    ,t "OVERLAY(string PLACING embedded_string FROM start)"
-     ,SpecialOpK [Name Nothing "overlay"] (Just $ Iden [Name Nothing "string"])
+     $ SpecialOpK [Name Nothing "overlay"] (Just $ Iden [Name Nothing "string"])
           [("placing", Iden [Name Nothing "embedded_string"])
-          ,("from", Iden [Name Nothing "start"])])
+          ,("from", Iden [Name Nothing "start"])]
 
-    ,("OVERLAY(string PLACING embedded_string FROM start FOR length)"
+    ,t "OVERLAY(string PLACING embedded_string FROM start FOR length)"
-     ,SpecialOpK [Name Nothing "overlay"] (Just $ Iden [Name Nothing "string"])
+     $ SpecialOpK [Name Nothing "overlay"] (Just $ Iden [Name Nothing "string"])
           [("placing", Iden [Name Nothing "embedded_string"])
           ,("from", Iden [Name Nothing "start"])
-          ,("for", Iden [Name Nothing "length"])])
+          ,("for", Iden [Name Nothing "length"])]
 
 {-
 TRIM( [ [{LEADING | TRAILING | BOTH}] [removal_char] FROM ]
@@ -299,135 +307,133 @@ target_string
 
 
 
-    ,("trim(from target_string)"
+    ,t "trim(from target_string)"
-     ,SpecialOpK [Name Nothing "trim"] Nothing
+     $ SpecialOpK [Name Nothing "trim"] Nothing
           [("both", StringLit "'" "'" " ")
-          ,("from", Iden [Name Nothing "target_string"])])
+          ,("from", Iden [Name Nothing "target_string"])]
 
-    ,("trim(leading from target_string)"
+    ,t "trim(leading from target_string)"
-     ,SpecialOpK [Name Nothing "trim"] Nothing
+     $ SpecialOpK [Name Nothing "trim"] Nothing
           [("leading", StringLit "'" "'" " ")
-          ,("from", Iden [Name Nothing "target_string"])])
+          ,("from", Iden [Name Nothing "target_string"])]
 
-    ,("trim(trailing from target_string)"
+    ,t "trim(trailing from target_string)"
-     ,SpecialOpK [Name Nothing "trim"] Nothing
+     $ SpecialOpK [Name Nothing "trim"] Nothing
           [("trailing", StringLit "'" "'" " ")
-          ,("from", Iden [Name Nothing "target_string"])])
+          ,("from", Iden [Name Nothing "target_string"])]
 
-    ,("trim(both from target_string)"
+    ,t "trim(both from target_string)"
-     ,SpecialOpK [Name Nothing "trim"] Nothing
+     $ SpecialOpK [Name Nothing "trim"] Nothing
           [("both", StringLit "'" "'" " ")
-          ,("from", Iden [Name Nothing "target_string"])])
+          ,("from", Iden [Name Nothing "target_string"])]
 
 
-    ,("trim(leading 'x' from target_string)"
+    ,t "trim(leading 'x' from target_string)"
-     ,SpecialOpK [Name Nothing "trim"] Nothing
+     $ SpecialOpK [Name Nothing "trim"] Nothing
           [("leading", StringLit "'" "'" "x")
-          ,("from", Iden [Name Nothing "target_string"])])
+          ,("from", Iden [Name Nothing "target_string"])]
 
-    ,("trim(trailing 'y' from target_string)"
+    ,t "trim(trailing 'y' from target_string)"
-     ,SpecialOpK [Name Nothing "trim"] Nothing
+     $ SpecialOpK [Name Nothing "trim"] Nothing
           [("trailing", StringLit "'" "'" "y")
-          ,("from", Iden [Name Nothing "target_string"])])
+          ,("from", Iden [Name Nothing "target_string"])]
 
-    ,("trim(both 'z' from target_string collate C)"
+    ,t "trim(both 'z' from target_string collate C)"
-     ,SpecialOpK [Name Nothing "trim"] Nothing
+     $ SpecialOpK [Name Nothing "trim"] Nothing
           [("both", StringLit "'" "'" "z")
-          ,("from", Collate (Iden [Name Nothing "target_string"]) [Name Nothing "C"])])
+          ,("from", Collate (Iden [Name Nothing "target_string"]) [Name Nothing "C"])]
 
-    ,("trim(leading from target_string)"
+    ,t "trim(leading from target_string)"
-     ,SpecialOpK [Name Nothing "trim"] Nothing
+     $ SpecialOpK [Name Nothing "trim"] Nothing
           [("leading", StringLit "'" "'" " ")
-          ,("from", Iden [Name Nothing "target_string"])])
+          ,("from", Iden [Name Nothing "target_string"])]
-
 
     ]
 
 aggregates :: TestItem
-aggregates = Group "aggregates" $ map (uncurry (TestScalarExpr ansi2011))
+aggregates = Group "aggregates"
-    [("count(*)",App [Name Nothing "count"] [Star])
+    [t "count(*)" $ App [Name Nothing "count"] [Star]
 
-    ,("sum(a order by a)"
+    ,t "sum(a order by a)"
-    ,AggregateApp [Name Nothing "sum"] SQDefault [Iden [Name Nothing "a"]]
+     $ AggregateApp [Name Nothing "sum"] SQDefault [Iden [Name Nothing "a"]]
-                  [SortSpec (Iden [Name Nothing "a"]) DirDefault NullsOrderDefault] Nothing)
+                  [SortSpec (Iden [Name Nothing "a"]) DirDefault NullsOrderDefault] Nothing
 
-    ,("sum(all a)"
+    ,t "sum(all a)"
-    ,AggregateApp [Name Nothing "sum"] All [Iden [Name Nothing "a"]] [] Nothing)
+     $ AggregateApp [Name Nothing "sum"] All [Iden [Name Nothing "a"]] [] Nothing
 
-    ,("count(distinct a)"
+    ,t "count(distinct a)"
-    ,AggregateApp [Name Nothing "count"] Distinct [Iden [Name Nothing "a"]] [] Nothing)
+     $ AggregateApp [Name Nothing "count"] Distinct [Iden [Name Nothing "a"]] [] Nothing
     ]
 
 windowFunctions :: TestItem
-windowFunctions = Group "windowFunctions" $ map (uncurry (TestScalarExpr ansi2011))
+windowFunctions = Group "windowFunctions"
-    [("max(a) over ()", WindowApp [Name Nothing "max"] [Iden [Name Nothing "a"]] [] [] Nothing)
+    [t "max(a) over ()" $ WindowApp [Name Nothing "max"] [Iden [Name Nothing "a"]] [] [] Nothing
-    ,("count(*) over ()", WindowApp [Name Nothing "count"] [Star] [] [] Nothing)
+    ,t "count(*) over ()" $ WindowApp [Name Nothing "count"] [Star] [] [] Nothing
 
-    ,("max(a) over (partition by b)"
+    ,t "max(a) over (partition by b)"
-     ,WindowApp [Name Nothing "max"] [Iden [Name Nothing "a"]] [Iden [Name Nothing "b"]] [] Nothing)
+     $ WindowApp [Name Nothing "max"] [Iden [Name Nothing "a"]] [Iden [Name Nothing "b"]] [] Nothing
 
-    ,("max(a) over (partition by b,c)"
+    ,t "max(a) over (partition by b,c)"
-     ,WindowApp [Name Nothing "max"] [Iden [Name Nothing "a"]] [Iden [Name Nothing "b"],Iden [Name Nothing "c"]] [] Nothing)
+     $ WindowApp [Name Nothing "max"] [Iden [Name Nothing "a"]] [Iden [Name Nothing "b"],Iden [Name Nothing "c"]] [] Nothing
 
-    ,("sum(a) over (order by b)"
+    ,t "sum(a) over (order by b)"
-     ,WindowApp [Name Nothing "sum"] [Iden [Name Nothing "a"]] []
+     $ WindowApp [Name Nothing "sum"] [Iden [Name Nothing "a"]] []
-          [SortSpec (Iden [Name Nothing "b"]) DirDefault NullsOrderDefault] Nothing)
+          [SortSpec (Iden [Name Nothing "b"]) DirDefault NullsOrderDefault] Nothing
 
-    ,("sum(a) over (order by b desc,c)"
+    ,t "sum(a) over (order by b desc,c)"
-     ,WindowApp [Name Nothing "sum"] [Iden [Name Nothing "a"]] []
+     $ WindowApp [Name Nothing "sum"] [Iden [Name Nothing "a"]] []
           [SortSpec (Iden [Name Nothing "b"]) Desc NullsOrderDefault
-          ,SortSpec (Iden [Name Nothing "c"]) DirDefault NullsOrderDefault] Nothing)
+          ,SortSpec (Iden [Name Nothing "c"]) DirDefault NullsOrderDefault] Nothing
 
-    ,("sum(a) over (partition by b order by c)"
+    ,t "sum(a) over (partition by b order by c)"
-     ,WindowApp [Name Nothing "sum"] [Iden [Name Nothing "a"]] [Iden [Name Nothing "b"]]
+     $ WindowApp [Name Nothing "sum"] [Iden [Name Nothing "a"]] [Iden [Name Nothing "b"]]
-          [SortSpec (Iden [Name Nothing "c"]) DirDefault NullsOrderDefault] Nothing)
+          [SortSpec (Iden [Name Nothing "c"]) DirDefault NullsOrderDefault] Nothing
 
-    ,("sum(a) over (partition by b order by c range unbounded preceding)"
+    ,t "sum(a) over (partition by b order by c range unbounded preceding)"
-     ,WindowApp [Name Nothing "sum"] [Iden [Name Nothing "a"]] [Iden [Name Nothing "b"]]
+     $ WindowApp [Name Nothing "sum"] [Iden [Name Nothing "a"]] [Iden [Name Nothing "b"]]
       [SortSpec (Iden [Name Nothing "c"]) DirDefault NullsOrderDefault]
-      $ Just $ FrameFrom FrameRange UnboundedPreceding)
+      $ Just $ FrameFrom FrameRange UnboundedPreceding
 
-    ,("sum(a) over (partition by b order by c range 5 preceding)"
+    ,t "sum(a) over (partition by b order by c range 5 preceding)"
-     ,WindowApp [Name Nothing "sum"] [Iden [Name Nothing "a"]] [Iden [Name Nothing "b"]]
+     $ WindowApp [Name Nothing "sum"] [Iden [Name Nothing "a"]] [Iden [Name Nothing "b"]]
       [SortSpec (Iden [Name Nothing "c"]) DirDefault NullsOrderDefault]
-      $ Just $ FrameFrom FrameRange $ Preceding (NumLit "5"))
+      $ Just $ FrameFrom FrameRange $ Preceding (NumLit "5")
 
-    ,("sum(a) over (partition by b order by c range current row)"
+    ,t "sum(a) over (partition by b order by c range current row)"
-     ,WindowApp [Name Nothing "sum"] [Iden [Name Nothing "a"]] [Iden [Name Nothing "b"]]
+     $ WindowApp [Name Nothing "sum"] [Iden [Name Nothing "a"]] [Iden [Name Nothing "b"]]
       [SortSpec (Iden [Name Nothing "c"]) DirDefault NullsOrderDefault]
-      $ Just $ FrameFrom FrameRange Current)
+      $ Just $ FrameFrom FrameRange Current
 
-    ,("sum(a) over (partition by b order by c rows 5 following)"
+    ,t "sum(a) over (partition by b order by c rows 5 following)"
-     ,WindowApp [Name Nothing "sum"] [Iden [Name Nothing "a"]] [Iden [Name Nothing "b"]]
+     $ WindowApp [Name Nothing "sum"] [Iden [Name Nothing "a"]] [Iden [Name Nothing "b"]]
       [SortSpec (Iden [Name Nothing "c"]) DirDefault NullsOrderDefault]
-      $ Just $ FrameFrom FrameRows $ Following (NumLit "5"))
+      $ Just $ FrameFrom FrameRows $ Following (NumLit "5")
 
-    ,("sum(a) over (partition by b order by c range unbounded following)"
+    ,t "sum(a) over (partition by b order by c range unbounded following)"
-     ,WindowApp [Name Nothing "sum"] [Iden [Name Nothing "a"]] [Iden [Name Nothing "b"]]
+     $ WindowApp [Name Nothing "sum"] [Iden [Name Nothing "a"]] [Iden [Name Nothing "b"]]
       [SortSpec (Iden [Name Nothing "c"]) DirDefault NullsOrderDefault]
-      $ Just $ FrameFrom FrameRange UnboundedFollowing)
+      $ Just $ FrameFrom FrameRange UnboundedFollowing
 
-    ,("sum(a) over (partition by b order by c \n\
+    ,t "sum(a) over (partition by b order by c \n\
       \range between 5 preceding and 5 following)"
-     ,WindowApp [Name Nothing "sum"] [Iden [Name Nothing "a"]] [Iden [Name Nothing "b"]]
+     $ WindowApp [Name Nothing "sum"] [Iden [Name Nothing "a"]] [Iden [Name Nothing "b"]]
       [SortSpec (Iden [Name Nothing "c"]) DirDefault NullsOrderDefault]
       $ Just $ FrameBetween FrameRange
                             (Preceding (NumLit "5"))
-                            (Following (NumLit "5")))
+                            (Following (NumLit "5"))
 
     ]
 
 parens :: TestItem
-parens = Group "parens" $ map (uncurry (TestScalarExpr ansi2011))
+parens = Group "parens"
-    [("(a)", Parens (Iden [Name Nothing "a"]))
+    [t "(a)" $ Parens (Iden [Name Nothing "a"])
-    ,("(a + b)", Parens (BinOp (Iden [Name Nothing "a"]) [Name Nothing "+"] (Iden [Name Nothing "b"])))
+    ,t "(a + b)" $ Parens (BinOp (Iden [Name Nothing "a"]) [Name Nothing "+"] (Iden [Name Nothing "b"]))
     ]
 
 functionsWithReservedNames :: TestItem
-functionsWithReservedNames = Group "functionsWithReservedNames" $ map t
+functionsWithReservedNames = Group "functionsWithReservedNames" $ map f
     ["abs"
     ,"char_length"
     ]
   where
-    t fn = TestScalarExpr ansi2011 (fn <> "(a)") $ App [Name Nothing fn] [Iden [Name Nothing "a"]]
+    f fn = t (fn <> "(a)") $ App [Name Nothing fn] [Iden [Name Nothing "a"]]
-

tests/Language/SQL/SimpleSQL/TableRefs.hs

@@ -9,100 +9,103 @@ module Language.SQL.SimpleSQL.TableRefs (tableRefTests) where
 
 import Language.SQL.SimpleSQL.TestTypes
 import Language.SQL.SimpleSQL.Syntax
-
+import Language.SQL.SimpleSQL.TestRunners
+import Data.Text (Text)
 
 tableRefTests :: TestItem
-tableRefTests = Group "tableRefTests" $ map (uncurry (TestQueryExpr ansi2011))
+tableRefTests = Group "tableRefTests"
-    [("select a from t"
+    [q "select a from t"
-     ,ms [TRSimple [Name Nothing "t"]])
+     $ ms [TRSimple [Name Nothing "t"]]
 
-     ,("select a from f(a)"
+     ,q "select a from f(a)"
-      ,ms [TRFunction [Name Nothing "f"] [Iden [Name Nothing "a"]]])
+      $ ms [TRFunction [Name Nothing "f"] [Iden [Name Nothing "a"]]]
 
-    ,("select a from t,u"
+    ,q "select a from t,u"
-     ,ms [TRSimple [Name Nothing "t"], TRSimple [Name Nothing "u"]])
+     $ ms [TRSimple [Name Nothing "t"], TRSimple [Name Nothing "u"]]
 
-    ,("select a from s.t"
+    ,q "select a from s.t"
-     ,ms [TRSimple [Name Nothing "s", Name Nothing "t"]])
+     $ ms [TRSimple [Name Nothing "s", Name Nothing "t"]]
 
 -- these lateral queries make no sense but the syntax is valid
 
-    ,("select a from lateral a"
+    ,q "select a from lateral a"
-     ,ms [TRLateral $ TRSimple [Name Nothing "a"]])
+     $ ms [TRLateral $ TRSimple [Name Nothing "a"]]
 
-    ,("select a from lateral a,b"
+    ,q "select a from lateral a,b"
-     ,ms [TRLateral $ TRSimple [Name Nothing "a"], TRSimple [Name Nothing "b"]])
+     $ ms [TRLateral $ TRSimple [Name Nothing "a"], TRSimple [Name Nothing "b"]]
 
-    ,("select a from a, lateral b"
+    ,q "select a from a, lateral b"
-     ,ms [TRSimple [Name Nothing "a"], TRLateral $ TRSimple [Name Nothing "b"]])
+     $ ms [TRSimple [Name Nothing "a"], TRLateral $ TRSimple [Name Nothing "b"]]
 
-    ,("select a from a natural join lateral b"
+    ,q "select a from a natural join lateral b"
-     ,ms [TRJoin (TRSimple [Name Nothing "a"]) True JInner
+     $ ms [TRJoin (TRSimple [Name Nothing "a"]) True JInner
                  (TRLateral $ TRSimple [Name Nothing "b"])
-                 Nothing])
+                 Nothing]
 
-    ,("select a from lateral a natural join lateral b"
+    ,q "select a from lateral a natural join lateral b"
-     ,ms [TRJoin (TRLateral $ TRSimple [Name Nothing "a"]) True JInner
+     $ ms [TRJoin (TRLateral $ TRSimple [Name Nothing "a"]) True JInner
                  (TRLateral $ TRSimple [Name Nothing "b"])
-                 Nothing])
+                 Nothing]
 
 
-    ,("select a from t inner join u on expr"
+    ,q "select a from t inner join u on expr"
-     ,ms [TRJoin (TRSimple [Name Nothing "t"]) False JInner (TRSimple [Name Nothing "u"])
+     $ ms [TRJoin (TRSimple [Name Nothing "t"]) False JInner (TRSimple [Name Nothing "u"])
-                       (Just $ JoinOn $ Iden [Name Nothing "expr"])])
+                       (Just $ JoinOn $ Iden [Name Nothing "expr"])]
 
-    ,("select a from t join u on expr"
+    ,q "select a from t join u on expr"
-     ,ms [TRJoin (TRSimple [Name Nothing "t"]) False JInner (TRSimple [Name Nothing "u"])
+     $ ms [TRJoin (TRSimple [Name Nothing "t"]) False JInner (TRSimple [Name Nothing "u"])
-                       (Just $ JoinOn $ Iden [Name Nothing "expr"])])
+                       (Just $ JoinOn $ Iden [Name Nothing "expr"])]
 
-    ,("select a from t left join u on expr"
+    ,q "select a from t left join u on expr"
-     ,ms [TRJoin (TRSimple [Name Nothing "t"]) False JLeft (TRSimple [Name Nothing "u"])
+     $ ms [TRJoin (TRSimple [Name Nothing "t"]) False JLeft (TRSimple [Name Nothing "u"])
-                       (Just $ JoinOn $ Iden [Name Nothing "expr"])])
+                       (Just $ JoinOn $ Iden [Name Nothing "expr"])]
 
-    ,("select a from t right join u on expr"
+    ,q "select a from t right join u on expr"
-     ,ms [TRJoin (TRSimple [Name Nothing "t"]) False JRight (TRSimple [Name Nothing "u"])
+     $ ms [TRJoin (TRSimple [Name Nothing "t"]) False JRight (TRSimple [Name Nothing "u"])
-                       (Just $ JoinOn $ Iden [Name Nothing "expr"])])
+                       (Just $ JoinOn $ Iden [Name Nothing "expr"])]
 
-    ,("select a from t full join u on expr"
+    ,q "select a from t full join u on expr"
-     ,ms [TRJoin (TRSimple [Name Nothing "t"]) False JFull (TRSimple [Name Nothing "u"])
+     $ ms [TRJoin (TRSimple [Name Nothing "t"]) False JFull (TRSimple [Name Nothing "u"])
-                       (Just $ JoinOn $ Iden [Name Nothing "expr"])])
+                       (Just $ JoinOn $ Iden [Name Nothing "expr"])]
 
-    ,("select a from t cross join u"
+    ,q "select a from t cross join u"
-     ,ms [TRJoin (TRSimple [Name Nothing "t"]) False
+     $ ms [TRJoin (TRSimple [Name Nothing "t"]) False
-                       JCross (TRSimple [Name Nothing "u"]) Nothing])
+                       JCross (TRSimple [Name Nothing "u"]) Nothing]
 
-    ,("select a from t natural inner join u"
+    ,q "select a from t natural inner join u"
-     ,ms [TRJoin (TRSimple [Name Nothing "t"]) True JInner (TRSimple [Name Nothing "u"])
+     $ ms [TRJoin (TRSimple [Name Nothing "t"]) True JInner (TRSimple [Name Nothing "u"])
-                       Nothing])
+                       Nothing]
 
-    ,("select a from t inner join u using(a,b)"
+    ,q "select a from t inner join u using(a,b)"
-     ,ms [TRJoin (TRSimple [Name Nothing "t"]) False JInner (TRSimple [Name Nothing "u"])
+     $ ms [TRJoin (TRSimple [Name Nothing "t"]) False JInner (TRSimple [Name Nothing "u"])
-                       (Just $ JoinUsing [Name Nothing "a", Name Nothing "b"])])
+                       (Just $ JoinUsing [Name Nothing "a", Name Nothing "b"])]
 
-    ,("select a from (select a from t)"
+    ,q "select a from (select a from t)"
-     ,ms [TRQueryExpr $ ms [TRSimple [Name Nothing "t"]]])
+     $ ms [TRQueryExpr $ ms [TRSimple [Name Nothing "t"]]]
 
-    ,("select a from t as u"
+    ,q "select a from t as u"
-     ,ms [TRAlias (TRSimple [Name Nothing "t"]) (Alias (Name Nothing "u") Nothing)])
+     $ ms [TRAlias (TRSimple [Name Nothing "t"]) (Alias (Name Nothing "u") Nothing)]
 
-    ,("select a from t u"
+    ,q "select a from t u"
-     ,ms [TRAlias (TRSimple [Name Nothing "t"]) (Alias (Name Nothing "u") Nothing)])
+     $ ms [TRAlias (TRSimple [Name Nothing "t"]) (Alias (Name Nothing "u") Nothing)]
 
-    ,("select a from t u(b)"
+    ,q "select a from t u(b)"
-     ,ms [TRAlias (TRSimple [Name Nothing "t"]) (Alias (Name Nothing "u") $ Just [Name Nothing "b"])])
+     $ ms [TRAlias (TRSimple [Name Nothing "t"]) (Alias (Name Nothing "u") $ Just [Name Nothing "b"])]
 
-    ,("select a from (t cross join u) as u"
+    ,q "select a from (t cross join u) as u"
-     ,ms [TRAlias (TRParens $
+     $ ms [TRAlias (TRParens $
                    TRJoin (TRSimple [Name Nothing "t"]) False JCross (TRSimple [Name Nothing "u"]) Nothing)
-                          (Alias (Name Nothing "u") Nothing)])
+                          (Alias (Name Nothing "u") Nothing)]
      -- todo: not sure if the associativity is correct
 
-    ,("select a from t cross join u cross join v",
+    ,q "select a from t cross join u cross join v"
-       ms [TRJoin
+       $ ms [TRJoin
            (TRJoin (TRSimple [Name Nothing "t"]) False
                    JCross (TRSimple [Name Nothing "u"]) Nothing)
-           False JCross (TRSimple [Name Nothing "v"]) Nothing])
+           False JCross (TRSimple [Name Nothing "v"]) Nothing]
     ]
   where
     ms f = toQueryExpr $ makeSelect {msSelectList = [(Iden [Name Nothing "a"],Nothing)]
                                     ,msFrom = f}
+    q :: HasCallStack => Text -> QueryExpr -> TestItem
+    q src ast = testQueryExpr ansi2011 src ast

tests/Language/SQL/SimpleSQL/TestRunners.hs

@@ -0,0 +1,92 @@
+
+{-# LANGUAGE OverloadedStrings #-}
+module Language.SQL.SimpleSQL.TestRunners
+    (testLex
+    ,lexFails
+    ,testScalarExpr
+    ,testQueryExpr
+    ,testStatement
+    ,testStatements
+    ,testParseQueryExpr
+    ,testParseQueryExprFails
+    ,testParseScalarExprFails
+    ,HasCallStack
+    ) where
+
+import Language.SQL.SimpleSQL.Syntax
+import Language.SQL.SimpleSQL.TestTypes
+import Language.SQL.SimpleSQL.Pretty
+import Language.SQL.SimpleSQL.Parse
+import qualified Language.SQL.SimpleSQL.Lex as Lex
+
+import Data.Text (Text)
+import qualified Data.Text as T
+
+import Language.SQL.SimpleSQL.Expectations
+    (shouldParseL
+    ,shouldFail
+    ,shouldParseA
+    ,shouldSucceed
+    )
+    
+import Test.Hspec
+    (it
+    ,HasCallStack
+    )
+
+testLex :: HasCallStack => Dialect -> Text -> [Lex.Token] -> TestItem
+testLex d input a =
+    LexTest d input a $ do
+        it (T.unpack input) $ Lex.lexSQL d False "" Nothing input `shouldParseL` a
+        it (T.unpack $ "pp: " <> input) $ Lex.lexSQL d False "" Nothing (Lex.prettyTokens d a) `shouldParseL` a
+
+lexFails :: HasCallStack => Dialect -> Text -> TestItem
+lexFails d input =
+    LexFails d input $ 
+        it (T.unpack input) $ shouldFail $ Lex.lexSQL d False "" Nothing input
+
+testScalarExpr :: HasCallStack => Dialect -> Text -> ScalarExpr -> TestItem
+testScalarExpr d input a =
+    TestScalarExpr d input a $ do
+        it (T.unpack input) $ parseScalarExpr d "" Nothing input `shouldParseA` a
+        it (T.unpack $ "pp: " <> input) $ parseScalarExpr d "" Nothing (prettyScalarExpr d a) `shouldParseA` a
+
+testQueryExpr :: HasCallStack => Dialect -> Text -> QueryExpr -> TestItem
+testQueryExpr d input a =
+    TestQueryExpr d input a $ do
+        it (T.unpack input) $ parseQueryExpr d "" Nothing input `shouldParseA` a
+        it (T.unpack $ "pp: " <> input) $ parseQueryExpr d "" Nothing (prettyQueryExpr d a) `shouldParseA` a
+
+testParseQueryExpr :: HasCallStack => Dialect -> Text -> TestItem
+testParseQueryExpr d input =
+    let a = parseQueryExpr d "" Nothing input
+    in ParseQueryExpr d input $ do
+        it (T.unpack input) $ shouldSucceed (T.unpack . prettyError) a
+        case a of
+            Left _ -> pure ()
+            Right a' ->
+                it (T.unpack $ "pp: " <> input) $
+                parseQueryExpr d "" Nothing (prettyQueryExpr d a') `shouldParseA` a'
+
+testParseQueryExprFails :: HasCallStack => Dialect -> Text -> TestItem
+testParseQueryExprFails d input =
+    ParseQueryExprFails d input $ 
+        it (T.unpack input) $ shouldFail $ parseQueryExpr d "" Nothing input
+
+testParseScalarExprFails :: HasCallStack => Dialect -> Text -> TestItem
+testParseScalarExprFails d input =
+    ParseScalarExprFails d input $ 
+        it (T.unpack input) $ shouldFail $ parseScalarExpr d "" Nothing input
+
+testStatement :: HasCallStack => Dialect -> Text -> Statement -> TestItem
+testStatement d input a =
+    TestStatement d input a $ do
+        it (T.unpack input) $ parseStatement d "" Nothing input `shouldParseA` a
+        it (T.unpack $ "pp: " <> input) $ parseStatement d "" Nothing (prettyStatement d a) `shouldParseA` a
+
+testStatements :: HasCallStack => Dialect -> Text -> [Statement] -> TestItem
+testStatements d input a =
+    TestStatements d input a $ do
+        it (T.unpack input) $ parseStatements d "" Nothing input `shouldParseA` a
+        it (T.unpack $ "pp: " <> input) $ parseStatements d "" Nothing (prettyStatements d a) `shouldParseA` a
+

tests/Language/SQL/SimpleSQL/TestTypes.hs

@@ -13,6 +13,9 @@ import Language.SQL.SimpleSQL.Syntax
 import Language.SQL.SimpleSQL.Lex (Token)
 import Language.SQL.SimpleSQL.Dialect
 
+import Test.Hspec (SpecWith)
+
+
 import Data.Text (Text)
 
 {-
@@ -20,13 +23,19 @@ TODO: maybe make the dialect args into [dialect], then each test
 checks all the dialects mentioned work, and all the dialects not
 mentioned give a parse error. Not sure if this will be too awkward due
 to lots of tricky exceptions/variationsx.
+
+The test items are designed to allow code to grab all the examples
+in easily usable data types, but since hspec has this neat feature
+where it will give a source location for a test failure, each testitem
+apart from group already has the SpecWith attached to run that test,
+that way we can attach the source location to each test item
 -}
 
 data TestItem = Group Text [TestItem]
-              | TestScalarExpr Dialect Text ScalarExpr
+              | TestScalarExpr Dialect Text ScalarExpr (SpecWith ())
-              | TestQueryExpr Dialect Text QueryExpr
+              | TestQueryExpr Dialect Text QueryExpr (SpecWith ())
-              | TestStatement Dialect Text Statement
+              | TestStatement Dialect Text Statement (SpecWith ())
-              | TestStatements Dialect Text [Statement]
+              | TestStatements Dialect Text [Statement] (SpecWith ())
 
 {-
 this just checks the sql parses without error, mostly just a
@@ -34,12 +43,13 @@ intermediate when I'm too lazy to write out the parsed AST. These
 should all be TODO to convert to a testqueryexpr test.
 -}
 
-              | ParseQueryExpr Dialect Text
+              | ParseQueryExpr Dialect Text (SpecWith ())
 
 -- check that the string given fails to parse
 
-              | ParseQueryExprFails Dialect Text
+              | ParseQueryExprFails Dialect Text (SpecWith ())
-              | ParseScalarExprFails Dialect Text
+              | ParseScalarExprFails Dialect Text (SpecWith ())
-              | LexTest Dialect Text [Token]
+              | LexTest Dialect Text [Token] (SpecWith ())
-              | LexFails Dialect Text
+              | LexFails Dialect Text (SpecWith ())
-                deriving (Eq,Show)
+              | GeneralParseFailTest Text Text (SpecWith ())
+

tests/Language/SQL/SimpleSQL/Tests.hs

@@ -12,13 +12,11 @@ module Language.SQL.SimpleSQL.Tests
     ,TestItem(..)
     ) where
 
-import qualified Test.Tasty as T
+import Test.Hspec
-import qualified Test.Tasty.HUnit as H
+    (SpecWith
-
+    ,describe
---import Language.SQL.SimpleSQL.Syntax
+    ,parallel
-import Language.SQL.SimpleSQL.Pretty
+    )
-import Language.SQL.SimpleSQL.Parse
-import qualified Language.SQL.SimpleSQL.Lex as Lex
 
 import Language.SQL.SimpleSQL.TestTypes
 
@@ -44,11 +42,10 @@ import Language.SQL.SimpleSQL.SQL2011Schema
 import Language.SQL.SimpleSQL.MySQL
 import Language.SQL.SimpleSQL.Oracle
 import Language.SQL.SimpleSQL.CustomDialect
+import Language.SQL.SimpleSQL.ErrorMessages
 
-import Data.Text (Text)
 import qualified Data.Text as T
 
-
 {-
 Order the tests to start from the simplest first. This is also the
 order on the generated documentation.
@@ -77,104 +74,22 @@ testData =
     ,customDialectTests
     ,emptyStatementTests
     ,createIndexTests
+    ,errorMessageTests
     ]
 
-tests :: T.TestTree
+tests :: SpecWith ()
-tests = itemToTest testData
+tests = parallel $ itemToTest testData
 
---runTests :: IO ()
+itemToTest :: TestItem -> SpecWith ()
---runTests = void $ H.runTestTT $ itemToTest testData
-
-itemToTest :: TestItem -> T.TestTree
 itemToTest (Group nm ts) =
-    T.testGroup (T.unpack nm) $ map itemToTest ts
+    describe (T.unpack nm) $ mapM_ itemToTest ts
-itemToTest (TestScalarExpr d str expected) =
+itemToTest (TestScalarExpr _ _ _ t) = t
-    toTest parseScalarExpr prettyScalarExpr d str expected
+itemToTest (TestQueryExpr _ _ _ t) = t
-itemToTest (TestQueryExpr d str expected) =
+itemToTest (TestStatement _ _ _ t) = t
-    toTest parseQueryExpr prettyQueryExpr d str expected
+itemToTest (TestStatements _ _ _ t) = t
-itemToTest (TestStatement d str expected) =
+itemToTest (ParseQueryExpr _ _ t) = t
-    toTest parseStatement prettyStatement d str expected
+itemToTest (ParseQueryExprFails _ _ t) = t
-itemToTest (TestStatements d str expected) =
+itemToTest (ParseScalarExprFails _ _ t) = t
-    toTest parseStatements prettyStatements d str expected
+itemToTest (LexTest _ _ _ t) = t
-itemToTest (ParseQueryExpr d str) =
+itemToTest (LexFails _ _ t) = t
-    toPTest parseQueryExpr prettyQueryExpr d str
+itemToTest (GeneralParseFailTest _ _ t) = t
-
-itemToTest (ParseQueryExprFails d str) =
-    toFTest parseQueryExpr prettyQueryExpr d str
-
-itemToTest (ParseScalarExprFails d str) =
-    toFTest parseScalarExpr prettyScalarExpr d str
-
-itemToTest (LexTest d s ts) = makeLexerTest d s ts
-itemToTest (LexFails d s) = makeLexingFailsTest d s
-
-makeLexerTest :: Dialect -> Text -> [Lex.Token] -> T.TestTree
-makeLexerTest d s ts = H.testCase (T.unpack s) $ do
-    let ts1 = either (error . T.unpack . Lex.prettyError) id $ Lex.lexSQL d "" Nothing s
-    H.assertEqual "" ts ts1
-    let s' = Lex.prettyTokens d $ ts1
-    H.assertEqual "pretty print" s s'
-
-makeLexingFailsTest :: Dialect -> Text -> T.TestTree
-makeLexingFailsTest d s = H.testCase (T.unpack s) $ do
-    case Lex.lexSQL d "" Nothing s of
-         Right x -> H.assertFailure $ "lexing should have failed: " ++ T.unpack s ++ "\ngot: " ++ show x
-         Left _ -> pure ()
-
-
-toTest :: (Eq a, Show a) =>
-          (Dialect -> Text -> Maybe (Int,Int) -> Text -> Either ParseError a)
-       -> (Dialect -> a -> Text)
-       -> Dialect
-       -> Text
-       -> a
-       -> T.TestTree
-toTest parser pp d str expected = H.testCase (T.unpack str) $ do
-        let egot = parser d "" Nothing str
-        case egot of
-            Left e -> H.assertFailure $ T.unpack $ prettyError e
-            Right got -> H.assertEqual "" expected got
-        
-        let str' = pp d expected
-            egot' = parser d "" Nothing str'
-        case egot' of
-            Left e' ->
-                H.assertFailure $ "pp roundtrip"
-                    ++ "\n" ++ (T.unpack str')
-                    ++ (T.unpack $ prettyError e')
-            Right got' ->
-                H.assertEqual
-                    ("pp roundtrip" ++ "\n" ++ T.unpack str')
-                    expected got'
-
-toPTest :: (Eq a, Show a) =>
-          (Dialect -> Text -> Maybe (Int,Int) -> Text -> Either ParseError a)
-       -> (Dialect -> a -> Text)
-       -> Dialect
-       -> Text
-       -> T.TestTree
-toPTest parser pp d str = H.testCase (T.unpack str) $ do
-        let egot = parser d "" Nothing str
-        case egot of
-            Left e -> H.assertFailure $ T.unpack $ prettyError e
-            Right got -> do
-                let str' = pp d got
-                let egot' = parser d "" Nothing str'
-                case egot' of
-                    Left e' -> H.assertFailure $ "pp roundtrip "
-                                                 ++ "\n" ++ T.unpack str' ++ "\n"
-                                                 ++ T.unpack (prettyError e')
-                    Right _got' -> return ()
-
-toFTest :: (Eq a, Show a) =>
-          (Dialect -> Text -> Maybe (Int,Int) -> Text -> Either ParseError a)
-       -> (Dialect -> a -> Text)
-       -> Dialect
-       -> Text
-       -> T.TestTree
-toFTest parser _pp d str = H.testCase (T.unpack str) $ do
-        let egot = parser d "" Nothing str
-        case egot of
-            Left _e -> return ()
-            Right _got ->
-              H.assertFailure $ "parse didn't fail: " ++ show d ++ "\n" ++ T.unpack str

tests/Language/SQL/SimpleSQL/Tpch.hs

@@ -14,15 +14,14 @@ module Language.SQL.SimpleSQL.Tpch (tpchTests,tpchQueries) where
 import Language.SQL.SimpleSQL.TestTypes
 
 import Data.Text (Text)
+import Language.SQL.SimpleSQL.TestRunners
 
 tpchTests :: TestItem
-tpchTests =
+tpchTests = Group "parse tpch" tpchQueries
-    Group "parse tpch"
-    $ map (ParseQueryExpr ansi2011 . snd) tpchQueries
 
-tpchQueries :: [(String,Text)]
+tpchQueries :: [TestItem]
 tpchQueries =
-  [("Q1","\n\
+  [q "Q1" "\n\
          \select\n\
          \        l_returnflag,\n\
          \        l_linestatus,\n\
@@ -43,8 +42,8 @@ tpchQueries =
          \        l_linestatus\n\
          \order by\n\
          \        l_returnflag,\n\
-         \        l_linestatus")
+         \        l_linestatus"
-  ,("Q2","\n\
+  ,q "Q2" "\n\
          \select\n\
          \        s_acctbal,\n\
          \        s_name,\n\
@@ -88,8 +87,8 @@ tpchQueries =
          \        n_name,\n\
          \        s_name,\n\
          \        p_partkey\n\
-         \fetch first 100 rows only")
+         \fetch first 100 rows only"
-  ,("Q3","\n\
+  ,q "Q3" "\n\
          \ select\n\
          \         l_orderkey,\n\
          \         sum(l_extendedprice * (1 - l_discount)) as revenue,\n\
@@ -112,8 +111,8 @@ tpchQueries =
          \ order by\n\
          \         revenue desc,\n\
          \         o_orderdate\n\
-         \ fetch first 10 rows only")
+         \ fetch first 10 rows only"
-  ,("Q4","\n\
+  ,q "Q4" "\n\
          \ select\n\
          \         o_orderpriority,\n\
          \         count(*) as order_count\n\
@@ -134,8 +133,8 @@ tpchQueries =
          \ group by\n\
          \         o_orderpriority\n\
          \ order by\n\
-         \         o_orderpriority")
+         \         o_orderpriority"
-  ,("Q5","\n\
+  ,q "Q5" "\n\
          \ select\n\
          \         n_name,\n\
          \         sum(l_extendedprice * (1 - l_discount)) as revenue\n\
@@ -159,8 +158,8 @@ tpchQueries =
          \ group by\n\
          \         n_name\n\
          \ order by\n\
-         \         revenue desc")
+         \         revenue desc"
-  ,("Q6","\n\
+  ,q "Q6" "\n\
          \ select\n\
          \         sum(l_extendedprice * l_discount) as revenue\n\
          \ from\n\
@@ -169,8 +168,8 @@ tpchQueries =
          \         l_shipdate >= date '1997-01-01'\n\
          \         and l_shipdate < date '1997-01-01' + interval '1' year\n\
          \         and l_discount between 0.07 - 0.01 and 0.07 + 0.01\n\
-         \         and l_quantity < 24")
+         \         and l_quantity < 24"
-  ,("Q7","\n\
+  ,q "Q7" "\n\
          \ select\n\
          \         supp_nation,\n\
          \         cust_nation,\n\
@@ -209,8 +208,8 @@ tpchQueries =
          \ order by\n\
          \         supp_nation,\n\
          \         cust_nation,\n\
-         \         l_year")
+         \         l_year"
-  ,("Q8","\n\
+  ,q "Q8" "\n\
          \ select\n\
          \         o_year,\n\
          \         sum(case\n\
@@ -247,8 +246,8 @@ tpchQueries =
          \ group by\n\
          \         o_year\n\
          \ order by\n\
-         \         o_year")
+         \         o_year"
-   ,("Q9","\n\
+   ,q "Q9" "\n\
          \ select\n\
          \         nation,\n\
          \         o_year,\n\
@@ -280,8 +279,8 @@ tpchQueries =
          \         o_year\n\
          \ order by\n\
          \         nation,\n\
-         \         o_year desc")
+         \         o_year desc"
-   ,("Q10","\n\
+   ,q "Q10" "\n\
          \ select\n\
          \         c_custkey,\n\
          \         c_name,\n\
@@ -313,8 +312,8 @@ tpchQueries =
          \         c_comment\n\
          \ order by\n\
          \         revenue desc\n\
-         \ fetch first 20 rows only")
+         \ fetch first 20 rows only"
-   ,("Q11","\n\
+   ,q "Q11" "\n\
          \ select\n\
          \         ps_partkey,\n\
          \         sum(ps_supplycost * ps_availqty) as value\n\
@@ -341,8 +340,8 @@ tpchQueries =
          \                                 and n_name = 'CHINA'\n\
          \                 )\n\
          \ order by\n\
-         \         value desc")
+         \         value desc"
-   ,("Q12","\n\
+   ,q "Q12" "\n\
          \ select\n\
          \         l_shipmode,\n\
          \         sum(case\n\
@@ -370,8 +369,8 @@ tpchQueries =
          \ group by\n\
          \         l_shipmode\n\
          \ order by\n\
-         \         l_shipmode")
+         \         l_shipmode"
-   ,("Q13","\n\
+   ,q "Q13" "\n\
          \ select\n\
          \         c_count,\n\
          \         count(*) as custdist\n\
@@ -391,8 +390,8 @@ tpchQueries =
          \         c_count\n\
          \ order by\n\
          \         custdist desc,\n\
-         \         c_count desc")
+         \         c_count desc"
-   ,("Q14","\n\
+   ,q "Q14" "\n\
          \ select\n\
          \         100.00 * sum(case\n\
          \                 when p_type like 'PROMO%'\n\
@@ -405,8 +404,8 @@ tpchQueries =
          \ where\n\
          \         l_partkey = p_partkey\n\
          \         and l_shipdate >= date '1994-12-01'\n\
-         \         and l_shipdate < date '1994-12-01' + interval '1' month")
+         \         and l_shipdate < date '1994-12-01' + interval '1' month"
-   ,("Q15","\n\
+   ,q "Q15" "\n\
          \ /*create view revenue0 (supplier_no, total_revenue) as\n\
          \         select\n\
          \                 l_suppkey,\n\
@@ -448,8 +447,8 @@ tpchQueries =
          \                         revenue0\n\
          \         )\n\
          \ order by\n\
-         \         s_suppkey")
+         \         s_suppkey"
-   ,("Q16","\n\
+   ,q "Q16" "\n\
          \ select\n\
          \         p_brand,\n\
          \         p_type,\n\
@@ -479,8 +478,8 @@ tpchQueries =
          \         supplier_cnt desc,\n\
          \         p_brand,\n\
          \         p_type,\n\
-         \         p_size")
+         \         p_size"
-   ,("Q17","\n\
+   ,q "Q17" "\n\
          \ select\n\
          \         sum(l_extendedprice) / 7.0 as avg_yearly\n\
          \ from\n\
@@ -497,8 +496,8 @@ tpchQueries =
          \                         lineitem\n\
          \                 where\n\
          \                         l_partkey = p_partkey\n\
-         \         )")
+         \         )"
-   ,("Q18","\n\
+   ,q "Q18" "\n\
          \ select\n\
          \         c_name,\n\
          \         c_custkey,\n\
@@ -531,8 +530,8 @@ tpchQueries =
          \ order by\n\
          \         o_totalprice desc,\n\
          \         o_orderdate\n\
-         \ fetch first 100 rows only")
+         \ fetch first 100 rows only"
-   ,("Q19","\n\
+   ,q "Q19" "\n\
          \ select\n\
          \         sum(l_extendedprice* (1 - l_discount)) as revenue\n\
          \ from\n\
@@ -567,8 +566,8 @@ tpchQueries =
          \                 and p_size between 1 and 15\n\
          \                 and l_shipmode in ('AIR', 'AIR REG')\n\
          \                 and l_shipinstruct = 'DELIVER IN PERSON'\n\
-         \         )")
+         \         )"
-   ,("Q20","\n\
+   ,q "Q20" "\n\
          \ select\n\
          \         s_name,\n\
          \         s_address\n\
@@ -605,8 +604,8 @@ tpchQueries =
          \         and s_nationkey = n_nationkey\n\
          \         and n_name = 'VIETNAM'\n\
          \ order by\n\
-         \         s_name")
+         \         s_name"
-   ,("Q21","\n\
+   ,q "Q21" "\n\
          \ select\n\
          \         s_name,\n\
          \         count(*) as numwait\n\
@@ -646,8 +645,8 @@ tpchQueries =
          \ order by\n\
          \         numwait desc,\n\
          \         s_name\n\
-         \ fetch first 100 rows only")
+         \ fetch first 100 rows only"
-   ,("Q22","\n\
+   ,q "Q22" "\n\
          \ select\n\
          \         cntrycode,\n\
          \         count(*) as numcust,\n\
@@ -684,5 +683,8 @@ tpchQueries =
          \ group by\n\
          \         cntrycode\n\
          \ order by\n\
-         \         cntrycode")
+         \         cntrycode"
   ]
+  where
+    q :: HasCallStack => Text -> Text -> TestItem
+    q _ src = testParseQueryExpr ansi2011 src

tests/RunTests.hs

@@ -1,8 +1,9 @@
 
 
-import Test.Tasty
+import Test.Hspec (hspec)
+
 
 import Language.SQL.SimpleSQL.Tests
 
 main :: IO ()
-main = defaultMain tests
+main = hspec tests

website/RenderTestCases.hs

@@ -20,26 +20,28 @@ doc _ (Group nm _) | "generated" `T.isInfixOf` nm = []
 doc n (Group nm is) =
     Heading n (L.fromStrict nm)
     : concatMap (doc (n + 1)) is
-doc _ (TestScalarExpr _ str e) =
+doc _ (TestScalarExpr _ str e _) =
     [Row (L.fromStrict str) (L.pack $ ppShow e)]
-doc _ (TestQueryExpr _ str e) =
+doc _ (TestQueryExpr _ str e _) =
     [Row (L.fromStrict str) (L.pack $ ppShow e)]
-doc _ (TestStatement _ str e) =
+doc _ (TestStatement _ str e _) =
     [Row (L.fromStrict str) (L.pack $ ppShow e)]
-doc _ (TestStatements _ str e) =
+doc _ (TestStatements _ str e _) =
     [Row (L.fromStrict str) (L.pack $ ppShow e)]
-doc _ (ParseQueryExpr d str) =
+doc _ (ParseQueryExpr d str _) =
     [Row (L.fromStrict str) (showResult $ P.parseQueryExpr d "" Nothing str)]
-doc _ (ParseQueryExprFails d str) =
+doc _ (ParseQueryExprFails d str _) =
     [Row (L.fromStrict str) (showResult $ P.parseQueryExpr d "" Nothing str)]
-doc _ (ParseScalarExprFails d str) =
+doc _ (ParseScalarExprFails d str _) =
     [Row (L.fromStrict str) (showResult $ P.parseScalarExpr d "" Nothing str)]
 
-doc _ (LexTest d str _) =
+doc _ (LexTest d str _ _) =
-    [Row (L.fromStrict str) (showResultL $ L.lexSQL d "" Nothing str)]
+    [Row (L.fromStrict str) (showResultL $ L.lexSQL d False "" Nothing str)]
+
+doc _ (LexFails d str _) =
+    [Row (L.fromStrict str) (showResultL $ L.lexSQL d False "" Nothing str)]
+doc _ (GeneralParseFailTest {}) = []
 
-doc _ (LexFails d str) =
-    [Row (L.fromStrict str) (showResultL $ L.lexSQL d "" Nothing str)]
 
 showResult :: Show a => Either P.ParseError a -> L.Text
 showResult = either (("Left\n" <>) . L.fromStrict . P.prettyError) (L.pack . ppShow)

website/index.md

@@ -184,6 +184,8 @@ generally available to work on these, so you should either make a pull
 request, or find someone willing to implement the features and make a
 pull request.
 
+Bug reports of confusing or poor parse errors are also encouraged.
+
 There is a related tutorial on implementing a SQL parser here:
 <http://jakewheat.github.io/intro_to_parsing/> (TODO: this is out of
 date, in the process of being updated)
@@ -210,6 +212,13 @@ Or use the makefile target
 make test
 ~~~~
 
+To skip some of the slow lexer tests, which you usually only need to
+run before each commit, use:
+
+~~~~
+make fast-test
+~~~~
+
 When you add support for new syntax: add some tests. If you modify or
 fix something, and it doesn't have tests, add some. If the syntax
 isn't in ANSI SQL, guard it behind a dialect flag. If you add

website/render-test-cases.cabal

@@ -1,7 +1,7 @@
 cabal-version:       2.2
 
 name:                simple-sql-parser
-version:             0.7.1
+version:             0.8.0
 
 executable RenderTestCases
   main-is:             RenderTestCases.hs
@@ -13,9 +13,11 @@ executable RenderTestCases
                        parser-combinators,
                        mtl,
                        containers,
-                       tasty,
+                       hspec,
-                       tasty-hunit,
+                       hspec-megaparsec,
                        pretty-show,
+                       hspec-expectations,
+                       raw-strings-qq,
   default-language:    Haskell2010
   ghc-options:         -Wall -O0
 
@@ -47,3 +49,6 @@ executable RenderTestCases
         Language.SQL.SimpleSQL.TestTypes
         Language.SQL.SimpleSQL.Tests
         Language.SQL.SimpleSQL.Tpch
+        Language.SQL.SimpleSQL.Expectations
+        Language.SQL.SimpleSQL.TestRunners
+        Language.SQL.SimpleSQL.ErrorMessages