+ GHCi integration of HLint has been provided by Gwern Branwen. The integration allows running :hlint from the GHCi prompt. The script is at hlint.ghci, and a copy is installed locally in the data directory. To use, add the contents to your GHCi startup file. +
+diff --git a/src/CmdLine.hs b/src/CmdLine.hs --- a/src/CmdLine.hs +++ b/src/CmdLine.hs @@ -6,7 +6,6 @@ import Data.Maybe import System.Console.GetOpt import System.Directory -import System.Environment import System.Exit import System.FilePath import Language.Preprocessor.Cpphs @@ -25,6 +24,7 @@ ,cmdShowAll :: Bool -- ^ display all skipped items ,cmdColor :: Bool -- ^ color the result ,cmdCpphs :: CpphsOptions -- ^ options for cpphs + ,cmdDataDir :: FilePath -- ^ the data directory } @@ -36,6 +36,7 @@ | Define String | Include String | Ext String + | DataDir String deriving Eq @@ -48,15 +49,15 @@ ,Option "s" ["show"] (NoArg ShowAll) "Show all ignored ideas" ,Option "e" ["extension"] (ReqArg Ext "ext") "File extensions to search (defaults to hs and lhs)" ,Option "t" ["test"] (NoArg Test) "Run in test mode" + ,Option "d" ["datadir"] (ReqArg DataDir "dir") "Override the data directory" ,Option "" ["cpp-define"] (ReqArg Define "name[=value]") "CPP #define" ,Option "" ["cpp-include"] (ReqArg Include "dir") "CPP include path" ] -- | Exit out if you need to display help info -getCmd :: IO Cmd -getCmd = do - args <- getArgs +getCmd :: [String] -> IO Cmd +getCmd args = do let (opt,files,err) = getOpt Permute opts args let test = Test `elem` opt unless (null err) $ @@ -70,11 +71,13 @@ putStr helpText exitWith ExitSuccess + dataDir <- last $ getDataDir : [return x | DataDir x <- opt] + let exts = [x | Ext x <- opt] files <- concatMapM (getFile $ if null exts then ["hs","lhs"] else exts) files let hintFiles = [x | Hints x <- opt] - hints <- mapM getHintFile $ hintFiles ++ ["HLint" | null hintFiles] + hints <- mapM (getHintFile dataDir) $ hintFiles ++ ["HLint" | null hintFiles] let cpphs = defaultCpphsOptions {boolopts=defaultBoolOptions{locations=False} @@ -91,11 +94,12 @@ ,cmdShowAll = ShowAll `elem` opt ,cmdColor = Color `elem` opt ,cmdCpphs = cpphs + ,cmdDataDir = dataDir } versionText :: String -versionText = "HLint v" ++ showVersion version ++ ", (C) Neil Mitchell 2006-2009\n" +versionText = "HLint v" ++ showVersion version ++ ", (C) Neil Mitchell 2006-2010\n" helpText :: String helpText = unlines @@ -121,10 +125,9 @@ return [file] -getHintFile :: FilePath -> IO FilePath -getHintFile x = do - dat <- getDataDir - let poss = nub $ concat [x : [x <.> "hs" | takeExtension x /= ".hs"] | x <- [x,dat x]] +getHintFile :: FilePath -> FilePath -> IO FilePath +getHintFile dataDir x = do + let poss = nub $ concat [x : [x <.> "hs" | takeExtension x /= ".hs"] | x <- [x,dataDir x]] f poss poss where f o [] = error $ unlines $ [ diff --git a/src/HLint.hs b/src/HLint.hs new file mode 100644 --- /dev/null +++ b/src/HLint.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE RecordWildCards #-} + +module HLint(hlint) where + +import Control.Arrow +import Control.Monad +import Data.List +import Data.Maybe + +import CmdLine +import Settings +import Report +import Type +import Hint +import Test +import Util +import Parallel +import Hint.All +import HSE.All + + +-- | This function takes the command line arguments, and returns the number +-- of errors reported. +hlint :: [String] -> IO Int +hlint args = do + Cmd{..} <- getCmd args + if cmdTest then test cmdDataDir else do + settings <- readSettings cmdDataDir cmdHintFiles + let extra = [Classify Ignore x ("","") | x <- cmdIgnore] + let apply :: FilePath -> IO [Idea] + apply = fmap (fmap $ classify $ settings ++ extra) . applyHint parseFlags{cpphs=Just cmdCpphs} (allHints settings) + ideas <- fmap concat $ parallel [listM' =<< apply x | x <- cmdFiles] + let visideas = filter (\i -> cmdShowAll || rank i /= Ignore) ideas + showItem <- if cmdColor then showANSI else return show + mapM_ (putStrLn . showItem) visideas + + -- figure out statistics + let counts = map (head &&& length) $ group $ sort $ map rank ideas + let [ignore,warn,err] = map (fromMaybe 0 . flip lookup counts) [Ignore,Warning,Error] + let total = ignore + warn + err + let shown = if cmdShowAll then total else total - ignore + + let ignored = [show i ++ " ignored" | let i = total - shown, i /= 0] + let errors = [show err ++ " error" ++ ['s'|err/=1] | err /= 0] + + if shown == 0 then do + when (cmdReports /= []) $ putStrLn "Skipping writing reports" + printMsg "No relevant suggestions" ignored + else do + forM_ cmdReports $ \x -> do + putStrLn $ "Writing report to " ++ x ++ " ..." + writeReport cmdDataDir x visideas + printMsg ("Found " ++ show shown ++ " suggestion" ++ ['s'|shown/=1]) (errors++ignored) + return err + + +printMsg :: String -> [String] -> IO () +printMsg msg xs = + putStrLn $ msg ++ if null xs then "" else + " (" ++ intercalate ", " xs ++ ")" diff --git a/src/HSE/All.hs b/src/HSE/All.hs --- a/src/HSE/All.hs +++ b/src/HSE/All.hs @@ -1,23 +1,18 @@ module HSE.All( - module Language.Haskell.Exts, module HSE.Util, module HSE.Evaluate, module HSE.Bracket, module HSE.Match, module HSE.Generics, module HSE.NameMatch, - ParseFlags(..), parseFlags, parseFile, parseString, fromParseResult + ParseFlags(..), parseFlags, parseFile, parseString ) where -import Language.Haskell.Exts hiding (parse, parseFile, paren, fromParseResult) -import qualified Language.Haskell.Exts as HSE - import HSE.Util import HSE.Evaluate import HSE.Generics import HSE.Bracket import HSE.Match import HSE.NameMatch -import Util import Data.Char import Data.List import Language.Preprocessor.Cpphs @@ -33,7 +28,7 @@ -- | Parse a Haskell module -parseString :: ParseFlags -> FilePath -> String -> ParseResult Module +parseString :: ParseFlags -> FilePath -> String -> ParseResult Module_ parseString flags file = parseFileContentsWithMode mode . maybe id (`runCpphs` file) (cpphs flags) where mode = defaultParseMode @@ -43,17 +38,10 @@ } --- | On failure returns an empty module and prints to the console -parseFile :: ParseFlags -> FilePath -> IO (ParseResult Module) +parseFile :: ParseFlags -> FilePath -> IO (ParseResult Module_) parseFile flags file = do src <- readFile file return $ parseString flags file src - - --- | TODO: Use the fromParseResult in HSE once it gives source location -fromParseResult :: ParseResult Module -> Module -fromParseResult (ParseOk x) = x -fromParseResult (ParseFailed src msg) = error $ showSrcLoc src ++ " Parse failure, " ++ limit 50 msg extension = diff --git a/src/HSE/Bracket.hs b/src/HSE/Bracket.hs --- a/src/HSE/Bracket.hs +++ b/src/HSE/Bracket.hs @@ -3,19 +3,19 @@ module HSE.Bracket where import Control.Monad.State -import Data.Generics.PlateData +import Data.Data +import Data.Generics.Uniplate.Data import Data.Maybe -import Language.Haskell.Exts import HSE.Util -paren :: Exp -> Exp -paren x = if isAtom x then x else Paren x +paren :: Exp s -> Exp s +paren x = if isAtom x then x else Paren (ann x) x -- | Is this item lexically requiring no bracketing ever -- i.e. is totally atomic -isAtom :: Exp -> Bool +isAtom :: Exp s -> Bool isAtom x = case x of Paren{} -> True Var{} -> True @@ -35,7 +35,7 @@ -- Err on the side of caution, True = don't know -needBracket :: Int -> Exp -> Exp -> Bool +needBracket :: Int -> Exp s -> Exp s -> Bool needBracket i parent child | isAtom child = False | InfixApp{} <- parent, isApp child = False @@ -48,16 +48,16 @@ -- True implies I changed this level -descendBracket :: (Exp -> (Bool, Exp)) -> Exp -> Exp +descendBracket :: Data s => (Exp s -> (Bool, Exp s)) -> Exp s -> Exp s descendBracket f x = flip evalState 0 $ flip descendM x $ \y -> do i <- get modify (+1) (b,y) <- return $ f y - let p = if b && needBracket i x y then Paren else id + let p = if b && needBracket i x y then (\x -> Paren (ann x) x) else id return $ p y -transformBracket :: (Exp -> Maybe Exp) -> Exp -> Exp +transformBracket :: Data s => (Exp s -> Maybe (Exp s)) -> Exp s -> Exp s transformBracket f = snd . g where g = f2 . descendBracket g @@ -65,5 +65,5 @@ -- ensure that all the 1-level children are appropriately bracketed -ensureBracket1 :: Exp -> Exp +ensureBracket1 :: Data s => Exp s -> Exp s ensureBracket1 = descendBracket ((,) True) diff --git a/src/HSE/Evaluate.hs b/src/HSE/Evaluate.hs --- a/src/HSE/Evaluate.hs +++ b/src/HSE/Evaluate.hs @@ -3,23 +3,24 @@ -- Evaluate a HSE Exp as much as possible module HSE.Evaluate(evaluate) where -import Language.Haskell.Exts -import Data.Generics.PlateData +import Data.Generics.Uniplate.Data import HSE.Match import HSE.Util import HSE.Bracket -evaluate :: Exp -> Exp +evaluate :: Exp_ -> Exp_ evaluate = fromParen . transform evaluate1 -evaluate1 :: Exp -> Exp -evaluate1 (App len (Lit (String xs))) | len ~= "length" = Lit $ Int $ fromIntegral $ length xs -evaluate1 (App len (List xs)) | len ~= "length" = Lit $ Int $ fromIntegral $ length xs -evaluate1 (view -> App2 op (Lit x) (Lit y)) | op ~= "==" = toNamed $ show $ x == y +evaluate1 :: Exp_ -> Exp_ +evaluate1 (App s len (Lit _ (String _ xs _))) | len ~= "length" = Lit s $ Int s n (show n) + where n = fromIntegral $ length xs +evaluate1 (App s len (List _ xs)) | len ~= "length" = Lit s $ Int s n (show n) + where n = fromIntegral $ length xs +evaluate1 (view -> App2 op (Lit _ x) (Lit _ y)) | op ~= "==" = toNamed $ show $ x =~= y evaluate1 (view -> App2 op x y) | op ~= "&&" && x ~= "True" = y | op ~= "&&" && x ~= "False" = x -evaluate1 (Paren x) | isAtom x = x +evaluate1 (Paren _ x) | isAtom x = x evaluate1 x = x diff --git a/src/HSE/Generics.hs b/src/HSE/Generics.hs --- a/src/HSE/Generics.hs +++ b/src/HSE/Generics.hs @@ -1,7 +1,7 @@ module HSE.Generics( - module Data.Generics, module Data.Generics.PlateData + module Data.Generics, module Data.Generics.Uniplate.Data ) where import Data.Generics hiding (Infix, Fixity) -import Data.Generics.PlateData +import Data.Generics.Uniplate.Data diff --git a/src/HSE/Match.hs b/src/HSE/Match.hs --- a/src/HSE/Match.hs +++ b/src/HSE/Match.hs @@ -1,10 +1,9 @@ -{-# LANGUAGE ViewPatterns, MultiParamTypeClasses #-} +{-# LANGUAGE ViewPatterns, MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances #-} module HSE.Match where import Data.Char import Data.List -import Language.Haskell.Exts import HSE.Util @@ -12,27 +11,39 @@ view :: a -> b -data App2 = NoApp2 | App2 Exp Exp Exp deriving Show +data App2 = NoApp2 | App2 Exp_ Exp_ Exp_ deriving Show -instance View Exp App2 where - view (fromParen -> InfixApp lhs op rhs) = view $ opExp op `App` lhs `App` rhs - view (fromParen -> (fromParen -> f `App` x) `App` y) = App2 f x y +instance View Exp_ App2 where + view (fromParen -> InfixApp _ lhs op rhs) = App2 (opExp op) lhs rhs + view (fromParen -> App _ (fromParen -> App _ f x) y) = App2 f x y view _ = NoApp2 -data App1 = NoApp1 | App1 Exp Exp deriving Show +data App1 = NoApp1 | App1 Exp_ Exp_ deriving Show -instance View Exp App1 where - view (fromParen -> f `App` x) = App1 f x +instance View Exp_ App1 where + view (fromParen -> App _ f x) = App1 f x view _ = NoApp1 +data PVar_ = NoPVar_ | PVar_ String -(~=) :: Exp -> String -> Bool +instance View Pat_ PVar_ where + view (fromPParen -> PVar _ x) = PVar_ $ fromNamed x + view _ = NoPVar_ + +data Var_ = NoVar_ | Var_ String deriving Eq + +instance View Exp_ Var_ where + view (fromParen -> Var _ (UnQual _ x)) = Var_ $ fromNamed x + view _ = NoVar_ + + +(~=) :: Exp_ -> String -> Bool (~=) = (==) . fromNamed --- | fromNamed will return "" when it cannot be represented --- toNamed may crash on "" +-- | fromNamed will return \"\" when it cannot be represented +-- toNamed may crash on \"\" class Named a where toNamed :: String -> a fromNamed :: a -> String @@ -45,67 +56,78 @@ isSym _ = False -instance Named Exp where - fromNamed (Var x) = fromNamed x - fromNamed (Con x) = fromNamed x - fromNamed (List []) = "[]" +instance Named (Exp S) where + fromNamed (Var _ x) = fromNamed x + fromNamed (Con _ x) = fromNamed x + fromNamed (List _ []) = "[]" fromNamed _ = "" - toNamed "[]" = List [] - toNamed x | isCon x = Con $ toNamed x - | otherwise = Var $ toNamed x + toNamed "[]" = List an [] + toNamed x | isCon x = Con an $ toNamed x + | otherwise = Var an $ toNamed x -instance Named QName where - fromNamed (Special Cons) = ":" - fromNamed (Special UnitCon) = "()" - fromNamed (UnQual x) = fromNamed x +instance Named (QName S) where + fromNamed (Special _ Cons{}) = ":" + fromNamed (Special _ UnitCon{}) = "()" + fromNamed (UnQual _ x) = fromNamed x fromNamed _ = "" - toNamed ":" = Special Cons - toNamed x = UnQual $ toNamed x + toNamed ":" = Special an $ Cons an + toNamed x = UnQual an $ toNamed x -instance Named Name where - fromNamed (Ident x) = x - fromNamed (Symbol x) = x +instance Named (Name S) where + fromNamed (Ident _ x) = x + fromNamed (Symbol _ x) = x - toNamed x | isSym x = Symbol x - | otherwise = Ident x + toNamed x | isSym x = Symbol an x + | otherwise = Ident an x -instance Named ModuleName where - fromNamed (ModuleName x) = x - toNamed = ModuleName +instance Named (ModuleName S) where + fromNamed (ModuleName _ x) = x + toNamed = ModuleName an -instance Named Pat where - fromNamed (PVar x) = fromNamed x - fromNamed (PApp x []) = fromNamed x +instance Named (Pat S) where + fromNamed (PVar _ x) = fromNamed x + fromNamed (PApp _ x []) = fromNamed x fromNamed _ = "" - toNamed x | isCon x = PApp (toNamed x) [] - | otherwise = PVar $ toNamed x + toNamed x | isCon x = PApp an (toNamed x) [] + | otherwise = PVar an $ toNamed x -instance Named TyVarBind where - fromNamed (KindedVar x _) = fromNamed x - fromNamed (UnkindedVar x) = fromNamed x - toNamed = UnkindedVar . toNamed +instance Named (TyVarBind S) where + fromNamed (KindedVar _ x _) = fromNamed x + fromNamed (UnkindedVar _ x) = fromNamed x + toNamed x = UnkindedVar an (toNamed x) -instance Named QOp where - fromNamed (QVarOp x) = fromNamed x - fromNamed (QConOp x) = fromNamed x - toNamed x | isCon x = QConOp $ toNamed x - | otherwise = QVarOp $ toNamed x +instance Named (QOp S) where + fromNamed (QVarOp _ x) = fromNamed x + fromNamed (QConOp _ x) = fromNamed x + toNamed x | isCon x = QConOp an $ toNamed x + | otherwise = QVarOp an $ toNamed x -instance Named Decl where - fromNamed (TypeDecl _ name _ _) = fromNamed name - fromNamed (DataDecl _ _ _ name _ _ _) = fromNamed name - fromNamed (GDataDecl _ _ _ name _ _ _ _) = fromNamed name - fromNamed (TypeFamDecl _ name _ _) = fromNamed name - fromNamed (DataFamDecl _ _ name _ _) = fromNamed name - fromNamed (ClassDecl _ _ name _ _ _) = fromNamed name - fromNamed (PatBind _ (PVar name) _ _ _) = fromNamed name - fromNamed (FunBind (Match _ name _ _ _ _ : _)) = fromNamed name +instance Named (Match S) where + fromNamed (Match _ x _ _ _) = fromNamed x + fromNamed (InfixMatch _ _ x _ _ _) = fromNamed x + toNamed = error "No toNamed for Match" + +instance Named (DeclHead S) where + fromNamed (DHead _ x _) = fromNamed x + fromNamed (DHInfix _ _ x _) = fromNamed x + fromNamed (DHParen _ x) = fromNamed x + toNamed = error "No toNamed for DeclHead" + +instance Named (Decl S) where + fromNamed (TypeDecl _ name _) = fromNamed name + fromNamed (DataDecl _ _ _ name _ _) = fromNamed name + fromNamed (GDataDecl _ _ _ name _ _ _) = fromNamed name + fromNamed (TypeFamDecl _ name _) = fromNamed name + fromNamed (DataFamDecl _ _ name _) = fromNamed name + fromNamed (ClassDecl _ _ name _ _) = fromNamed name + fromNamed (PatBind _ (PVar _ name) _ _ _) = fromNamed name + fromNamed (FunBind _ (name:_)) = fromNamed name fromNamed (ForImp _ _ _ _ name _) = fromNamed name fromNamed (ForExp _ _ _ name _) = fromNamed name fromNamed _ = "" diff --git a/src/HSE/NameMatch.hs b/src/HSE/NameMatch.hs --- a/src/HSE/NameMatch.hs +++ b/src/HSE/NameMatch.hs @@ -1,14 +1,15 @@ module HSE.NameMatch(NameMatch, nameMatch) where -import Language.Haskell.Exts +import HSE.Util +import HSE.Match import qualified Data.Map as Map import Data.List import Data.Function import Util -type NameMatch = QName -> QName -> Bool +type NameMatch = QName S -> QName S -> Bool -- Given a list of import statements, are the names equal @@ -16,37 +17,38 @@ -- -- If the left is unqualified, then the right is dequalified and checked for match -- If the left is qualified, then the right is wrapped and name resolved -nameMatch :: [ImportDecl] -> NameMatch +nameMatch :: [ImportDecl S] -> NameMatch nameMatch imps = f where -- deal with "as" imports - resolve :: ModuleName -> ModuleName - resolve = \x -> Map.findWithDefault x x mp - where mp = Map.fromList [(as, importModule i) | i <- imps, Just as <- [importAs i]] + resolve :: ModuleName S -> ModuleName S + resolve = \x -> Map.findWithDefault x (fromNamed x) mp + where mp = Map.fromList [(fromNamed as, importModule i) | i <- imps, Just as <- [importAs i]] -- return True if x is potentially imported by B - importedFrom :: ModuleName -> Name -> Bool - importedFrom = \modu x -> any (g x) $ Map.findWithDefault [(True,[]) | modu == ModuleName "Prelude"] modu mp + importedFrom :: ModuleName S -> Name S -> Bool + importedFrom = \modu x -> + any (g x) $ Map.findWithDefault [(True,[]) | fromNamed modu == "Prelude"] (fromNamed modu) mp where mp = Map.fromList $ groupSortFst - [(importModule i, importSpecNames i) | i <- imps, not $ importQualified i] + [(fromNamed $ importModule i, importSpecNames i) | i <- imps, not $ importQualified i] - g x (hide,y) = hide /= (x `elem` y) + g x (hide,y) = hide /= (x `elem_` y) - f (Qual xm x) (Qual ym y) = x == y && xm == resolve ym - f (Qual xm x) (UnQual y) = x == y && importedFrom xm x - f x y = x == y + f (Qual _ xm x) (Qual _ ym y) = x =~= y && xm =~= resolve ym + f (Qual _ xm x) (UnQual _ y) = x =~= y && importedFrom xm x + f x y = x =~= y -importSpecNames :: ImportDecl -> (Bool, [Name]) +importSpecNames :: ImportDecl S -> (Bool, [Name S]) importSpecNames x = case importSpecs x of Nothing -> (True, []) - Just (b, x) -> (b, concatMap f x) + Just (ImportSpecList _ b x) -> (b, concatMap f x) where - f (IVar x) = [x] - f (IAbs x) = [x] - f (IThingAll x) = [x] - f (IThingWith x ys) = x : map g ys - g (VarName x) = x - g (ConName x) = x + f (IVar _ x) = [x] + f (IAbs _ x) = [x] + f (IThingAll _ x) = [x] + f (IThingWith _ x ys) = x : map g ys + g (VarName _ x) = x + g (ConName _ x) = x diff --git a/src/HSE/Operators.hs b/src/HSE/Operators.hs deleted file mode 100644 --- a/src/HSE/Operators.hs +++ /dev/null @@ -1,113 +0,0 @@ - -module HSE.Operators( - FixityDecl(..), preludeFixities, baseFixities, - applyFixities, testFixities, - infixr_, infixl_, infix_ - ) where - -import Data.Generics -import Data.Generics.PlateData -import Data.Char -import Data.List -import Data.Maybe -import Language.Haskell.Exts hiding - (preludeFixities, baseFixities, applyFixities, Fixity, - infixr_, infixl_, infix_) -import HSE.Match -import HSE.Util -import HSE.Bracket -import qualified Data.Map as Map - - -data FixityDecl = Fixity Assoc Int Op - - -preludeFixities :: [FixityDecl] -preludeFixities = concat - [infixr_ 9 ["."] - ,infixl_ 9 ["!!"] - ,infixr_ 8 ["^","^^","**"] - ,infixl_ 7 ["*","/","`quot`","`rem`","`div`","`mod`",":%","%"] - ,infixl_ 6 ["+","-"] - ,infixr_ 5 [":","++"] - ,infix_ 4 ["==","/=","<","<=",">=",">","`elem`","`notElem`"] - ,infixr_ 3 ["&&"] - ,infixr_ 2 ["||"] - ,infixl_ 1 [">>",">>="] - ,infixr_ 1 ["=<<"] - ,infixr_ 0 ["$","$!","`seq`"] - ] - -baseFixities :: [FixityDecl] -baseFixities = preludeFixities ++ concat - [infixl_ 9 ["!","//","!:"] - ,infixl_ 8 ["`shift`","`rotate`","`shiftL`","`shiftR`","`rotateL`","`rotateR`"] - ,infixl_ 7 [".&."] - ,infixl_ 6 ["`xor`"] - ,infix_ 6 [":+"] - ,infixl_ 5 [".|."] - ,infixr_ 5 ["+:+","<++","<+>"] -- fixity conflict for +++ between ReadP and Arrow - ,infix_ 5 ["\\\\"] - ,infixl_ 4 ["<$>","<$","<*>","<*","*>","<**>"] - ,infix_ 4 ["`elemP`","`notElemP`"] - ,infixl_ 3 ["<|>"] - ,infixr_ 3 ["&&&","***"] - ,infixr_ 2 ["+++","|||"] - ,infixr_ 1 ["<=<",">=>",">>>","<<<","^<<","<<^","^>>",">>^"] - ,infixl_ 0 ["`on`"] - ,infixr_ 0 ["`par`","`pseq`"] - ] - - -infixr_ = fixity AssocRight -infixl_ = fixity AssocLeft -infix_ = fixity AssocNone - -fixity a p = map (Fixity a p . op) - where - op ('`':xs) = (if isUpper (head xs) then ConOp else VarOp) $ Ident $ init xs - op xs = (if head xs == ':' then ConOp else VarOp) $ Symbol xs - - --- Inspired by the code at: --- http://hackage.haskell.org/trac/haskell-prime/attachment/wiki/FixityResolution/resolve.hs -applyFixities :: Biplate a Exp => [FixityDecl] -> a -> a -applyFixities fixs = descendBi (transform f) - where - ask = askFixity fixs - - f o@(InfixApp (InfixApp x op1 y) op2 z) - | p1 == p2 && (a1 /= a2 || a1 == AssocNone) = o -- Ambiguous infix expression! - | p1 > p2 || p1 == p2 && (a1 == AssocLeft || a2 == AssocNone) = o - | otherwise = InfixApp x op1 (f $ InfixApp y op2 z) - where - (a1,p1) = ask op1 - (a2,p2) = ask op2 - f x = x - - -testFixities = let (==) = f in and - ["f + g + x" == "(f + g) + x" - ,"f : g : x" == "f : (g : x)" - ,"f $ g $ x" == "f $ (g $ x)" - ,"f . g . x" == "f . (g . x)" - ,"f . g $ x" == "(f . g) $ x" - ,"f $ g . x" == "f $ (g . x)" - ,"a && b || c && d" == "(a && b) || (c && d)" - ] - where - f lhs rhs = g lhs == g rhs || error ("Fixity mismatch " ++ lhs ++ " =/= " ++ rhs) - g = transformBi (const nullSrcLoc) $ transformBi fromParen . applyFixities preludeFixities . fromParseResult . parseFileContents . (++) "foo = " - - -askFixity :: [FixityDecl] -> QOp -> (Assoc, Int) -askFixity xs = \k -> Map.findWithDefault (AssocLeft, 9) (f k) mp - where - mp = Map.fromList [(x,(a,p)) | Fixity a p x <- xs] - - f (QVarOp x) = VarOp (g x) - f (QConOp x) = ConOp (g x) - - g (Qual _ x) = x - g (UnQual x) = x - g (Special Cons) = Symbol ":" diff --git a/src/HSE/Util.hs b/src/HSE/Util.hs --- a/src/HSE/Util.hs +++ b/src/HSE/Util.hs @@ -1,56 +1,67 @@ -{-# LANGUAGE PatternGuards #-} -module HSE.Util where +module HSE.Util(module Language.Haskell.Exts.Annotated, module HSE.Util) where import Control.Monad import Data.Generics -import Data.Generics.PlateData +import Data.Generics.Uniplate.Data import Data.List import Data.Maybe -import Language.Haskell.Exts -import Util +import Language.Haskell.Exts.Annotated hiding (parse, loc, parseFile, paren) +type S = SrcSpanInfo +type Module_ = Module S +type Decl_ = Decl S +type Exp_ = Exp S +type Pat_ = Pat S +type Type_ = Type S + + --------------------------------------------------------------------- -- ACCESSOR/TESTER -opExp :: QOp -> Exp -opExp (QVarOp op) = Var op -opExp (QConOp op) = Con op +opExp :: QOp s -> Exp s +opExp (QVarOp s op) = Var s op +opExp (QConOp s op) = Con s op -moduleDecls :: Module -> [Decl] -moduleDecls (Module _ _ _ _ _ _ xs) = xs +moduleDecls :: Module s -> [Decl s] +moduleDecls (Module _ _ _ _ xs) = xs -moduleName :: Module -> String -moduleName (Module _ (ModuleName x) _ _ _ _ _) = x +moduleName :: Module s -> String +moduleName (Module _ Nothing _ _ _) = "Main" +moduleName (Module _ (Just (ModuleHead _ (ModuleName _ x) _ _)) _ _ _) = x -moduleImports :: Module -> [ImportDecl] -moduleImports (Module _ _ _ _ _ x _) = x +moduleImports :: Module s -> [ImportDecl s] +moduleImports (Module _ _ _ x _) = x -modulePragmas :: Module -> [OptionPragma] -modulePragmas (Module _ _ x _ _ _ _) = x +modulePragmas :: Module s -> [OptionPragma s] +modulePragmas (Module _ _ x _ _) = x -isChar :: Exp -> Bool -isChar (Lit (Char _)) = True +isChar :: Exp s -> Bool +isChar (Lit _ Char{}) = True isChar _ = False -fromChar :: Exp -> Char -fromChar (Lit (Char x)) = x +fromChar :: Exp s -> Char +fromChar (Lit _ (Char _ x _)) = x -isString :: Exp -> Bool -isString (Lit (String _)) = True +isString :: Exp s -> Bool +isString (Lit _ String{}) = True isString _ = False -fromString :: Exp -> String -fromString (Lit (String x)) = x +fromString :: Exp s -> String +fromString (Lit _ (String _ x _)) = x -isPString (PLit (String _)) = True; isPString _ = False -fromPString (PLit (String x)) = x +isPString (PLit _ String{}) = True; isPString _ = False +fromPString (PLit _ (String _ x _)) = x -fromParen :: Exp -> Exp -fromParen (Paren x) = fromParen x +fromParen :: Exp s -> Exp s +fromParen (Paren _ x) = fromParen x fromParen x = x +fromPParen :: Pat s -> Pat s +fromPParen (PParen _ x) = fromPParen x +fromPParen x = x + -- is* :: Exp -> Bool isVar Var{} = True; isVar _ = False isApp App{} = True; isApp _ = False @@ -73,23 +84,18 @@ -- which names are bound by a declaration -declBind :: Decl -> [Name] -declBind (FunBind (Match _ x _ _ _ _ : _)) = [x] -declBind (PatBind _ x _ _ _) = [x | PVar x <- universe x] +declBind :: Decl_ -> [String] +declBind (FunBind _ (Match _ x _ _ _ : _)) = [prettyPrint x] +declBind (PatBind _ x _ _ _) = pvars x declBind _ = [] --------------------------------------------------------------------- -- HSE FUNCTIONS --- pick a variable that is not being used -freeVar :: Data a => a -> String -freeVar x = head $ allVars \\ concat [[y, drop 1 y] | Ident y <- universeBi x] - where allVars = [letter : number | number <- "" : map show [1..], letter <- ['a'..'z']] - -getEquations :: Decl -> [Decl] -getEquations (FunBind xs) = map (FunBind . (:[])) xs -getEquations (PatBind src (PVar name) typ bod bind) = [FunBind [Match src name [] typ bod bind]] +getEquations :: Decl s -> [Decl s] +getEquations (FunBind s xs) = map (FunBind s . (:[])) xs +getEquations (PatBind s (PVar _ name) _ bod bind) = [FunBind s [Match s name [] bod bind]] getEquations x = [x] @@ -97,76 +103,105 @@ -- VECTOR APPLICATION -apps :: [Exp] -> Exp -apps = foldl1 App +apps :: [Exp s] -> Exp s +apps xs = foldl1 (App $ ann $ head xs) xs -fromApps :: Exp -> [Exp] -fromApps (App x y) = fromApps x ++ [y] +fromApps :: Exp s -> [Exp s] +fromApps (App _ x y) = fromApps x ++ [y] fromApps x = [x] -- Rule for the Uniplate Apps functions -- Given (f a) b, consider the children to be: children f ++ [a,b] -childrenApps :: Exp -> [Exp] -childrenApps (App x@App{} y) = childrenApps x ++ [y] -childrenApps (App x y) = children x ++ [y] +childrenApps :: Data s => Exp s -> [Exp s] +childrenApps (App _ x@App{} y) = childrenApps x ++ [y] +childrenApps (App _ x y) = children x ++ [y] childrenApps x = children x -descendApps :: (Exp -> Exp) -> Exp -> Exp -descendApps f (App x@App{} y) = App (descendApps f x) (f y) -descendApps f (App x y) = App (descend f x) (f y) +descendApps :: Data s => (Exp s -> Exp s) -> Exp s -> Exp s +descendApps f (App s x@App{} y) = App s (descendApps f x) (f y) +descendApps f (App s x y) = App s (descend f x) (f y) descendApps f x = descend f x -descendAppsM :: Monad m => (Exp -> m Exp) -> Exp -> m Exp -descendAppsM f (App x@App{} y) = liftM2 App (descendAppsM f x) (f y) -descendAppsM f (App x y) = liftM2 App (descendM f x) (f y) +descendAppsM :: (Data s, Monad m) => (Exp s -> m (Exp s)) -> Exp s -> m (Exp s) +descendAppsM f (App s x@App{} y) = liftM2 (App s) (descendAppsM f x) (f y) +descendAppsM f (App s x y) = liftM2 (App s) (descendM f x) (f y) descendAppsM f x = descendM f x -universeApps :: Exp -> [Exp] +universeApps :: Data s => Exp s -> [Exp s] universeApps x = x : concatMap universeApps (childrenApps x) -transformApps :: (Exp -> Exp) -> Exp -> Exp +transformApps :: Data s => (Exp s -> Exp s) -> Exp s -> Exp s transformApps f = f . descendApps (transformApps f) -transformAppsM :: Monad m => (Exp -> m Exp) -> Exp -> m Exp +transformAppsM :: (Data s, Monad m) => (Exp s -> m (Exp s)) -> Exp s -> m (Exp s) transformAppsM f x = f =<< descendAppsM (transformAppsM f) x --------------------------------------------------------------------- --- SRCLOC FUNCTIONS +-- UNIPLATE FUNCTIONS -nullSrcLoc :: SrcLoc -nullSrcLoc = SrcLoc "" 0 0 +universeS :: (Functor f, Data (f S), Data x) => x -> [f S] +universeS = universeBi +childrenS :: (Functor f, Data (f S), Data x) => x -> [f S] +childrenS = childrenBi + + +vars :: Data a => a -> [String] +vars xs = [prettyPrint x | Var _ (UnQual _ x) <- universeS xs] + +pvars :: Data a => a -> [String] +pvars xs = [prettyPrint x | PVar _ x <- universeS xs] + +--------------------------------------------------------------------- +-- SRCLOC FUNCTIONS + showSrcLoc :: SrcLoc -> String showSrcLoc (SrcLoc file line col) = file ++ ":" ++ show line ++ ":" ++ show col ++ ":" -getSrcLoc :: Data a => a -> Maybe SrcLoc -getSrcLoc = headDef Nothing . gmapQ cast +toSrcLoc :: SrcInfo si => si -> SrcLoc +toSrcLoc = getPointLoc +nullSrcLoc :: SrcLoc +nullSrcLoc = SrcLoc "" 0 0 -declSrcLoc :: Decl -> SrcLoc -declSrcLoc (FunBind (x:xs)) = fromMaybe nullSrcLoc $ getSrcLoc x -declSrcLoc x = fromMaybe nullSrcLoc $ getSrcLoc x +an :: SrcSpanInfo +an = toSrcInfo nullSrcLoc [] nullSrcLoc +dropAnn :: Functor f => f s -> f () +dropAnn = fmap (const ()) + + --------------------------------------------------------------------- --- UNIPLATE STYLE FUNCTIONS +-- SRCLOC EQUALITY --- children on Exp, but with SrcLoc's -children1Exp :: Data a => SrcLoc -> a -> [(SrcLoc, Exp)] -children1Exp src x = concat $ gmapQ (children0Exp src2) x - where src2 = fromMaybe src (getSrcLoc x) +-- enforce all being on S, as otherwise easy to =~= on a Just, and get the wrong functor -children0Exp :: Data a => SrcLoc -> a -> [(SrcLoc, Exp)] -children0Exp src x | Just y <- cast x = [(src, y)] - | otherwise = children1Exp src x +x /=~= y = not $ x =~= y -universeExp :: Data a => SrcLoc -> a -> [(SrcLoc, Exp)] -universeExp src x = concatMap f (children0Exp src x) - where f (src,x) = (src,x) : concatMap f (children1Exp src x) +elem_ :: (Annotated f, Eq (f ())) => f S -> [f S] -> Bool +elem_ x y = any (x =~=) y + +nub_ :: (Annotated f, Eq (f ())) => [f S] -> [f S] +nub_ = nubBy (=~=) + +intersect_ :: (Annotated f, Eq (f ())) => [f S] -> [f S] -> [f S] +intersect_ = intersectBy (=~=) + +eqList, neqList :: (Annotated f, Eq (f ())) => [f S] -> [f S] -> Bool +neqList x y = not $ eqList x y +eqList (x:xs) (y:ys) = x =~= y && eqList xs ys +eqList [] [] = True +eqList _ _ = False + +eqMaybe:: (Annotated f, Eq (f ())) => Maybe (f S) -> Maybe (f S) -> Bool +eqMaybe (Just x) (Just y) = x =~= y +eqMaybe Nothing Nothing = True +eqMaybe _ _ = False diff --git a/src/Hint.hs b/src/Hint.hs new file mode 100644 --- /dev/null +++ b/src/Hint.hs @@ -0,0 +1,36 @@ + +module Hint where + +import HSE.All +import Data.Char +import Data.List +import Data.Ord +import Type + + +type DeclHint = NameMatch -> Module_ -> Decl_ -> [Idea] +type ModuHint = NameMatch -> Module_ -> [Idea] + +data Hint = DeclHint {declHint :: DeclHint} | ModuHint {moduHint :: ModuHint} + + +applyHint :: ParseFlags -> [Hint] -> FilePath -> IO [Idea] +applyHint flags h file = do + src <- readFile file + return $ applyHintStr flags h file src + + +applyHintStr :: ParseFlags -> [Hint] -> FilePath -> String -> [Idea] +applyHintStr flags h file src = + case parseString flags file src of + ParseFailed sl msg -> + let ticks = [" "," ","> "," "," "] + bad = zipWith (++) ticks $ take 5 $ drop (srcLine sl - 3) $ lines src ++ [""] + bad2 = reverse $ dropWhile (all isSpace) $ reverse $ dropWhile (all isSpace) bad + in [ParseError Warning "Parse error" sl msg (unlines bad2)] + ParseOk m -> + let name = moduleName m + nm = nameMatch $ moduleImports m + order n = map (\i -> i{func = (name,n)}) . sortBy (comparing loc) + in order "" [i | ModuHint h <- h, i <- h nm m] ++ + concat [order (fromNamed d) [i | DeclHint h <- h, i <- h nm m d] | d <- moduleDecls m] diff --git a/src/Hint/All.hs b/src/Hint/All.hs --- a/src/Hint/All.hs +++ b/src/Hint/All.hs @@ -2,6 +2,7 @@ module Hint.All where import Type +import Hint import Data.List import Data.Maybe diff --git a/src/Hint/Bracket.hs b/src/Hint/Bracket.hs --- a/src/Hint/Bracket.hs +++ b/src/Hint/Bracket.hs @@ -25,32 +25,33 @@ import Control.Arrow import Type +import Hint import HSE.All bracketHint :: DeclHint -bracketHint _ _ = concatMap bracketExp . children0Exp nullSrcLoc +bracketHint _ _ = concatMap bracketExp . childrenBi -bracketExp :: (SrcLoc,Exp) -> [Idea] -bracketExp (loc,x) = - [g loc x (fromParen x) | isParen x] ++ f loc x +bracketExp :: Exp_ -> [Idea] +bracketExp x = + [g x (fromParen x) | isParen x] ++ f x where - f loc x = testDirect loc x ++ testDollar loc x ++ concatMap (uncurry f) (children1Exp loc x) + f x = testDirect x ++ testDollar x ++ concatMap f (children x) g = warn "Redundant brackets" - testDirect loc x = [g loc x y | let y = descendBracket (isParen &&& fromParen) x, x /= y] + testDirect x = [g x y | let y = descendBracket (isParen &&& fromParen) x, x /=~= y] - testDollar loc x = - [idea Error "Redundant $" loc x y | InfixApp a d b <- [x], opExp d ~= "$" - ,let y = App a b, not $ needBracket 0 y a, not $ needBracket 1 y b] + testDollar x = + [idea Error "Redundant $" x y | InfixApp _ a d b <- [x], opExp d ~= "$" + ,let y = App an a b, not $ needBracket 0 y a, not $ needBracket 1 y b] ++ - [idea Error "Redundant $" loc x (t y) - |(t, Paren (InfixApp a1 op1 a2)) <- infixes x + [idea Error "Redundant $" x (t y) + |(t, Paren _ (InfixApp _ a1 op1 a2)) <- infixes x ,opExp op1 ~= "$", isVar a1 || isApp a1 || isParen a1, not $ isAtom a2 - ,let y = App a1 (Paren a2)] + ,let y = App an a1 (Paren an a2)] -- return both sides, and a way to put them together again -infixes :: Exp -> [(Exp -> Exp, Exp)] -infixes (InfixApp a b c) = [(InfixApp a b, c), (\a -> InfixApp a b c, a)] +infixes :: Exp_ -> [(Exp_ -> Exp_, Exp_)] +infixes (InfixApp s a b c) = [(InfixApp s a b, c), (\a -> InfixApp s a b c, a)] infixes _ = [] diff --git a/src/Hint/Extensions.hs b/src/Hint/Extensions.hs --- a/src/Hint/Extensions.hs +++ b/src/Hint/Extensions.hs @@ -31,59 +31,60 @@ import HSE.All import Type +import Hint import Data.List import Data.Maybe import Data.Function extensionsHint :: ModuHint -extensionsHint _ x = [rawIdea Error "Unused LANGUAGE pragma" sl +extensionsHint _ x = [rawIdea Error "Unused LANGUAGE pragma" (toSrcLoc sl) (prettyPrint o) (if null new then "" else prettyPrint $ LanguagePragma sl new) - | let usedTH = used TemplateHaskell x -- if TH is on, can use all other extensions programmatically - , o@(LanguagePragma sl old) <- modulePragmas x, not usedTH + | not $ used TemplateHaskell x -- if TH is on, can use all other extensions programmatically + , o@(LanguagePragma sl old) <- modulePragmas x , let new = filter (flip used x . classifyExtension . prettyPrint) old , length new /= length old] -used :: Extension -> Module -> Bool -used RecursiveDo = has isMDo -used ParallelListComp = has isParComp -used FunctionalDependencies = has isFunDep -used ImplicitParams = hasT (un :: IPName) -used EmptyDataDecls = has f - where f (DataDecl _ _ _ _ _ [] _) = True - f (GDataDecl _ _ _ _ _ _ [] _) = True +used :: Extension -> Module_ -> Bool +used RecursiveDo = hasS isMDo +used ParallelListComp = hasS isParComp +used FunctionalDependencies = hasS isFunDep +used ImplicitParams = hasT (un :: IPName S) +used EmptyDataDecls = hasS f + where f (DataDecl _ _ _ _ [] _) = True + f (GDataDecl _ _ _ _ _ [] _) = True f _ = False -used KindSignatures = hasT (un :: Kind) -used BangPatterns = has isPBangPat -used TemplateHaskell = hasT2 (un :: (Bracket,Splice)) & has f +used KindSignatures = hasT (un :: Kind S) +used BangPatterns = hasS isPBangPat +used TemplateHaskell = hasT2 (un :: (Bracket S, Splice S)) & hasS f where f VarQuote{} = True f TypQuote{} = True f _ = False -used ForeignFunctionInterface = hasT (un :: CallConv) -used Generics = has isPExplTypeArg -used PatternGuards = has f1 & has f2 +used ForeignFunctionInterface = hasT (un :: CallConv S) +used Generics = hasS isPExplTypeArg +used PatternGuards = hasS f1 & hasS f2 where f1 (GuardedRhs _ xs _) = g xs f2 (GuardedAlt _ xs _) = g xs g [] = False - g [Qualifier _] = False + g [Qualifier{}] = False g _ = True -used StandaloneDeriving = has isDerivDecl -used PatternSignatures = has isPatTypeSig -used RecordWildCards = has isPFieldWildcard -used RecordPuns = has isPFieldPun +used StandaloneDeriving = hasS isDerivDecl +used PatternSignatures = hasS isPatTypeSig +used RecordWildCards = hasS isPFieldWildcard +used RecordPuns = hasS isPFieldPun used UnboxedTuples = has isBoxed -used PackageImports = has (isJust . importPkg) -used QuasiQuotes = has isQuasiQuote -used ViewPatterns = has isPViewPat -used Arrows = has f +used PackageImports = hasS (isJust . importPkg) +used QuasiQuotes = hasS isQuasiQuote +used ViewPatterns = hasS isPViewPat +used Arrows = hasS f where f Proc{} = True f LeftArrApp{} = True f RightArrApp{} = True f LeftArrHighApp{} = True f RightArrHighApp{} = True f _ = False -used TransformListComp = has f +used TransformListComp = hasS f where f QualStmt{} = False f _ = True @@ -97,6 +98,9 @@ hasT t x = not $ null (universeBi x `asTypeOf` [t]) hasT2 ~(t1,t2) = hasT t1 & hasT t2 + +hasS :: (Data (f S), Data x, Functor f) => (f S -> Bool) -> x -> Bool +hasS test = any test . universeBi has f = any f . universeBi diff --git a/src/Hint/Import.hs b/src/Hint/Import.hs --- a/src/Hint/Import.hs +++ b/src/Hint/Import.hs @@ -33,6 +33,7 @@ import HSE.All import Type +import Hint import Util import Data.List import Data.Maybe @@ -40,23 +41,23 @@ importHint :: ModuHint importHint _ x = concatMap (wrap . snd) $ groupSortFst - [((importModule i,importPkg i),i) | i <- universeBi x, not $ importSrc i] + [((fromNamed $ importModule i,importPkg i),i) | i <- universeBi x, not $ importSrc i] -wrap :: [ImportDecl] -> [Idea] -wrap o = [ rawIdea Error "Use fewer imports" (importLoc $ head x) (f o) (f x) +wrap :: [ImportDecl S] -> [Idea] +wrap o = [ rawIdea Error "Use fewer imports" (toSrcLoc $ ann $ head o) (f o) (f x) | Just x <- [simplify o]] where f = unlines . map prettyPrint -simplify :: [ImportDecl] -> Maybe [ImportDecl] +simplify :: [ImportDecl S] -> Maybe [ImportDecl S] simplify [] = Nothing simplify (x:xs) = case simplifyHead x xs of Nothing -> fmap (x:) $ simplify xs Just xs -> Just $ fromMaybe xs $ simplify xs -simplifyHead :: ImportDecl -> [ImportDecl] -> Maybe [ImportDecl] +simplifyHead :: ImportDecl S -> [ImportDecl S] -> Maybe [ImportDecl S] simplifyHead x [] = Nothing simplifyHead x (y:ys) = case reduce x y of Nothing -> fmap (y:) $ simplifyHead x ys @@ -71,16 +72,16 @@ -- importAs :: Maybe ModuleName -- importSpecs :: Maybe (Bool, [ImportSpec]) -reduce :: ImportDecl -> ImportDecl -> Maybe ImportDecl +reduce :: ImportDecl S -> ImportDecl S -> Maybe (ImportDecl S) reduce x y | qual, as, specs = Just x - | qual, as, Just (False, xs) <- importSpecs x, Just (False, ys) <- importSpecs y = - Just x{importSpecs = Just (False, nub $ xs ++ ys)} + | qual, as, Just (ImportSpecList _ False xs) <- importSpecs x, Just (ImportSpecList _ False ys) <- importSpecs y = + Just x{importSpecs = Just $ ImportSpecList an False $ nub_ $ xs ++ ys} | qual, as, isNothing (importSpecs x) || isNothing (importSpecs y) = Just x{importSpecs=Nothing} | not (importQualified x), qual, specs, length ass == 1 = Just x{importAs=Just $ head ass} where qual = importQualified x == importQualified y - as = importAs x == importAs y + as = importAs x `eqMaybe` importAs y ass = mapMaybe importAs [x,y] - specs = importSpecs x == importSpecs y + specs = importSpecs x `eqMaybe` importSpecs y reduce _ _ = Nothing diff --git a/src/Hint/Lambda.hs b/src/Hint/Lambda.hs --- a/src/Hint/Lambda.hs +++ b/src/Hint/Lambda.hs @@ -26,9 +26,6 @@ h a = f ((++) a) a -- (a ++) h a = flip f x (y z) -- f (y z) x h a = flip f x $ y z -type Test a = Foo Char a -type Test a = Foo a Char a -type Test (a :: * -> *) = Foo Char a yes = foo (\x -> sum x) -- sum yes = foo (\x l -> sum x x l) -- \x -> sum x x test = foo (\x -> y == x) -- (y ==) @@ -45,103 +42,80 @@ import HSE.All import Type +import Hint import Control.Monad -import Data.Generics.PlateData import Data.Maybe lambdaHint :: DeclHint -lambdaHint _ _ x@TypeDecl{} = lambdaType x -lambdaHint _ _ x = concatMap (uncurry lambdaExp) (universeExp nullSrcLoc x) ++ concatMap lambdaDecl (universe x) +lambdaHint _ _ x = concatMap lambdaExp (universeBi x) ++ concatMap lambdaDecl (universe x) -lambdaExp :: SrcLoc -> Exp -> [Idea] -lambdaExp _ o@(Lambda loc [v] y) | isAtom y, Just x <- f v, x `notElem` universeBi y = - [warn "Use const" loc o res] +lambdaExp :: Exp_ -> [Idea] +lambdaExp o@(Lambda _ [v] y) | isAtom y, Just x <- f v, x `notElem` universeBi y = + [warn "Use const" o res] where - f (PVar x) = Just x - f PWildCard = Just $ Ident "_" + f (view -> PVar_ x) = Just x + f PWildCard{} = Just "_" f _ = Nothing - res = App (toNamed "const") y -lambdaExp _ o@(Lambda loc vs x) | length vs /= length vs2 = - [warn "Eta reduce" loc o $ if null vs2 then x2 else Lambda loc vs2 x2] + res = App an (toNamed "const") y +lambdaExp o@(Lambda _ vs x) | length vs /= length vs2 = + [warn "Eta reduce" o $ if null vs2 then x2 else Lambda an vs2 x2] where (vs2,x2) = etaReduces vs x -lambdaExp loc o@(Paren (App (Var x@(UnQual (Symbol _))) y)) | isAtom y = - [warn "Operator rotate" loc o $ LeftSection y (QVarOp x)] -lambdaExp loc o@(App (App (App flp x) y) z) | flp ~= "flip" = - [idea Error "Redundant flip" loc o $ App (App x z) y] -lambdaExp _ _ = [] +lambdaExp o@(Paren _ (App _ (Var _ x@(UnQual _ Symbol{})) y)) | isAtom y = + [warn "Operator rotate" o $ LeftSection an y (QVarOp an x)] +lambdaExp o@(App _ (App _ (App _ flp x) y) z) | flp ~= "flip" = + [idea Error "Redundant flip" o $ App an (App an x z) y] +lambdaExp _ = [] -lambdaDecl :: Decl -> [Idea] -lambdaDecl (PatBind loc (PVar x) typ rhs bind) = lambdaDef $ Match loc x [] typ rhs bind -lambdaDecl (FunBind [x]) = lambdaDef x --only apply to 1-def, because arities must be the same +lambdaDecl :: Decl_ -> [Idea] +lambdaDecl (PatBind _ (PVar _ x) typ rhs bind) = lambdaDef $ Match an x [] rhs bind +lambdaDecl (FunBind _ [x]) = lambdaDef x --only apply to 1-def, because arities must be the same lambdaDecl _ = [] -lambdaDef :: Match -> [Idea] -lambdaDef o@(Match loc name pats typ (UnGuardedRhs bod) (BDecls [])) - | Lambda loc vs y <- bod = [warn "Redundant lambda" loc o $ reform (pats++vs) y] - | [PVar x, PVar y] <- pats, Just (f,g) <- useOn x y bod = - [warn "Use on" loc o $ reform [] (ensureBracket1 $ InfixApp f (toNamed "on") g)] - | (p2,y) <- etaReduces pats bod, length p2 /= length pats = [warn "Eta reduce" loc o $ reform p2 y] +lambdaDef :: Match S -> [Idea] +lambdaDef o@(Match _ name pats (UnGuardedRhs _ bod) Nothing) + | Lambda loc vs y <- bod = [warn "Redundant lambda" o $ reform (pats++vs) y] + | [PVar _ x, PVar _ y] <- pats, Just (f,g) <- useOn x y bod = + [warn "Use on" o $ reform [] (ensureBracket1 $ InfixApp an f (toNamed "on") g)] + | (p2,y) <- etaReduces pats bod, length p2 /= length pats = [warn "Eta reduce" o $ reform p2 y] | otherwise = [] - where reform pats2 bod2 = Match loc name pats2 typ (UnGuardedRhs bod2) (BDecls []) + where reform pats2 bod2 = Match an name pats2 (UnGuardedRhs an bod2) Nothing +lambdaDef (InfixMatch an p1 name p2 rhs binds) = lambdaDef $ Match an name [p1,p2] rhs binds lambdaDef _ = [] -- given x y, f (g x) (g y) = Just (f, g) -useOn :: Name -> Name -> Exp -> Maybe (Exp, Exp) +useOn :: Name S -> Name S -> Exp_ -> Maybe (Exp_, Exp_) useOn x1 y1 (view -> App2 f (view -> App1 g1 x2) (view -> App1 g2 y2)) - | fromNamed f `elem` ["==",">=",">","!=","<","<="] && g1 == g2, map (Var . UnQual) [x1,y1] == [x2,y2] + | fromNamed f `elem` ["==",">=",">","!=","<","<="] && g1 =~= g2, map (Var an . UnQual an) [x1,y1] `eqList` [x2,y2] = Just (f,g1) useOn _ _ _ = Nothing -etaReduces :: [Pat] -> Exp -> ([Pat], Exp) -etaReduces ps x | ps /= [], PVar p <- last ps, p /= Ident "mr", Just y <- etaReduce p x = etaReduces (init ps) y +etaReduces :: [Pat S] -> Exp_ -> ([Pat S], Exp_) +etaReduces ps x | ps /= [], PVar_ p <- view $ last ps, p /= "mr", Just y <- etaReduce p x = etaReduces (init ps) y | otherwise = (ps,x) -etaReduce :: Name -> Exp -> Maybe Exp -etaReduce x (App y (Var (UnQual z))) | x == z && x `notElem` universeBi y = Just y -etaReduce x (InfixApp y op z) | f y z = Just $ RightSection op z - | f z y = Just $ LeftSection y op - where f y z = op `notElem` map (toNamed . return) "+-" && - all (not . isInfixApp) [y,z] && var x == y && x `notElem` universeBi z -etaReduce x (App y z) | not (uglyEta y z) && x `notElem` universeBi y = do +etaReduce :: String -> Exp_ -> Maybe Exp_ +etaReduce x (App _ y (view -> Var_ z)) | x == z && x `notElem` vars y = Just y +etaReduce x (InfixApp _ y op z) | f y z = Just $ RightSection an op z + | f z y = Just $ LeftSection an y op + where f y z = prettyPrint op `notElem` ["+","-"] && + all (not . isInfixApp) [y,z] && view y == Var_ x && x `notElem` vars z +etaReduce x (App _ y z) | not (uglyEta y z) && x `notElem` vars y = do z2 <- etaReduce x z - return $ InfixApp y (toNamed ".") z2 -etaReduce x (view -> App2 dollar y z) | dollar ~= "$" = etaReduce x (App y z) -etaReduce x (LeftSection y op) = etaReduce x $ App (opExp op) y + return $ InfixApp an y (toNamed ".") z2 +etaReduce x (view -> App2 dollar y z) | dollar ~= "$" = etaReduce x (App an y z) +etaReduce x (LeftSection _ y op) = etaReduce x $ App an (opExp op) y etaReduce x y | isParen y = etaReduce x (fromParen y) etaReduce x y = Nothing -- (f (g x)) (h y), ugly if g == h -uglyEta :: Exp -> Exp -> Bool -uglyEta (fromParen -> App f (fromParen -> App g x)) (fromParen -> App h y) = g == h +uglyEta :: Exp_ -> Exp_ -> Bool +uglyEta (fromParen -> App _ f (fromParen -> App _ g x)) (fromParen -> App _ h y) = g =~= h uglyEta _ _ = False - - - --- NOTE: Never perform lambda reduction on types --- > type Foo a = Bar a --- can be reduced for type Foo = Bar, only if Bar is --- a data type, not a type alias - but we can't know --- which it is -lambdaType :: Decl -> [Idea] -lambdaType o@(TypeDecl src name args typ) = [] -{- - [warn "Type eta reduce" src o t2 | i /= 0] - where - (i,t) = f (reverse args) typ - t2 = TypeDecl src name (take (length args - i) args) t - - -- return the number you managed to delete - f :: [TyVarBind] -> Type -> (Int, Type) - f (UnkindedVar x:xs) (TyApp t1 (TyVar v)) - | fromNamed v == fromNamed x && x `notElem` universeBi t1 - = first (+1) $ f xs t1 - f _ t = (0,t) --} diff --git a/src/Hint/List.hs b/src/Hint/List.hs --- a/src/Hint/List.hs +++ b/src/Hint/List.hs @@ -25,21 +25,22 @@ import HSE.All import Type +import Hint listHint :: DeclHint listHint _ _ = listDecl -listDecl :: Decl -> [Idea] -listDecl x = concatMap (listExp False) (children0Exp nullSrcLoc x) ++ - concatMap (stringType (declSrcLoc x)) (childrenBi x) +listDecl :: Decl_ -> [Idea] +listDecl x = concatMap (listExp False) (childrenBi x) ++ + concatMap stringType (childrenBi x) -- boolean = are you in a ++ chain -listExp :: Bool -> (SrcLoc,Exp) -> [Idea] -listExp b (loc,x) = - if null res then concatMap (listExp $ isAppend x) $ children1Exp loc x else [head res] +listExp :: Bool -> Exp_ -> [Idea] +listExp b x = + if null res then concatMap (listExp $ isAppend x) $ children x else [head res] where - res = [warn name loc x x2 | (name,f) <- checks, Just x2 <- [f b x]] + res = [warn name x x2 | (name,f) <- checks, Just x2 <- [f b x]] isAppend (view -> App2 op _ _) = op ~= "++" @@ -53,29 +54,30 @@ ] -useString b (List xs) | xs /= [] && all isChar xs = Just $ Lit $ String $ map fromChar xs +useString b (List _ xs) | xs /= [] && all isChar xs = Just $ Lit an $ String an s (show s) + where s = map fromChar xs useString b _ = Nothing -useList b = fmap List . f True +useList b = fmap (List an) . f True where f first x | x ~= "[]" = if first then Nothing else Just [] f first (view -> App2 c a b) | c ~= ":" = fmap (a:) $ f False b f first _ = Nothing useCons False (view -> App2 op x y) | op ~= "++", Just x2 <- f x, not $ isAppend y = - Just $ InfixApp x2 (QConOp list_cons_name) y + Just $ InfixApp an x2 (QConOp an $ list_cons_name an) y where - f (Lit (String [x])) = Just $ Lit $ Char x - f (List [x]) = Just $ paren x + f (Lit _ (String _ [x] _)) = Just $ Lit an $ Char an x (show x) + f (List _ [x]) = Just $ paren x f _ = Nothing useCons _ _ = Nothing -typeListChar = TyList (TyCon (toNamed "Char")) -typeString = TyCon (toNamed "String") +typeListChar = TyList an (TyCon an (toNamed "Char")) +typeString = TyCon an (toNamed "String") -stringType :: SrcLoc -> Type -> [Idea] -stringType loc x = [warn "Use String" loc x (transform f x) | typeListChar `elem` universe x] - where f x = if x == typeListChar then typeString else x +stringType :: Type_ -> [Idea] +stringType x = [warn "Use String" x (transform f x) | any (=~= typeListChar) $ universe x] + where f x = if x =~= typeListChar then typeString else x diff --git a/src/Hint/ListRec.hs b/src/Hint/ListRec.hs --- a/src/Hint/ListRec.hs +++ b/src/Hint/ListRec.hs @@ -25,6 +25,7 @@ module Hint.ListRec(listRecHint) where import Type +import Hint import Util import HSE.All import Data.List @@ -32,7 +33,6 @@ import Data.Ord import Data.Either import Control.Monad -import Data.Generics.PlateData listRecHint :: DeclHint @@ -42,9 +42,7 @@ let x = o (x, addCase) <- findCase x (use,rank,x) <- matchListRec x - let res = addCase x - loc = headDef nullSrcLoc $ universeBi o - return $ idea rank ("Use " ++ use) loc o res + return $ idea rank ("Use " ++ use) o $ addCase x recursive = toNamed "_recursive_" @@ -52,15 +50,15 @@ -- recursion parameters, nil-case, (x,xs,cons-case) -- for cons-case delete any recursive calls with xs from them -- any recursive calls are marked "_recursive_" -data ListCase = ListCase [Name] Exp (Name,Name,Exp) +data ListCase = ListCase [String] Exp_ (String,String,Exp_) deriving Show -data BList = BNil | BCons Name Name +data BList = BNil | BCons String String deriving (Eq,Ord,Show) -- function name, parameters, list-position, list-type, body (unmodified) -data Branch = Branch Name [Name] Int BList Exp +data Branch = Branch String [String] Int BList Exp_ deriving Show @@ -69,47 +67,47 @@ -- MATCH THE RECURSION -matchListRec :: ListCase -> Maybe (String,Rank,Exp) -matchListRec o@(ListCase vars nil (x,xs,cons)) +matchListRec :: ListCase -> Maybe (String,Rank,Exp_) +matchListRec o@(ListCase vs nil (x,xs,cons)) - | [] <- vars, nil ~= "[]", InfixApp lhs c rhs <- cons, opExp c ~= ":" - , fromParen rhs == recursive, Var (UnQual xs) `notElem` universe lhs + | [] <- vs, nil ~= "[]", InfixApp _ lhs c rhs <- cons, opExp c ~= ":" + , fromParen rhs =~= recursive, xs `notElem` vars lhs = Just $ (,,) "map" Error $ appsBracket - [toNamed "map", lambda [x] lhs, Var $ UnQual xs] + [toNamed "map", lambda [x] lhs, toNamed xs] - | [] <- vars, App2 op lhs rhs <- view cons - , null $ universe op `intersect` [Var (UnQual x), Var (UnQual xs)] - , fromParen rhs == recursive, Var (UnQual xs) `notElem` universe lhs + | [] <- vs, App2 op lhs rhs <- view cons + , null $ vars op `intersect` [x,xs] + , fromParen rhs == recursive, xs `notElem` vars lhs = Just $ (,,) "foldr" Warning $ appsBracket - [toNamed "foldr", lambda [x] $ appsBracket [op,lhs], nil, Var $ UnQual xs] + [toNamed "foldr", lambda [x] $ appsBracket [op,lhs], nil, toNamed xs] - | [v] <- vars, Var (UnQual v) == nil, App r lhs <- cons, r == recursive - , Var (UnQual xs) `notElem` universe lhs + | [v] <- vs, view nil == Var_ v, App _ r lhs <- cons, r =~= recursive + , xs `notElem` vars lhs = Just $ (,,) "foldl" Warning $ appsBracket - [toNamed "foldl", lambda [v,x] lhs, Var $ UnQual v, Var $ UnQual xs] + [toNamed "foldl", lambda [v,x] lhs, toNamed v, toNamed xs] - | [v] <- vars, App ret res <- nil, ret ~= "return", res ~= "()" || res == Var (UnQual v) - , [Generator _ (PVar b1) e, Qualifier (fromParen -> App r (Var (UnQual b2)))] <- asDo cons - , b1 == b2, r == recursive, Var (UnQual xs) `notElem` universe e + | [v] <- vs, App _ ret res <- nil, ret ~= "return", res ~= "()" || view res == Var_ v + , [Generator _ (view -> PVar_ b1) e, Qualifier _ (fromParen -> App _ r (view -> Var_ b2))] <- asDo cons + , b1 == b2, r == recursive, xs `notElem` vars e , name <- "foldM" ++ ['_'|res ~= "()"] = Just $ (,,) name Warning $ appsBracket - [toNamed name, lambda [v,x] e, Var $ UnQual v, Var $ UnQual xs] + [toNamed name, lambda [v,x] e, toNamed v, toNamed xs] | otherwise = Nothing -- Very limited attempt to convert >>= to do, only useful for foldM/foldM_ -asDo :: Exp -> [Stmt] -asDo (view -> App2 bind lhs (Lambda src [v] rhs)) = [Generator src v lhs, Qualifier rhs] -asDo (Do x) = x -asDo x = [Qualifier x] +asDo :: Exp_ -> [Stmt S] +asDo (view -> App2 bind lhs (Lambda _ [v] rhs)) = [Generator an v lhs, Qualifier an rhs] +asDo (Do _ x) = x +asDo x = [Qualifier an x] --------------------------------------------------------------------- -- FIND THE CASE ANALYSIS -findCase :: Decl -> Maybe (ListCase, Exp -> Decl) +findCase :: Decl_ -> Maybe (ListCase, Exp_ -> Decl_) findCase x = do - FunBind [x1,x2] <- return x + FunBind _ [x1,x2] <- return x Branch name1 ps1 p1 c1 b1 <- findBranch x1 Branch name2 ps2 p2 c2 b2 <- findBranch x2 guard (name1 == name2 && ps1 == ps2 && p1 == p2) @@ -117,24 +115,24 @@ b2 <- transformAppsM (delCons name1 p1 xs) b2 (ps,b2) <- return $ eliminateArgs ps1 b2 - let ps12 = let (a,b) = splitAt p1 ps1 in map PVar $ a ++ xs : b + let ps12 = let (a,b) = splitAt p1 ps1 in map toNamed $ a ++ xs : b return (ListCase ps b1 (x,xs,b2) - ,\e -> FunBind [Match nullSrcLoc name1 ps12 Nothing (UnGuardedRhs e) (BDecls [])]) + ,\e -> FunBind an [Match an (toNamed name1) ps12 (UnGuardedRhs an e) Nothing]) -delCons :: Name -> Int -> Name -> Exp -> Maybe Exp -delCons func pos var (fromApps -> Var (UnQual x):xs) | func == x = do - (pre,Var (UnQual v):post) <- return $ splitAt pos xs +delCons :: String -> Int -> String -> Exp_ -> Maybe Exp_ +delCons func pos var (fromApps -> (view -> Var_ x):xs) | func == x = do + (pre, (view -> Var_ v):post) <- return $ splitAt pos xs guard $ v == var return $ apps $ recursive : pre ++ post delCons _ _ _ x = return x -eliminateArgs :: [Name] -> Exp -> ([Name], Exp) +eliminateArgs :: [String] -> Exp_ -> ([String], Exp_) eliminateArgs ps cons = (remove ps, transform f cons) where - args = [zs | z:zs <- map fromApps $ universeApps cons, z == recursive] - elim = [all (\xs -> length xs > i && xs !! i == Var (UnQual p)) args | (i,p) <- zip [0..] ps] ++ repeat False + args = [zs | z:zs <- map fromApps $ universeApps cons, z =~= recursive] + elim = [all (\xs -> length xs > i && view (xs !! i) == Var_ p) args | (i,p) <- zip [0..] ps] ++ repeat False remove = concat . zipWith (\b x -> [x | not b]) elim f (fromApps -> x:xs) | x == recursive = apps $ x : remove xs @@ -144,14 +142,14 @@ --------------------------------------------------------------------- -- FIND A BRANCH -findBranch :: Match -> Maybe Branch +findBranch :: Match S -> Maybe Branch findBranch x = do - Match _ name ps Nothing (UnGuardedRhs bod) (BDecls []) <- return x + Match _ name ps (UnGuardedRhs _ bod) Nothing <- return x (a,b,c) <- findPat ps - return $ Branch name a b c bod + return $ Branch (fromNamed name) a b c bod -findPat :: [Pat] -> Maybe ([Name], Int, BList) +findPat :: [Pat_] -> Maybe ([String], Int, BList) findPat ps = do ps <- mapM readPat ps [i] <- return $ findIndices isRight ps @@ -159,10 +157,10 @@ return (left, i, right) -readPat :: Pat -> Maybe (Either Name BList) -readPat (PVar x) = Just $ Left x -readPat (PParen (PInfixApp (PVar x) (Special Cons) (PVar xs))) = Just $ Right $ BCons x xs -readPat (PList []) = Just $ Right BNil +readPat :: Pat_ -> Maybe (Either String BList) +readPat (view -> PVar_ x) = Just $ Left x +readPat (PParen _ (PInfixApp _ (view -> PVar_ x) (Special _ Cons{}) (view -> PVar_ xs))) = Just $ Right $ BCons x xs +readPat (PList _ []) = Just $ Right BNil readPat _ = Nothing @@ -170,22 +168,22 @@ -- UTILITY FUNCTIONS -- a list of application, with any necessary brackets -appsBracket :: [Exp] -> Exp -appsBracket = foldl1 (\x -> ensureBracket1 . App x) +appsBracket :: [Exp_] -> Exp_ +appsBracket = foldl1 (\x -> ensureBracket1 . App an x) -- generate a lambda, but prettier (if possible) -lambda :: [Name] -> Exp -> Exp -lambda xs (Paren x) = lambda xs x -lambda xs (Lambda s (PVar v:vs) x) = lambda (xs++[v]) (Lambda s vs x) +lambda :: [String] -> Exp_ -> Exp_ +lambda xs (Paren _ x) = lambda xs x +lambda xs (Lambda _ ((view -> PVar_ v):vs) x) = lambda (xs++[v]) (Lambda an vs x) lambda xs (Lambda _ [] x) = lambda xs x -lambda [x] (App a b) | Var (UnQual x) == b = a -lambda [x] (App a (Paren (App b c))) - | isAtom a && isAtom b && Var (UnQual x) == c = InfixApp a (toNamed ".") b -lambda [x] (InfixApp a op b) - | a == Var (UnQual x) = RightSection op b - | b == Var (UnQual x) = LeftSection a op -lambda [x,y] (view -> App2 op x1 y1) - | x1 == Var (UnQual x) && y1 == Var (UnQual y) = op - | x1 == Var (UnQual y) && y1 == Var (UnQual x) = App (toNamed "flip") op -lambda ps x = Lambda nullSrcLoc (map PVar ps) x +lambda [x] (App _ a (view -> Var_ b)) | x == b = a +lambda [x] (App _ a (Paren _ (App _ b (view -> Var_ c)))) + | isAtom a && isAtom b && x == c = InfixApp an a (toNamed ".") b +lambda [x] (InfixApp _ a op b) + | view a == Var_ x = RightSection an op b + | view b == Var_ x = LeftSection an a op +lambda [x,y] (view -> App2 op (view -> Var_ x1) (view -> Var_ y1)) + | x1 == x && y1 == y = op + | x1 == y && y1 == x = App an (toNamed "flip") op +lambda ps x = Lambda an (map toNamed ps) x diff --git a/src/Hint/Match.hs b/src/Hint/Match.hs --- a/src/Hint/Match.hs +++ b/src/Hint/Match.hs @@ -13,6 +13,7 @@ import Data.List import Data.Maybe import Type +import Hint import HSE.All import Control.Monad import Data.Function @@ -27,16 +28,16 @@ readMatch = findIdeas . filter isMatchExp -findIdeas :: [Setting] -> NameMatch -> Module -> Decl -> [Idea] +findIdeas :: [Setting] -> NameMatch -> Module S -> Decl_ -> [Idea] findIdeas matches nm _ decl = - [ idea (rankS m) (hintS m) loc x y - | (loc, x) <- universeExp nullSrcLoc decl, not $ isParen x + [ idea (rankS m) (hintS m) x y + | x <- universeBi decl, not $ isParen x , m <- matches, Just y <- [matchIdea nm m x]] -matchIdea :: NameMatch -> Setting -> Exp -> Maybe Exp +matchIdea :: NameMatch -> Setting -> Exp_ -> Maybe Exp_ matchIdea nm MatchExp{lhs=lhs,rhs=rhs,side=side} x = do - u <- unify nm lhs x + u <- unify nm (fmap (const an) lhs) (fmap (const an) x) u <- check u guard $ checkSide side u let rhs2 = subst u rhs @@ -45,59 +46,57 @@ -- unify a b = c, a[c] = b -unify :: NameMatch -> Exp -> Exp -> Maybe [(String,Exp)] -unify nm (Do xs) (Do ys) | length xs == length ys = concatZipWithM (unifyStmt nm) xs ys +unify :: NameMatch -> Exp_ -> Exp_ -> Maybe [(String,Exp_)] +unify nm (Do _ xs) (Do _ ys) | length xs == length ys = concatZipWithM (unifyStmt nm) xs ys unify nm (Lambda _ xs x) (Lambda _ ys y) | length xs == length ys = liftM2 (++) (unify nm x y) (concatZipWithM unifyPat xs ys) unify nm x y | isParen x || isParen y = unify nm (fromParen x) (fromParen y) -unify nm (Var (fromNamed -> v)) y | isUnifyVar v = Just [(v,y)] -unify nm (Var x) (Var y) | nm x y = Just [] +unify nm (Var _ (fromNamed -> v)) y | isUnifyVar v = Just [(v,y)] +unify nm (Var _ x) (Var _ y) | nm x y = Just [] unify nm x y | ((==) `on` descend (const $ toNamed "_")) x y = concatZipWithM (unify nm) (children x) (children y) unify nm x o@(view -> App2 op y1 y2) - | op ~= "$" = unify nm x $ y1 `App` y2 + | op ~= "$" = unify nm x $ App an y1 y2 | op ~= "." = unify nm x $ dotExpand o -unify nm x (InfixApp lhs op rhs) = unify nm x (opExp op `App` lhs `App` rhs) +unify nm x (InfixApp _ lhs op rhs) = unify nm x $ App an (App an (opExp op) lhs) rhs unify nm _ _ = Nothing -unifyStmt :: NameMatch -> Stmt -> Stmt -> Maybe [(String,Exp)] +unifyStmt :: NameMatch -> Stmt S -> Stmt S -> Maybe [(String,Exp_)] unifyStmt nm (Generator _ p1 x1) (Generator _ p2 x2) = liftM2 (++) (unifyPat p1 p2) (unify nm x1 x2) -unifyStmt nm x y | ((==) `on` descendBi (const (toNamed "_" :: Exp))) x y = concatZipWithM (unify nm) (childrenBi x) (childrenBi y) +unifyStmt nm x y | ((==) `on` descendBi (const (toNamed "_" :: Exp_))) x y = concatZipWithM (unify nm) (childrenBi x) (childrenBi y) unifyStmt nm _ _ = Nothing -unifyPat :: Pat -> Pat -> Maybe [(String,Exp)] -unifyPat (PVar x) (PVar y) = Just [(fromNamed x, toNamed $ fromNamed y)] -unifyPat PWildCard (PVar _) = Just [] -unifyPat x y | ((==) `on` descend (const PWildCard)) x y = concatZipWithM unifyPat (children x) (children y) +unifyPat :: Pat_ -> Pat_ -> Maybe [(String,Exp_)] +unifyPat (PVar _ x) (PVar _ y) = Just [(fromNamed x, toNamed $ fromNamed y)] +unifyPat PWildCard{} PVar{} = Just [] +unifyPat x y | ((==) `on` descend (const $ PWildCard an)) x y = concatZipWithM unifyPat (children x) (children y) unifyPat _ _ = Nothing -concatZipWithM f xs = liftM concat . zipWithM f xs - - -- check the unification is valid -check :: [(String,Exp)] -> Maybe [(String,Exp)] +check :: [(String,Exp_)] -> Maybe [(String,Exp_)] check = mapM f . groupSortFst where f (x,ys) = if length (nub ys) == 1 then Just (x,head ys) else Nothing -checkSide :: Maybe Exp -> [(String,Exp)] -> Bool +checkSide :: Maybe Exp_ -> [(String,Exp_)] -> Bool checkSide Nothing bind = True checkSide (Just x) bind = f x where - f (InfixApp x op y) + f (InfixApp _ x op y) | opExp op ~= "&&" = f x && f y | opExp op ~= "||" = f x || f y - f (Paren x) = f x - f (App x (Var y)) + f (Paren _ x) = f x + f (App _ x (Var _ y)) | 'i':'s':typ <- fromNamed x, Just e <- lookup (fromNamed y) bind = if typ == "Atom" then isAtom e else head (words $ show e) == typ - f (App (App nin xs) ys) | nin ~= "notIn" = and [notIn x y | x <- g xs, y <- g ys] + f (App _ (App _ nin xs) ys) | nin ~= "notIn" = and [notIn x y | x <- g xs, y <- g ys] + f x | x ~= "notTypeSafe" = True f x = error $ "Hint.Match.checkSide, unknown side condition: " ++ prettyPrint x - g :: Exp -> [Exp] - g (List xs) = xs + g :: Exp_ -> [Exp_] + g (List _ xs) = xs g x = [x] notIn x y = fromMaybe False $ do @@ -108,45 +107,45 @@ -- If they have have a lambda in the pattern -- don't allow dot contraction to happen, as it's usually wrong -checkDot :: Exp -> Exp -> Bool -checkDot lhs rhs2 = not $ any isLambda (universeBi lhs) && toNamed "?" `elem` universe rhs2 +checkDot :: Exp_ -> Exp_ -> Bool +checkDot lhs rhs2 = not $ any isLambda (universeS lhs) && toNamed "?" `elem` universe rhs2 -- perform a substitution -subst :: [(String,Exp)] -> Exp -> Exp +subst :: [(String,Exp_)] -> Exp_ -> Exp_ subst bind = transform g . transformBracket f where - f (Var (fromNamed -> x)) | isUnifyVar x = lookup x bind + f (Var _ (fromNamed -> x)) | isUnifyVar x = lookup x bind f _ = Nothing - g (App np (Paren x)) | np ~= "_noParen_" = x + g (App _ np (Paren _ x)) | np ~= "_noParen_" = x g x = x -dotExpand :: Exp -> Exp -dotExpand (view -> App2 op x1 x2) | op ~= "." = ensureBracket1 $ App x1 (dotExpand x2) -dotExpand x = ensureBracket1 $ App x (toNamed "?") +dotExpand :: Exp_ -> Exp_ +dotExpand (view -> App2 op x1 x2) | op ~= "." = ensureBracket1 $ App an x1 (dotExpand x2) +dotExpand x = ensureBracket1 $ App an x (toNamed "?") -- simplify, removing any introduced ? vars, from expanding (.) -dotContract :: Exp -> Exp +dotContract :: Exp_ -> Exp_ dotContract x = fromMaybe x (f x) where f x | isParen x = f $ fromParen x - f (App x y) | "?" <- fromNamed y = Just x - | Just z <- f y = Just $ InfixApp x (toNamed ".") z + f (App _ x y) | "?" <- fromNamed y = Just x + | Just z <- f y = Just $ InfixApp an x (toNamed ".") z f _ = Nothing -- if it has _eval_ do evaluation on it -performEval :: Exp -> Exp -performEval (App e x) | e ~= "_eval_" = evaluate x +performEval :: Exp_ -> Exp_ +performEval (App _ e x) | e ~= "_eval_" = evaluate x performEval x = x -- contract Data.List.foo ==> foo, if Data.List is loaded -unqualify :: NameMatch -> Exp -> Exp +unqualify :: NameMatch -> Exp_ -> Exp_ unqualify nm = transformBi f where - f (Qual mod x) | nm (Qual mod x) (UnQual x) = UnQual x + f (Qual _ mod x) | nm (Qual an mod x) (UnQual an x) = UnQual an x f x = x diff --git a/src/Hint/Monad.hs b/src/Hint/Monad.hs --- a/src/Hint/Monad.hs +++ b/src/Hint/Monad.hs @@ -36,59 +36,60 @@ import Data.List import HSE.All import Type +import Hint badFuncs = ["mapM","foldM","forM","replicateM","sequence","zipWithM"] monadHint :: DeclHint -monadHint _ _ = concatMap monadExp . universeExp nullSrcLoc +monadHint _ _ = concatMap monadExp . universeBi -monadExp :: (SrcLoc,Exp) -> [Idea] -monadExp (loc,x) = case x of +monadExp :: Exp_ -> [Idea] +monadExp x = case x of (view -> App2 op x1 x2) | op ~= ">>" -> f x1 - Do xs -> [idea Error "Redundant return" loc x y | Just y <- [monadReturn xs]] ++ - [idea Error "Use join" loc x (Do y) | Just y <- [monadJoin xs]] ++ - [idea Error "Redundant do" loc x y | [Qualifier y] <- [xs]] ++ - [idea Error "Use let" loc x (Do y) | Just y <- [monadLet xs]] ++ - concat [f x | Qualifier x <- init xs] + Do _ xs -> [idea Error "Redundant return" x y | Just y <- [monadReturn xs]] ++ + [idea Error "Use join" x (Do an y) | Just y <- [monadJoin xs]] ++ + [idea Error "Redundant do" x y | [Qualifier _ y] <- [xs]] ++ + [idea Error "Use let" x (Do an y) | Just y <- [monadLet xs]] ++ + concat [f x | Qualifier _ x <- init xs] _ -> [] where - f x = [idea Error ("Use " ++ name) loc x y + f x = [idea Error ("Use " ++ name) x y |Just (name,y) <- [monadCall x]] -- see through Paren and down if/case etc -monadCall :: Exp -> Maybe (String,Exp) -monadCall (Paren x) = liftM (second Paren) $ monadCall x -monadCall (App x y) = liftM (second (`App` y)) $ monadCall x +monadCall :: Exp_ -> Maybe (String,Exp_) +monadCall (Paren _ x) = fmap (second $ Paren an) $ monadCall x +monadCall (App _ x y) = fmap (second $ \x -> App an x y) $ monadCall x monadCall x | x:_ <- filter (x ~=) badFuncs = let x2 = x ++ "_" in Just (x2, toNamed x2) monadCall _ = Nothing -monadReturn (reverse -> Qualifier (App ret (Var v)):Generator _ (PVar p) x:rest) +monadReturn (reverse -> Qualifier _ (App _ ret (Var _ v)):Generator _ (PVar _ p) x:rest) | ret ~= "return", fromNamed v == fromNamed p - = Just $ Do $ reverse $ Qualifier x : rest + = Just $ Do an $ reverse $ Qualifier an x : rest monadReturn _ = Nothing -monadJoin (Generator _ (PVar p) x:Qualifier (Var v):xs) - | fromNamed p == fromNamed v && Var v `notElem` universeBi xs - = Just $ Qualifier (ensureBracket1 $ App (toNamed "join") x) : fromMaybe xs (monadJoin xs) -monadJoin (x:xs) = liftM (x:) $ monadJoin xs +monadJoin (Generator _ (view -> PVar_ p) x:Qualifier _ (view -> Var_ v):xs) + | p == v && v `notElem` vars xs + = Just $ Qualifier an (ensureBracket1 $ App an (toNamed "join") x) : fromMaybe xs (monadJoin xs) +monadJoin (x:xs) = fmap (x:) $ monadJoin xs monadJoin [] = Nothing monadLet xs = if xs == ys then Nothing else Just ys where ys = map mkLet xs - vars = [v | Generator _ p _ <- xs, PVar v <- universe p] - mkLet (Generator sl (PVar p) (fromRet -> Just y)) - | p `notElem` [v | Var (UnQual v) <- universeBi y], p `notElem` delete p vars - = LetStmt $ BDecls [PatBind sl (PVar p) Nothing (UnGuardedRhs y) (BDecls [])] + vs = concatMap pvars [p | Generator _ p _ <- xs] + mkLet (Generator _ (view -> PVar_ p) (fromRet -> Just y)) + | p `notElem` vars y, p `notElem` delete p vs + = LetStmt an $ BDecls an [PatBind an (toNamed p) Nothing (UnGuardedRhs an y) Nothing] mkLet x = x -fromRet (Paren x) = fromRet x -fromRet (InfixApp x y z) | opExp y ~= "$" = fromRet $ App x z -fromRet (App x y) | x ~= "return" = Just y +fromRet (Paren _ x) = fromRet x +fromRet (InfixApp _ x y z) | opExp y ~= "$" = fromRet $ App an x z +fromRet (App _ x y) | x ~= "return" = Just y fromRet _ = Nothing diff --git a/src/Hint/Naming.hs b/src/Hint/Naming.hs --- a/src/Hint/Naming.hs +++ b/src/Hint/Naming.hs @@ -26,6 +26,7 @@ import HSE.All import Type +import Hint import Data.List import Data.Char import Data.Maybe @@ -33,32 +34,32 @@ namingHint :: DeclHint -namingHint _ modu = naming $ Set.fromList [x | Ident x <- universeBi modu] +namingHint _ modu = naming $ Set.fromList [x | Ident _ x <- universeS modu] -naming :: Set.Set String -> Decl -> [Idea] -naming seen x = [warn "Use camelCase" (declSrcLoc x) x2 (replaceNames res x2) | not $ null res] +naming :: Set.Set String -> Decl_ -> [Idea] +naming seen x = [warn "Use camelCase" x2 (replaceNames res x2) | not $ null res] where res = [(n,y) | n <- nub $ getNames x, Just y <- [suggestName n], not $ y `Set.member` seen] x2 = shorten x -shorten :: Decl -> Decl +shorten :: Decl_ -> Decl_ shorten x = case x of - FunBind (Match a b c d e _:_) -> FunBind [f (Match a b c d) e] + FunBind sl (Match a b c d _:_) -> FunBind sl [f (Match a b c) d] PatBind a b c d _ -> f (PatBind a b c) d x -> x where - dots = Var $ UnQual $ Ident "..." -- Must be an Ident, not a Symbol - f cont (UnGuardedRhs _) = cont (UnGuardedRhs dots) (BDecls []) - f cont (GuardedRhss _) = cont (GuardedRhss [GuardedRhs nullSrcLoc [Qualifier dots] dots]) (BDecls []) + dots = Var an $ UnQual an $ Ident an "..." -- Must be an Ident, not a Symbol + f cont (UnGuardedRhs _ _) = cont (UnGuardedRhs an dots) Nothing + f cont (GuardedRhss _ _) = cont (GuardedRhss an [GuardedRhs an [Qualifier an dots] dots]) Nothing -getNames :: Decl -> [String] +getNames :: Decl_ -> [String] getNames x = case x of FunBind{} -> name PatBind{} -> name TypeDecl{} -> name - DataDecl _ _ _ _ _ cons _ -> name ++ [fromNamed x | QualConDecl _ _ _ x <- cons, x <- f x] - GDataDecl _ _ _ _ _ _ cons _ -> name ++ [fromNamed x | GadtDecl _ x _ <- cons] + DataDecl _ _ _ _ cons _ -> name ++ [fromNamed x | QualConDecl _ _ _ x <- cons, x <- f x] + GDataDecl _ _ _ _ _ cons _ -> name ++ [fromNamed x | GadtDecl _ x _ <- cons] TypeFamDecl{} -> name DataFamDecl{} -> name ClassDecl{} -> name @@ -66,9 +67,9 @@ where name = [fromNamed x] - f (ConDecl x _) = [x] - f (InfixConDecl _ x _) = [x] - f (RecDecl x ys) = x : concatMap fst ys + f (ConDecl _ x _) = [x] + f (InfixConDecl _ _ x _) = [x] + f (RecDecl _ x ys) = x : concat [y | FieldDecl _ y _ <- ys] suggestName :: String -> Maybe String diff --git a/src/Hint/Pragma.hs b/src/Hint/Pragma.hs --- a/src/Hint/Pragma.hs +++ b/src/Hint/Pragma.hs @@ -28,42 +28,43 @@ import HSE.All import Type +import Hint import Data.List import Data.Maybe import Data.Function pragmaHint :: ModuHint -pragmaHint _ x = languageDupes lang ++ [pragmaIdea old $ [LanguagePragma nullSrcLoc ns2 | ns2 /= []] ++ catMaybes new | old /= []] +pragmaHint _ x = languageDupes lang ++ [pragmaIdea old $ [LanguagePragma an (map toNamed ns2) | ns2 /= []] ++ catMaybes new | old /= []] where lang = [x | x@LanguagePragma{} <- modulePragmas x] (old,new,ns) = unzip3 [(old,new,ns) | old <- modulePragmas x, Just (new,ns) <- [optToLanguage old]] - ns2 = nub (concat ns) \\ concat [n | LanguagePragma _ n <- lang] + ns2 = nub (concat ns) \\ concat [map fromNamed n | LanguagePragma _ n <- lang] -pragmaIdea :: [OptionPragma] -> [OptionPragma] -> Idea -pragmaIdea xs ys = rawIdea Error "Use better pragmas" (fromJust $ getSrcLoc $ head xs) (f xs) (f ys) +pragmaIdea :: [OptionPragma S] -> [OptionPragma S] -> Idea +pragmaIdea xs ys = rawIdea Error "Use better pragmas" (toSrcLoc $ ann $ head xs) (f xs) (f ys) where f = unlines . map prettyPrint -languageDupes :: [OptionPragma] -> [Idea] +languageDupes :: [OptionPragma S] -> [Idea] languageDupes [] = [] -languageDupes (a@(LanguagePragma sl x):xs) = - (if nub x /= x - then [pragmaIdea [a] [LanguagePragma sl $ nub x]] - else [pragmaIdea [a,b] [LanguagePragma sl (nub $ x ++ y)] | b@(LanguagePragma _ y) <- xs, not $ null $ intersect x y]) ++ +languageDupes (a@(LanguagePragma _ x):xs) = + (if nub_ x `neqList` x + then [pragmaIdea [a] [LanguagePragma an $ nub_ x]] + else [pragmaIdea [a,b] [LanguagePragma an (nub_ $ x ++ y)] | b@(LanguagePragma _ y) <- xs, not $ null $ intersect_ x y]) ++ languageDupes xs -- Given a pragma, can you extract some language features out -strToLanguage :: String -> Maybe [Name] -strToLanguage "-cpp" = Just [Ident "CPP"] -strToLanguage x | "-X" `isPrefixOf` x = Just [Ident $ drop 2 x] -strToLanguage "-fglasgow-exts" = Just $ map (Ident . show) glasgowExts +strToLanguage :: String -> Maybe [String] +strToLanguage "-cpp" = Just ["CPP"] +strToLanguage x | "-X" `isPrefixOf` x = Just [drop 2 x] +strToLanguage "-fglasgow-exts" = Just $ map show glasgowExts strToLanguage _ = Nothing -optToLanguage :: OptionPragma -> Maybe (Maybe OptionPragma, [Name]) +optToLanguage :: OptionPragma S -> Maybe (Maybe (OptionPragma S), [String]) optToLanguage (OptionsPragma sl tool val) | maybe True (== GHC) tool && any isJust vs = Just (res, concat $ catMaybes vs) where diff --git a/src/Hint/Structure.hs b/src/Hint/Structure.hs --- a/src/Hint/Structure.hs +++ b/src/Hint/Structure.hs @@ -23,52 +23,50 @@ import HSE.All import Type +import Hint import Util import Data.List import Data.Maybe structureHint :: DeclHint -structureHint _ _ x = concat [concatMap useGuards xs | FunBind xs <- [x]] ++ - concatMap useIf (universeExp nullSrcLoc x) +structureHint _ _ x = concat [concatMap useGuards xs | FunBind _ xs <- [x]] ++ + concatMap useIf (universeBi x) -useGuards :: Match -> [Idea] -useGuards x@(Match a b c d (UnGuardedRhs bod) e) - | length guards > 2 = [warn "Use guards" a x x2] +useGuards :: Match S -> [Idea] +useGuards x@(Match a b c (UnGuardedRhs d bod) e) + | length guards > 2 = [warn "Use guards" x x2] where guards = asGuards bod - x2 = Match a b c d (GuardedRhss guards) e + x2 = Match a b c (GuardedRhss d guards) e -useGuards o@(Match sl b pats d (GuardedRhss [GuardedRhs _ [Generator _ pat (App op (Var (UnQual p)))] bod]) (BDecls decs)) - | Just i <- findIndex (== PVar p) pats - , p `notElem` (vr bod ++ vr decs) - , vr op `disjoint` decsBind, pvr pats `disjoint` vr op, pvr pat `disjoint` pvr pats - = [warn "Use view patterns" sl o $ - Match sl b (take i pats ++ [PParen $ PViewPat op pat] ++ drop (i+1) pats) d (UnGuardedRhs bod) (BDecls decs)] +useGuards o@(Match sl b pats (GuardedRhss _ [GuardedRhs _ [Generator _ pat (App _ op (view -> Var_ p))] bod]) decs) + | Just i <- findIndex (=~= (toNamed p :: Pat_)) pats + , p `notElem` (vars bod ++ vars decs) + , vars op `disjoint` decsBind, pvars pats `disjoint` vars op, pvars pat `disjoint` pvars pats + = [warn "Use view patterns" o $ + Match sl b (take i pats ++ [PParen an $ PViewPat an op pat] ++ drop (i+1) pats) (UnGuardedRhs an bod) decs] where - decsBind = nub $ concatMap declBind decs - - vr x = [y | Var (UnQual y) <- universeBi x] - pvr x = [y | PVar y <- universeBi x] + decsBind = nub $ concatMap declBind $ childrenBi decs useGuards _ = [] -asGuards :: Exp -> [GuardedRhs] -asGuards (Paren x) = asGuards x -asGuards (If a b c) = GuardedRhs nullSrcLoc [Qualifier a] b : asGuards c -asGuards x = [GuardedRhs nullSrcLoc [Qualifier $ toNamed "otherwise"] x] +asGuards :: Exp_ -> [GuardedRhs S] +asGuards (Paren _ x) = asGuards x +asGuards (If _ a b c) = GuardedRhs an [Qualifier an a] b : asGuards c +asGuards x = [GuardedRhs an [Qualifier an $ toNamed "otherwise"] x] -useIf :: (SrcLoc,Exp) -> [Idea] -useIf (loc,x@(Case on [simpAlt -> Just (as,av), simpAlt -> Just (bs,bv)])) +useIf :: Exp_ -> [Idea] +useIf x@(Case _ on [simpAlt -> Just (as,av), simpAlt -> Just (bs,bv)]) | as == "True" && bs `elem` ["False","_"] = iff av bv | as == "False" && bs `elem` ["True" ,"_"] = iff bv av where - iff t f = [warn "Use if" loc x (If on t f)] + iff t f = [warn "Use if" x (If an on t f)] useIf _ = [] -simpAlt (Alt _ p (UnGuardedAlt x) (BDecls [])) = Just (prettyPrint p, x) +simpAlt (Alt _ p (UnGuardedAlt _ x) Nothing) = Just (prettyPrint p, x) simpAlt _ = Nothing diff --git a/src/Language/Haskell/HLint.hs b/src/Language/Haskell/HLint.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/HLint.hs @@ -0,0 +1,4 @@ + +module Language.Haskell.HLint(hlint) where + +import HLint diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,6 +1,6 @@ {- HLint, Haskell source code suggestions -Copyright (C) 2006-2009, Neil Mitchell +Copyright (C) 2006-2010, Neil Mitchell This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -16,62 +16,17 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -} -{-# LANGUAGE RecordWildCards #-} - module Main where -import Control.Arrow +import Language.Haskell.HLint import Control.Monad -import Data.List -import Data.Maybe +import System.Environment import System.Exit -import CmdLine -import Settings -import Report -import Type -import Test -import Util -import Parallel -import Hint.All -import HSE.All - - +main :: IO () main = do - Cmd{..} <- getCmd - if cmdTest then test else do - settings <- readSettings cmdHintFiles - let extra = [Classify Ignore x ("","") | x <- cmdIgnore] - let apply :: FilePath -> IO [Idea] - apply = fmap (fmap $ classify $ settings ++ extra) . applyHint parseFlags{cpphs=Just cmdCpphs} (allHints settings) - ideas <- liftM concat $ parallel [listM' =<< apply x | x <- cmdFiles] - let visideas = filter (\i -> cmdShowAll || rank i /= Ignore) ideas - showItem <- if cmdColor then showANSI else return show - mapM_ (putStrLn . showItem) visideas - - -- figure out statistics - let counts = map (head &&& length) $ group $ sort $ map rank ideas - let [ignore,warn,err] = map (fromMaybe 0 . flip lookup counts) [Ignore,Warning,Error] - let total = ignore + warn + err - let shown = if cmdShowAll then total else total - ignore - - let ignored = [show i ++ " ignored" | let i = total - shown, i /= 0] - let errors = [show err ++ " error" ++ ['s'|err/=1] | err /= 0] - - if shown == 0 then do - when (cmdReports /= []) $ putStrLn "Skipping writing reports" - printMsg "No relevant suggestions" ignored - else do - forM_ cmdReports $ \x -> do - putStrLn $ "Writing report to " ++ x ++ " ..." - writeReport x visideas - printMsg ("Found " ++ show shown ++ " suggestion" ++ ['s'|shown/=1]) (errors++ignored) - - when (err > 0) $ - exitWith $ ExitFailure 1 - + args <- getArgs + errs <- hlint args + when (errs > 0) $ + exitWith $ ExitFailure 1 -printMsg :: String -> [String] -> IO () -printMsg msg xs = - putStrLn $ msg ++ if null xs then "" else - " (" ++ intercalate ", " xs ++ ")" diff --git a/src/Report.hs b/src/Report.hs --- a/src/Report.hs +++ b/src/Report.hs @@ -13,18 +13,17 @@ import Language.Haskell.HsColour.CSS -writeTemplate :: [(String,[String])] -> FilePath -> IO () -writeTemplate content to = do - dat <- getDataDir - src <- readFile $ dat "report.html" +writeTemplate :: FilePath -> [(String,[String])] -> FilePath -> IO () +writeTemplate dataDir content to = do + src <- readFile $ dataDir "report.html" writeFile to $ unlines $ concatMap f $ lines src where f ('$':xs) = fromMaybe ['$':xs] $ lookup xs content f x = [x] -writeReport :: FilePath -> [Idea] -> IO () -writeReport file ideas = writeTemplate inner file +writeReport :: FilePath -> FilePath -> [Idea] -> IO () +writeReport dataDir file ideas = writeTemplate dataDir inner file where generateIds :: [String] -> [(String,Int)] -- sorted by name generateIds = map (head &&& length) . group . sort diff --git a/src/Settings.hs b/src/Settings.hs --- a/src/Settings.hs +++ b/src/Settings.hs @@ -1,39 +1,36 @@ {-# LANGUAGE PatternGuards, ViewPatterns #-} -module Settings(readSettings, classify) where +module Settings(readSettings, classify, defaultName) where import HSE.All -import Paths_hlint import Type import Data.Char import Data.List import System.FilePath import Util -import Data.Generics.PlateData +import Data.Generics.Uniplate.Data -- Given a list of hint files to start from -- Return the list of settings commands -readSettings :: [FilePath] -> IO [Setting] -readSettings xs = do - (builtin,mods) <- fmap unzipEither $ concatMapM readHints xs +readSettings :: FilePath -> [FilePath] -> IO [Setting] +readSettings dataDir xs = do + (builtin,mods) <- fmap unzipEither $ concatMapM (readHints dataDir) xs return $ map Builtin builtin ++ concatMap (concatMap readSetting . concatMap getEquations . moduleDecls) mods -- read all the files -- in future this should also do import chasing, but -- currently it doesn't -readHints :: FilePath -> IO [Either String Module] -readHints file = do +readHints :: FilePath -> FilePath -> IO [Either String Module_] +readHints dataDir file = do y <- fromParseResult `fmap` parseFile parseFlags{implies=True} file ys <- concatMapM (f . fromNamed . importModule) $ moduleImports y return $ Right y:ys where f x | "HLint.Builtin." `isPrefixOf` x = return [Left $ drop 14 x] - | "HLint." `isPrefixOf` x = do - dat <- getDataDir - readHints $ dat drop 6 x <.> "hs" - | otherwise = readHints $ x <.> "hs" + | "HLint." `isPrefixOf` x = readHints dataDir $ dataDir drop 6 x <.> "hs" + | otherwise = readHints dataDir $ x <.> "hs" -- Eta bound variable lifted so the filter only happens once per classify @@ -52,49 +49,50 @@ --------------------------------------------------------------------- -- READ A HINT -readSetting :: Decl -> [Setting] -readSetting (FunBind [Match src (Ident (getRank -> rank)) pats _ - (UnGuardedRhs bod) (BDecls bind)]) - | InfixApp lhs op rhs <- bod, opExp op ~= "==>" = - [MatchExp rank (head names) (fromParen lhs) (fromParen rhs) (readSide bind)] +defaultName = "Use alternative" + +readSetting :: Decl_ -> [Setting] +readSetting (FunBind _ [Match _ (Ident _ (getRank -> rank)) pats (UnGuardedRhs _ bod) bind]) + | InfixApp _ lhs op rhs <- bod, opExp op ~= "==>" = + [MatchExp rank (if null names then defaultName else head names) (fromParen lhs) (fromParen rhs) (readSide $ childrenBi bind)] | otherwise = [Classify rank n func | n <- names2, func <- readFuncs bod] where names = getNames pats bod names2 = ["" | null names] ++ names -readSetting (PatBind src (PVar name) typ bod bind) = readSetting $ FunBind [Match src name [PLit (String "")] typ bod bind] -readSetting (FunBind xs) | length xs /= 1 = concatMap (readSetting . FunBind . (:[])) xs -readSetting x = error $ "Failed to read hint " ++ maybe "" showSrcLoc (getSrcLoc x) ++ "\n" ++ prettyPrint x +readSetting (PatBind _ (PVar _ name) _ bod bind) = readSetting $ FunBind an [Match an name [PLit an (String an "" "")] bod bind] +readSetting (FunBind _ xs) | length xs /= 1 = concatMap (readSetting . FunBind an . (:[])) xs +readSetting x = error $ "Failed to read hint " ++ prettyPrint (getPointLoc $ ann x) ++ "\n" ++ prettyPrint x -readSide :: [Decl] -> Maybe Exp +readSide :: [Decl_] -> Maybe Exp_ readSide [] = Nothing -readSide [PatBind src PWildCard Nothing (UnGuardedRhs bod) (BDecls [])] = Just bod -readSide (x:_) = error $ "Failed to read side condition " ++ maybe "" showSrcLoc (getSrcLoc x) ++ "\n" ++ prettyPrint x +readSide [PatBind _ PWildCard{} Nothing (UnGuardedRhs _ bod) Nothing] = Just bod +readSide (x:_) = error $ "Failed to read side condition " ++ prettyPrint (getPointLoc $ ann x) ++ "\n" ++ prettyPrint x -readFuncs :: Exp -> [FuncName] -readFuncs (App x y) = readFuncs x ++ readFuncs y -readFuncs (Lit (String "")) = [("","")] -readFuncs (Var (UnQual name)) = [("",fromNamed name)] -readFuncs (Var (Qual (ModuleName mod) name)) = [(mod, fromNamed name)] -readFuncs (Con (UnQual name)) = [(fromNamed name,"")] -readFuncs (Con (Qual (ModuleName mod) name)) = [(mod ++ "." ++ fromNamed name,"")] +readFuncs :: Exp_ -> [FuncName] +readFuncs (App _ x y) = readFuncs x ++ readFuncs y +readFuncs (Lit _ (String _ "" _)) = [("","")] +readFuncs (Var _ (UnQual _ name)) = [("",fromNamed name)] +readFuncs (Var _ (Qual _ (ModuleName _ mod) name)) = [(mod, fromNamed name)] +readFuncs (Con _ (UnQual _ name)) = [(fromNamed name,"")] +readFuncs (Con _ (Qual _ (ModuleName _ mod) name)) = [(mod ++ "." ++ fromNamed name,"")] readFuncs x = error $ "Failed to read classification rule\n" ++ prettyPrint x -getNames :: [Pat] -> Exp -> [String] +getNames :: [Pat_] -> Exp_ -> [String] getNames ps _ | ps /= [] && all isPString ps = map fromPString ps -getNames [] (InfixApp lhs op rhs) | opExp op ~= "==>" = ["Use " ++ head (names ++ ["alternative"])] +getNames [] (InfixApp _ lhs op rhs) | opExp op ~= "==>" = map ("Use "++) names where - lnames = map f $ childrenBi lhs - rnames = map f $ childrenBi rhs + lnames = map f $ childrenS lhs + rnames = map f $ childrenS rhs names = filter (not . isUnifyVar) $ (rnames \\ lnames) ++ rnames - f (Ident x) = x - f (Symbol x) = x -getNames [] _ = [""] + f (Ident _ x) = x + f (Symbol _ x) = x +getNames _ _ = [] getRank :: String -> Rank diff --git a/src/Test.hs b/src/Test.hs --- a/src/Test.hs +++ b/src/Test.hs @@ -3,6 +3,7 @@ module Test where import Control.Arrow +import Control.Exception import Control.Monad import Data.Char import Data.List @@ -10,12 +11,15 @@ import Data.Function import System.Directory import System.FilePath +import System.IO +import System.Cmd +import System.Exit import Settings import Type +import Hint import HSE.All import Hint.All -import Paths_hlint -- Input, Output @@ -24,27 +28,66 @@ data Test = Test SrcLoc String (Maybe String) -test :: IO () -test = do - dat <- getDataDir - datDir <- getDirectoryContents dat +test :: FilePath -> IO Int +test dataDir = do + dataLs <- getDirectoryContents dataDir src <- doesDirectoryExist "src/Hint" - (fail,total) <- liftM ((sum *** sum) . unzip) $ sequence $ - [runTestDyn (dat h) | h <- datDir, takeExtension h == ".hs"] ++ + (fail,total) <- fmap ((sum *** sum) . unzip) $ sequence $ + [runTestDyn dataDir (dataDir h) | h <- dataLs, takeExtension h == ".hs", not $ "HLint" `isPrefixOf` takeBaseName h] ++ [runTest h ("src/Hint" name <.> "hs") | (name,h) <- staticHints, src] unless src $ putStrLn "Warning, couldn't find source code, so non-hint tests skipped" if fail == 0 then putStrLn $ "Tests passed (" ++ show total ++ ")" else putStrLn $ "Tests failed (" ++ show fail ++ " of " ++ show total ++ ")" + return fail -runTestDyn :: FilePath -> IO (Int,Int) -runTestDyn file = do - settings <- readSettings [file] - runTest (dynamicHints settings) file +runTestDyn :: FilePath -> FilePath -> IO (Int,Int) +runTestDyn dataDir file = do + settings <- readSettings dataDir [file] + let bad = [putStrLn $ "No name for the hint " ++ prettyPrint (lhs x) | x@MatchExp{} <- settings, hintS x == defaultName] + sequence_ bad + + (f1,t1) <- runTestTypes settings + (f2,t2) <- runTest (dynamicHints settings) file + return (length bad + f1 + f2, t1 + t2) + +runTestTypes :: [Setting] -> IO (Int,Int) +runTestTypes settings = bracket + (openTempFile "." "hlinttmp.hs") + (\(file,h) -> removeFile file) + $ \(file,h) -> do + hPutStrLn h $ unlines contents + hClose h + res <- system $ "runhaskell " ++ file + return (if res == ExitSuccess then 0 else 1, 1) + where + contents = + ["{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules #-}" + ,"import System.IO" + ,"import Control.Arrow" + ,"import Data.Maybe" + ,"import Control.Monad" + ,"import Data.List" + ,"import Data.Int" + ,"import Data.Ord" + ,"import Data.Monoid" + ,"import Data.Function" + ,"main = return ()" + ,"(==>) :: a -> a -> a; (==>) = undefined" + ,"_noParen_ = id" + ,"_eval_ = id" + ,"bad = undefined"] ++ + [prettyPrint $ PatBind an (toNamed $ "test" ++ show i) Nothing bod Nothing + | (i, MatchExp _ _ lhs rhs side) <- zip [1..] settings, "notTypeSafe" `notElem` vars side + , let vs = map toNamed $ nub $ filter isUnifyVar $ vars lhs ++ vars rhs + , let inner = InfixApp an (Paren an lhs) (toNamed "==>") (Paren an rhs) + , let bod = UnGuardedRhs an $ if null vs then inner else Lambda an vs inner] + + -- return the number of fails/total runTest :: Hint -> FilePath -> IO (Int,Int) runTest hint file = do @@ -54,7 +97,7 @@ return (length failures, length tests) where f (Test loc inp out) = - ["TEST FAILURE\n" ++ + ["TEST FAILURE (" ++ show (length ideas) ++ " hints generated)\n" ++ "SRC: " ++ showSrcLoc loc ++ "\n" ++ "INPUT: " ++ inp ++ "\n" ++ concatMap ((++) "OUTPUT: " . show) ideas ++ diff --git a/src/Type.hs b/src/Type.hs --- a/src/Type.hs +++ b/src/Type.hs @@ -29,7 +29,7 @@ -- Idea are generated by the program data Setting = Classify {rankS :: Rank, hintS :: String, funcS :: FuncName} - | MatchExp {rankS :: Rank, hintS :: String, lhs :: Exp, rhs :: Exp, side :: Maybe Exp} + | MatchExp {rankS :: Rank, hintS :: String, lhs :: Exp_, rhs :: Exp_, side :: Maybe Exp_} | Builtin String -- use a builtin hint set deriving Show @@ -62,9 +62,8 @@ [showSrcLoc loc ++ " Parse error","Error message:"," " ++ msg,"Code:"] ++ map (" "++) (lines $ tt from) --- The real key will be filled in by applyHint rawIdea = Idea ("","") -idea rank hint loc from to = rawIdea rank hint loc (f from) (f to) +idea rank hint from to = rawIdea rank hint (toSrcLoc $ ann from) (f from) (f to) where f = dropWhile isSpace . prettyPrint warn mr = idea Warning mr @@ -73,33 +72,3 @@ isUnifyVar :: String -> Bool isUnifyVar [x] = x == '?' || isAlpha x isUnifyVar _ = False - ---------------------------------------------------------------------- --- HINTS - -type DeclHint = NameMatch -> Module -> Decl -> [Idea] -type ModuHint = NameMatch -> Module -> [Idea] - -data Hint = DeclHint {declHint :: DeclHint} | ModuHint {moduHint :: ModuHint} - - -applyHint :: ParseFlags -> [Hint] -> FilePath -> IO [Idea] -applyHint flags h file = do - src <- readFile file - return $ applyHintStr flags h file src - - -applyHintStr :: ParseFlags -> [Hint] -> FilePath -> String -> [Idea] -applyHintStr flags h file src = - case parseString flags file src of - ParseFailed sl msg -> - let ticks = [" "," ","> "," "," "] - bad = zipWith (++) ticks $ take 5 $ drop (srcLine sl - 3) $ lines src ++ [""] - bad2 = reverse $ dropWhile (all isSpace) $ reverse $ dropWhile (all isSpace) bad - in [ParseError Warning "Parse error" sl msg (unlines bad2)] - ParseOk m -> - let name = moduleName m - nm = nameMatch $ moduleImports m - order n = map (\i -> i{func = (name,n)}) . sortBy (comparing loc) - in order "" [i | ModuHint h <- h, i <- h nm m] ++ - concat [order (fromNamed d) [i | DeclHint h <- h, i <- h nm m d] | d <- moduleDecls m] diff --git a/src/Util.hs b/src/Util.hs --- a/src/Util.hs +++ b/src/Util.hs @@ -32,6 +32,10 @@ concatMapM f = liftM concat . mapM f +concatZipWithM :: Monad m => (a -> b -> m [c]) -> [a] -> [b] -> m [c] +concatZipWithM f xs ys = liftM concat $ zipWithM f xs ys + + headDef :: a -> [a] -> a headDef x [] = x headDef x (y:ys) = y