hlint pass

Author: JakeWheat

Language/SQL/SimpleSQL/Lex.hs

@@ -71,7 +71,6 @@ try again to add annotation to the ast
 -}
 
 -- | Lexer for SQL.
-{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards   #-}
 {-# LANGUAGE TypeFamilies      #-}
@@ -150,6 +149,7 @@ import Data.Char
 import Control.Monad (void, guard)
 import Data.Text (Text)
 import qualified Data.Text as T
+import Data.Maybe (fromMaybe)
 
 ------------------------------------------------------------------------------
 
@@ -223,13 +223,13 @@ lexSQL
     -- ^ the SQL source to lex
     -> Either ParseError [Token]
 lexSQL dialect fn p src =
-    fmap (map tokenVal) $ lexSQLWithPositions dialect fn p src
+    map tokenVal <$> lexSQLWithPositions dialect fn p src
 
-myParse :: Text -> (Maybe (Int,Int)) -> Parser a -> Text -> Either ParseError a
+myParse :: Text -> Maybe (Int,Int) -> Parser a -> Text -> Either ParseError a
 myParse name sp' p s =
-        let sp = maybe (1,1) id sp'
+        let sp = fromMaybe (1,1) sp'
             ps = SourcePos (T.unpack name) (mkPos $ fst sp) (mkPos $ snd sp)
-            is = (initialState (T.unpack name) s)
+            is = initialState (T.unpack name) s
             sps = (statePosState is) {pstateSourcePos = ps}
             is' = is {statePosState = sps}
         in snd $ runParser' p is'
@@ -352,7 +352,7 @@ sqlString d = dollarString <|> csString <|> normalString
                 <$> try cs
                 <*> pure "'"
                 <*> normalStringSuffix False ""
-    csPrefixes = (map (flip T.cons "'") "nNbBxX") ++ ["u&'", "U&'"]
+    csPrefixes = map (`T.cons` "'") "nNbBxX" ++ ["u&'", "U&'"]
     cs :: Parser Text
     cs = choice $ map string csPrefixes
 
@@ -387,7 +387,7 @@ identifier d =
     -- 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 "&"))
+                        <$> (f <$> try (oneOf "uU" <* string "&"))
                         <*> qidenPart
       where f x = Just (T.cons x "&\"", "\"")
     qidenPart = char '"' *> qidenSuffix ""
