diff --git a/data/Default.hs b/data/Default.hs --- a/data/Default.hs +++ b/data/Default.hs @@ -98,18 +98,25 @@ warn = (\(x,y) -> (f x,y)) ==> first f where _ = notIn [x,y] f warn = (\(x,y) -> (x,f y)) ==> second f where _ = notIn [x,y] f +-- FUNCTOR + +error "Functor law" = fmap f (fmap g x) ==> fmap (f . g) x +error "Functor law" = fmap id ==> id + -- MONAD error "Monad law, left identity" = return a >>= f ==> f a error "Monad law, right identity" = m >>= return ==> m warn = m >>= return . f ==> liftM f m error = (if x then y else return ()) ==> when x $ _noParen_ y +error = (if x then return () else y) ==> unless x $ _noParen_ y error = sequence (map f x) ==> mapM f x error = sequence_ (map f x) ==> mapM_ f x warn = flip mapM ==> forM warn = flip mapM_ ==> forM_ error = when (not x) ==> unless x error = x >>= id ==> join x +error = liftM f (liftM g x) ==> liftM (f . g) x -- MONAD LIST diff --git a/hlint.cabal b/hlint.cabal --- a/hlint.cabal +++ b/hlint.cabal @@ -1,7 +1,7 @@ cabal-version: >= 1.6 build-type: Simple name: hlint -version: 1.6.5 +version: 1.6.6 license: GPL license-file: LICENSE category: Development @@ -29,8 +29,8 @@ executable hlint build-depends: - base == 4.*, syb, filepath, directory, mtl, containers, hscolour >= 1.10, - haskell-src-exts >= 1 && < 1.1, uniplate == 1.2.* && >= 1.2.0.2, parallel + base == 4.*, syb, filepath, directory, mtl, containers, hscolour >= 1.15, cpphs >= 1.7, + haskell-src-exts == 1.1.*, uniplate == 1.2.* && >= 1.2.0.2 ghc-options: -fno-warn-overlapping-patterns -threaded @@ -57,10 +57,13 @@ HSE.NameMatch Hint.All Hint.Bracket + Hint.Extensions + Hint.Import Hint.Lambda Hint.List Hint.ListRec Hint.Match Hint.Monad Hint.Naming + Hint.Pragma Hint.Structure diff --git a/hlint.htm b/hlint.htm --- a/hlint.htm +++ b/hlint.htm @@ -86,6 +86,7 @@

Installing and running HLint

@@ -151,6 +152,17 @@

To run HLint on n processors append the flags +RTS -Nn, as described in the GHC user manual. HLint will usually perform fastest if n is equal to the number of physical processors.

+ +

C preprocesor support

+ +

+ HLint always runs the cpphs C preprocessor over all input files, by default using the current directory as the include path with no defined macros. These settings can be modified using the flags --cpp-include and --cpp-define. There are a number of limitations to the C preprocessor support: +

+

FAQ

