hlint 2.1.15 → 2.1.16
raw patch · 15 files changed
+292/−46 lines, 15 filesdep ~basedep ~haskell-src-exts-utilPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base, haskell-src-exts-util
API changes (from Hackage documentation)
+ Language.Haskell.HLint3: HintSmell :: HintBuiltin
Files
- CHANGES.txt +12/−0
- README.md +2/−2
- data/hlint.yaml +22/−4
- hlint.cabal +4/−3
- src/Config/Type.hs +13/−2
- src/Config/Yaml.hs +17/−0
- src/HLint.hs +1/−1
- src/HSE/Util.hs +4/−0
- src/Hint/All.hs +3/−1
- src/Hint/Extensions.hs +4/−1
- src/Hint/List.hs +13/−5
- src/Hint/Match.hs +18/−13
- src/Hint/Naming.hs +6/−3
- src/Hint/Smell.hs +148/−0
- src/Test/Annotations.hs +25/−11
CHANGES.txt view
@@ -1,5 +1,17 @@ Changelog for HLint (* = breaking change) +2.1.16, released 2019-04-15+ Make `seq` and `rem` hints apply to prefix functions+ #604, suggest rnf x `seq` () ==> rnf x+ #619, require haskell-src-exts-util-0.2.5+ #619, fix move guards forward with record puns+ #618, add pure x <*> y ==> x <$> y+ #611, add == and subst for more advanced match conditions+ #612, add: Suggest f =<< instead of maybe Nothing f+ #609, add code smells+ #614, adds refactorings for camelCase and some list suggestions+ #605, make command line arguments override the .yaml file+ #603, QuasiQuotes can programatically use any extension 2.1.15, released 2019-02-27 #593, reorder guards in list comps where possible #597, suggest pushing a map over a list comp inside
README.md view
@@ -1,4 +1,4 @@-# HLint [](https://hackage.haskell.org/package/hlint) [](https://www.stackage.org/package/hlint) [](https://travis-ci.org/ndmitchell/hlint) [](https://ci.appveyor.com/project/ndmitchell/hlint)+# HLint [](https://hackage.haskell.org/package/hlint) [](https://www.stackage.org/package/hlint) [](https://travis-ci.org/ndmitchell/hlint) [](https://ci.appveyor.com/project/ndmitchell/hlint) HLint is a tool for suggesting possible improvements to Haskell code. These suggestions include ideas such as using alternative functions, simplifying code and spotting redundancies. You can try HLint online at [lpaste.net](http://lpaste.net/) - suggestions are shown at the bottom. This document is structured as follows: @@ -171,7 +171,7 @@ ### Why doesn't HLint know the fixity for my custom !@%$ operator? -HLint knows the fixities for all the operators in the base library, but no others. HLint works on a single file at a time, and does not resolve imports, so cannot see fixity declarations from imported modules. You can tell HLint about fixities by putting them in a hint file, or passing them on the command line. For example, pass `--with=infixr 5 !@%$`, or put all the fixity declarations in a file and pass `--hint=fixities.hs`. You can also use [--find](https://rawgithub.com/ndmitchell/hlint/master/hlint.htm#find) to automatically produce a list of fixity declarations in a file.+HLint knows the fixities for all the operators in the base library, but no others. HLint works on a single file at a time, and does not resolve imports, so cannot see fixity declarations from imported modules. You can tell HLint about fixities by putting them in a hint file, or passing them on the command line. For example, pass `--with=infixr 5 !@%$`, or put all the fixity declarations in a `.hlint.yaml` file as `- fixity: "infixr 5 !@%$"`. You can also use [--find](https://rawgithub.com/ndmitchell/hlint/master/hlint.htm#find) to automatically produce a list of fixity declarations in a file. ### Which hints are used?
data/hlint.yaml view
@@ -338,6 +338,11 @@ - hint: {lhs: x <&> pure y, rhs: x Data.Functor.$> y} - hint: {lhs: x <&> return y, rhs: x Data.Functor.$> y} + # APPLICATIVE++ - hint: {lhs: return x <*> y, rhs: x <$> y}+ - hint: {lhs: pure x <*> y, rhs: x <$> y}+ # MONAD - warn: {lhs: return a >>= f, rhs: f a, name: "Monad law, left identity"}@@ -425,12 +430,13 @@ # SEQ - - warn: {lhs: x `seq` x, rhs: x, name: Redundant seq}+ - warn: {lhs: seq x x, rhs: x, name: Redundant seq} - warn: {lhs: join seq, rhs: id, name: Redundant seq} - warn: {lhs: id $! x, rhs: x, name: Redundant $!}- - warn: {lhs: x `seq` y, rhs: "y", side: isWHNF x, name: Redundant seq}+ - warn: {lhs: seq x y, rhs: "y", side: isWHNF x, name: Redundant seq} - warn: {lhs: f $! x, rhs: f x, side: isWHNF x, name: Redundant $!} - warn: {lhs: evaluate x, rhs: return x, side: isWHNF x, name: Redundant evaluate}+ - warn: {lhs: seq (rnf x) (), rhs: rhs x, name: Redundant seq} # TUPLE @@ -472,6 +478,7 @@ - hint: {lhs: "[x | Just x <- a]", rhs: Data.Maybe.catMaybes a} - hint: {lhs: case m of Nothing -> Nothing; Just x -> x, rhs: Control.Monad.join m} - hint: {lhs: maybe Nothing id, rhs: join}+ - hint: {lhs: maybe Nothing f x, rhs: f =<< x} - hint: {lhs: maybe (f x) (f . g), rhs: f . maybe x g, note: IncreasesLaziness, name: Too strict maybe} # EITHER@@ -499,8 +506,8 @@ - warn: {lhs: negate (negate x), rhs: x, name: Redundant negate} - hint: {lhs: log y / log x, rhs: logBase x y} - hint: {lhs: sin x / cos x, rhs: tan x}- - hint: {lhs: n `rem` 2 == 0, rhs: even n}- - hint: {lhs: n `rem` 2 /= 0, rhs: odd n}+ - hint: {lhs: rem n 2 == 0, rhs: even n}+ - hint: {lhs: rem n 2 /= 0, rhs: odd n} - hint: {lhs: not (even x), rhs: odd x} - hint: {lhs: not (odd x), rhs: even x} - hint: {lhs: x ** 0.5, rhs: sqrt x}@@ -665,6 +672,16 @@ - error: {lhs: "Control.Lens.nullOf (a . Control.Lens.at b)", rhs: "Control.Lens.nullOf a"} - group:+ name: use-lens+ enabled: false+ imports:+ - package base+ - package lens+ rules:+ - warn: {lhs: "either Just (const Nothing)", rhs: preview _Left}+ - warn: {lhs: "either (const Nothing) Just", rhs: preview _Right}++- group: name: attoparsec enabled: true imports:@@ -694,6 +711,7 @@ - warn: {lhs: either (const mempty), rhs: foldMap} - warn: {lhs: Data.Maybe.fromMaybe mempty, rhs: Data.Foldable.fold} - warn: {lhs: Data.Either.fromRight mempty, rhs: Data.Foldable.fold}+ - warn: {lhs: if f x then Just x else Nothing, rhs: mfilter f (Just x)} - group: name: dollar
hlint.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.18 build-type: Simple name: hlint-version: 2.1.15+version: 2.1.16 license: BSD3 license-file: LICENSE category: Development@@ -27,7 +27,7 @@ extra-doc-files: README.md CHANGES.txt-tested-with: GHC==8.6.3, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3+tested-with: GHC==8.6.4, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3 source-repository head type: git@@ -54,7 +54,7 @@ cmdargs >= 0.10, yaml >= 0.5.0, haskell-src-exts >= 1.21 && < 1.22,- haskell-src-exts-util >= 0.2.1.2,+ haskell-src-exts-util >= 0.2.5, uniplate >= 1.5, ansi-terminal >= 0.6.2, extra >= 1.6.6,@@ -115,6 +115,7 @@ Hint.Pattern Hint.Pragma Hint.Restrict+ Hint.Smell Hint.Type Hint.Unsafe Hint.Util
src/Config/Type.hs view
@@ -1,8 +1,8 @@ module Config.Type( Severity(..), Classify(..), HintRule(..), Note(..), Setting(..),- Restrict(..), RestrictType(..),- defaultHintName, isUnifyVar, showNotes, getSeverity, getRestrictType+ Restrict(..), RestrictType(..), SmellType(..),+ defaultHintName, isUnifyVar, showNotes, getSeverity, getRestrictType, getSmellType ) where import HSE.All@@ -106,11 +106,22 @@ ,restrictWithin :: [(String, String)] } deriving Show +data SmellType = SmellLongFunctions | SmellLongTypeLists | SmellManyArgFunctions | SmellManyImports+ deriving (Show,Eq,Ord)++getSmellType :: String -> Maybe SmellType+getSmellType "long functions" = Just SmellLongFunctions+getSmellType "long type lists" = Just SmellLongTypeLists+getSmellType "many arg functions" = Just SmellManyArgFunctions+getSmellType "many imports" = Just SmellManyImports+getSmellType _ = Nothing+ data Setting = SettingClassify Classify | SettingMatchExp HintRule | SettingRestrict Restrict | SettingArgument String -- ^ Extra command-line argument+ | SettingSmell SmellType Int | Builtin String -- use a builtin hint set | Infix Fixity deriving Show
src/Config/Yaml.hs view
@@ -109,6 +109,10 @@ parseString (getVal -> String x) = return $ T.unpack x parseString v = parseFail v "Expected a String" +parseInt :: Val -> Parser Int+parseInt (getVal -> s@Number{}) = parseJSON s+parseInt v = parseFail v "Expected an Int"+ parseArrayString :: Val -> Parser [String] parseArrayString = parseArray >=> mapM parseString @@ -162,10 +166,12 @@ "group" -> ConfigGroup <$> parseGroup v "arguments" -> ConfigSetting . map SettingArgument <$> parseArrayString v "fixity" -> ConfigSetting <$> parseFixity v+ "smell" -> ConfigSetting <$> parseSmell v _ | isJust $ getSeverity s -> ConfigGroup . ruleToGroup <$> parseRule o _ | Just r <- getRestrictType s -> ConfigSetting . map SettingRestrict <$> (parseArray v >>= mapM (parseRestrict r)) _ -> parseFail v "Expecting an object with a 'package' or 'group' key, a hint or a restriction" + parsePackage :: Val -> Parser Package parsePackage v = do packageName <- parseField "name" v >>= parseString@@ -178,6 +184,17 @@ where f x@InfixDecl{} = return $ map Infix $ getFixity x f _ = parseFail v "Expected fixity declaration"++parseSmell :: Val -> Parser [Setting]+parseSmell v = do+ smellName <- parseField "type" v >>= parseString+ smellType <- require v "Expected SmellType" $ getSmellType smellName+ smellLimit <- parseField "limit" v >>= parseInt+ return [SettingSmell smellType smellLimit]+ where+ require :: Val -> String -> Maybe a -> Parser a+ require _ _ (Just a) = return a+ require val err Nothing = parseFail val err parseGroup :: Val -> Parser Group parseGroup v = do
src/HLint.hs view
@@ -158,7 +158,7 @@ ++ [("CommandLine.hs",Just x) | x <- cmdWithHints] ++ [("CommandLine.yaml",Just (enableGroup x)) | x <- cmdWithGroups] let args2 = [x | SettingArgument x <- settings1]- cmd@CmdMain{..} <- if null args2 then return cmd else getCmd $ args1 ++ args2+ cmd@CmdMain{..} <- if null args2 then return cmd else getCmd $ args2 ++ args1 -- command line arguments are passed last settings2 <- concatMapM (fmap snd . computeSettings (cmdParseFlags cmd)) cmdFindHints settings3 <- return [SettingClassify $ Classify Ignore x "" "" | x <- cmdIgnore] return (cmd, settings1 ++ settings2 ++ settings3)
src/HSE/Util.hs view
@@ -71,6 +71,10 @@ fromPString (PLit _ _ (String _ x _)) = Just x fromPString _ = Nothing +fromParen1 :: Exp_ -> Exp_+fromParen1 (Paren _ x) = x+fromParen1 x = x+ fromParen :: Exp_ -> Exp_ fromParen (Paren _ x) = fromParen x fromParen x = x
src/Hint/All.hs view
@@ -30,6 +30,7 @@ import Hint.Comment import Hint.Unsafe import Hint.NewType+import Hint.Smell -- | A list of the builtin hints wired into HLint. -- This list is likely to grow over time.@@ -37,7 +38,7 @@ HintList | HintListRec | HintMonad | HintLambda | HintBracket | HintNaming | HintPattern | HintImport | HintExport | HintPragma | HintExtensions | HintUnsafe | HintDuplicate | HintRestrict |- HintComment | HintNewType+ HintComment | HintNewType | HintSmell deriving (Show,Eq,Ord,Bounded,Enum) @@ -59,6 +60,7 @@ HintComment -> comm commentHint HintNewType -> decl newtypeHint HintRestrict -> mempty{hintModule=restrictHint}+ HintSmell -> mempty{hintDecl=smellHint,hintModule=smellModuleHint} where wrap = timed "Hint" (drop 4 $ show x) . forceList decl f = mempty{hintDecl=const $ \a b c -> wrap $ f a b c}
src/Hint/Extensions.hs view
@@ -125,6 +125,8 @@ {-# LANGUAGE PolyKinds, KindSignatures #-} -- {-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds, KindSignatures #-} \ data Set (cxt :: * -> *) a = Set [a] -- @Note Extension KindSignatures is implied by PolyKinds+{-# LANGUAGE QuasiQuotes, OverloadedStrings #-} \+main = putStrLn [f|{T.intercalate "blah" []}|] </TEST> -} @@ -164,7 +166,8 @@ , let newPragma = if null after then "" else prettyPrint $ LanguagePragma sl $ map (toNamed . prettyExtension) after ] where- usedTH = used TemplateHaskell x -- if TH is on, can use all other extensions programmatically+ usedTH = used TemplateHaskell x || used QuasiQuotes x+ -- if TH or QuasiQuotes is on, can use all other extensions programmatically -- all the extensions defined to be used extensions = Set.fromList [parseExtension $ fromNamed e | LanguagePragma _ exts <- modulePragmas x, e <- exts]
src/Hint/List.hs view
@@ -30,6 +30,7 @@ foo = [x + 1 | x <- [1..10], let y = even x, y] foo = [x + 1 | x <- [1..10], let q = even 1, q] -- [x + 1 | let q = even 1, q, x <- [1..10]] foo = [fooValue | Foo{..} <- y, fooField]+issue619 = [pkgJobs | Pkg{pkgGpd, pkgJobs} <- pkgs, not $ null $ C.condTestSuites pkgGpd] </TEST> -} @@ -40,7 +41,8 @@ import Data.List.Extra import Data.Maybe import Prelude-import Refact.Types+import Refact.Types hiding (SrcSpan)+import qualified Refact.Types as R listHint :: DeclHint@@ -55,18 +57,24 @@ listComp :: Exp_ -> [Idea] listComp o@(ListComp a e xs)- | "False" `elem` cons = [suggest "Short-circuited list comprehension" o (List an []) []]- | "True" `elem` cons = [suggest "Redundant True guards" o o2 []]- | let ys = moveGuardsForward xs, xs /= ys = [suggest "Move guards forward" o (ListComp a e ys) []]+ | "False" `elem` cons = [suggest "Short-circuited list comprehension" o o' (suggestExpr o o')]+ | "True" `elem` cons = [suggest "Redundant True guards" o o2 (suggestExpr o o2)]+ | xs /= ys = [suggest "Move guards forward" o o3 (suggestExpr o o3)] where+ ys = moveGuardsForward xs+ o' = List an [] o2 = ListComp a e $ filter ((/= Just "True") . qualCon) xs+ o3 = ListComp a e ys cons = mapMaybe qualCon xs qualCon (QualStmt _ (Qualifier _ (Con _ x))) = Just $ fromNamed x qualCon _ = Nothing listComp o@(view -> App2 mp f (ListComp a e xs)) | mp ~= "map" =- [suggest "Move map inside list comprehension" o o2 []]+ [suggest "Move map inside list comprehension" o o2 (suggestExpr o o2)] where o2 = ListComp a (App an (paren f) (paren e)) xs listComp _ = []++suggestExpr :: Exp_ -> Exp_ -> [Refactoring R.SrcSpan]+suggestExpr o o2 = [Replace Expr (toSS o) [] (prettyPrint o2)] -- Move all the list comp guards as far forward as they can go moveGuardsForward :: [QualStmt S] -> [QualStmt S]
src/Hint/Match.hs view
@@ -126,23 +126,28 @@ -- SIDE CONDITIONS checkSide :: Maybe Exp_ -> [(String, Exp_)] -> Bool-checkSide x bind = maybe True f x+checkSide x bind = maybe True bool x where- f (InfixApp _ x op y)- | opExp op ~= "&&" = f x && f y- | opExp op ~= "||" = f x || f y- f (App _ x y) | x ~= "not" = not $ f y- f (Paren _ x) = f x+ bool :: Exp_ -> Bool+ bool (InfixApp _ x op y)+ | opExp op ~= "&&" = bool x && bool y+ | opExp op ~= "||" = bool x || bool y+ | opExp op ~= "==" = expr (fromParen1 x) =~= expr (fromParen1 y)+ bool (App _ x y) | x ~= "not" = not $ bool y+ bool (Paren _ x) = bool x - f (App _ cond (sub -> y))- | 'i':'s':typ <- fromNamed cond- = isType typ y- f (App _ (App _ cond (sub -> x)) (sub -> y))+ bool (App _ cond (sub -> y))+ | 'i':'s':typ <- fromNamed cond = isType typ y+ bool (App _ (App _ cond (sub -> x)) (sub -> y)) | cond ~= "notIn" = and [x `notElem` universe y | x <- list x, y <- list y] | cond ~= "notEq" = x /=~= y- f x | x ~= "noTypeCheck" = True- f x | x ~= "noQuickCheck" = True- f x = error $ "Hint.Match.checkSide, unknown side condition: " ++ prettyPrint x+ bool x | x ~= "noTypeCheck" = True+ bool x | x ~= "noQuickCheck" = True+ bool x = error $ "Hint.Match.checkSide, unknown side condition: " ++ prettyPrint x++ expr :: Exp_ -> Exp_+ expr (App _ (fromNamed -> "subst") x) = sub $ fromParen1 x+ expr x = x isType "Compare" x = True -- just a hint for proof stuff isType "Atom" x = isAtom x
src/Hint/Naming.hs view
@@ -42,6 +42,7 @@ import Data.Data import Data.Char import Data.Maybe+import Refact.Types hiding (RType(Match)) import qualified Data.Set as Set @@ -49,9 +50,11 @@ namingHint _ modu = naming $ Set.fromList $ concatMap getNames $ moduleDecls modu naming :: Set.Set String -> Decl_ -> [Idea]-naming seen x = [suggestN "Use camelCase" x2 (replaceNames res x2) | not $ null res]+naming seen x = [suggest "Use camelCase" x' x2' [Replace Bind (toSS x) [] (prettyPrint x2)] | not $ null res] where res = [(n,y) | n <- nubOrd $ getNames x, Just y <- [suggestName n], not $ y `Set.member` seen]- x2 = shorten x+ x2 = replaceNames res x+ x' = shorten x+ x2' = shorten x2 shorten :: Decl_ -> Decl_@@ -104,6 +107,6 @@ replaceNames :: Data a => [(String,String)] -> a -> a-replaceNames rep = descendBi f+replaceNames rep = transformBi f where f (Ident _ x) = Ident an $ fromMaybe x $ lookup x rep f x = x
+ src/Hint/Smell.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE ViewPatterns #-}++module Hint.Smell (+ smellModuleHint,+ smellHint+ ) where++{-+<TEST> [{smell: { type: many arg functions, limit: 2 }}]+f :: Int -> Int \+f = undefined++f :: Int -> Int -> Int \+f = undefined --+</TEST>++<TEST>+f :: Int -> Int \+f = undefined++f :: Int -> Int -> Int \+f = undefined+</TEST>++<TEST> [{smell: { type: long functions, limit: 3}}]+f = do \+ x <- y \+ return x --++f = do \+ return z \+\+ where \+ z = do \+ a \+ b --++f = do \+ return z \+\+ where \+ z = a++f = Con \+ { a = x \+ , b = y \+ , c = z \+ }++f = return x+</TEST>++<TEST>+f = do \+ x <- y \+ return x++f = return x+</TEST>++<TEST> [{smell: { type: long type lists, limit: 2}}]+f :: Bool -> Int -> (Int -> Proxy '[a, b]) --+f :: Proxy '[a]+</TEST>++<TEST>+f :: Proxy '[a, b]+f :: Proxy '[a]+</TEST>++<TEST> [{smell: { type: many imports, limit: 2}}]+import A; import B --+import A+</TEST>++<TEST>+import A; import B+import A+</TEST>+-}++import Hint.Type+import Config.Type+import Data.List.Extra+import qualified Data.Map as Map++smellModuleHint :: [Setting] -> ModuHint+smellModuleHint settings scope m@(moduleImports -> imports) = case Map.lookup SmellManyImports (smells settings) of+ Just n | length imports >= n ->+ let span = foldl1 mergeSrcSpan $ srcInfoSpan . ann <$> imports+ displayImports = unlines $ f <$> imports+ in [rawIdea Warning "Many imports" span displayImports Nothing [] [] ]+ where+ f = trimStart . prettyPrint+ _ -> []++smellHint :: [Setting] -> DeclHint+smellHint settings scope m d =+ sniff smellLongFunctions SmellLongFunctions +++ sniff smellLongTypeLists SmellLongTypeLists +++ sniff smellManyArgFunctions SmellManyArgFunctions+ where+ sniff f t = fmap (\i -> i {ideaTo = Nothing }) . take 1 $ maybe [] (f d) $ Map.lookup t (smells settings)++smellLongFunctions :: Decl_ -> Int -> [Idea]+smellLongFunctions d n = [ idea+ | (span, idea) <- declSpans d+ , spanLength span >= n+ ]++declSpans :: Decl_ -> [(SrcSpanInfo, Idea)]+declSpans (FunBind _ [Match _ _ _ rhs where_]) = rhsSpans rhs ++ whereSpans where_+declSpans f@(FunBind l match) = [(l, warn "Long function" f f [])] -- count where clauses+declSpans (PatBind _ _ rhs where_) = rhsSpans rhs ++ whereSpans where_+declSpans _ = []++whereSpans :: Maybe (Binds SrcSpanInfo) -> [(SrcSpanInfo, Idea)]+whereSpans (Just (BDecls _ decls)) = concatMap declSpans decls+whereSpans _ = []++rhsSpans :: Rhs SrcSpanInfo -> [(SrcSpanInfo, Idea)]+rhsSpans (UnGuardedRhs l RecConstr{}) = [] --- record constructors get a pass+rhsSpans r@(UnGuardedRhs l _) = [(l, warn "Long function" r r [])]+rhsSpans r@(GuardedRhss l _) = [(l, warn "Long function" r r [])]++spanLength :: SrcSpanInfo -> Int+spanLength (SrcSpanInfo span _) = srcSpanEndLine span - srcSpanStartLine span + 1++smellLongTypeLists :: Decl_ -> Int -> [Idea]+smellLongTypeLists d@(TypeSig _ _ t) n = warn "Long type list" d d [] <$ filter longTypeList (universe t)+ where+ longTypeList (TyPromoted _ (PromotedList _ _ x)) = length x >= n+ longTypeList _ = False+smellLongTypeLists _ _ = []++smellManyArgFunctions :: Decl_ -> Int -> [Idea]+smellManyArgFunctions d@(TypeSig _ _ t) n = warn "Many arg function" d d [] <$ filter manyArgFunction (universe t)+ where+ manyArgFunction x = countFunctionArgs x >= n+smellManyArgFunctions _ _ = []++countFunctionArgs :: Type l -> Int+countFunctionArgs (TyFun _ _ b) = 1 + countFunctionArgs b+countFunctionArgs (TyParen _ t) = countFunctionArgs t+countFunctionArgs _ = 0++smells :: [Setting] -> Map.Map SmellType Int+smells settings = Map.fromList [ (smellType, smellLimit) | SettingSmell smellType smellLimit <- settings]
src/Test/Annotations.hs view
@@ -10,6 +10,8 @@ import Data.List.Extra import Data.Maybe import Data.Function+import Data.Yaml+import qualified Data.ByteString.Char8 as BS import Config.Type import Idea@@ -18,21 +20,22 @@ import Test.Util import Data.Functor import Prelude+import Config.Yaml -- Input, Output -- Output = Nothing, should not match -- Output = Just xs, should match xs-data Test = Test SrcLoc String (Maybe String)+data Test = Test SrcLoc String (Maybe String) [Setting] deriving (Show) testAnnotations :: [Setting] -> FilePath -> IO () testAnnotations setting file = do tests <- parseTestFile file mapM_ f tests where- f (Test loc inp out) = do+ f (Test loc inp out additionalSettings) = do ideas <- try_ $ do- res <- applyHintFile defaultParseFlags setting file $ Just inp+ res <- applyHintFile defaultParseFlags (setting ++ additionalSettings) file $ Just inp evaluate $ length $ show res return res let good = case (out, ideas) of@@ -69,17 +72,28 @@ parseTestFile :: FilePath -> IO [Test] parseTestFile file = -- we remove all leading # symbols since Yaml only lets us do comments that way- f False . zip [1..] . map (\x -> fromMaybe x $ stripPrefix "# " x) . lines <$> readFile file+ f Nothing . zip [1..] . map (\x -> fromMaybe x $ stripPrefix "# " x) . lines <$> readFile file where- open = isPrefixOf "<TEST>"+ open :: String -> Maybe [Setting]+ open line+ | "<TEST>" `isPrefixOf` line =+ let suffix = dropPrefix "<TEST>" line+ config = decodeEither' $ BS.pack suffix+ in case config of+ Left err -> Just []+ Right config -> Just $ settingsFromConfigYaml [config]+ | otherwise = Nothing++ shut :: String -> Bool shut = isPrefixOf "</TEST>" - f False ((i,x):xs) = f (open x) xs- f True ((i,x):xs)- | shut x = f False xs- | null x || "-- " `isPrefixOf` x = f True xs- | "\\" `isSuffixOf` x, (_,y):ys <- xs = f True $ (i,init x++"\n"++y):ys- | otherwise = parseTest file i x : f True xs+ f :: Maybe [Setting] -> [(Int, String)] -> [Test]+ f Nothing ((i,x):xs) = f (open x) xs+ f (Just s) ((i,x):xs)+ | shut x = f Nothing xs+ | null x || "-- " `isPrefixOf` x = f (Just s) xs+ | "\\" `isSuffixOf` x, (_,y):ys <- xs = f (Just s) $ (i,init x++"\n"++y):ys+ | otherwise = parseTest file i x s : f (Just s) xs f _ [] = []