diff --git a/hedgehog-test/Main.hs b/hedgehog-test/Main.hs --- a/hedgehog-test/Main.hs +++ b/hedgehog-test/Main.hs @@ -2,33 +2,32 @@ import qualified Data.Text as Text import Hedgehog -import qualified Hedgehog.Gen as Gen import Hedgehog.Main -import qualified Hedgehog.Range as Range import qualified Main.Gen as Gen -import qualified PostgresqlSyntax.Ast as Ast import qualified PostgresqlSyntax.Parsing as Parsing import qualified PostgresqlSyntax.Rendering as Rendering import Prelude +main :: IO () main = defaultMain - [ checkParallel $ - Group "Parsing a rendered AST produces the same AST" $ - let p _name _amount _gen _parser _renderer = - (,) _name $ - withDiscards (fromIntegral _amount * 200) $ - withTests _amount $ - property $ do - ast <- forAll _gen - let sql = Rendering.toText (_renderer ast) - in do - footnote ("SQL: " <> Text.unpack sql) - case Parsing.run _parser sql of - Left err -> do - footnote err - failure - Right ast' -> ast === ast' + [ checkParallel + $ Group "Parsing a rendered AST produces the same AST" + $ let p name amount gen parser renderer = + (,) name + $ withDiscards (fromIntegral amount * 200) + $ withTests amount + $ property + $ do + ast <- forAll gen + let sql = Rendering.toText (renderer ast) + in do + footnote ("SQL: " <> Text.unpack sql) + case Parsing.run parser sql of + Left err -> do + footnote err + failure + Right ast' -> ast === ast' in [ p "typename" 10000 Gen.typename Parsing.typename Rendering.typename, p "tableRef" 10000 Gen.tableRef Parsing.tableRef Rendering.tableRef, p "aExpr" 60000 Gen.aExpr Parsing.aExpr Rendering.aExpr, diff --git a/hedgehog-test/Main/Gen.hs b/hedgehog-test/Main/Gen.hs --- a/hedgehog-test/Main/Gen.hs +++ b/hedgehog-test/Main/Gen.hs @@ -1,9 +1,11 @@ +{-# OPTIONS_GHC -Wno-missing-signatures #-} + module Main.Gen where import qualified Data.HashSet as HashSet import qualified Data.List as List import qualified Data.Text as Text -import Hedgehog (Gen, MonadGen) +import Hedgehog (Gen) import Hedgehog.Gen import qualified Hedgehog.Range as Range import PostgresqlSyntax.Ast @@ -13,9 +15,9 @@ -- * Generic -inSet _set = filter (flip HashSet.member _set) +inSet set = filter (flip HashSet.member set) -notInSet _set = filter (not . flip HashSet.member _set) +notInSet set = filter (not . flip HashSet.member set) -- * Statements @@ -105,8 +107,8 @@ -- ** selectWithParens -selectWithParens = sized $ \_size -> - if _size <= 1 +selectWithParens = sized $ \size -> + if size <= 1 then discard else frequency @@ -144,8 +146,8 @@ valuesSimpleSelect = ValuesSimpleSelect <$> valuesClause -binSimpleSelect _leftSelect = - BinSimpleSelect <$> selectBinOp <*> pure _leftSelect <*> maybe allOrDistinct <*> small selectClause +binSimpleSelect leftSelect = + BinSimpleSelect <$> selectBinOp <*> pure leftSelect <*> maybe allOrDistinct <*> small selectClause terminalSimpleSelect = pure (NormalSimpleSelect Nothing Nothing Nothing Nothing Nothing Nothing Nothing) @@ -523,8 +525,6 @@ GroupingCExpr <$> exprList ] --- ** - caseExpr = CaseExpr <$> maybe aExpr <*> whenClauseList <*> maybe aExpr whenClauseList = nonEmpty (Range.exponential 1 7) whenClause @@ -538,8 +538,8 @@ ] arrayExpr = - small $ - choice + small + $ choice [ ExprListArrayExpr <$> exprList, ArrayExprListArrayExpr <$> arrayExprList, pure EmptyArrayExpr @@ -678,7 +678,7 @@ ] op = do - a <- text (Range.exponential 1 7) (element "+-*/<>=~!@#%^&|`?") + a <- text (Range.exponential 1 7) (listElement "+-*/<>=~!@#%^&|`?") case Validation.op a of Nothing -> return a _ -> discard @@ -741,8 +741,8 @@ [ IAexprConst <$> iconst, FAexprConst <$> fconst, SAexprConst <$> sconst, - BAexprConst <$> text (Range.exponential 1 100) (element "01"), - XAexprConst <$> text (Range.exponential 1 100) (element "0123456789abcdefABCDEF"), + BAexprConst <$> text (Range.exponential 1 100) (listElement "01"), + XAexprConst <$> text (Range.exponential 1 100) (listElement "0123456789abcdefABCDEF"), FuncAexprConst <$> funcName <*> maybe funcConstArgs <*> sconst, ConstTypenameAexprConst <$> constTypename <*> sconst, StringIntervalAexprConst <$> sconst <*> maybe interval, @@ -822,8 +822,8 @@ iconstOrFconst = choice [Left <$> iconst <|> Right <$> fconst] fconst = - filter (\a -> fromIntegral (round a) /= a) $ - realFrac_ (Range.exponentialFloat 0 309457394857984375983475943) + filter (\a -> fromIntegral (round a) /= a) + $ realFrac_ (Range.exponentialFloat 0 309457394857984375983475943) iconst = integral (Range.exponential 0 maxBound) @@ -945,3 +945,8 @@ ascDesc = enumBounded nullsOrder = enumBounded + +-- * Helpers + +listElement :: [a] -> Gen a +listElement = element diff --git a/library/PostgresqlSyntax/Ast.hs b/library/PostgresqlSyntax/Ast.hs --- a/library/PostgresqlSyntax/Ast.hs +++ b/library/PostgresqlSyntax/Ast.hs @@ -5,7 +5,7 @@ -- For reasoning see the docs of the parsing module of this project. module PostgresqlSyntax.Ast where -import PostgresqlSyntax.Prelude hiding (Op, Order) +import PostgresqlSyntax.Prelude -- * Statement @@ -773,15 +773,15 @@ -- @ data RelationExpr = SimpleRelationExpr + -- | Name. QualifiedName - -- ^ Name. + -- | Is asterisk present? Bool - -- ^ Is asterisk present? | OnlyRelationExpr + -- | Name. QualifiedName - -- ^ Name. + -- | Are parentheses present? Bool - -- ^ Are parentheses present? deriving (Show, Generic, Eq, Ord) -- | @@ -1162,8 +1162,6 @@ | GroupingCExpr ExprList deriving (Show, Generic, Eq, Ord) --- ** - -- | -- ==== References -- @ @@ -1983,13 +1981,13 @@ -- @ data Typename = Typename + -- | SETOF Bool - -- ^ SETOF SimpleTypename + -- | Question mark Bool - -- ^ Question mark + -- | Array dimensions possibly followed by a question mark (Maybe (TypenameArrayDimensions, Bool)) - -- ^ Array dimensions possibly followed by a question mark deriving (Show, Generic, Eq, Ord) -- | diff --git a/library/PostgresqlSyntax/Extras/HeadedMegaparsec.hs b/library/PostgresqlSyntax/Extras/HeadedMegaparsec.hs --- a/library/PostgresqlSyntax/Extras/HeadedMegaparsec.hs +++ b/library/PostgresqlSyntax/Extras/HeadedMegaparsec.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-redundant-constraints -Wno-dodgy-imports -Wno-unused-imports #-} + -- | -- Generic helpers for HeadedMegaparsec. module PostgresqlSyntax.Extras.HeadedMegaparsec where @@ -79,11 +81,11 @@ -- * Combinators sep1 :: (Ord err, Stream strm, Megaparsec.Token strm ~ Char) => HeadedParsec err strm separtor -> HeadedParsec err strm a -> HeadedParsec err strm (NonEmpty a) -sep1 _separator _parser = do - _head <- _parser +sep1 separator parser = do + head <- parser endHead - _tail <- many $ _separator *> _parser - return (_head :| _tail) + tail <- many $ separator *> parser + return (head :| tail) sepEnd1 :: (Ord err, Stream strm, Megaparsec.Token strm ~ Char) => HeadedParsec err strm separator -> HeadedParsec err strm end -> HeadedParsec err strm el -> HeadedParsec err strm (NonEmpty el, end) sepEnd1 sepP endP elP = do diff --git a/library/PostgresqlSyntax/Extras/NonEmpty.hs b/library/PostgresqlSyntax/Extras/NonEmpty.hs --- a/library/PostgresqlSyntax/Extras/NonEmpty.hs +++ b/library/PostgresqlSyntax/Extras/NonEmpty.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-dodgy-imports #-} + module PostgresqlSyntax.Extras.NonEmpty where import Data.List.NonEmpty @@ -9,7 +11,7 @@ -- -- >>> intersperseFoldMap ", " id (fromList ["a", "b", "c"]) -- "a, b, c" -intersperseFoldMap :: Monoid m => m -> (a -> m) -> NonEmpty a -> m +intersperseFoldMap :: (Monoid m) => m -> (a -> m) -> NonEmpty a -> m intersperseFoldMap a b (c :| d) = b c <> foldMap (mappend a . b) d unsnoc :: NonEmpty a -> (Maybe (NonEmpty a), a) diff --git a/library/PostgresqlSyntax/KeywordSet.hs b/library/PostgresqlSyntax/KeywordSet.hs --- a/library/PostgresqlSyntax/KeywordSet.hs +++ b/library/PostgresqlSyntax/KeywordSet.hs @@ -1,8 +1,7 @@ module PostgresqlSyntax.KeywordSet where import Data.HashSet -import qualified Data.Text as Text -import PostgresqlSyntax.Prelude hiding (expression, fromList, toList) +import PostgresqlSyntax.Prelude hiding (fromList, toList) {-# NOINLINE keyword #-} {- @@ -36,6 +35,7 @@ lexicalBinOp = fromList ["and", "or"] {-# NOINLINE colId #-} +colId :: HashSet Text colId = unions [unreservedKeyword, colNameKeyword] {- @@ -45,6 +45,7 @@ | type_func_name_keyword -} {-# NOINLINE typeFunctionName #-} +typeFunctionName :: HashSet Text typeFunctionName = unions [unreservedKeyword, typeFuncNameKeyword] -- | @@ -57,7 +58,9 @@ -- * rather than the generic Op. -- */ {-# NOINLINE nonOp #-} +nonOp :: HashSet Text nonOp = fromList [">=", "<=", "=>", "<>", "!="] <> mathOp {-# NOINLINE mathOp #-} +mathOp :: HashSet Text mathOp = fromList ["<>", ">=", "!=", "<=", "+", "-", "*", "/", "%", "^", "<", ">", "="] diff --git a/library/PostgresqlSyntax/Parsing.hs b/library/PostgresqlSyntax/Parsing.hs --- a/library/PostgresqlSyntax/Parsing.hs +++ b/library/PostgresqlSyntax/Parsing.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-redundant-constraints -Wno-missing-signatures -Wno-dodgy-imports #-} + -- | -- -- Our parsing strategy is to port the original Postgres parser as closely as possible. @@ -28,7 +30,6 @@ import Control.Applicative.Combinators hiding (some) import Control.Applicative.Combinators.NonEmpty import qualified Data.HashSet as HashSet -import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Text as Text import HeadedMegaparsec hiding (string) import PostgresqlSyntax.Ast @@ -40,10 +41,8 @@ import PostgresqlSyntax.Prelude hiding (bit, expr, filter, fromList, head, many, option, some, sortBy, tail, try) import qualified PostgresqlSyntax.Validation as Validation import qualified Text.Builder as TextBuilder -import Text.Megaparsec (Parsec, Stream) import qualified Text.Megaparsec as Megaparsec import qualified Text.Megaparsec.Char as MegaparsecChar -import qualified Text.Megaparsec.Char.Lexer as MegaparsecLexer -- $setup -- >>> testParser parser = either putStr print . run parser @@ -76,16 +75,16 @@ inParensCont p = char '(' *> endHead *> pure (space *> p <* endHead <* space <* char ')') inParensWithLabel :: (label -> content -> result) -> Parser label -> Parser content -> Parser result -inParensWithLabel _result _labelParser _contentParser = do - _label <- wrapToHead _labelParser +inParensWithLabel result labelParser contentParser = do + label <- wrapToHead labelParser space char '(' endHead space - _content <- _contentParser + content <- contentParser space char ')' - pure (_result _label _content) + pure (result label content) inParensWithClause :: Parser clause -> Parser content -> Parser content inParensWithClause = inParensWithLabel (const id) @@ -100,21 +99,21 @@ quotedString q = do char q endHead - _tail <- - parse $ - let collectChunks !bdr = do - chunk <- Megaparsec.takeWhileP Nothing (/= q) - let bdr' = bdr <> TextBuilder.text chunk - Megaparsec.try (consumeEscapedQuote bdr') <|> finish bdr' - consumeEscapedQuote bdr = do - MegaparsecChar.char q - MegaparsecChar.char q - collectChunks (bdr <> TextBuilder.char q) - finish bdr = do - MegaparsecChar.char q - return (TextBuilder.run bdr) - in collectChunks mempty - return _tail + tail <- + parse + $ let collectChunks !bdr = do + chunk <- Megaparsec.takeWhileP Nothing (/= q) + let bdr' = bdr <> TextBuilder.text chunk + Megaparsec.try (consumeEscapedQuote bdr') <|> finish bdr' + consumeEscapedQuote bdr = do + MegaparsecChar.char q + MegaparsecChar.char q + collectChunks (bdr <> TextBuilder.char q) + finish bdr = do + MegaparsecChar.char q + return (TextBuilder.run bdr) + in collectChunks mempty + return tail atEnd :: Parser a -> Parser a atEnd p = space *> p <* endHead <* space <* eof @@ -311,12 +310,12 @@ selectNoParens = withSelectNoParens <|> simpleSelectNoParens -sharedSelectNoParens _with = do - _select <- selectClause - _sort <- optional (space1 *> sortClause) - _limit <- optional (space1 *> selectLimit) - _forLocking <- optional (space1 *> forLockingClause) - return (SelectNoParens _with _select _sort _limit _forLocking) +sharedSelectNoParens with = do + select <- selectClause + sort <- optional (space1 *> sortClause) + limit <- optional (space1 *> selectLimit) + forLocking <- optional (space1 *> forLockingClause) + return (SelectNoParens with select sort limit forLocking) -- | -- The one that doesn't start with \"WITH\". @@ -331,9 +330,9 @@ simpleSelectNoParens = sharedSelectNoParens Nothing withSelectNoParens = do - _with <- wrapToHead withClause + with <- wrapToHead withClause space1 - sharedSelectNoParens (Just _with) + sharedSelectNoParens (Just with) selectClause = suffixRec base suffix where @@ -350,14 +349,14 @@ keyword "select" notFollowedBy $ satisfy $ isAlphaNum endHead - _targeting <- optional (space1 *> targeting) - _intoClause <- optional (space1 *> keyword "into" *> endHead *> space1 *> optTempTableName) - _fromClause <- optional (space1 *> fromClause) - _whereClause <- optional (space1 *> whereClause) - _groupClause <- optional (space1 *> keyphrase "group by" *> endHead *> space1 *> sep1 commaSeparator groupByItem) - _havingClause <- optional (space1 *> keyword "having" *> endHead *> space1 *> aExpr) - _windowClause <- optional (space1 *> keyword "window" *> endHead *> space1 *> sep1 commaSeparator windowDefinition) - return (NormalSimpleSelect _targeting _intoClause _fromClause _whereClause _groupClause _havingClause _windowClause), + targeting <- optional (space1 *> targeting) + intoClause <- optional (space1 *> keyword "into" *> endHead *> space1 *> optTempTableName) + fromClause <- optional (space1 *> fromClause) + whereClause <- optional (space1 *> whereClause) + groupClause <- optional (space1 *> keyphrase "group by" *> endHead *> space1 *> sep1 commaSeparator groupByItem) + havingClause <- optional (space1 *> keyword "having" *> endHead *> space1 *> aExpr) + windowClause <- optional (space1 *> keyword "window" *> endHead *> space1 *> sep1 commaSeparator windowDefinition) + return (NormalSimpleSelect targeting intoClause fromClause whereClause groupClause havingClause windowClause), do keyword "table" space1 @@ -366,12 +365,12 @@ ValuesSimpleSelect <$> valuesClause ] -extensionSimpleSelect _headSelectClause = do - _op <- space1 *> selectBinOp <* space1 +extensionSimpleSelect headSelectClause = do + op <- space1 *> selectBinOp <* space1 endHead - _allOrDistinct <- optional (allOrDistinct <* space1) - _selectClause <- selectClause - return (BinSimpleSelect _op _headSelectClause _allOrDistinct _selectClause) + allOrDistinct <- optional (allOrDistinct <* space1) + selectClause <- selectClause + return (BinSimpleSelect op headSelectClause allOrDistinct selectClause) allOrDistinct = keyword "all" $> False <|> keyword "distinct" $> True @@ -389,27 +388,27 @@ char '(' endHead space - _a <- sep1 commaSeparator aExpr + a <- sep1 commaSeparator aExpr space char ')' - return _a + return a withClause = label "with clause" $ do keyword "with" space1 endHead - _recursive <- option False (True <$ keyword "recursive" <* space1) - _cteList <- sep1 commaSeparator commonTableExpr - return (WithClause _recursive _cteList) + recursive <- option False (True <$ keyword "recursive" <* space1) + cteList <- sep1 commaSeparator commonTableExpr + return (WithClause recursive cteList) commonTableExpr = label "common table expression" $ do - _name <- colId <* space <* endHead - _nameList <- optional (inParens (sep1 commaSeparator colId) <* space1) + name <- colId <* space <* endHead + nameList <- optional (inParens (sep1 commaSeparator colId) <* space1) keyword "as" space1 - _materialized <- optional (materialized <* space1) - _stmt <- inParens preparableStmt - return (CommonTableExpr _name _nameList _materialized _stmt) + materialized <- optional (materialized <* space1) + stmt <- inParens preparableStmt + return (CommonTableExpr name nameList materialized stmt) materialized = True <$ keyword "materialized" @@ -427,9 +426,9 @@ keyword "distinct" space1 endHead - _optOn <- optional (onExpressionsClause <* space1) - _targetList <- targetList - return (DistinctTargeting _optOn _targetList) + optOn <- optional (onExpressionsClause <* space1) + targetList <- targetList + return (DistinctTargeting optOn targetList) targetList = sep1 commaSeparator targetEl @@ -437,18 +436,18 @@ -- >>> testParser targetEl "a.b as c" -- AliasedExprTargetEl (CExprAExpr (ColumnrefCExpr (Columnref (UnquotedIdent "a") (Just (AttrNameIndirectionEl (UnquotedIdent "b") :| []))))) (UnquotedIdent "c") targetEl = - label "target" $ - asum + label "target" + $ asum [ do - _expr <- aExpr + expr <- aExpr asum [ do space1 asum - [ AliasedExprTargetEl _expr <$> (keyword "as" *> space1 *> endHead *> colLabel), - ImplicitlyAliasedExprTargetEl _expr <$> ident + [ AliasedExprTargetEl expr <$> (keyword "as" *> space1 *> endHead *> colLabel), + ImplicitlyAliasedExprTargetEl expr <$> ident ], - pure (ExprTargetEl _expr) + pure (ExprTargetEl expr) ], AsteriskTargetEl <$ char '*' ] @@ -522,8 +521,8 @@ -- opt_sort_clause opt_frame_clause ')' -- @ windowSpecification = - inParens $ - asum + inParens + $ asum [ do a <- frameClause return (WindowSpecification Nothing Nothing Nothing (Just a)), @@ -607,18 +606,18 @@ -- >>> testParser tableRef "a left join b on (a.i = b.i)" -- JoinTableRef (MethJoinedTable (QualJoinMeth... tableRef = - label "table reference" $ - do - _tr <- nonTrailingTableRef - recur _tr + label "table reference" + $ do + tr <- nonTrailingTableRef + recur tr where - recur _tr = + recur tr = asum [ do - _tr2 <- wrapToHead (space1 *> trailingTableRef _tr) + tr2 <- wrapToHead (space1 *> trailingTableRef tr) endHead - recur _tr2, - pure _tr + recur tr2, + pure tr ] nonTrailingTableRef = @@ -631,11 +630,11 @@ ] where relationExprTableRef = do - _relationExpr <- relationExpr + relationExpr <- relationExpr endHead - _optAliasClause <- optional (space1 *> aliasClause) - _optTablesampleClause <- optional (space1 *> tablesampleClause) - return (RelationExprTableRef _relationExpr _optAliasClause _optTablesampleClause) + optAliasClause <- optional (space1 *> aliasClause) + optTablesampleClause <- optional (space1 *> tablesampleClause) + return (RelationExprTableRef relationExpr optAliasClause optTablesampleClause) lateralTableRef = do keyword "lateral" @@ -645,46 +644,46 @@ nonLateralTableRef = lateralableTableRef False - lateralableTableRef _lateral = + lateralableTableRef lateral = asum [ do a <- funcTable b <- optional (space1 *> funcAliasClause) - return (FuncTableRef _lateral a b), + return (FuncTableRef lateral a b), do - _select <- selectWithParens - _optAliasClause <- optional $ space1 *> aliasClause - return (SelectTableRef _lateral _select _optAliasClause) + select <- selectWithParens + optAliasClause <- optional $ space1 *> aliasClause + return (SelectTableRef lateral select optAliasClause) ] inParensJoinedTableTableRef = JoinTableRef <$> inParensJoinedTable <*> pure Nothing joinedTableWithAliasTableRef = do - _joinedTable <- wrapToHead (inParens joinedTable) + joinedTable <- wrapToHead (inParens joinedTable) space1 - _alias <- aliasClause - return (JoinTableRef _joinedTable (Just _alias)) + alias <- aliasClause + return (JoinTableRef joinedTable (Just alias)) -trailingTableRef _tableRef = - JoinTableRef <$> trailingJoinedTable _tableRef <*> pure Nothing +trailingTableRef tableRef = + JoinTableRef <$> trailingJoinedTable tableRef <*> pure Nothing relationExpr = - label "relation expression" $ - asum + label "relation expression" + $ asum [ do keyword "only" space1 - _name <- qualifiedName - return (OnlyRelationExpr _name False), + name <- qualifiedName + return (OnlyRelationExpr name False), inParensWithClause (keyword "only") qualifiedName <&> \a -> OnlyRelationExpr a True, do - _name <- qualifiedName - _asterisk <- + name <- qualifiedName + asterisk <- asum [ True <$ (space1 *> char '*'), pure False ] - return (SimpleRelationExpr _name _asterisk) + return (SimpleRelationExpr name asterisk) ] relationExprOptAlias reservedKeywords = do @@ -796,18 +795,18 @@ head = asum [ do - _tr <- wrapToHead nonTrailingTableRef + tr <- wrapToHead nonTrailingTableRef space1 - trailingJoinedTable _tr, + trailingJoinedTable tr, inParensJoinedTable ] - tail _jt = + tail jt = asum [ do - _jt2 <- wrapToHead (space1 *> trailingJoinedTable (JoinTableRef _jt Nothing)) + jt2 <- wrapToHead (space1 *> trailingJoinedTable (JoinTableRef jt Nothing)) endHead - tail _jt2, - pure _jt + tail jt2, + pure jt ] -- | @@ -826,30 +825,30 @@ -- | table_ref NATURAL join_type JOIN table_ref -- | table_ref NATURAL JOIN table_ref -- @ -trailingJoinedTable _tr1 = +trailingJoinedTable tr1 = asum [ do keyphrase "cross join" endHead space1 - _tr2 <- nonTrailingTableRef - return (MethJoinedTable CrossJoinMeth _tr1 _tr2), + tr2 <- nonTrailingTableRef + return (MethJoinedTable CrossJoinMeth tr1 tr2), do - _jt <- joinTypedJoin + jt <- joinTypedJoin endHead space1 - _tr2 <- tableRef + tr2 <- tableRef space1 - _jq <- joinQual - return (MethJoinedTable (QualJoinMeth _jt _jq) _tr1 _tr2), + jq <- joinQual + return (MethJoinedTable (QualJoinMeth jt jq) tr1 tr2), do keyword "natural" endHead space1 - _jt <- joinTypedJoin + jt <- joinTypedJoin space1 - _tr2 <- nonTrailingTableRef - return (MethJoinedTable (NaturalJoinMeth _jt) _tr1 _tr2) + tr2 <- nonTrailingTableRef + return (MethJoinedTable (NaturalJoinMeth jt) tr1 tr2) ] where joinTypedJoin = @@ -861,18 +860,18 @@ [ do keyword "full" endHead - _outer <- outerAfterSpace - return (FullJoinType _outer), + outer <- outerAfterSpace + return (FullJoinType outer), do keyword "left" endHead - _outer <- outerAfterSpace - return (LeftJoinType _outer), + outer <- outerAfterSpace + return (LeftJoinType outer), do keyword "right" endHead - _outer <- outerAfterSpace - return (RightJoinType _outer), + outer <- outerAfterSpace + return (RightJoinType outer), keyword "inner" $> InnerJoinType ] where @@ -885,9 +884,9 @@ ] aliasClause = do - (_as, _alias) <- (True,) <$> (keyword "as" *> space1 *> endHead *> colId) <|> (False,) <$> colId - _columnAliases <- optional (space1 *> inParens (sep1 commaSeparator colId)) - return (AliasClause _as _alias _columnAliases) + (as, alias) <- (True,) <$> (keyword "as" *> space1 *> endHead *> colId) <|> (False,) <$> colId + columnAliases <- optional (space1 *> inParens (sep1 commaSeparator colId)) + return (AliasClause as alias columnAliases) -- * Where @@ -1055,7 +1054,6 @@ customizedBExpr cExpr = suffixRec base suffix where - aExpr = customizedAExpr cExpr bExpr = customizedBExpr cExpr base = asum @@ -1096,8 +1094,8 @@ do keyword "array" space - join $ - asum + join + $ asum [ fmap (fmap (ArrayCExpr . Right)) arrayExprCont, fmap (fmap (ArrayCExpr . Left) . pure) selectWithParens ], @@ -1112,8 +1110,6 @@ ColumnrefCExpr <$> columnref ] --- * - subqueryOp = asum [ AnySubqueryOp <$> (keyword "operator" *> space *> endHead *> inParens anyOperator), @@ -1132,19 +1128,19 @@ inExpr = SelectInExpr <$> wrapToHead selectWithParens <|> ExprListInExpr <$> inParens exprList -symbolicBinOpExpr _a _bParser _constr = do - _binOp <- label "binary operator" (space *> wrapToHead symbolicExprBinOp <* space) - _b <- _bParser - return (_constr _a _binOp _b) +symbolicBinOpExpr a bParser constr = do + binOp <- label "binary operator" (space *> wrapToHead symbolicExprBinOp <* space) + b <- bParser + return (constr a binOp b) typecastExpr :: a -> (a -> Typename -> a) -> HeadedParsec Void Text a -typecastExpr _prefix _constr = do +typecastExpr prefix constr = do space string "::" endHead space - _type <- typename - return (_constr _prefix _type) + type' <- typename + return (constr prefix type') plusedExpr expr = char '+' *> space *> expr @@ -1164,8 +1160,8 @@ (c, d) -> ImplicitRow c d arrayExprCont = - inBracketsCont $ - asum + inBracketsCont + $ asum [ ArrayExprListArrayExpr <$> sep1 commaSeparator (join arrayExprCont), ExprListArrayExpr <$> exprList, pure EmptyArrayExpr @@ -1175,23 +1171,23 @@ keyword "case" space1 endHead - _arg <- optional (aExpr <* space1) - _whenClauses <- sep1 space1 whenClause + arg <- optional (aExpr <* space1) + whenClauses <- sep1 space1 whenClause space1 - _default <- optional elseClause + default' <- optional elseClause keyword "end" - pure $ CaseExpr _arg _whenClauses _default + pure $ CaseExpr arg whenClauses default' whenClause = do keyword "when" space1 endHead - _a <- aExpr + a <- aExpr space1 keyword "then" space1 - _b <- aExpr - return (WhenClause _a _b) + b <- aExpr + return (WhenClause a b) elseClause = do keyword "else" @@ -1267,7 +1263,7 @@ inParensWithClause (keyword "least") (LeastFuncExprCommonSubexpr <$> exprList) ] where - labeledIconst _label = keyword _label *> endHead *> optional (space *> inParens iconst) + labeledIconst label = keyword label *> endHead *> optional (space *> inParens iconst) extractList = ExtractList <$> extractArg <*> (space1 *> keyword "from" *> space1 *> aExpr) @@ -1349,26 +1345,26 @@ ] normalFuncApplicationParams = do - _optAllOrDistinct <- optional (allOrDistinct <* space1) - _argList <- sep1 commaSeparator funcArgExpr + optAllOrDistinct <- optional (allOrDistinct <* space1) + argList <- sep1 commaSeparator funcArgExpr endHead - _optSortClause <- optional (space1 *> sortClause) - return (NormalFuncApplicationParams _optAllOrDistinct _argList _optSortClause) + optSortClause <- optional (space1 *> sortClause) + return (NormalFuncApplicationParams optAllOrDistinct argList optSortClause) singleVariadicFuncApplicationParams = do keyword "variadic" space1 endHead - _arg <- funcArgExpr - _optSortClause <- optional (space1 *> sortClause) - return (VariadicFuncApplicationParams Nothing _arg _optSortClause) + arg <- funcArgExpr + optSortClause <- optional (space1 *> sortClause) + return (VariadicFuncApplicationParams Nothing arg optSortClause) listVariadicFuncApplicationParams = do - (_argList, _) <- wrapToHead $ sepEnd1 commaSeparator (keyword "variadic" <* space1) funcArgExpr + (argList, _) <- wrapToHead $ sepEnd1 commaSeparator (keyword "variadic" <* space1) funcArgExpr endHead - _arg <- funcArgExpr - _optSortClause <- optional (space1 *> sortClause) - return (VariadicFuncApplicationParams (Just _argList) _arg _optSortClause) + arg <- funcArgExpr + optSortClause <- optional (space1 *> sortClause) + return (VariadicFuncApplicationParams (Just argList) arg optSortClause) starFuncApplicationParams = space *> char '*' *> endHead *> space $> StarFuncApplicationParams @@ -1668,11 +1664,11 @@ selectLimit = asum [ do - _a <- limitClause - LimitOffsetSelectLimit _a <$> (space1 *> offsetClause) <|> pure (LimitSelectLimit _a), + a <- limitClause + LimitOffsetSelectLimit a <$> (space1 *> offsetClause) <|> pure (LimitSelectLimit a), do - _a <- offsetClause - OffsetLimitSelectLimit _a <$> (space1 *> limitClause) <|> pure (OffsetSelectLimit _a) + a <- offsetClause + OffsetLimitSelectLimit a <$> (space1 *> limitClause) <|> pure (OffsetSelectLimit a) ] -- | @@ -1689,31 +1685,31 @@ keyword "limit" endHead space1 - _a <- selectLimitValue - _b <- optional $ do + a <- selectLimitValue + b <- optional $ do commaSeparator aExpr - return (LimitLimitClause _a _b) + return (LimitLimitClause a b) ) <|> ( do keyword "fetch" endHead space1 - _a <- firstOrNext + a <- firstOrNext space1 asum [ do - _b <- rowOrRows + b <- rowOrRows space1 keyword "only" - return (FetchOnlyLimitClause _a Nothing _b), + return (FetchOnlyLimitClause a Nothing b), do - _b <- selectFetchFirstValue + b <- selectFetchFirstValue space1 - _c <- rowOrRows + c <- rowOrRows space1 keyword "only" - return (FetchOnlyLimitClause _a (Just _b) _c) + return (FetchOnlyLimitClause a (Just b) c) ] ) @@ -1783,10 +1779,10 @@ -- | EMPTY -- @ forLockingItem = do - _strength <- forLockingStrength - _rels <- optional $ space1 *> keyword "of" *> space1 *> endHead *> sep1 commaSeparator qualifiedName - _nowaitOrSkip <- optional (space1 *> nowaitOrSkip) - return (ForLockingItem _strength _rels _nowaitOrSkip) + strength <- forLockingStrength + rels <- optional $ space1 *> keyword "of" *> space1 *> endHead *> sep1 commaSeparator qualifiedName + nowaitOrSkip <- optional (space1 *> nowaitOrSkip) + return (ForLockingItem strength rels nowaitOrSkip) -- | -- ==== References @@ -1828,14 +1824,15 @@ -- @ {-# NOINLINE colId #-} colId = - label "identifier" $ - ident <|> keywordNameFromSet (KeywordSet.unreservedKeyword <> KeywordSet.colNameKeyword) + label "identifier" + $ ident + <|> keywordNameFromSet (KeywordSet.unreservedKeyword <> KeywordSet.colNameKeyword) {-# NOINLINE filteredColId #-} filteredColId = - let _originalSet = KeywordSet.unreservedKeyword <> KeywordSet.colNameKeyword - _filteredSet = foldr HashSet.delete _originalSet - in \_reservedKeywords -> label "identifier" $ ident <|> keywordNameFromSet (_filteredSet _reservedKeywords) + let originalSet = KeywordSet.unreservedKeyword <> KeywordSet.colNameKeyword + filteredSet = foldr HashSet.delete originalSet + in \reservedKeywords -> label "identifier" $ ident <|> keywordNameFromSet (filteredSet reservedKeywords) -- | -- ==== References @@ -1848,8 +1845,9 @@ -- | reserved_keyword -- @ colLabel = - label "column label" $ - keywordNameFromSet KeywordSet.keyword <|> ident + label "column label" + $ keywordNameFromSet KeywordSet.keyword + <|> ident -- | -- >>> testParser qualifiedName "a.b" @@ -1871,7 +1869,7 @@ columnref = customizedColumnref colId -filteredColumnref _keywords = customizedColumnref (filteredColId _keywords) +filteredColumnref keywords = customizedColumnref (filteredColId keywords) customizedColumnref colId = do a <- wrapToHead colId @@ -1881,7 +1879,7 @@ anyName = customizedAnyName colId -filteredAnyName _keywords = customizedAnyName (filteredColId _keywords) +filteredAnyName keywords = customizedAnyName (filteredColId keywords) customizedAnyName colId = do a <- wrapToHead colId @@ -1950,29 +1948,29 @@ char '[' endHead space - _a <- + a <- asum [ do char ':' endHead space - _b <- optional aExpr - return (SliceIndirectionEl Nothing _b), + b <- optional aExpr + return (SliceIndirectionEl Nothing b), do - _a <- aExpr + a <- aExpr asum [ do space char ':' space - _b <- optional aExpr - return (SliceIndirectionEl (Just _a) _b), - return (ExprIndirectionEl _a) + b <- optional aExpr + return (SliceIndirectionEl (Just a) b), + return (ExprIndirectionEl a) ] ] space char ']' - return _a + return a ] -- | @@ -1983,20 +1981,21 @@ -- @ attrName = colLabel -keywordNameFromSet _set = keywordNameByPredicate (Predicate.inSet _set) +keywordNameFromSet set = keywordNameByPredicate (Predicate.inSet set) -keywordNameByPredicate _predicate = - fmap UnquotedIdent $ - filter +keywordNameByPredicate predicate = + fmap UnquotedIdent + $ filter (\a -> "Reserved keyword " <> show a <> " used as an identifier. If that's what you intend, you have to wrap it in double quotes.") - _predicate + predicate anyKeyword -anyKeyword = parse $ - Megaparsec.label "keyword" $ do - _firstChar <- Megaparsec.satisfy Predicate.firstIdentifierChar - _remainder <- Megaparsec.takeWhileP Nothing Predicate.notFirstIdentifierChar - return (Text.toLower (Text.cons _firstChar _remainder)) +anyKeyword = parse + $ Megaparsec.label "keyword" + $ do + firstChar <- Megaparsec.satisfy Predicate.firstIdentifierChar + remainder <- Megaparsec.takeWhileP Nothing Predicate.notFirstIdentifierChar + return (Text.toLower (Text.cons firstChar remainder)) -- | Expected keyword keyword a = mfilter (a ==) anyKeyword @@ -2044,20 +2043,20 @@ arrayBounds = sep1 space (inBrackets (optional iconst)) simpleTypename = - asum $ - [ do - keyword "interval" - endHead - asum - [ ConstIntervalSimpleTypename <$> Right <$> (space *> inParens iconst), - ConstIntervalSimpleTypename <$> Left <$> optional (space *> interval) - ], - ConstDatetimeSimpleTypename <$> constDatetime, - NumericSimpleTypename <$> numeric, - BitSimpleTypename <$> bit, - CharacterSimpleTypename <$> character, - GenericTypeSimpleTypename <$> genericType - ] + asum + $ [ do + keyword "interval" + endHead + asum + [ ConstIntervalSimpleTypename <$> Right <$> (space *> inParens iconst), + ConstIntervalSimpleTypename <$> Left <$> optional (space *> interval) + ], + ConstDatetimeSimpleTypename <$> constDatetime, + NumericSimpleTypename <$> numeric, + BitSimpleTypename <$> bit, + CharacterSimpleTypename <$> character, + GenericTypeSimpleTypename <$> genericType + ] genericType = do a <- typeFunctionName diff --git a/library/PostgresqlSyntax/Predicate.hs b/library/PostgresqlSyntax/Predicate.hs --- a/library/PostgresqlSyntax/Predicate.hs +++ b/library/PostgresqlSyntax/Predicate.hs @@ -1,9 +1,11 @@ +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + module PostgresqlSyntax.Predicate where import qualified Data.HashSet as HashSet import qualified PostgresqlSyntax.CharSet as CharSet import qualified PostgresqlSyntax.KeywordSet as KeywordSet -import PostgresqlSyntax.Prelude hiding (expression) +import PostgresqlSyntax.Prelude -- * Generic @@ -23,12 +25,9 @@ inSet :: (Eq a, Hashable a) => HashSet a -> a -> Bool inSet = flip HashSet.member --- * - +hexDigit :: Char -> Bool hexDigit = inSet CharSet.hexDigit --- * - {- ident_start [A-Za-z\200-\377_] -} @@ -62,8 +61,11 @@ -- ** Op chars +opChar :: Char -> Bool opChar = inSet CharSet.op +prohibitedOpChar :: Char -> Bool prohibitedOpChar a = a == '+' || a == '-' +prohibitionLiftingOpChar :: Char -> Bool prohibitionLiftingOpChar = inSet CharSet.prohibitionLiftingOp diff --git a/library/PostgresqlSyntax/Prelude.hs b/library/PostgresqlSyntax/Prelude.hs --- a/library/PostgresqlSyntax/Prelude.hs +++ b/library/PostgresqlSyntax/Prelude.hs @@ -29,7 +29,7 @@ import Data.Fixed as Exports import Data.Foldable as Exports import Data.Function as Exports hiding (id, (.)) -import Data.Functor as Exports +import Data.Functor as Exports hiding (unzip) import Data.Functor.Identity as Exports import Data.HashMap.Strict as Exports (HashMap) import Data.HashSet as Exports (HashSet) @@ -37,7 +37,7 @@ import Data.IORef as Exports import Data.Int as Exports import Data.Ix as Exports -import Data.List as Exports hiding (all, and, any, concat, concatMap, elem, find, foldl, foldl', foldl1, foldr, foldr1, isSubsequenceOf, mapAccumL, mapAccumR, maximum, maximumBy, minimum, minimumBy, notElem, or, product, sortOn, sum, uncons) +import Data.List as Exports hiding (all, and, any, concat, concatMap, elem, find, foldl, foldl', foldl1, foldr, foldr1, isSubsequenceOf, mapAccumL, mapAccumR, maximum, maximumBy, minimum, minimumBy, notElem, or, product, sortOn, sum, uncons, unsnoc) import Data.List.NonEmpty as Exports (NonEmpty (..)) import Data.Maybe as Exports import Data.Monoid as Exports hiding (First (..), Last (..), (<>)) @@ -72,20 +72,24 @@ import System.Mem as Exports import System.Mem.StableName as Exports import System.Timeout as Exports -import Text.ParserCombinators.ReadP as Exports (ReadP, ReadS, readP_to_S, readS_to_P) -import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readP_to_Prec, readPrec_to_P, readPrec_to_S, readS_to_Prec) import Text.Printf as Exports (hPrintf, printf) import Text.Read as Exports (Read (..), readEither, readMaybe) import Unsafe.Coerce as Exports import Prelude as Exports hiding (all, and, any, concat, concatMap, elem, fail, foldl, foldl1, foldr, foldr1, id, mapM, mapM_, maximum, minimum, notElem, or, product, sequence, sequence_, sum, (.)) -showAsText :: Show a => a -> Text +showAsText :: (Show a) => a -> Text showAsText = show >>> fromString -- | -- Compose a monad, which attempts to extend a value, based on the following input. --- It does that recursively until the suffix alternative fails. -suffixRec :: (Monad m, Alternative m) => m a -> (a -> m a) -> m a -suffixRec base suffix = do - _base <- base - suffixRec (suffix _base) suffix <|> pure _base +-- It does so recursively until the suffix alternative fails. +suffixRec :: (MonadPlus m) => m a -> (a -> m a) -> m a +suffixRec base suffix = base >>= extendMany suffix + +extendMany :: (MonadPlus m) => (a -> m a) -> a -> m a +extendMany attempt = loop + where + loop !state = + optional (attempt state) >>= \case + Nothing -> pure state + Just newState -> loop newState diff --git a/library/PostgresqlSyntax/Rendering.hs b/library/PostgresqlSyntax/Rendering.hs --- a/library/PostgresqlSyntax/Rendering.hs +++ b/library/PostgresqlSyntax/Rendering.hs @@ -1,6 +1,7 @@ +{-# OPTIONS_GHC -Wno-missing-signatures -Wno-dodgy-imports #-} + module PostgresqlSyntax.Rendering where -import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import PostgresqlSyntax.Ast @@ -398,8 +399,8 @@ windowDefinition (WindowDefinition a b) = ident a <> " AS " <> windowSpecification b windowSpecification (WindowSpecification a b c d) = - inParens $ - optLexemes + inParens + $ optLexemes [ fmap ident a, fmap partitionClause b, fmap sortClause c, @@ -566,8 +567,6 @@ GreaterEqualsMathOp -> ">=" ArrowLeftArrowRightMathOp -> "<>" ExclamationEqualsMathOp -> "!=" - --- * inExpr = \case SelectInExpr a -> selectWithParens a diff --git a/library/PostgresqlSyntax/Validation.hs b/library/PostgresqlSyntax/Validation.hs --- a/library/PostgresqlSyntax/Validation.hs +++ b/library/PostgresqlSyntax/Validation.hs @@ -1,10 +1,9 @@ module PostgresqlSyntax.Validation where -import qualified Data.HashSet as HashSet import qualified Data.Text as Text -import qualified PostgresqlSyntax.KeywordSet as HashSet +import qualified PostgresqlSyntax.KeywordSet as KeywordSet import qualified PostgresqlSyntax.Predicate as Predicate -import PostgresqlSyntax.Prelude hiding (expression) +import PostgresqlSyntax.Prelude {- The operator name is a sequence of up to NAMEDATALEN-1 (63 by default) @@ -41,7 +40,7 @@ if Text.isInfixOf "/*" a then Just ("Operator contains a prohibited \"/*\" sequence: " <> a) else - if Predicate.inSet HashSet.nonOp a + if Predicate.inSet KeywordSet.nonOp a then Just ("Operator is not generic: " <> a) else if Text.find Predicate.prohibitionLiftingOpChar a & isJust diff --git a/postgresql-syntax.cabal b/postgresql-syntax.cabal --- a/postgresql-syntax.cabal +++ b/postgresql-syntax.cabal @@ -1,78 +1,118 @@ -name: postgresql-syntax -version: 0.4.1 -category: Database, PostgreSQL, Parsing -synopsis: PostgreSQL AST parsing and rendering +cabal-version: 3.0 +name: postgresql-syntax +version: 0.4.1.1 +category: Database, PostgreSQL, Parsing +synopsis: PostgreSQL AST parsing and rendering description: Postgres syntax tree and related utils extracted from the \"hasql-th\" package. The API is in a rather raw \"guts out\" state with most documentation lacking, but the codebase is well tested. -homepage: https://github.com/nikita-volkov/postgresql-syntax -bug-reports: https://github.com/nikita-volkov/postgresql-syntax/issues -author: Nikita Volkov -maintainer: Nikita Volkov -copyright: (c) 2020, Nikita Volkov -license: MIT -license-file: LICENSE -build-type: Simple -cabal-version: >=1.10 +homepage: https://github.com/nikita-volkov/postgresql-syntax +bug-reports: https://github.com/nikita-volkov/postgresql-syntax/issues +author: Nikita Volkov +maintainer: Nikita Volkov +copyright: (c) 2020, Nikita Volkov +license: MIT +license-file: LICENSE + source-repository head - type: git + type: git location: git://github.com/nikita-volkov/postgresql-syntax.git +common base-settings + default-language: Haskell2010 + default-extensions: + NoImplicitPrelude + NoMonomorphismRestriction + ApplicativeDo + Arrows + BangPatterns + ConstraintKinds + DataKinds + DefaultSignatures + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + DuplicateRecordFields + EmptyDataDecls + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + LambdaCase + LiberalTypeSynonyms + MagicHash + MultiParamTypeClasses + MultiWayIf + OverloadedStrings + ParallelListComp + PatternGuards + QuasiQuotes + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TemplateHaskell + TupleSections + TypeApplications + TypeFamilies + TypeOperators + UnboxedTuples + library - hs-source-dirs: library - default-extensions: ApplicativeDo, Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, DuplicateRecordFields, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples - default-language: Haskell2010 + import: base-settings + hs-source-dirs: library exposed-modules: PostgresqlSyntax.Ast PostgresqlSyntax.KeywordSet PostgresqlSyntax.Parsing PostgresqlSyntax.Rendering PostgresqlSyntax.Validation + other-modules: PostgresqlSyntax.CharSet - PostgresqlSyntax.Extras.TextBuilder PostgresqlSyntax.Extras.HeadedMegaparsec PostgresqlSyntax.Extras.NonEmpty + PostgresqlSyntax.Extras.TextBuilder PostgresqlSyntax.Predicate PostgresqlSyntax.Prelude + build-depends: - base >=4.12 && <5, - bytestring >=0.10 && <0.12, - case-insensitive >=1.2.1 && <2, - hashable >=1.3.5 && <2, - headed-megaparsec >=0.2.0.1 && <0.3, - megaparsec >=9.2 && <10, - parser-combinators >=1.3 && <1.4, - text >=1 && <3, - text-builder >=0.6.6.3 && <0.7, - unordered-containers >=0.2.16 && <0.3 + , base >=4.12 && <5 + , bytestring >=0.10 && <0.13 + , case-insensitive >=1.2.1 && <2 + , hashable >=1.3.5 && <2 + , headed-megaparsec >=0.2.0.1 && <0.3 + , megaparsec >=9.2 && <10 + , parser-combinators >=1.3 && <1.4 + , text >=1 && <3 + , text-builder >=0.6.6.3 && <0.7 + , unordered-containers >=0.2.16 && <0.3 test-suite tasty-test - type: exitcode-stdio-1.0 + import: base-settings + type: exitcode-stdio-1.0 hs-source-dirs: tasty-test - main-is: Main.hs - default-extensions: ApplicativeDo, Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, DuplicateRecordFields, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples - default-language: Haskell2010 + main-is: Main.hs + ghc-options: -threaded build-depends: - postgresql-syntax, - QuickCheck >=2.10 && <3, - quickcheck-instances >=0.3.22 && <0.4, - rerebase <2, - tasty >=1.2.3 && <2, - tasty-hunit >=0.10 && <0.11, - tasty-quickcheck >=0.10 && <0.11 + , postgresql-syntax + , rerebase <2 + , tasty >=1.2.3 && <2 + , tasty-hunit >=0.10 && <0.11 test-suite hedgehog-test - type: exitcode-stdio-1.0 + import: base-settings + type: exitcode-stdio-1.0 hs-source-dirs: hedgehog-test - default-extensions: ApplicativeDo, Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, DuplicateRecordFields, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples - default-language: Haskell2010 - main-is: Main.hs - other-modules: - Main.Gen + main-is: Main.hs + ghc-options: -threaded + other-modules: Main.Gen build-depends: - hedgehog >=1.0.1 && <2, - postgresql-syntax, - rerebase >=1.6.1 && <2 + , hedgehog >=1.0.1 && <2 + , postgresql-syntax + , rerebase >=1.6.1 && <2 diff --git a/tasty-test/Main.hs b/tasty-test/Main.hs --- a/tasty-test/Main.hs +++ b/tasty-test/Main.hs @@ -1,71 +1,61 @@ module Main where import qualified Data.Text as Text -import qualified PostgresqlSyntax.Ast as Ast import qualified PostgresqlSyntax.Parsing as Parsing -import qualified PostgresqlSyntax.Rendering as Rendering -import qualified Test.QuickCheck as QuickCheck -import Test.QuickCheck.Instances import Test.Tasty import Test.Tasty.HUnit -import Test.Tasty.QuickCheck -import Test.Tasty.Runners import Prelude hiding (assert) +main :: IO () main = - defaultMain $ - testGroup + defaultMain + $ testGroup "" - [ testGroup "Parsers" $ - let testParserOnAllInputs parserName parser inputs = - testCase parserName $ - forM_ inputs $ \input -> case Parsing.run parser input of - Left err -> assertFailure (err <> "\ninput: " <> Text.unpack input) - Right _ -> return () - testParserOnEachInput parserName parser inputs = - testGroup parserName $ - flip fmap inputs $ \input -> - testCase (Text.unpack input) $ case Parsing.run parser input of - Left err -> assertFailure err + [ testGroup "Parsers" + $ let testParserOnAllInputs parserName parser inputs = + testCase parserName + $ forM_ inputs + $ \input -> case Parsing.run parser input of + Left err -> assertFailure (err <> "\ninput: " <> Text.unpack input) Right _ -> return () - in [ testParserOnAllInputs - "preparableStmt" - Parsing.preparableStmt - [ "select i :: int8 from auth.user as u\n\ - \inner join edgenode.usere_provider as p\n\ - \on u.id = p.user_id\n\ - \inner join edgenode.provider_branch as b\n\ - \on b.provider_fk = p.provider_id" - ], - testParserOnAllInputs - "typename" - Parsing.typename - [ "int4[]", - "int4[][]", - "int4?[]", - "int4?[]?", - "aa array", - "DOUBLE PRECISION", - "bool", - "int2", - "int4", - "int8", - "float4", - "float8", - "numeric", - "char", - "text", - "bytea", - "date", - "timestamp", - "timestamptz", - "time", - "timetz", - "interval", - "uuid", - "inet", - "json", - "jsonb" - ] - ] + in [ testParserOnAllInputs + "preparableStmt" + Parsing.preparableStmt + [ "select i :: int8 from auth.user as u\n\ + \inner join edgenode.usere_provider as p\n\ + \on u.id = p.user_id\n\ + \inner join edgenode.provider_branch as b\n\ + \on b.provider_fk = p.provider_id" + ], + testParserOnAllInputs + "typename" + Parsing.typename + [ "int4[]", + "int4[][]", + "int4?[]", + "int4?[]?", + "aa array", + "DOUBLE PRECISION", + "bool", + "int2", + "int4", + "int8", + "float4", + "float8", + "numeric", + "char", + "text", + "bytea", + "date", + "timestamp", + "timestamptz", + "time", + "timetz", + "interval", + "uuid", + "inet", + "json", + "jsonb" + ] + ] ]