diff --git a/src/CmdLine.hs b/src/CmdLine.hs --- a/src/CmdLine.hs +++ b/src/CmdLine.hs @@ -9,6 +9,7 @@ import System.Environment import System.Exit import System.FilePath +import Language.Preprocessor.Cpphs import Util import Paths_hlint @@ -23,6 +24,7 @@ ,cmdIgnore :: [String] -- ^ the hints to ignore ,cmdShowAll :: Bool -- ^ display all skipped items ,cmdColor :: Bool -- ^ color the result + ,cmdCpphs :: CpphsOptions -- ^ options for cpphs } @@ -31,6 +33,8 @@ | Report FilePath | Skip String | ShowAll | Color + | Define String + | Include String deriving Eq @@ -42,6 +46,8 @@ ,Option "i" ["ignore"] (ReqArg Skip "message") "Ignore a particular hint" ,Option "s" ["show"] (NoArg ShowAll) "Show all ignored ideas" ,Option "t" ["test"] (NoArg Test) "Run in test mode" + ,Option "" ["cpp-define"] (ReqArg Define "name[=value]") "CPP #define" + ,Option "" ["cpp-include"] (ReqArg Include "dir") "CPP include path" ] @@ -67,6 +73,12 @@ let hintFiles = [x | Hints x <- opt] hints <- mapM getHintFile $ hintFiles ++ ["HLint" | null hintFiles] + let cpphs = defaultCpphsOptions + {boolopts=defaultBoolOptions{locations=False} + ,includes = [x | Include x <- opt] + ,defines = [(a,drop 1 b) | Define x <- opt, let (a,b) = break (== '=') x] + } + return Cmd {cmdTest = test ,cmdFiles = files @@ -75,6 +87,7 @@ ,cmdIgnore = [x | Skip x <- opt] ,cmdShowAll = ShowAll `elem` opt ,cmdColor = Color `elem` opt + ,cmdCpphs = cpphs } diff --git a/src/HSE/All.hs b/src/HSE/All.hs --- a/src/HSE/All.hs +++ b/src/HSE/All.hs @@ -5,7 +5,7 @@ module HSE.Bracket, module HSE.Match, module HSE.Generics, module HSE.NameMatch, - parseFile, parseString, fromParseResult + ParseFlags(..), parseFlags, parseFile, parseString, fromParseResult ) where import Language.Haskell.Exts hiding (parse, parseFile, paren, fromParseResult) @@ -20,27 +20,34 @@ import Util import Data.Char import Data.List +import Language.Preprocessor.Cpphs +data ParseFlags = ParseFlags + {cpphs :: Maybe CpphsOptions + ,implies :: Bool + } + +parseFlags :: ParseFlags +parseFlags = ParseFlags Nothing False + + -- | Parse a Haskell module -parseString :: Bool -> FilePath -> String -> ParseResult Module -parseString implies file = parseFileContentsWithMode mode . unlines . map f . lines +parseString :: ParseFlags -> FilePath -> String -> ParseResult Module +parseString flags file = parseFileContentsWithMode mode . maybe id (`runCpphs` file) (cpphs flags) where - f x | "#" `isPrefixOf` dropWhile isSpace x = "" - | otherwise = x - mode = defaultParseMode {parseFilename = file ,extensions = extension - ,fixities = concat [infix_ (-1) ["==>"] | implies] ++ baseFixities + ,fixities = concat [infix_ (-1) ["==>"] | implies flags] ++ baseFixities } -- | On failure returns an empty module and prints to the console -parseFile :: Bool -> FilePath -> IO (ParseResult Module) -parseFile implies file = do +parseFile :: ParseFlags -> FilePath -> IO (ParseResult Module) +parseFile flags file = do src <- readFile file - return $ parseString implies file src + return $ parseString flags file src -- | TODO: Use the fromParseResult in HSE once it gives source location @@ -67,4 +74,3 @@ -- NOT: TransformListComp - steals the group keyword -- NOT: XmlSyntax, RegularPatterns - steals a-b ] - diff --git a/src/HSE/Bracket.hs b/src/HSE/Bracket.hs --- a/src/HSE/Bracket.hs +++ b/src/HSE/Bracket.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE PatternGuards, ViewPatterns, MultiParamTypeClasses #-} +{-# LANGUAGE PatternGuards #-} module HSE.Bracket where diff --git a/src/HSE/Match.hs b/src/HSE/Match.hs --- a/src/HSE/Match.hs +++ b/src/HSE/Match.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE PatternGuards, ViewPatterns, MultiParamTypeClasses #-} +{-# LANGUAGE ViewPatterns, MultiParamTypeClasses #-} module HSE.Match where diff --git a/src/HSE/Operators.hs b/src/HSE/Operators.hs --- a/src/HSE/Operators.hs +++ b/src/HSE/Operators.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE PatternGuards, ViewPatterns, MultiParamTypeClasses, FlexibleContexts #-} module HSE.Operators( FixityDecl(..), preludeFixities, baseFixities, diff --git a/src/HSE/Util.hs b/src/HSE/Util.hs --- a/src/HSE/Util.hs +++ b/src/HSE/Util.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE PatternGuards, ViewPatterns, MultiParamTypeClasses #-} +{-# LANGUAGE PatternGuards #-} module HSE.Util where @@ -27,6 +27,9 @@ moduleImports :: Module -> [ImportDecl] moduleImports (Module _ _ _ _ _ x _) = x +modulePragmas :: Module -> [OptionPragma] +modulePragmas (Module _ _ x _ _ _ _) = x + isChar :: Exp -> Bool isChar (Lit (Char _)) = True isChar _ = False @@ -54,7 +57,18 @@ isInfixApp InfixApp{} = True; isInfixApp _ = False isAnyApp x = isApp x || isInfixApp x isParen Paren{} = True; isParen _ = False - +isMDo MDo{} = True; isMDo _ = False +isBoxed Boxed{} = True; isBoxed _ = False +isDerivDecl DerivDecl{} = True; isDerivDecl _ = False +isFunDep FunDep{} = True; isFunDep _ = False +isPBangPat PBangPat{} = True; isPBangPat _ = False +isPExplTypeArg PExplTypeArg{} = True; isPExplTypeArg _ = False +isPFieldPun PFieldPun{} = True; isPFieldPun _ = False +isPFieldWildcard PFieldWildcard{} = True; isPFieldWildcard _ = False +isPViewPat PViewPat{} = True; isPViewPat _ = False +isParComp ParComp{} = True; isParComp _ = False +isPatTypeSig PatTypeSig{} = True; isPatTypeSig _ = False +isQuasiQuote QuasiQuote{} = True; isQuasiQuote _ = False --------------------------------------------------------------------- -- HSE FUNCTIONS diff --git a/src/Hint/All.hs b/src/Hint/All.hs --- a/src/Hint/All.hs +++ b/src/Hint/All.hs @@ -11,23 +11,29 @@ import Hint.Bracket import Hint.Naming import Hint.Structure +import Hint.Import +import Hint.Pragma +import Hint.Extensions staticHints :: [(String,Hint)] staticHints = - let (*) = (,) in - ["List" * listHint - ,"ListRec" * listRecHint - ,"Monad" * monadHint - ,"Lambda" * lambdaHint - ,"Bracket" * bracketHint - ,"Naming" * namingHint - ,"Structure" * structureHint + let x*y = (x,DeclHint y) ; x+y = (x,ModuHint y) in + ["List" * listHint + ,"ListRec" * listRecHint + ,"Monad" * monadHint + ,"Lambda" * lambdaHint + ,"Bracket" * bracketHint + ,"Naming" * namingHint + ,"Structure" * structureHint + ,"Import" + importHint + ,"Pragma" + pragmaHint + ,"Extensions" + extensionsHint ] dynamicHints :: [Setting] -> Hint -dynamicHints = readMatch +dynamicHints = DeclHint . readMatch -allHints :: [Setting] -> Hint -allHints xs = concatHints $ dynamicHints xs : map snd staticHints +allHints :: [Setting] -> [Hint] +allHints xs = dynamicHints xs : map snd staticHints diff --git a/src/Hint/Bracket.hs b/src/Hint/Bracket.hs --- a/src/Hint/Bracket.hs +++ b/src/Hint/Bracket.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE PatternGuards #-} - {- yes = (f x) x where res = f x x @@ -28,7 +26,7 @@ import HSE.All -bracketHint :: Hint +bracketHint :: DeclHint bracketHint _ = concatMap bracketExp . children0Exp nullSrcLoc bracketExp :: (SrcLoc,Exp) -> [Idea] diff --git a/src/Hint/Extensions.hs b/src/Hint/Extensions.hs new file mode 100644 --- /dev/null +++ b/src/Hint/Extensions.hs @@ -0,0 +1,61 @@ +{- + Suggest removal of unnecessary extensions + i.e. They have {-# LANGUAGE RecursiveDo #-} but no mdo keywords + + +-} + + +module Hint.Extensions where + +import HSE.All +import Type +import Data.List +import Data.Maybe +import Data.Function + + +extensionsHint :: ModuHint +extensionsHint _ x = [idea Error "Unused LANGUAGE pragma" sl o (LanguagePragma sl new) + | 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 x = any isMDo $ universeBi x +used ParallelListComp x = any isParComp $ universeBi x +used FunctionalDependencies x = any isFunDep $ universeBi x +used ImplicitParams x = not $ null (universeBi x :: [IPName]) +used EmptyDataDecls x = any f $ universeBi x + where f (DataDecl _ _ _ _ _ [] _) = True + f (GDataDecl _ _ _ _ _ _ [] _) = True + f _ = False +used KindSignatures x = not $ null (universeBi x :: [Kind]) +used BangPatterns x = any isPBangPat $ universeBi x +used TemplateHaskell x = not (null (universeBi x :: [Bracket])) && not (null (universeBi x :: [Splice])) +used ForeignFunctionInterface x = not $ null (universeBi x :: [CallConv]) +used Generics x = any isPExplTypeArg $ universeBi x +used PatternGuards x = any f $ universeBi x + where f (GuardedRhs _ [] _) = False + f (GuardedRhs _ [Qualifier _] _) = False + f _ = True +used StandaloneDeriving x = any isDerivDecl $ universeBi x +used PatternSignatures x = any isPatTypeSig $ universeBi x +used RecordWildCards x = any isPFieldWildcard $ universeBi x +used RecordPuns x = any isPFieldPun $ universeBi x +used UnboxedTuples x = any isBoxed $ universeBi x +used PackageImports x = any (isJust . importPkg) $ universeBi x +used QuasiQuotes x = any isQuasiQuote $ universeBi x +used ViewPatterns x = any isPViewPat $ universeBi x +used Arrows x = any f $ universeBi x + where f Proc{} = True + f LeftArrApp{} = True + f RightArrApp{} = True + f LeftArrHighApp{} = True + f RightArrHighApp{} = True +used TransformListComp x = any f $ universeBi x + where f QualStmt{} = False + f _ = True + +used _ _ = True diff --git a/src/Hint/Import.hs b/src/Hint/Import.hs new file mode 100644 --- /dev/null +++ b/src/Hint/Import.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE PatternGuards #-} +{- + Reduce the number of import declarations. + Two import declarations can be combined if: + (note, A[] is A with whatever import list, or none) + + import A[]; import A[] = import A[] + import A(B); import A(C) = import A(B,C) + import A; import A(C) = import A + import A; import A hiding (C) = import A + import A[]; import A[] as Y = import A[] as Y + + + +-} + + +module Hint.Import where + +import HSE.All +import Type +import Data.List +import Data.Maybe +import Data.Function + + +importHint :: ModuHint +importHint _ x = concatMap (wrap . map snd) $ groupBy ((==) `on` fst) $ sortBy (compare `on` fst) + [((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) + | Just x <- [simplify o]] + where f = unlines . map prettyPrint + + +simplify :: [ImportDecl] -> Maybe [ImportDecl] +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 x [] = Nothing +simplifyHead x (y:ys) = case reduce x y of + Nothing -> fmap (y:) $ simplifyHead x ys + Just xy -> Just $ xy : ys + + +-- Useful fields in import are: +-- importModule :: ModuleName [same] +-- importPkg :: Maybe String [same] +-- importQualified :: Bool +-- importSrc :: Bool [False] +-- importAs :: Maybe ModuleName +-- importSpecs :: Maybe (Bool, [ImportSpec]) + +reduce :: ImportDecl -> ImportDecl -> Maybe ImportDecl +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, isNothing (importSpecs x) || isNothing (importSpecs y) = Just x{importSpecs=Nothing} + | not (importQualified x), qual, specs, isNothing (importAs x) || isNothing (importAs y) = Just x{importAs=Nothing} + where + qual = importQualified x == importQualified y + as = importAs x == importAs y + specs = importSpecs x == 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 @@ -40,7 +40,7 @@ import Data.Maybe -lambdaHint :: Hint +lambdaHint :: DeclHint lambdaHint _ x@TypeDecl{} = lambdaType x lambdaHint _ x = concatMap lambdaExp (universeBi x) ++ concatMap lambdaDecl (universe x) diff --git a/src/Hint/List.hs b/src/Hint/List.hs --- a/src/Hint/List.hs +++ b/src/Hint/List.hs @@ -27,7 +27,7 @@ import Type -listHint :: Hint +listHint :: DeclHint listHint _ = listDecl listDecl :: Decl -> [Idea] diff --git a/src/Hint/ListRec.hs b/src/Hint/ListRec.hs --- a/src/Hint/ListRec.hs +++ b/src/Hint/ListRec.hs @@ -35,7 +35,7 @@ import Data.Generics.PlateData -listRecHint :: Hint +listRecHint :: DeclHint listRecHint _ = concatMap f . universe where f o = maybeToList $ do diff --git a/src/Hint/Match.hs b/src/Hint/Match.hs --- a/src/Hint/Match.hs +++ b/src/Hint/Match.hs @@ -22,7 +22,7 @@ --------------------------------------------------------------------- -- PERFORM MATCHING -readMatch :: [Setting] -> Hint +readMatch :: [Setting] -> DeclHint readMatch = findIdeas . filter isMatchExp diff --git a/src/Hint/Monad.hs b/src/Hint/Monad.hs --- a/src/Hint/Monad.hs +++ b/src/Hint/Monad.hs @@ -33,7 +33,7 @@ badFuncs = ["mapM","foldM","forM","replicateM","sequence","zipWithM"] -monadHint :: Hint +monadHint :: DeclHint monadHint _ = concatMap monadExp . universeExp nullSrcLoc monadExp :: (SrcLoc,Exp) -> [Idea] diff --git a/src/Hint/Naming.hs b/src/Hint/Naming.hs --- a/src/Hint/Naming.hs +++ b/src/Hint/Naming.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE ViewPatterns, PatternGuards #-} - {- Suggest the use of camelCase @@ -31,7 +29,7 @@ import Data.Maybe -namingHint :: Hint +namingHint :: DeclHint namingHint _ x = [warn "Use camelCase" (declSrcLoc x) x2 (replaceNames res x2) | not $ null res] where res = [(n,y) | n <- nub $ getNames x, Just y <- [suggestName n]] x2 = shorten x diff --git a/src/Hint/Pragma.hs b/src/Hint/Pragma.hs new file mode 100644 --- /dev/null +++ b/src/Hint/Pragma.hs @@ -0,0 +1,60 @@ +{- + Suggest better pragmas + OPTIONS_GHC -cpp => LANGUAGE CPP + OPTIONS_GHC -fglasgow-exts => LANGUAGE ... (in HSE) + OPTIONS_GHC -XFoo => LANGUAGE Foo + LANGUAGE A, A => LANGUAGE A + -- do not do LANGUAGE A, LANGUAGE B to combine + + +-} + + +module Hint.Pragma where + +import HSE.All +import Type +import Data.List +import Data.Maybe +import Data.Function + + +pragmaHint :: ModuHint +pragmaHint _ x = languageDupes lang ++ [pragmaIdea old $ [LanguagePragma nullSrcLoc 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] + + +pragmaIdea :: [OptionPragma] -> [OptionPragma] -> Idea +pragmaIdea xs ys = rawIdea Error "Use better pragmas" (fromJust $ getSrcLoc $ head xs) (f xs) (f ys) + where f = unlines . map prettyPrint + + +languageDupes :: [OptionPragma] -> [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 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 _ = Nothing + + +optToLanguage :: OptionPragma -> Maybe (Maybe OptionPragma, [Name]) +optToLanguage (OptionsPragma sl tool val) + | maybe True (== GHC) tool && any isJust vs = Just (res, concat $ catMaybes vs) + where + strs = words val + vs = map strToLanguage strs + keep = concat $ zipWith (\v s -> [s | isNothing v]) vs strs + res = if null keep then Nothing else Just $ OptionsPragma sl tool (unwords keep) +optToLanguage _ = Nothing diff --git a/src/Hint/Structure.hs b/src/Hint/Structure.hs --- a/src/Hint/Structure.hs +++ b/src/Hint/Structure.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ViewPatterns, PatternGuards #-} +{-# LANGUAGE ViewPatterns #-} {- Improve the structure of code @@ -20,7 +20,7 @@ import Data.Maybe -structureHint :: Hint +structureHint :: DeclHint structureHint _ x = concat [concatMap useGuards xs | FunBind xs <- [x]] ++ concatMap useIf (universeExp nullSrcLoc x) diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -16,6 +16,7 @@ import Util import Parallel import Hint.All +import HSE.All main = do @@ -24,7 +25,7 @@ settings <- readSettings cmdHintFiles let extra = [Classify Ignore x ("","") | x <- cmdIgnore] let apply :: FilePath -> IO [Idea] - apply = fmap (fmap $ classify $ settings ++ extra) . applyHint (allHints settings) + apply = fmap (fmap $ classify $ settings ++ extra) . applyHint parseFlags{cpphs=Just cmdCpphs} (allHints settings) ideas <- liftM concat $ parallel [listM' =<< apply x | x <- cmdFiles] showItem <- if cmdColor then showANSI else return show mapM_ putStrLn [showItem i | i <- ideas, cmdShowAll || rank i /= Ignore] diff --git a/src/Report.hs b/src/Report.hs --- a/src/Report.hs +++ b/src/Report.hs @@ -46,7 +46,7 @@ where id = mode ++ show i -code = hscolour False True "" +code = hscolour False writeIdea :: String -> Idea -> [String] diff --git a/src/Settings.hs b/src/Settings.hs --- a/src/Settings.hs +++ b/src/Settings.hs @@ -25,7 +25,7 @@ -- currently it doesn't readHints :: FilePath -> IO [Module] readHints file = do - y <- fromParseResult `fmap` parseFile True file + y <- fromParseResult `fmap` parseFile parseFlags{implies=True} file ys <- concatMapM (f . fromNamed . importModule) $ moduleImports y return $ y:ys where diff --git a/src/Test.hs b/src/Test.hs --- a/src/Test.hs +++ b/src/Test.hs @@ -59,7 +59,7 @@ concatMap ((++) " | " . show) ideas ++ "\n" ++ prettyPrint inp | not good] where - ideas = hint nm inp + ideas = declHint hint nm inp good = case out of Nothing -> ideas == [] Just x -> length ideas == 1 && (null x || to (head ideas) == x) @@ -69,7 +69,7 @@ parseTestFile file = do src <- readFile file return [(nm, createTest eqn) - | code <- f $ lines src, let modu = fromParseResult $ parseString False file code + | code <- f $ lines src, let modu = fromParseResult $ parseString parseFlags file code , let nm = nameMatch $ moduleImports modu , eqn <- concatMap getEquations $ moduleDecls modu] where diff --git a/src/Type.hs b/src/Type.hs --- a/src/Type.hs +++ b/src/Type.hs @@ -62,7 +62,8 @@ -- The real key will be filled in by applyHint -idea rank hint loc from to = Idea ("","") rank hint loc (f from) (f to) +rawIdea = Idea ("","") +idea rank hint loc from to = rawIdea rank hint loc (f from) (f to) where f = dropWhile isSpace . prettyPrint warn mr = idea Warning mr @@ -75,17 +76,16 @@ --------------------------------------------------------------------- -- HINTS -type Hint = NameMatch -> Decl -> [Idea] - +type DeclHint = NameMatch -> Decl -> [Idea] +type ModuHint = NameMatch -> Module -> [Idea] -concatHints :: [Hint] -> Hint -concatHints hs nm x = concatMap (\h -> h nm x) hs +data Hint = DeclHint {declHint :: DeclHint} | ModuHint {moduHint :: ModuHint} -applyHint :: Hint -> FilePath -> IO [Idea] -applyHint h file = do +applyHint :: ParseFlags -> [Hint] -> FilePath -> IO [Idea] +applyHint flags h file = do src <- readFile file - case parseString False file src of + case parseString flags file src of ParseFailed sl msg -> do let ticks = [" "," ","> "," "," "] let bad = zipWith (++) ticks $ take 5 $ drop (srcLine sl - 3) $ lines src ++ [""] @@ -94,5 +94,7 @@ ParseOk m -> do let name = moduleName m let nm = nameMatch $ moduleImports m - return [ i{func = (name,fromNamed d)} - | d <- moduleDecls m, i <- sortBy (comparing loc) $ h nm d] + let order n = map (\i -> i{func = (name,n)}) . sortBy (comparing loc) + return $ + order "" [i | ModuHint h <- h, i <- h nm m] ++ + concat [order (fromNamed d) [i | DeclHint h <- h, i <- h nm d] | d <- moduleDecls m]