@@ -404,7 +404,7 @@ identifierString :: Parser Text
 identifierString = (do
     c <- satisfy isFirstLetter
     choice
-        [T.cons c <$> (takeWhileP (Just "identifier char") isIdentifierChar)
+        [T.cons c <$> takeWhileP (Just "identifier char") isIdentifierChar
         ,pure $ T.singleton c]) <?> "identifier"
   where
      isFirstLetter c = c == '_' || isAlpha c
@@ -486,7 +486,7 @@ sqlNumber d =
     -- this is for definitely avoiding possibly ambiguous source
     <* choice [-- special case to allow e.g. 1..2
                guard (diPostgresSymbols d)
-               *> (void $ lookAhead $ try $ (string ".." <?> ""))
+               *> void (lookAhead $ try (string ".." <?> ""))
                   <|> void (notFollowedBy (oneOf "eE."))
               ,notFollowedBy (oneOf "eE.")
               ]
@@ -737,7 +737,7 @@ two symbols next to eachother will fail if the symbols can combine and
     | diPostgresSymbols d
     , Symbol a' <- a
     , Symbol b' <- b
-    , b' `notElem` ["+", "-"] || or (map (`T.elem` a') "~!@#%^&|`?") = False
+    , b' `notElem` ["+", "-"] || any (`T.elem` a') ("~!@#%^&|`?" :: [Char]) = False
 
 {-
 check two adjacent symbols in non postgres where the combination

Language/SQL/SimpleSQL/Parse.hs

@@ -217,6 +217,7 @@ import Control.Monad.Reader
     (Reader
     ,runReader
     ,ask
+    ,asks
     )
 
 import qualified Data.Set           as Set
@@ -227,7 +228,7 @@ import Control.Applicative ((<**>))
 import Data.Char (isDigit)
 import Data.List (sort,groupBy)
 import Data.Function (on)
-import Data.Maybe (catMaybes, isJust)
+import Data.Maybe (catMaybes, isJust, mapMaybe)
 import Data.Text (Text)
 import qualified Data.Text as T
 
@@ -379,7 +380,7 @@ u&"example quoted"
 
 name :: Parser Name
 name = do
-    bl <- queryDialect diKeywords
+    bl <- askDialect diKeywords
     uncurry Name <$> identifierTok bl
 
 -- todo: replace (:[]) with a named function all over
@@ -561,7 +562,7 @@ typeName =
     -- type names, plus all the type names which are
     -- reserved words
     reservedTypeNames = do
-        stn <- queryDialect diSpecialTypeNames
+        stn <- askDialect diSpecialTypeNames
         (:[]) . Name Nothing . T.unwords <$> makeKeywordTree stn
 
 
@@ -771,7 +772,7 @@ idenExpr =
     -- special cases for keywords that can be parsed as an iden or app
     keywordFunctionOrIden = try $ do
         x <- unquotedIdentifierTok [] Nothing
-        d <- queryDialect id
+        d <- askDialect id
         let i = T.toLower x `elem` diIdentifierKeywords d
             a = T.toLower x `elem` diAppKeywords d
         case () of
@@ -923,7 +924,7 @@ app =
     openParen *> choice
     [duplicates
      <**> (commaSep1 scalarExpr
-           <**> (((option [] orderBy) <* closeParen)
+           <**> ((option [] orderBy <* closeParen)
                  <**> (optional afilter <$$$$$> AggregateApp)))
      -- separate cases with no all or distinct which must have at
      -- least one scalar expr
@@ -967,17 +968,17 @@ window :: Parser ([ScalarExpr] -> [Name] -> ScalarExpr)
 window =
   keyword_ "over" *> openParen *> option [] partitionBy
   <**> (option [] orderBy
-        <**> (((optional frameClause) <* closeParen) <$$$$$> WindowApp))
+        <**> ((optional frameClause <* closeParen) <$$$$$> WindowApp))
   where
     partitionBy = keywords_ ["partition","by"] *> commaSep1 scalarExpr
     frameClause =
         frameRowsRange -- TODO: this 'and' could be an issue
-        <**> (choice [(keyword_ "between" *> frameLimit True)
+        <**> choice [(keyword_ "between" *> frameLimit True)
                       <**> ((keyword_ "and" *> frameLimit True)
                             <$$$> FrameBetween)
                       -- maybe this should still use a b expression
                       -- for consistency
-                     ,frameLimit False <**> pure (flip FrameFrom)])
+                     ,frameLimit False <**> pure (flip FrameFrom)]
     frameRowsRange = FrameRows <$ keyword_ "rows"
                      <|> FrameRange <$ keyword_ "range"
     frameLimit useB =
@@ -1013,7 +1014,7 @@ inSuffix =
   where
     inty = choice [True <$ keyword_ "in"
                   ,False <$ keywords_ ["not","in"]]
-    mkIn i v = \e -> In i e v
+    mkIn i v e = In i e v
 
 {-
 === between
@@ -1034,14 +1035,15 @@ and operator. This is the call to scalarExprB.
 
 betweenSuffix :: Parser (ScalarExpr -> ScalarExpr)
 betweenSuffix =
-    makeOp <$> Name Nothing <$> opName
+    makeOp . Name Nothing
+           <$> opName
            <*> scalarExprB
            <*> (keyword_ "and" *> scalarExprB)
   where
     opName = choice
              ["between" <$ keyword_ "between"
              ,"not between" <$ try (keywords_ ["not","between"])]
-    makeOp n b c = \a -> SpecialOp [n] [a,b,c]
+    makeOp n b c a = SpecialOp [n] [a,b,c]
 
 {-
 === quantified comparison
@@ -1224,7 +1226,7 @@ opTable bExpr =
 
         ,[prefixKeyword "not"]
 
-        ,if bExpr then [] else [binaryKeywordL "and"]
+        ,[binaryKeywordL "and" | not bExpr]
 
         ,[binaryKeywordL "or"]
 
@@ -1368,7 +1370,7 @@ 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") >>= optionSuffix joinTrefSuffix
     nonJoinTref = choice
         [parens $ choice
              [TRQueryExpr <$> queryExpr
@@ -1519,7 +1521,7 @@ queryExpr = E.makeExprParser qeterm qeOpTable
         mkSelect
         <$> option SQDefault duplicates
         <*> selectList
-        <*> (optional tableExpression) <?> "table expression"
+        <*> optional tableExpression <?> "table expression"
     mkSelect d sl Nothing =
         toQueryExpr $ makeSelect {msSetQuantifier = d, msSelectList = sl}
     mkSelect d sl (Just (TableExpression f w g h od ofs fe)) =
@@ -1621,15 +1623,15 @@ statementWithoutSemicolon = choice
     ]
 
 statement :: Parser Statement
-statement = statementWithoutSemicolon <* optional semi <|> semi *> pure EmptyStatement
+statement = statementWithoutSemicolon <* optional semi <|> EmptyStatement <$ semi
 
 createSchema :: Parser Statement
 createSchema = keyword_ "schema" >>
     CreateSchema <$> names
 
 createTable :: Parser Statement
 createTable = do 
-  d <- queryDialect id
+  d <- askDialect id
   let 
     parseColumnDef = TableColumnDef <$> columnDef 
     parseConstraintDef = uncurry TableConstraintDef <$> tableConstraintDef
@@ -1675,7 +1677,7 @@ columnDef = ColumnDef <$> name <*> typeName
 tableConstraintDef :: Parser (Maybe [Name], TableConstraint)
 tableConstraintDef =
     (,)
-    <$> (optional (keyword_ "constraint" *> names))
+    <$> optional (keyword_ "constraint" *> names)
     <*> (unique <|> primaryKey <|> check <|> references)
   where
     unique = keyword_ "unique" >>
@@ -1725,7 +1727,7 @@ colConstraintDef =
     unique = ColUniqueConstraint <$ keyword_ "unique"
     primaryKey = do
       keywords_ ["primary", "key"] 
-      d <- queryDialect id
+      d <- askDialect id
       autoincrement <- if diAutoincrement d 
         then optional (keyword_ "autoincrement")
         else pure Nothing
@@ -2099,9 +2101,9 @@ makeKeywordTree sets =
     parseGroup :: [[Text]] -> Parser [Text]
     parseGroup l@((k:_):_) = do
         keyword_ k
-        let tls = catMaybes $ map safeTail l
+        let tls = mapMaybe safeTail l
             pr = (k:) <$> parseTrees tls
-        if (or $ map null tls)
+        if any null tls
           then pr <|> pure [k]
           else pr
     parseGroup _ = guard False >> fail "impossible"
@@ -2175,7 +2177,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) <?> T.unpack s
 
 singleCharSymbol :: Char -> Parser Char
 singleCharSymbol c = c <$ symbol (T.singleton c)
@@ -2205,12 +2207,12 @@ semi = singleCharSymbol ';' <?> ""
 -- = helper functions
 
 keyword :: Text -> Parser Text
-keyword k = unquotedIdentifierTok [] (Just k) <?> (T.unpack k)
+keyword k = unquotedIdentifierTok [] (Just k) <?> T.unpack k
 
 -- helper function to improve error messages
 
 keywords_ :: [Text] -> Parser ()
-keywords_ ks = mapM_ keyword_ ks <?> (T.unpack (T.unwords ks))
+keywords_ ks = mapM_ keyword_ ks <?> T.unpack (T.unwords ks)
 
 
 parens :: Parser a -> Parser a
@@ -2270,7 +2272,7 @@ stringTokExtend = do
          guard (s == "'" && e == "'")
          (s',e',y) <- stringTokExtend
          guard (s' == "'" && e' == "'")
-         pure $ (s,e,x <> y)
+         pure (s,e,x <> y)
         ,pure (s,e,x)
         ]
 
@@ -2361,12 +2363,8 @@ unquotedIdentifierTok blackList kw = token test Set.empty <?> ""
 -- dialect
 
 guardDialect :: (Dialect -> Bool) -> Parser ()
-guardDialect p = do
-    d <- ask
-    guard (p d)
-
-queryDialect :: (Dialect -> a) -> Parser a
-queryDialect f = do
-    d <- ask
-    pure $ f d
+guardDialect p = guard . p =<< ask
+
+askDialect :: (Dialect -> a) -> Parser a
+askDialect = asks
 

Language/SQL/SimpleSQL/Pretty.hs

@@ -3,6 +3,7 @@
 -- source from ASTs. The code attempts to format the output in a
 -- readable way.
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
 module Language.SQL.SimpleSQL.Pretty
     (prettyQueryExpr
     ,prettyScalarExpr
@@ -120,7 +121,7 @@ scalarExpr d (WindowApp f es pb od fr) =
     <+> pretty "over"
     <+> parens ((case pb of
                     [] -> mempty
-                    _ -> (pretty "partition by") <+> align
+                    _ -> pretty "partition by" <+> align
                                    (commaSep $ map (scalarExpr d) pb))
                 <+> orderBy d od
     <+> me frd fr)
@@ -142,7 +143,7 @@ scalarExpr dia (SpecialOp nm [a,b,c])
     | nm `elem` [[Name Nothing "between"]
                 ,[Name Nothing "not between"]] =
   sep [scalarExpr dia a
-      ,names nm <+> nest ((T.length (unnames nm) - 3)) (sep
+      ,names nm <+> nest (T.length (unnames nm) - 3) (sep
           [scalarExpr dia b
           ,pretty "and" <+> scalarExpr dia c])]
 
@@ -206,10 +207,10 @@ scalarExpr d (SubQueryExpr ty qe) =
 scalarExpr d (QuantifiedComparison v c cp sq) =
     scalarExpr d v
     <+> names c
-    <+> (pretty $ case cp of
-             CPAny -> "any"
-             CPSome -> "some"
-             CPAll -> "all")
+    <+> pretty (case cp of
+                    CPAny -> "any"
+                    CPSome -> "some"
+                    CPAll -> "all")
     <+> parens (queryExpr d sq)
 
 scalarExpr d (Match v u sq) =
@@ -306,13 +307,13 @@ typeName (PrecScaleTypeName t a b) =
 typeName (PrecLengthTypeName t i m u) =
     names t
     <> parens (pretty (show i)
-               <> me (\x -> case x of
+               <> me (\case
                            PrecK -> pretty "K"
                            PrecM -> pretty "M"
                            PrecG -> pretty "G"
                            PrecT -> pretty "T"
                            PrecP -> pretty "P") m
-               <+> me (\x -> case x of
+               <+> me (\case
                        PrecCharacters -> pretty "CHARACTERS"
                        PrecOctets -> pretty "OCTETS") u)
 typeName (CharTypeName t i cs col) =
@@ -350,7 +351,7 @@ intervalTypeField (Itf n p) =
     pretty n
     <+> me (\(x,x1) ->
              parens (pretty (show x)
-                     <+> me (\y -> (sep [comma,pretty (show y)])) x1)) p
+                     <+> me (\y -> sep [comma,pretty (show y)]) x1)) p
 
 
 -- = query expressions
@@ -524,7 +525,7 @@ statement d (AlterDomain nm act) =
     <+> a act
   where
     a (ADSetDefault v) = texts ["set","default"] <+> scalarExpr d v
-    a (ADDropDefault) = texts ["drop","default"]
+    a ADDropDefault = texts ["drop","default"]
     a (ADAddConstraint cnm e) =
         pretty "add"
         <+> maybe mempty (\cnm' -> pretty "constraint" <+> names cnm') cnm
@@ -603,7 +604,7 @@ statement _ (DropTable n b) =
 statement d (CreateView r nm al q co) =
     pretty "create" <+> (if r then pretty "recursive" else mempty)
     <+> pretty "view" <+> names nm
-    <+> (maybe mempty (\al' -> parens $ commaSep $ map name al')) al
+    <+> maybe mempty (parens . commaSep . map name) al
     <+> pretty "as"
     <+> queryExpr d q
     <+> case co of
@@ -731,7 +732,7 @@ columnDef d (ColumnDef n t mdef cons) =
     pcon (ColReferencesConstraint tb c m u del) =
         pretty "references"
         <+> names tb
-        <+> maybe mempty (\c' -> parens (name c')) c
+        <+> maybe mempty (parens . name) c
         <+> refMatch m
         <+> refAct "update" u
         <+> refAct "delete" del