diff --git a/Language/Haskell/GhcMod/Boot.hs b/Language/Haskell/GhcMod/Boot.hs index 7399de1..b4652c7 100644 --- a/Language/Haskell/GhcMod/Boot.hs +++ b/Language/Haskell/GhcMod/Boot.hs @@ -7,12 +7,13 @@ import Language.Haskell.GhcMod.Flag import Language.Haskell.GhcMod.Lang import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Modules +import Language.Haskell.GhcMod.Types (defaultBrowseOpts) -- | Printing necessary information for front-end booting. boot :: IOish m => GhcModT m String boot = concat <$> sequence ms where - ms = [modules False, languages, flags, concat <$> mapM (browse (BrowseOpts False False False)) preBrowsedModules] + ms = [modules False, languages, flags, concat <$> mapM (browse defaultBrowseOpts) preBrowsedModules] preBrowsedModules :: [String] preBrowsedModules = [ diff --git a/Language/Haskell/GhcMod/Browse.hs b/Language/Haskell/GhcMod/Browse.hs index 05bc969..882e4ac 100644 --- a/Language/Haskell/GhcMod/Browse.hs +++ b/Language/Haskell/GhcMod/Browse.hs @@ -11,6 +11,7 @@ import Data.List import Data.Maybe import FastString import GHC +import HscTypes import qualified GHC as G import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Doc (showPage, styleUnqualified) @@ -96,14 +97,20 @@ showExport opt minfo e = do mqualified = (G.moduleNameString (G.moduleName $ G.nameModule e) ++ ".") `justIf` optBrowseQualified opt mtype :: m (Maybe String) mtype - | optBrowseDetailed opt = do + | optBrowseDetailed opt || optBrowseParents opt = do tyInfo <- G.modInfoLookupName minfo e -- If nothing found, load dependent module and lookup global tyResult <- maybe (inOtherModule e) (return . Just) tyInfo dflag <- G.getSessionDynFlags - return $ do - typeName <- tyResult >>= showThing dflag - (" :: " ++ typeName) `justIf` optBrowseDetailed opt + let sig = do + typeName <- tyResult >>= showThing dflag + (" :: " ++ typeName) `justIf` optBrowseDetailed opt + let parent = do + thing <- fmap getOccString $ tyResult >>= tyThingParent_maybe + (" -- from:" ++ thing) `justIf` optBrowseParents opt + return $ case concat $ catMaybes [sig, parent] of + [] -> Nothing + x -> Just x | otherwise = return Nothing formatOp nm | null nm = error "formatOp" diff --git a/Language/Haskell/GhcMod/CaseSplit.hs b/Language/Haskell/GhcMod/CaseSplit.hs index a327dd4..d3ea112 100644 --- a/Language/Haskell/GhcMod/CaseSplit.hs +++ b/Language/Haskell/GhcMod/CaseSplit.hs @@ -29,6 +29,7 @@ import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Utils (withMappedFile) import Language.Haskell.GhcMod.FileMapping (fileModSummaryWithMapping) +import Control.DeepSeq ---------------------------------------------------------------- -- CASE SPLITTING @@ -55,19 +56,17 @@ splits file lineNo colNo = style <- getStyle dflag <- G.getSessionDynFlags modSum <- fileModSummaryWithMapping (cradleCurrentDir crdl file) - whenFound' oopts (getSrcSpanTypeForSplit modSum lineNo colNo) $ \x -> case x of - (SplitInfo varName bndLoc (varLoc,varT) _matches) -> do - let varName' = showName dflag style varName -- Convert name to string + whenFound' oopts (getSrcSpanTypeForSplit modSum lineNo colNo) $ \x -> do + let (varName, bndLoc, (varLoc,varT)) + | (SplitInfo vn bl vlvt _matches) <- x + = (vn, bl, vlvt) + | (TySplitInfo vn bl vlvt) <- x + = (vn, bl, vlvt) + varName' = showName dflag style varName -- Convert name to string t <- withMappedFile file $ \file' -> genCaseSplitTextFile file' (SplitToTextInfo varName' bndLoc varLoc $ getTyCons dflag style varName varT) - return (fourInts bndLoc, t) - (TySplitInfo varName bndLoc (varLoc,varT)) -> do - let varName' = showName dflag style varName -- Convert name to string - t <- withMappedFile file $ \file' -> - genCaseSplitTextFile file' (SplitToTextInfo varName' bndLoc varLoc $ - getTyCons dflag style varName varT) - return (fourInts bndLoc, t) + return $!! (fourInts bndLoc, t) where handler (SomeException ex) = do gmLog GmException "splits" $ @@ -215,8 +214,8 @@ genCaseSplitTextFile file info = liftIO $ do return $ getCaseSplitText (T.lines t) info getCaseSplitText :: [T.Text] -> SplitToTextInfo -> String -getCaseSplitText t (SplitToTextInfo { sVarName = sVN, sBindingSpan = sBS - , sVarSpan = sVS, sTycons = sT }) = +getCaseSplitText t SplitToTextInfo{ sVarName = sVN, sBindingSpan = sBS + , sVarSpan = sVS, sTycons = sT } = let bindingText = getBindingText t sBS difference = srcSpanDifference sBS sVS replaced = map (replaceVarWithTyCon bindingText difference sVN) sT diff --git a/Language/Haskell/GhcMod/Gap.hs b/Language/Haskell/GhcMod/Gap.hs index 3e74c67..ab897a1 100644 --- a/Language/Haskell/GhcMod/Gap.hs +++ b/Language/Haskell/GhcMod/Gap.hs @@ -44,6 +44,7 @@ module Language.Haskell.GhcMod.Gap ( , Language.Haskell.GhcMod.Gap.isSynTyCon , parseModuleHeader , mkErrStyle' + , everythingStagedWithContext ) where import Control.Applicative hiding (empty) @@ -115,6 +116,8 @@ import Lexer as L import Parser import SrcLoc import Packages +import Data.Generics (GenericQ, extQ, gmapQ) +import GHC.SYB.Utils (Stage(..)) import Language.Haskell.GhcMod.Types (Expression(..)) import Prelude @@ -607,3 +610,20 @@ instance NFData ByteString where rnf Empty = () rnf (Chunk _ b) = rnf b #endif + +-- | Like 'everything', but avoid known potholes, based on the 'Stage' that +-- generated the Ast. +everythingStagedWithContext :: Stage -> s -> (r -> r -> r) -> r -> GenericQ (s -> (r, s)) -> GenericQ r +everythingStagedWithContext stage s0 f z q x + | (const False +#if __GLASGOW_HASKELL__ <= 708 + `extQ` postTcType +#endif + `extQ` fixity `extQ` nameSet) x = z + | otherwise = foldl f r (gmapQ (everythingStagedWithContext stage s' f z q) x) + where nameSet = const (stage `elem` [Parser,TypeChecker]) :: NameSet -> Bool +#if __GLASGOW_HASKELL__ <= 708 + postTcType = const (stage Bool +#endif + fixity = const (stage Bool + (r, s') = q x s0 diff --git a/Language/Haskell/GhcMod/Info.hs b/Language/Haskell/GhcMod/Info.hs index 31a8eab..dc18f7c 100644 --- a/Language/Haskell/GhcMod/Info.hs +++ b/Language/Haskell/GhcMod/Info.hs @@ -5,10 +5,9 @@ module Language.Haskell.GhcMod.Info ( import Data.Function (on) import Data.List (sortBy) -import Data.Maybe (catMaybes) import System.FilePath import Exception (ghandle, SomeException(..)) -import GHC (GhcMonad, LHsBind, LHsExpr, LPat, Id, TypecheckedModule(..), SrcSpan, Type) +import GHC (GhcMonad, SrcSpan) import Prelude import qualified GHC as G import qualified Language.Haskell.GhcMod.Gap as Gap @@ -53,17 +52,18 @@ info file expr = -- | Obtaining type of a target expression. (GHCi's type:) types :: IOish m - => FilePath -- ^ A target file. + => Bool -- ^ Include constraints into type signature + -> FilePath -- ^ A target file. -> Int -- ^ Line number. -> Int -- ^ Column number. -> GhcModT m String -types file lineNo colNo = +types withConstraints file lineNo colNo = ghandle handler $ runGmlT' [Left file] deferErrors $ withInteractiveContext $ do crdl <- cradle modSum <- fileModSummaryWithMapping (cradleCurrentDir crdl file) - srcSpanTypes <- getSrcSpanType modSum lineNo colNo + srcSpanTypes <- getSrcSpanType withConstraints modSum lineNo colNo dflag <- G.getSessionDynFlags st <- getStyle convert' $ map (toTup dflag st) $ sortBy (cmp `on` fst) srcSpanTypes @@ -72,14 +72,8 @@ types file lineNo colNo = gmLog GmException "types" $ showDoc ex return [] -getSrcSpanType :: GhcMonad m => G.ModSummary -> Int -> Int -> m [(SrcSpan, Type)] -getSrcSpanType modSum lineNo colNo = do - p <- G.parseModule modSum - tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p - let bs = listifySpans tcs (lineNo, colNo) :: [LHsBind Id] - es = listifySpans tcs (lineNo, colNo) :: [LHsExpr Id] - ps = listifySpans tcs (lineNo, colNo) :: [LPat Id] - bts <- mapM (getType tcm) bs - ets <- mapM (getType tcm) es - pts <- mapM (getType tcm) ps - return $ catMaybes $ concat [ets, bts, pts] +getSrcSpanType :: (GhcMonad m) => Bool -> G.ModSummary -> Int -> Int -> m [(SrcSpan, G.Type)] +getSrcSpanType withConstraints modSum lineNo colNo = + G.parseModule modSum + >>= G.typecheckModule + >>= flip (collectSpansTypes withConstraints) (lineNo, colNo) diff --git a/Language/Haskell/GhcMod/SrcUtils.hs b/Language/Haskell/GhcMod/SrcUtils.hs index 0938f81..961bfae 100644 --- a/Language/Haskell/GhcMod/SrcUtils.hs +++ b/Language/Haskell/GhcMod/SrcUtils.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TupleSections, FlexibleInstances, Rank2Types #-} +{-# LANGUAGE TupleSections, FlexibleInstances, Rank2Types, ImpredicativeTypes #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Language.Haskell.GhcMod.SrcUtils where @@ -6,11 +6,14 @@ module Language.Haskell.GhcMod.SrcUtils where import Control.Applicative import CoreUtils (exprType) import Data.Generics -import Data.Maybe (fromMaybe) +import Data.Maybe import Data.Ord as O import GHC (LHsExpr, LPat, Id, DynFlags, SrcSpan, Type, Located, ParsedSource, RenamedSource, TypecheckedSource, GenLocated(L)) +import Var (Var) import qualified GHC as G -import GHC.SYB.Utils (Stage(..), everythingStaged) +import qualified Var as G +import qualified Type as G +import GHC.SYB.Utils import GhcMonad import qualified Language.Haskell.Exts.Annotated as HE import Language.Haskell.GhcMod.Doc @@ -20,6 +23,10 @@ import OccName (OccName) import Outputable (PprStyle) import TcHsSyn (hsPatType) import Prelude +import Control.Monad +import Data.List (nub) +import Control.Arrow +import qualified Data.Map as M ---------------------------------------------------------------- @@ -34,6 +41,82 @@ instance HasType (LPat Id) where ---------------------------------------------------------------- +-- | Stores mapping from monomorphic to polymorphic types +type CstGenQS = M.Map Var Type +-- | Generic type to simplify SYB definition +type CstGenQT a = forall m. GhcMonad m => a Id -> CstGenQS -> (m [(SrcSpan, Type)], CstGenQS) + +collectSpansTypes :: (GhcMonad m) => Bool -> G.TypecheckedModule -> (Int, Int) -> m [(SrcSpan, Type)] +collectSpansTypes withConstraints tcs lc = + -- This walks AST top-down, left-to-right, while carrying CstGenQS down the tree + -- (but not left-to-right) + everythingStagedWithContext TypeChecker M.empty (liftM2 (++)) + (return []) + ((return [],) + `mkQ` (hsBind :: CstGenQT G.LHsBind) -- matches on binds + `extQ` (genericCT :: CstGenQT G.LHsExpr) -- matches on expressions + `extQ` (genericCT :: CstGenQT G.LPat) -- matches on patterns + ) + (G.tm_typechecked_source tcs) + where + -- Helper function to insert mapping into CstGenQS + insExp x = M.insert (G.abe_mono x) (G.varType $ G.abe_poly x) + -- If there is AbsBinds here, insert mapping into CstGenQS if needed + hsBind (L _ G.AbsBinds{abs_exports = es'}) s + | withConstraints = (return [], foldr insExp s es') + | otherwise = (return [], s) + -- Otherwise, it's the same as other cases + hsBind x s = genericCT x s + -- Generic SYB function to get type + genericCT x s + | withConstraints + = (maybe [] (uncurry $ constrainedType (collectBinders x) s) <$> getType' x, s) + | otherwise = (maybeToList <$> getType' x, s) + -- Collects everything with Id from LHsBind, LHsExpr, or LPat + collectBinders :: Data a => a -> [Id] + collectBinders = listifyStaged TypeChecker (const True) + -- Gets monomorphic type with location + getType' x@(L spn _) + | G.isGoodSrcSpan spn && spn `G.spans` lc + = getType tcs x + | otherwise = return Nothing + -- Gets constrained type + constrainedType :: [Var] -- ^ Binders in expression, i.e. anything with Id + -> CstGenQS -- ^ Map from Id to polymorphic type + -> SrcSpan -- ^ extent of expression, copied to result + -> Type -- ^ monomorphic type + -> [(SrcSpan, Type)] -- ^ result + constrainedType pids s spn genTyp = + let + -- runs build on every binder. + ctys = mapMaybe build (nub pids) + -- Computes constrained type for x. Returns (constraints, substitutions) + -- Substitutions are needed because type variables don't match + -- between polymorphic and monomorphic types. + -- E.g. poly type might be `Monad m => m ()`, while monomorphic might be `f ()` + build x | Just cti <- x `M.lookup` s + = let + (preds', ctt) = getPreds cti + -- list of type variables in monomorphic type + vts = listifyStaged TypeChecker G.isTyVar $ G.varType x + -- list of type variables in polymorphic type + tvm = listifyStaged TypeChecker G.isTyVarTy ctt + in Just (preds', zip vts tvm) + | otherwise = Nothing + -- list of constraints + preds = concatMap fst ctys + -- Type variable substitutions + subs = G.mkTopTvSubst $ concatMap snd ctys + -- Constrained type + ty = G.substTy subs $ G.mkFunTys preds genTyp + in [(spn, ty)] + -- Splits a given type into list of constraints and simple type. Drops foralls. + getPreds :: Type -> ([Type], Type) + getPreds x | G.isForAllTy x = getPreds $ G.dropForAlls x + | Just (c, t) <- G.splitFunTy_maybe x + , G.isPredTy c = first (c:) $ getPreds t + | otherwise = ([], x) + listifySpans :: Typeable a => TypecheckedSource -> (Int, Int) -> [Located a] listifySpans tcs lc = listifyStaged TypeChecker p tcs where diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 2281ba9..7b4a8d1 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -71,7 +71,7 @@ data OutputStyle = LispStyle -- ^ S expression style. newtype LineSeparator = LineSeparator String deriving (Show) data FileMapping = FileMapping {fmPath :: FilePath, fmTemp :: Bool} - deriving Show + deriving (Eq, Show) type FileMappingMap = Map FilePath FileMapping @@ -388,13 +388,15 @@ data BrowseOpts = BrowseOpts { -- ^ If 'True', "browseWith" also returns operators. , optBrowseDetailed :: Bool -- ^ If 'True', "browseWith" also returns types. + , optBrowseParents :: Bool + -- ^ If 'True', "browseWith" also returns parents. , optBrowseQualified :: Bool -- ^ If 'True', "browseWith" will return fully qualified name } deriving (Show) -- | Default "BrowseOpts" instance defaultBrowseOpts :: BrowseOpts -defaultBrowseOpts = BrowseOpts False False False +defaultBrowseOpts = BrowseOpts False False False False mkLabel ''GhcModCaches mkLabel ''GhcModState diff --git a/Language/Haskell/GhcMod/World.hs b/Language/Haskell/GhcMod/World.hs index 74ed5a2..d166b49 100644 --- a/Language/Haskell/GhcMod/World.hs +++ b/Language/Haskell/GhcMod/World.hs @@ -19,6 +19,7 @@ data World = World { , worldCabalFile :: Maybe TimedFile , worldCabalConfig :: Maybe TimedFile , worldCabalSandboxConfig :: Maybe TimedFile + , worldMappedFiles :: FileMappingMap } deriving (Eq) timedPackageCaches :: IOish m => GhcModT m [TimedFile] @@ -34,12 +35,14 @@ getCurrentWorld = do mCabalFile <- liftIO $ timeFile `traverse` cradleCabalFile crdl mCabalConfig <- liftIO $ timeMaybe (setupConfigFile crdl) mCabalSandboxConfig <- liftIO $ timeMaybe (sandboxConfigFile crdl) + mFileMap <- getMMappedFiles return World { worldPackageCaches = pkgCaches , worldCabalFile = mCabalFile , worldCabalConfig = mCabalConfig , worldCabalSandboxConfig = mCabalSandboxConfig + , worldMappedFiles = mFileMap } didWorldChange :: IOish m => World -> GhcModT m Bool diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 82b2261..c112995 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -165,7 +165,7 @@ Library , bytestring < 0.11 , binary < 0.9 && >= 0.5.1.0 , containers < 0.6 - , cabal-helper < 0.8 && >= 0.7.0.1 + , cabal-helper < 0.8 && >= 0.7.1.0 , deepseq < 1.5 , directory < 1.3 , filepath < 1.5 diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 713d567..ed28d56 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -151,7 +151,7 @@ ghcCommands (CmdBrowse opts ms) = concat <$> browse opts `mapM` ms ghcCommands (CmdCheck files) = checkSyntax files ghcCommands (CmdExpand files) = expandTemplate files ghcCommands (CmdInfo file symb) = info file $ Expression symb -ghcCommands (CmdType file (line, col)) = types file line col +ghcCommands (CmdType wCon file (line, col)) = types wCon file line col ghcCommands (CmdSplit file (line, col)) = splits file line col ghcCommands (CmdSig file (line, col)) = sig file line col ghcCommands (CmdAuto file (line, col)) = auto file line col diff --git a/src/GHCMod/Options/Commands.hs b/src/GHCMod/Options/Commands.hs index a2ab3c0..688905f 100644 --- a/src/GHCMod/Options/Commands.hs +++ b/src/GHCMod/Options/Commands.hs @@ -51,7 +51,7 @@ data GhcModCommands = | CmdCheck [FilePath] | CmdExpand [FilePath] | CmdInfo FilePath Symbol - | CmdType FilePath Point + | CmdType Bool FilePath Point | CmdSplit FilePath Point | CmdSig FilePath Point | CmdAuto FilePath Point @@ -215,12 +215,12 @@ interactiveCommandsSpec = strArg :: String -> Parser String strArg = argument str . metavar -filesArgsSpec :: ([String] -> b) -> Parser b -filesArgsSpec x = x <$> some (strArg "FILES..") +filesArgsSpec :: Parser ([String] -> b) -> Parser b +filesArgsSpec x = x <*> some (strArg "FILES..") -locArgSpec :: (String -> (Int, Int) -> b) -> Parser b +locArgSpec :: Parser (String -> (Int, Int) -> b) -> Parser b locArgSpec x = x - <$> strArg "FILE" + <*> strArg "FILE" <*> ( (,) <$> argument int (metavar "LINE") <*> argument int (metavar "COL") @@ -255,23 +255,31 @@ browseArgSpec = CmdBrowse $$ long "detailed" <=> short 'd' <=> help "Print symbols with accompanying signature" + <*> switch + $$ long "parents" + <=> short 'p' + <=> help "Print symbols parents" <*> switch $$ long "qualified" <=> short 'q' <=> help "Qualify symbols" ) <*> some (strArg "MODULE") -debugComponentArgSpec = filesArgsSpec CmdDebugComponent -checkArgSpec = filesArgsSpec CmdCheck -expandArgSpec = filesArgsSpec CmdExpand +debugComponentArgSpec = filesArgsSpec (pure CmdDebugComponent) +checkArgSpec = filesArgsSpec (pure CmdCheck) +expandArgSpec = filesArgsSpec (pure CmdExpand) infoArgSpec = CmdInfo <$> strArg "FILE" <*> strArg "SYMBOL" -typeArgSpec = locArgSpec CmdType -autoArgSpec = locArgSpec CmdAuto -splitArgSpec = locArgSpec CmdSplit -sigArgSpec = locArgSpec CmdSig -refineArgSpec = locArgSpec CmdRefine <*> strArg "SYMBOL" +typeArgSpec = locArgSpec $ CmdType <$> + switch + $$ long "constraints" + <=> short 'c' + <=> help "Include constraints into type signature" +autoArgSpec = locArgSpec (pure CmdAuto) +splitArgSpec = locArgSpec (pure CmdSplit) +sigArgSpec = locArgSpec (pure CmdSig) +refineArgSpec = locArgSpec (pure CmdRefine) <*> strArg "SYMBOL" mapArgSpec = CmdMapFile <$> strArg "FILE" unmapArgSpec = CmdUnmapFile <$> strArg "FILE" legacyInteractiveArgSpec = const CmdLegacyInteractive <$> diff --git a/test/CaseSplitSpec.hs b/test/CaseSplitSpec.hs index 5e5db3f..4cec78b 100644 --- a/test/CaseSplitSpec.hs +++ b/test/CaseSplitSpec.hs @@ -39,3 +39,8 @@ spec = do res `shouldBe` "38 21 38 59"++ " \"mlReverse' Nil accum = _mlReverse_body\NUL"++ " mlReverse' (Cons xs'1 xs'2) accum = _mlReverse_body\"\n" + + it "doesn't crash when source doesn't make sense" $ + withDirectory_ "test/data/case-split" $ do + res <- runD $ splits "Crash.hs" 4 6 + res `shouldBe` [] diff --git a/test/FileMappingSpec.hs b/test/FileMappingSpec.hs index d6ba1bb..9598fb6 100644 --- a/test/FileMappingSpec.hs +++ b/test/FileMappingSpec.hs @@ -134,13 +134,19 @@ spec = do let tdir = "test/data/file-mapping" res <- runD' tdir $ do loadMappedFile "File.hs" "File_Redir_Lint.hs" - types "File.hs" 4 12 + types False "File.hs" 4 12 res `shouldBe` "4 12 4 15 \"a -> a -> a\"\n4 12 4 17 \"a -> a\"\n4 12 4 19 \"a\"\n4 1 4 19 \"a -> a -> a\"\n" + it "shows types of the expression with constraints for redirected files" $ do + let tdir = "test/data/file-mapping" + res <- runD' tdir $ do + loadMappedFile "File.hs" "File_Redir_Lint.hs" + types True "File.hs" 4 12 + res `shouldBe` "4 12 4 15 \"a -> a -> a\"\n4 12 4 17 \"a -> a\"\n4 12 4 19 \"a\"\n4 1 4 19 \"Num a => a -> a -> a\"\n" it "shows types of the expression for in-memory files" $ do let tdir = "test/data/file-mapping" res <- runD' tdir $ do loadMappedFileSource "File.hs" "main = putStrLn \"Hello!\"" - types "File.hs" 1 14 + types False "File.hs" 1 14 res `shouldBe` "1 8 1 16 \"String -> IO ()\"\n1 8 1 25 \"IO ()\"\n1 1 1 25 \"IO ()\"\n" it "shows info for the expression for redirected files" $ do let tdir = "test/data/file-mapping" @@ -234,7 +240,7 @@ spec = do ,("Bar.hs", tmpdir "Bar_Redir.hs")] res <- run defaultOptions $ do mapM_ (uncurry loadMappedFile) fm - types "Bar.hs" 5 1 + types False "Bar.hs" 5 1 res `shouldBe` unlines ["5 1 5 20 \"[Char]\""] it "works with a memory module using TemplateHaskell" $ do srcFoo <- readFile "test/data/template-haskell/Foo.hs" @@ -244,5 +250,5 @@ spec = do ,("Bar.hs", srcBar)] res <- run defaultOptions $ do mapM_ (uncurry loadMappedFileSource) fm - types "Bar.hs" 5 1 + types False "Bar.hs" 5 1 res `shouldBe` unlines ["5 1 5 20 \"[Char]\""] diff --git a/test/InfoSpec.hs b/test/InfoSpec.hs index 3bdd5ae..d084b9a 100644 --- a/test/InfoSpec.hs +++ b/test/InfoSpec.hs @@ -19,17 +19,22 @@ spec = do describe "types" $ do it "shows types of the expression and its outers" $ do let tdir = "test/data/ghc-mod-check" - res <- runD' tdir $ types "lib/Data/Foo.hs" 9 5 + res <- runD' tdir $ types False "lib/Data/Foo.hs" 9 5 res `shouldBe` "9 5 11 40 \"Int -> a -> a -> a\"\n7 1 11 40 \"Int -> Integer\"\n" + it "shows types of the expression with constraints and its outers" $ do + let tdir = "test/data/ghc-mod-check" + res <- runD' tdir $ types True "lib/Data/Foo.hs" 9 5 + res `shouldBe` "9 5 11 40 \"Num a => Int -> a -> a -> a\"\n7 1 11 40 \"Int -> Integer\"\n" + it "works with a module using TemplateHaskell" $ do let tdir = "test/data/template-haskell" - res <- runD' tdir $ types "Bar.hs" 5 1 + res <- runD' tdir $ types False "Bar.hs" 5 1 res `shouldBe` unlines ["5 1 5 20 \"[Char]\""] it "works with a module that imports another module using TemplateHaskell" $ do let tdir = "test/data/template-haskell" - res <- runD' tdir $ types "ImportsTH.hs" 3 8 + res <- runD' tdir $ types False "ImportsTH.hs" 3 8 res `shouldBe` unlines ["3 8 3 16 \"String -> IO ()\"", "3 8 3 20 \"IO ()\"", "3 1 3 20 \"IO ()\""] describe "info" $ do diff --git a/test/data/case-split/Crash.hs b/test/data/case-split/Crash.hs new file mode 100644 index 0000000..7ee88cb --- /dev/null +++ b/test/data/case-split/Crash.hs @@ -0,0 +1,4 @@ +module Crash where + +test :: Maybe a +test x = undefined