diff --git a/Data/Binary/Generic.hs b/Data/Binary/Generic.hs index 906b081..2d5500d 100644 --- a/Data/Binary/Generic.hs +++ b/Data/Binary/Generic.hs @@ -66,7 +66,6 @@ instance Binary a => GGBinary (K1 i a) where #define GETSUM(WORD) GUARD(WORD) = (get :: Get WORD) >>= checkGetSum (fromIntegral size) instance ( GSum a, GSum b - , GGBinary a, GGBinary b , SumSize a, SumSize b) => GGBinary (a :+: b) where ggput | PUTSUM(Word8) | PUTSUM(Word16) | PUTSUM(Word32) | PUTSUM(Word64) | otherwise = sizeError "encode" size @@ -96,7 +95,7 @@ class GSum f where getSum :: (Ord word, Num word, Bits word) => word -> word -> Get (f a) putSum :: (Num w, Bits w, Binary w) => w -> w -> f a -> Put -instance (GSum a, GSum b, GGBinary a, GGBinary b) => GSum (a :+: b) where +instance (GSum a, GSum b) => GSum (a :+: b) where getSum !code !size | code < sizeL = L1 <$> getSum code sizeL | otherwise = R1 <$> getSum (code - sizeL) sizeR where 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..53bf2d4 100644 --- a/Language/Haskell/GhcMod/Browse.hs +++ b/Language/Haskell/GhcMod/Browse.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} module Language.Haskell.GhcMod.Browse ( browse, BrowseOpts(..) @@ -11,6 +12,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) @@ -24,6 +26,9 @@ import TyCon (isAlgTyCon) import Type (dropForAlls, splitFunTy_maybe, mkFunTy, isPredTy) import Exception (ExceptionMonad, ghandle) import Prelude +#if __GLASGOW_HASKELL__ >= 800 +import PatSyn (pprPatSynType) +#endif ---------------------------------------------------------------- @@ -96,14 +101,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" @@ -124,6 +135,9 @@ showThing' dflag (GtA a) = Just $ formatType dflag a showThing' _ (GtT t) = unwords . toList <$> tyType t where toList t' = t' : getOccString t : map getOccString (G.tyConTyVars t) +#if __GLASGOW_HASKELL__ >= 800 +showThing' dflag (GtPatSyn p) = Just $ showSDoc dflag $ pprPatSynType p +#endif showThing' _ _ = Nothing formatType :: DynFlags -> Type -> String diff --git a/Language/Haskell/GhcMod/CaseSplit.hs b/Language/Haskell/GhcMod/CaseSplit.hs index 7bcd3fa..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" $ @@ -110,7 +109,11 @@ isPatternVar (L _ (G.VarPat _)) = True isPatternVar _ = False getPatternVarName :: LPat Id -> G.Name +#if __GLASGOW_HASKELL__ >= 800 +getPatternVarName (L _ (G.VarPat (L _ vName))) = G.getName vName +#else getPatternVarName (L _ (G.VarPat vName)) = G.getName vName +#endif getPatternVarName _ = error "This should never happened" -- TODO: Information for a type family case split @@ -170,7 +173,11 @@ getDataCon dflag style vName dcon | [] <- Ty.dataConFieldLabels dcon = -- 3. Records getDataCon dflag style vName dcon = let dName = showName dflag style $ Ty.dataConName dcon +#if __GLASGOW_HASKELL__ >= 800 + flds = map Ty.flSelector $ Ty.dataConFieldLabels dcon +#else flds = Ty.dataConFieldLabels dcon +#endif in dName ++ " { " ++ showFieldNames dflag style vName flds ++ " }" -- Create a new variable by adjoining a number @@ -207,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/Check.hs b/Language/Haskell/GhcMod/Check.hs index f4bd658..1cf52a2 100644 --- a/Language/Haskell/GhcMod/Check.hs +++ b/Language/Haskell/GhcMod/Check.hs @@ -33,7 +33,7 @@ check files = runGmlTWith (map Left files) return - ((fmap fst <$>) . withLogger setNoMaxRelevantBindings) + ((fmap fst <$>) . withLogger Gap.setNoMaxRelevantBindings) (return ()) ---------------------------------------------------------------- diff --git a/Language/Haskell/GhcMod/DebugLogger.hs b/Language/Haskell/GhcMod/DebugLogger.hs index f44679e..0bd0d59 100644 --- a/Language/Haskell/GhcMod/DebugLogger.hs +++ b/Language/Haskell/GhcMod/DebugLogger.hs @@ -13,7 +13,7 @@ -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, RankNTypes #-} module Language.Haskell.GhcMod.DebugLogger where -- (c) The University of Glasgow 2005 @@ -62,27 +62,27 @@ import Language.Haskell.GhcMod.Gap import Prelude debugLogAction :: (String -> IO ()) -> GmLogAction -debugLogAction putErr dflags severity srcSpan style msg +debugLogAction putErr _reason dflags severity srcSpan style' msg = case severity of - SevOutput -> printSDoc putErr msg style + SevOutput -> printSDoc putErr msg style' #if __GLASGOW_HASKELL__ >= 706 - SevDump -> printSDoc putErr (msg Outputable.$$ blankLine) style + SevDump -> printSDoc putErr (msg Outputable.$$ blankLine) style' #endif #if __GLASGOW_HASKELL__ >= 708 SevInteractive -> let putStrSDoc = debugLogActionHPutStrDoc dflags putErr in - putStrSDoc msg style + putStrSDoc msg style' #endif - SevInfo -> printErrs putErr msg style - SevFatal -> printErrs putErr msg style + SevInfo -> printErrs putErr msg style' + SevFatal -> printErrs putErr msg style' _ -> do putErr "\n" #if __GLASGOW_HASKELL__ >= 706 - printErrs putErr (mkLocMessage severity srcSpan msg) style + printErrs putErr (mkLocMessage severity srcSpan msg) style' #else - printErrs putErr (mkLocMessage srcSpan msg) style + printErrs putErr (mkLocMessage srcSpan msg) style' #endif -- careful (#2302): printErrs prints in UTF-8, -- whereas converting to string first and using diff --git a/Language/Haskell/GhcMod/Doc.hs b/Language/Haskell/GhcMod/Doc.hs index 823e19b..7914e2e 100644 --- a/Language/Haskell/GhcMod/Doc.hs +++ b/Language/Haskell/GhcMod/Doc.hs @@ -11,11 +11,6 @@ showPage dflag style = showDocWith dflag PageMode . withStyle dflag style showOneLine :: DynFlags -> PprStyle -> SDoc -> String showOneLine dflag style = showDocWith dflag OneLineMode . withStyle dflag style --- showForUser :: DynFlags -> PrintUnqualified -> SDoc -> String --- showForUser dflags unqual sdoc = --- showDocWith dflags PageMode $ --- runSDoc sdoc $ initSDocContext dflags $ mkUserStyle unqual AllTheWay - getStyle :: GhcMonad m => m PprStyle getStyle = do unqual <- getPrintUnqual diff --git a/Language/Haskell/GhcMod/DynFlags.hs b/Language/Haskell/GhcMod/DynFlags.hs index 09975db..a68a050 100644 --- a/Language/Haskell/GhcMod/DynFlags.hs +++ b/Language/Haskell/GhcMod/DynFlags.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} module Language.Haskell.GhcMod.DynFlags where @@ -16,7 +16,7 @@ import Prelude setEmptyLogger :: DynFlags -> DynFlags setEmptyLogger df = - Gap.setLogAction df $ \_ _ _ _ _ -> return () + Gap.setLogAction df $ \_ _ _ _ _ _ -> return () setDebugLogger :: (String -> IO ()) -> DynFlags -> DynFlags setDebugLogger put df = do @@ -95,14 +95,6 @@ allWarningFlags = unsafePerformIO $ ---------------------------------------------------------------- --- | Set 'DynFlags' equivalent to "-fno-max-relevant-bindings". -setNoMaxRelevantBindings :: DynFlags -> DynFlags -#if __GLASGOW_HASKELL__ >= 708 -setNoMaxRelevantBindings df = df { maxRelevantBinds = Nothing } -#else -setNoMaxRelevantBindings = id -#endif - deferErrors :: Monad m => DynFlags -> m DynFlags deferErrors df = return $ Gap.setWarnTypedHoles $ Gap.setDeferTypedHoles $ diff --git a/Language/Haskell/GhcMod/DynFlagsTH.hs b/Language/Haskell/GhcMod/DynFlagsTH.hs index 084396b..afb2cc5 100644 --- a/Language/Haskell/GhcMod/DynFlagsTH.hs +++ b/Language/Haskell/GhcMod/DynFlagsTH.hs @@ -27,7 +27,12 @@ import Prelude deriveEqDynFlags :: Q [Dec] -> Q [Dec] deriveEqDynFlags qds = do - ~(TyConI (DataD [] _ [] [ctor] _ )) <- reify ''DynFlags +#if __GLASGOW_HASKELL__ <= 710 + ~(TyConI (DataD [] _ [] [ctor] _ )) +#else + ~(TyConI (DataD [] _ [] _ [ctor] _ )) +#endif + <- reify ''DynFlags let ~(RecC _ fs) = ctor a <- newName "a" @@ -83,7 +88,7 @@ deriveEqDynFlags qds = do |] return $ AppE (AppE eqfn fa) fb -#if __GLASGOW_HASKELL__ >= 710 +#if __GLASGOW_HASKELL__ >= 710 && __GLASGOW_HASKELL__ < 800 "sigOf" -> do eqfn <- [| let eqfn NotSigOf NotSigOf = True eqfn (SigOf a') (SigOf b') = a' == b' diff --git a/Language/Haskell/GhcMod/FileMapping.hs b/Language/Haskell/GhcMod/FileMapping.hs index a3f2f97..4655605 100644 --- a/Language/Haskell/GhcMod/FileMapping.hs +++ b/Language/Haskell/GhcMod/FileMapping.hs @@ -63,23 +63,22 @@ loadMappedFile' from to isTemp = do let to' = makeRelative (cradleRootDir crdl) to addMMappedFile cfn (FileMapping to' isTemp) -mapFile :: (IOish m, GmState m, GhcMonad m, GmEnv m) => - HscEnv -> Target -> m Target +mapFile :: (IOish m, GmState m) => HscEnv -> Target -> m Target mapFile _ (Target tid@(TargetFile filePath _) taoc _) = do mapping <- lookupMMappedFile filePath - mkMappedTarget (Just filePath) tid taoc mapping + return $ mkMappedTarget (Just filePath) tid taoc mapping mapFile env (Target tid@(TargetModule moduleName) taoc _) = do (fp, mapping) <- do filePath <- fmap (fmap mpPath) (liftIO $ findModulePath env moduleName) mmf <- runMaybeT $ MaybeT (return filePath) >>= MaybeT . lookupMMappedFile return (filePath, mmf) - mkMappedTarget fp tid taoc mapping + return $ mkMappedTarget fp tid taoc mapping -mkMappedTarget :: (IOish m, GmState m, GmEnv m, GhcMonad m) => - Maybe FilePath -> TargetId -> Bool -> Maybe FileMapping -> m Target +mkMappedTarget :: Maybe FilePath -> TargetId -> Bool -> Maybe FileMapping -> Target mkMappedTarget _ _ taoc (Just to) = - return $ mkTarget (TargetFile (fmPath to) Nothing) taoc Nothing -mkMappedTarget _ tid taoc _ = return $ mkTarget tid taoc Nothing + mkTarget (TargetFile (fmPath to) Nothing) taoc Nothing +mkMappedTarget _ tid taoc _ = + mkTarget tid taoc Nothing {-| unloads previously mapped file \'file\', so that it's no longer mapped, diff --git a/Language/Haskell/GhcMod/FillSig.hs b/Language/Haskell/GhcMod/FillSig.hs index 6ab76c1..3f7ae4c 100644 --- a/Language/Haskell/GhcMod/FillSig.hs +++ b/Language/Haskell/GhcMod/FillSig.hs @@ -116,7 +116,9 @@ getSignature modSum lineNo colNo = do p@ParsedModule{pm_parsed_source = ps} <- G.parseModule modSum -- Inspect the parse tree to find the signature case listifyParsedSpans ps (lineNo, colNo) :: [G.LHsDecl G.RdrName] of -#if __GLASGOW_HASKELL__ >= 710 +#if __GLASGOW_HASKELL__ >= 800 + [L loc (G.SigD (Ty.TypeSig names (G.HsIB _ (G.HsWC _ _ (L _ ty)))))] -> +#elif __GLASGOW_HASKELL__ >= 710 [L loc (G.SigD (Ty.TypeSig names (L _ ty) _))] -> #else [L loc (G.SigD (Ty.TypeSig names (L _ ty)))] -> @@ -131,7 +133,9 @@ getSignature modSum lineNo colNo = do case Gap.getClass lst of Just (clsName,loc) -> obtainClassInfo minfo clsName loc _ -> return Nothing -#if __GLASGOW_HASKELL__ >= 708 +#if __GLASGOW_HASKELL__ >= 800 + [L loc (G.TyClD (G.FamDecl (G.FamilyDecl info (L _ name) (G.HsQTvs _ vars _) _ _)))] -> do +#elif __GLASGOW_HASKELL__ >= 708 [L loc (G.TyClD (G.FamDecl (G.FamilyDecl info (L _ name) (G.HsQTvs _ vars) _)))] -> do #elif __GLASGOW_HASKELL__ >= 706 [L loc (G.TyClD (G.TyFamily info (L _ name) (G.HsQTvs _ vars) _))] -> do @@ -149,7 +153,11 @@ getSignature modSum lineNo colNo = do G.DataFamily -> Data #endif -#if __GLASGOW_HASKELL__ >= 710 +#if __GLASGOW_HASKELL__ >= 800 + getTyFamVarName x = case x of + L _ (G.UserTyVar (G.L _ n)) -> n + L _ (G.KindedTyVar (G.L _ n) _) -> n +#elif __GLASGOW_HASKELL__ >= 710 getTyFamVarName x = case x of L _ (G.UserTyVar n) -> n L _ (G.KindedTyVar (G.L _ n) _) -> n @@ -269,7 +277,9 @@ class FnArgsInfo ty name | ty -> name, name -> ty where instance FnArgsInfo (G.HsType G.RdrName) (G.RdrName) where getFnName dflag style name = showOccName dflag style $ Gap.occName name -#if __GLASGOW_HASKELL__ >= 710 +#if __GLASGOW_HASKELL__ >= 800 + getFnArgs (G.HsForAllTy _ (L _ iTy)) +#elif __GLASGOW_HASKELL__ >= 710 getFnArgs (G.HsForAllTy _ _ _ _ (L _ iTy)) #else getFnArgs (G.HsForAllTy _ _ _ (L _ iTy)) @@ -280,7 +290,9 @@ instance FnArgsInfo (G.HsType G.RdrName) (G.RdrName) where getFnArgs (G.HsFunTy (L _ lTy) (L _ rTy)) = (if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy where fnarg ty = case ty of -#if __GLASGOW_HASKELL__ >= 710 +#if __GLASGOW_HASKELL__ >= 800 + (G.HsForAllTy _ (L _ iTy)) -> +#elif __GLASGOW_HASKELL__ >= 710 (G.HsForAllTy _ _ _ _ (L _ iTy)) -> #else (G.HsForAllTy _ _ _ (L _ iTy)) -> @@ -381,7 +393,11 @@ findVar -> m (Maybe (SrcSpan, String, Type, Bool)) findVar dflag style tcm tcs lineNo colNo = case lst of +#if __GLASGOW_HASKELL__ >= 800 + e@(L _ (G.HsVar (L _ i))):others -> do +#else e@(L _ (G.HsVar i)):others -> do +#endif tyInfo <- Gap.getType tcm e case tyInfo of Just (s, typ) @@ -409,7 +425,11 @@ doParen False s = s doParen True s = if ' ' `elem` s then '(':s ++ ")" else s isSearchedVar :: Id -> G.HsExpr Id -> Bool +#if __GLASGOW_HASKELL__ >= 800 +isSearchedVar i (G.HsVar (L _ i2)) = i == i2 +#else isSearchedVar i (G.HsVar i2) = i == i2 +#endif isSearchedVar _ _ = False @@ -512,7 +532,11 @@ getPatsForVariable tcs (lineNo, colNo) = _ -> (error "This should never happen", []) getBindingsForPat :: Ty.Pat Id -> M.Map G.Name Type +#if __GLASGOW_HASKELL__ >= 800 +getBindingsForPat (Ty.VarPat (L _ i)) = M.singleton (G.getName i) (Ty.varType i) +#else getBindingsForPat (Ty.VarPat i) = M.singleton (G.getName i) (Ty.varType i) +#endif getBindingsForPat (Ty.LazyPat (L _ l)) = getBindingsForPat l getBindingsForPat (Ty.BangPat (L _ b)) = getBindingsForPat b getBindingsForPat (Ty.AsPat (L _ a) (L _ i)) = @@ -537,11 +561,23 @@ getBindingsForPat (Ty.ConPatOut { Ty.pat_args = d }) = getBindingsForRecPat d getBindingsForPat _ = M.empty getBindingsForRecPat :: Ty.HsConPatDetails Id -> M.Map G.Name Type +#if __GLASGOW_HASKELL__ >= 800 +getBindingsForRecPat (G.PrefixCon args) = +#else getBindingsForRecPat (Ty.PrefixCon args) = +#endif M.unions $ map (\(L _ i) -> getBindingsForPat i) args +#if __GLASGOW_HASKELL__ >= 800 +getBindingsForRecPat (G.InfixCon (L _ a1) (L _ a2)) = +#else getBindingsForRecPat (Ty.InfixCon (L _ a1) (L _ a2)) = +#endif M.union (getBindingsForPat a1) (getBindingsForPat a2) +#if __GLASGOW_HASKELL__ >= 800 +getBindingsForRecPat (G.RecCon (Ty.HsRecFields { Ty.rec_flds = fields })) = +#else getBindingsForRecPat (Ty.RecCon (Ty.HsRecFields { Ty.rec_flds = fields })) = +#endif getBindingsForRecFields (map unLoc' fields) where #if __GLASGOW_HASKELL__ >= 710 diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs index bd51749..23462aa 100644 --- a/Language/Haskell/GhcMod/Find.hs +++ b/Language/Haskell/GhcMod/Find.hs @@ -72,7 +72,16 @@ data SymbolDb = SymbolDb , sdTimestamp :: ModTime } deriving (Generic) +#if __GLASGOW_HASKELL__ >= 708 instance Binary SymbolDb +#else +instance Binary SymbolDb where + put (SymbolDb a b) = put a >> put b + get = do + a <- get + b <- get + return (SymbolDb a b) +#endif instance NFData SymbolDb isOutdated :: IOish m => SymbolDb -> GhcModT m Bool diff --git a/Language/Haskell/GhcMod/Flag.hs b/Language/Haskell/GhcMod/Flag.hs index 5fc3e2b..24cb61b 100644 --- a/Language/Haskell/GhcMod/Flag.hs +++ b/Language/Haskell/GhcMod/Flag.hs @@ -4,10 +4,6 @@ import qualified Language.Haskell.GhcMod.Gap as Gap import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Monad --- | Listing GHC flags. (e.g -fno-warn-orphans) - +-- | Listing of GHC flags, same as @ghc@\'s @--show-options@ with @ghc >= 7.10@. flags :: IOish m => GhcModT m String -flags = convert' [ "-f" ++ prefix ++ option - | option <- Gap.fOptions - , prefix <- ["","no-"] - ] +flags = convert' Gap.ghcCmdOptions diff --git a/Language/Haskell/GhcMod/Gap.hs b/Language/Haskell/GhcMod/Gap.hs index bf38e1c..2659c5a 100644 --- a/Language/Haskell/GhcMod/Gap.hs +++ b/Language/Haskell/GhcMod/Gap.hs @@ -9,7 +9,7 @@ module Language.Haskell.GhcMod.Gap ( , getSrcSpan , getSrcFile , withInteractiveContext - , fOptions + , ghcCmdOptions , toStringBuffer , showSeverityCaption , setCabalPkg @@ -18,12 +18,14 @@ module Language.Haskell.GhcMod.Gap ( , setDeferTypedHoles , setWarnTypedHoles , setDumpSplices + , setNoMaxRelevantBindings , isDumpSplices , filterOutChildren , infoThing , pprInfo , HasType(..) , errorMsgSpan + , setErrorMsgSpan , typeForUser , nameForUser , occNameForUser @@ -44,6 +46,7 @@ module Language.Haskell.GhcMod.Gap ( , Language.Haskell.GhcMod.Gap.isSynTyCon , parseModuleHeader , mkErrStyle' + , everythingStagedWithContext ) where import Control.Applicative hiding (empty) @@ -82,7 +85,7 @@ import CoAxiom (coAxiomTyCon) #if __GLASGOW_HASKELL__ >= 708 import FamInstEnv import ConLike (ConLike(..)) -import PatSyn (patSynType) +import PatSyn #else import TcRnTypes #endif @@ -115,6 +118,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 @@ -145,22 +150,32 @@ withStyle = withPprStyleDoc withStyle _ = withPprStyleDoc #endif -#if __GLASGOW_HASKELL__ >= 706 -type GmLogAction = LogAction +#if __GLASGOW_HASKELL__ >= 800 +-- flip LogAction +type GmLogAction = WarnReason -> DynFlags -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO () +#elif __GLASGOW_HASKELL__ >= 706 +type GmLogAction = forall a. a -> LogAction #else -type GmLogAction = DynFlags -> LogAction +type GmLogAction = forall a. a -> DynFlags -> LogAction #endif +-- DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO () + setLogAction :: DynFlags -> GmLogAction -> DynFlags setLogAction df f = -#if __GLASGOW_HASKELL__ >= 706 - df { log_action = f } +#if __GLASGOW_HASKELL__ >= 800 + df { log_action = flip f } +#elif __GLASGOW_HASKELL__ >= 706 + df { log_action = f (error "setLogAction") } #else - df { log_action = f df } + df { log_action = f (error "setLogAction") df } #endif showDocWith :: DynFlags -> Pretty.Mode -> Pretty.Doc -> String -#if __GLASGOW_HASKELL__ >= 708 +#if __GLASGOW_HASKELL__ >= 800 +showDocWith dflags mode = Pretty.renderStyle mstyle where + mstyle = Pretty.style { Pretty.mode = mode, Pretty.lineLength = pprCols dflags } +#elif __GLASGOW_HASKELL__ >= 708 -- Pretty.showDocWith disappeard. -- https://github.com/ghc/ghc/commit/08a3536e4246e323fbcd8040e0b80001950fe9bc showDocWith dflags mode = Pretty.showDoc mode (pprCols dflags) @@ -202,19 +217,26 @@ toStringBuffer = liftIO . stringToStringBuffer . unlines ---------------------------------------------------------------- -fOptions :: [String] +ghcCmdOptions :: [String] #if __GLASGOW_HASKELL__ >= 710 -fOptions = [option | (FlagSpec option _ _ _) <- fFlags] - ++ [option | (FlagSpec option _ _ _) <- fWarningFlags] - ++ [option | (FlagSpec option _ _ _) <- fLangFlags] -#elif __GLASGOW_HASKELL__ >= 704 -fOptions = [option | (option,_,_) <- fFlags] +-- this also includes -X options and all sorts of other things so the +ghcCmdOptions = flagsForCompletion False +#else +ghcCmdOptions = [ "-f" ++ prefix ++ option + | option <- opts + , prefix <- ["","no-"] + ] +# if __GLASGOW_HASKELL__ >= 704 + where opts = + [option | (option,_,_) <- fFlags] ++ [option | (option,_,_) <- fWarningFlags] ++ [option | (option,_,_) <- fLangFlags] -#else -fOptions = [option | (option,_,_,_) <- fFlags] +# else + where opts = + [option | (option,_,_,_) <- fFlags] ++ [option | (option,_,_,_) <- fWarningFlags] ++ [option | (option,_,_,_) <- fLangFlags] +# endif #endif ---------------------------------------------------------------- @@ -316,6 +338,16 @@ setWarnTypedHoles dflag = wopt_set dflag Opt_WarnTypedHoles setWarnTypedHoles = id #endif +---------------------------------------------------------------- + +-- | Set 'DynFlags' equivalent to "-fno-max-relevant-bindings". +setNoMaxRelevantBindings :: DynFlags -> DynFlags +#if __GLASGOW_HASKELL__ >= 708 +setNoMaxRelevantBindings df = df { maxRelevantBinds = Nothing } +#else +setNoMaxRelevantBindings = id +#endif + ---------------------------------------------------------------- ---------------------------------------------------------------- @@ -420,6 +452,13 @@ errorMsgSpan = errMsgSpan errorMsgSpan = head . errMsgSpans #endif +setErrorMsgSpan :: ErrMsg -> SrcSpan -> ErrMsg +#if __GLASGOW_HASKELL__ >= 708 +setErrorMsgSpan err s = err { errMsgSpan = s } +#else +setErrorMsgSpan err s = err { errMsgSpans = [s] } +#endif + typeForUser :: Type -> SDoc #if __GLASGOW_HASKELL__ >= 708 typeForUser = pprTypeForUser @@ -449,13 +488,22 @@ deSugar tcm e hs_env = snd <$> deSugarExpr hs_env modu rn_env ty_env e ---------------------------------------------------------------- ---------------------------------------------------------------- -data GapThing = GtA Type | GtT TyCon | GtN +data GapThing = GtA Type + | GtT TyCon + | GtN +#if __GLASGOW_HASKELL__ >= 800 + | GtPatSyn PatSyn +#endif fromTyThing :: TyThing -> GapThing fromTyThing (AnId i) = GtA $ varType i #if __GLASGOW_HASKELL__ >= 708 fromTyThing (AConLike (RealDataCon d)) = GtA $ dataConRepType d +#if __GLASGOW_HASKELL__ >= 800 +fromTyThing (AConLike (PatSynCon p)) = GtPatSyn p +#else fromTyThing (AConLike (PatSynCon p)) = GtA $ patSynType p +#endif #else fromTyThing (ADataCon d) = GtA $ dataConRepType d #endif @@ -487,7 +535,12 @@ type GLMatchI = LMatch Id #endif getClass :: [LInstDecl Name] -> Maybe (Name, SrcSpan) -#if __GLASGOW_HASKELL__ >= 710 +#if __GLASGOW_HASKELL__ >= 800 +-- Instance declarations of sort 'instance F (G a)' +getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = HsIB _ (L _ (HsForAllTy _ (L _ (HsAppTy (L _ (HsTyVar (L _ className))) _))))}))] = Just (className, loc) +-- Instance declarations of sort 'instance F G' (no variables) +getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = HsIB _ (L _ (HsAppTy (L _ (HsTyVar (L _ className))) _))}))] = Just (className, loc) +#elif __GLASGOW_HASKELL__ >= 710 -- Instance declarations of sort 'instance F (G a)' getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsForAllTy _ _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _))))}))] = Just (className, loc) -- Instance declarations of sort 'instance F G' (no variables) @@ -595,3 +648,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/Lint.hs b/Language/Haskell/GhcMod/Lint.hs index f6c549f..a506565 100644 --- a/Language/Haskell/GhcMod/Lint.hs +++ b/Language/Haskell/GhcMod/Lint.hs @@ -9,7 +9,7 @@ import Language.Haskell.GhcMod.Monad import Language.Haskell.HLint3 import Language.Haskell.GhcMod.Utils (withMappedFile) -import Language.Haskell.Exts.Pretty (prettyPrint) +import Language.Haskell.Exts.SrcLoc (SrcLoc(..)) import System.IO -- | Checking syntax of a target file using hlint. @@ -27,7 +27,8 @@ lint opt file = ghandle handler $ case res of Right m -> pack . map show $ applyHints classify hint [m] Left ParseError{parseErrorLocation=loc, parseErrorMessage=err} -> - return $ prettyPrint loc ++ ":Error:" ++ err ++ "\n" + return $ showSrcLoc loc ++ ":Error:" ++ err ++ "\n" where pack = convert' . map init -- init drops the last \n. handler (SomeException e) = return $ checkErrorPrefix ++ show e ++ "\n" + showSrcLoc (SrcLoc f l c) = concat [f, ":", show l, ":", show c] diff --git a/Language/Haskell/GhcMod/Logger.hs b/Language/Haskell/GhcMod/Logger.hs index 36d1995..74e88f0 100644 --- a/Language/Haskell/GhcMod/Logger.hs +++ b/Language/Haskell/GhcMod/Logger.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP, RankNTypes #-} + module Language.Haskell.GhcMod.Logger ( withLogger , withLogger' @@ -12,7 +14,7 @@ import Data.Ord import Data.List import Data.Maybe import Data.Function -import Control.Monad.Reader (Reader, asks, runReader) +import Control.Monad.Reader (Reader, ask, runReader) import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef) import System.FilePath (normalise) import Text.PrettyPrint @@ -23,6 +25,8 @@ import HscTypes import Outputable import qualified GHC as G import Bag +import SrcLoc +import FastString import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Doc (showPage) @@ -57,15 +61,13 @@ readAndClearLogRef (LogRef ref) = do writeIORef ref emptyLog return $ b [] -appendLogRef :: (FilePath -> FilePath) -> DynFlags -> LogRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO () -appendLogRef rfm df (LogRef ref) _ sev src st msg = do +appendLogRef :: (FilePath -> FilePath) -> DynFlags -> LogRef -> Gap.GmLogAction +appendLogRef map_file df (LogRef ref) _reason _df sev src st msg = do modifyIORef ref update where - gpe = GmPprEnv { - gpeDynFlags = df - , gpeMapFile = rfm - } - l = runReader (ppMsg st src sev msg) gpe + -- TODO: get rid of ppMsg and just do more or less what ghc's + -- defaultLogAction does + l = ppMsg map_file df st src sev msg update lg@(Log ls b) | l `elem` ls = lg @@ -132,38 +134,51 @@ sortMsgBag bag = sortBy (compare `on` Gap.errorMsgSpan) $ bagToList bag ppErrMsg :: ErrMsg -> GmPprEnvM String ppErrMsg err = do - dflags <- asks gpeDynFlags + GmPprEnv {..} <- ask let unqual = errMsgContext err - st = Gap.mkErrStyle' dflags unqual - let ext = showPage dflags st (errMsgExtraInfo err) - m <- ppMsg st spn SevError msg - return $ m ++ (if null ext then "" else "\n" ++ ext) - where - spn = Gap.errorMsgSpan err - msg = errMsgShortDoc err + st = Gap.mkErrStyle' gpeDynFlags unqual + err' = Gap.setErrorMsgSpan err $ mapSrcSpanFile gpeMapFile (Gap.errorMsgSpan err) + return $ showPage gpeDynFlags st $ pprLocErrMsg err' -ppMsg :: PprStyle -> SrcSpan -> Severity -> SDoc -> GmPprEnvM String -ppMsg st spn sev msg = do - dflags <- asks gpeDynFlags - let cts = showPage dflags st msg - prefix <- ppMsgPrefix spn sev cts - return $ prefix ++ cts +mapSrcSpanFile :: (FilePath -> FilePath) -> SrcSpan -> SrcSpan +mapSrcSpanFile map_file (RealSrcSpan s) = + RealSrcSpan $ mapRealSrcSpanFile map_file s +mapSrcSpanFile _ (UnhelpfulSpan s) = + UnhelpfulSpan s -ppMsgPrefix :: SrcSpan -> Severity -> String -> GmPprEnvM String -ppMsgPrefix spn sev cts = do - dflags <- asks gpeDynFlags - mr <- asks gpeMapFile - let defaultPrefix - | Gap.isDumpSplices dflags = "" - | otherwise = checkErrorPrefix - return $ fromMaybe defaultPrefix $ do - (line,col,_,_) <- Gap.getSrcSpan spn - file <- mr <$> normalise <$> Gap.getSrcFile spn - let severityCaption = Gap.showSeverityCaption sev - pref0 | or (map (\x -> x `isPrefixOf` cts) warningAsErrorPrefixes) - = file ++ ":" ++ show line ++ ":" ++ show col ++ ":" - | otherwise = file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ severityCaption - return pref0 +mapRealSrcSpanFile :: (FilePath -> FilePath) -> RealSrcSpan -> RealSrcSpan +mapRealSrcSpanFile map_file s = let + start = mapRealSrcLocFile map_file $ realSrcSpanStart s + end = mapRealSrcLocFile map_file $ realSrcSpanEnd s + in + mkRealSrcSpan start end + +mapRealSrcLocFile :: (FilePath -> FilePath) -> RealSrcLoc -> RealSrcLoc +mapRealSrcLocFile map_file l = let + file = mkFastString $ map_file $ unpackFS $ srcLocFile l + line = srcLocLine l + col = srcLocCol l + in + mkRealSrcLoc file line col + +ppMsg :: (FilePath -> FilePath) -> DynFlags -> PprStyle -> SrcSpan -> Severity -> SDoc -> String +ppMsg map_file df st spn sev msg = let + cts = showPage df st msg + in + ppMsgPrefix map_file df spn sev cts ++ cts + +ppMsgPrefix :: (FilePath -> FilePath) -> DynFlags -> SrcSpan -> Severity -> String -> String +ppMsgPrefix map_file df spn sev cts = + let + defaultPrefix = if Gap.isDumpSplices df then "" else checkErrorPrefix + in + fromMaybe defaultPrefix $ do + (line,col,_,_) <- Gap.getSrcSpan spn + file <- map_file <$> normalise <$> Gap.getSrcFile spn + return $ file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ + if or (map (\x -> x `isPrefixOf` cts) warningAsErrorPrefixes) + then "" + else Gap.showSeverityCaption sev checkErrorPrefix :: String checkErrorPrefix = "Dummy:0:0:Error:" diff --git a/Language/Haskell/GhcMod/Monad.hs b/Language/Haskell/GhcMod/Monad.hs index 96d55e5..fb25074 100644 --- a/Language/Haskell/GhcMod/Monad.hs +++ b/Language/Haskell/GhcMod/Monad.hs @@ -103,7 +103,7 @@ runGmOutT opts ma = do (const $ liftIO $ flushStdoutGateway gmoChan) action -runGmOutT' :: IOish m => GhcModOut -> GmOutT m a -> m a +runGmOutT' :: GhcModOut -> GmOutT m a -> m a runGmOutT' gmo ma = flip runReaderT gmo $ unGmOutT ma -- | Run a @GhcModT m@ computation. diff --git a/Language/Haskell/GhcMod/Monad/Newtypes.hs b/Language/Haskell/GhcMod/Monad/Newtypes.hs index dd7e5a6..ab3d82e 100644 --- a/Language/Haskell/GhcMod/Monad/Newtypes.hs +++ b/Language/Haskell/GhcMod/Monad/Newtypes.hs @@ -124,7 +124,7 @@ instance MonadTrans GmlT where -- GmT ------------------------------------------ -instance forall r m. MonadReader r m => MonadReader r (GmT m) where +instance MonadReader r m => MonadReader r (GmT m) where local f ma = gmLiftWithInner (\run -> local f (run ma)) ask = gmLiftInner ask diff --git a/Language/Haskell/GhcMod/SrcUtils.hs b/Language/Haskell/GhcMod/SrcUtils.hs index 0938f81..fb36289 100644 --- a/Language/Haskell/GhcMod/SrcUtils.hs +++ b/Language/Haskell/GhcMod/SrcUtils.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE TupleSections, FlexibleInstances, Rank2Types #-} +-- TODO: remove CPP once Gap(ed) +{-# LANGUAGE CPP, TupleSections, FlexibleInstances, Rank2Types #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Language.Haskell.GhcMod.SrcUtils where @@ -6,11 +7,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 +24,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 +42,101 @@ 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) +#if __GLASGOW_HASKELL__ >= 800 + -- TODO: move to Gap + -- Note: this deals with bindings with explicit type signature, e.g. + -- double :: Num a => a -> a + -- double x = 2*x + hsBind (L _ G.AbsBindsSig{abs_sig_export = poly, abs_sig_bind = bind}) s + | withConstraints = + let new_s = + case bind of + G.L _ G.FunBind{fun_id = i} -> M.insert (G.unLoc i) (G.varType poly) s + _ -> s + in (return [], new_s) + | otherwise = (return [], s) +#endif + -- 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 +#if __GLASGOW_HASKELL__ >= 800 + -- TODO: move to Gap + subs = G.mkTvSubstPrs $ concatMap snd ctys +#else + subs = G.mkTopTvSubst $ concatMap snd ctys +#endif + -- 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/Stack.hs b/Language/Haskell/GhcMod/Stack.hs index 498430e..8a0fb3d 100644 --- a/Language/Haskell/GhcMod/Stack.hs +++ b/Language/Haskell/GhcMod/Stack.hs @@ -75,12 +75,12 @@ findExecutablesInStackBinPath exe StackEnv {..} = findExecutablesInDirectories' :: [FilePath] -> String -> IO [FilePath] findExecutablesInDirectories' path binary = - U.findFilesWith' isExecutable path (binary <.> exeExtension) + U.findFilesWith' isExecutable path (binary <.> exeExtension') where isExecutable file = do perms <- getPermissions file return $ executable perms - exeExtension = if isWindows then "exe" else "" + exeExtension' = if isWindows then "exe" else "" readStack :: (IOish m, GmOut m, GmLog m) => [String] -> MaybeT m String readStack args = do diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 67fa140..7b5c857 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -21,6 +21,9 @@ import Control.Arrow import Control.Applicative import Control.Category ((.)) import GHC +#if __GLASGOW_HASKELL__ >= 800 +import GHC.LanguageExtensions +#endif import GHC.Paths (libdir) import SysTools import DynFlags @@ -287,8 +290,7 @@ findCandidates scns = foldl1 Set.intersection scns pickComponent :: Set ChComponentName -> ChComponentName pickComponent scn = Set.findMin scn -packageGhcOptions :: (Applicative m, IOish m, Gm m) - => m [GHCOption] +packageGhcOptions :: (IOish m, Applicative m, Gm m) => m [GHCOption] packageGhcOptions = do crdl <- cradle case cradleProject crdl of @@ -491,11 +493,17 @@ loadTargets opts targetStrs = do needsHscInterpreted :: ModuleGraph -> Bool needsHscInterpreted = any $ \ms -> let df = ms_hspp_opts ms in +#if __GLASGOW_HASKELL__ >= 800 + TemplateHaskell `xopt` df + || QuasiQuotes `xopt` df + || PatternSynonyms `xopt` df +#else Opt_TemplateHaskell `xopt` df || Opt_QuasiQuotes `xopt` df #if __GLASGOW_HASKELL__ >= 708 || (Opt_PatternSynonyms `xopt` df) #endif +#endif cabalResolvedComponents :: (IOish m) => GhcModT m (Map ChComponentName (GmComponent 'GMCResolved (Set ModulePath))) diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 2281ba9..407beef 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 @@ -271,7 +271,7 @@ instance Binary GmModuleGraph where mpGraph = Map.map (Set.map intToMp) $ Map.mapKeys intToMp graph return $ GmModuleGraph mpGraph where - swapMap :: (Ord k, Ord v) => Map k v -> Map v k + swapMap :: Ord v => Map k v -> Map v k swapMap = Map.fromList . map (\(x, y) -> (y, x)) . Map.toList instance Monoid GmModuleGraph where @@ -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/NotCPP/Declarations.hs b/NotCPP/Declarations.hs index b57feae..9567689 100644 --- a/NotCPP/Declarations.hs +++ b/NotCPP/Declarations.hs @@ -133,7 +133,7 @@ boundNames decl = #endif map ((,) TcClsName) (conNames ctor) - InstanceD _ _ty _ -> + InstanceD {} -> -- _ _ty _ error "notcpp: Instance declarations are not supported yet" ForeignD _ -> error "notcpp: Foreign declarations are not supported yet" diff --git a/NotCPP/LookupValueName.hs b/NotCPP/LookupValueName.hs index 9132e99..b12d08f 100644 --- a/NotCPP/LookupValueName.hs +++ b/NotCPP/LookupValueName.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE CPP, TemplateHaskell #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} -- | This module uses scope lookup techniques to either export -- 'lookupValueName' from @Language.Haskell.TH@, or define -- its own 'lookupValueName', which attempts to do the @@ -39,9 +40,5 @@ bestValueGuess s = do err = fail . showString "NotCPP.bestValueGuess: " . unwords $(recover [d| lookupValueName = bestValueGuess |] $ do -#if __GLASGOW_HASKELL__ >= 800 - VarI _ _ _ <- reify (mkName "lookupValueName") -#else - VarI _ _ _ _ <- reify (mkName "lookupValueName") -#endif + VarI{} <- reify (mkName "lookupValueName") return []) diff --git a/NotCPP/Utils.hs b/NotCPP/Utils.hs index 8557c4a..d25b637 100644 --- a/NotCPP/Utils.hs +++ b/NotCPP/Utils.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE CPP, TemplateHaskell #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} module NotCPP.Utils where import Control.Applicative ((<$>)) @@ -24,19 +25,11 @@ recoverMaybe q = recover (return Nothing) (Just <$> q) -- | Returns @'Just' ('VarE' n)@ if the info relates to a value called -- @n@, or 'Nothing' if it relates to a different sort of thing. infoToExp :: Info -> Maybe Exp - #if __GLASGOW_HASKELL__ >= 800 -infoToExp (VarI n _ _) = +infoToExp (VarI n _ _) = Just (VarE n) +infoToExp (DataConI n _ _) = Just (ConE n) #else -infoToExp (VarI n _ _ _) = +infoToExp (VarI n _ _ _) = Just (VarE n) +infoToExp (DataConI n _ _ _) = Just (ConE n) #endif - Just (VarE n) - -#if __GLASGOW_HASKELL__ >= 800 -infoToExp (DataConI n _ _) = -#else -infoToExp (DataConI n _ _ _) = -#endif - Just (ConE n) - infoToExp _ = Nothing diff --git a/elisp/ghc.el b/elisp/ghc.el index ec14a81..5c35f05 100644 --- a/elisp/ghc.el +++ b/elisp/ghc.el @@ -28,7 +28,7 @@ (< emacs-minor-version minor))) (error "ghc-mod requires at least Emacs %d.%d" major minor))) -(defconst ghc-version "5.5.0.0") +(defconst ghc-version "5.6.0.0") (defgroup ghc-mod '() "ghc-mod customization") diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 583e033..d2d8e9d 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -1,5 +1,5 @@ Name: ghc-mod -Version: 5.5.0.0 +Version: 5.6.0.0 Author: Kazu Yamamoto , Daniel Gröber , Alejandro Serrano , @@ -95,6 +95,15 @@ Extra-Source-Files: ChangeLog test/data/stack-project/src/*.hs test/data/stack-project/test/*.hs +Custom-Setup + Setup-Depends: base + , Cabal < 1.25 + , containers + , filepath + , process + , template-haskell + , transformers + Library Default-Language: Haskell2010 GHC-Options: -Wall -fno-warn-deprecations @@ -165,7 +174,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 @@ -197,6 +206,8 @@ Library , syb if impl(ghc < 7.8) Build-Depends: convertible + if impl(ghc >= 8.0) + Build-Depends: ghc-boot Executable ghc-mod Default-Language: Haskell2010 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/stack-8.yaml b/stack-8.yaml new file mode 100644 index 0000000..2d4ead8 --- /dev/null +++ b/stack-8.yaml @@ -0,0 +1,5 @@ +flags: {} +packages: +- '.' +extra-deps: [] +resolver: nightly-2016-06-04 diff --git a/test/CabalHelperSpec.hs b/test/CabalHelperSpec.hs index 2a3086e..1645c81 100644 --- a/test/CabalHelperSpec.hs +++ b/test/CabalHelperSpec.hs @@ -33,7 +33,11 @@ pkgOptions (x:y:xs) | x == "-package-id" = [name y] ++ pkgOptions xs | otherwise = pkgOptions (y:xs) where stripDash s = maybe s id $ (flip drop s . (+1) <$> findIndex (=='-') s) +#if __GLASGOW_HASKELL__ >= 800 + name s = reverse $ stripDash $ reverse s +#else name s = reverse $ stripDash $ stripDash $ reverse s +#endif idirOpts :: [(c, [String])] -> [(c, [String])] idirOpts = map (second $ map (drop 2) . filter ("-i"`isPrefixOf`)) @@ -69,7 +73,7 @@ spec = do it "extracts build dependencies" $ do let tdir = "test/data/cabal-project" opts <- map gmcGhcOpts <$> runD' tdir getComponents - let ghcOpts = head opts + let ghcOpts:_ = opts pkgs = pkgOptions ghcOpts pkgs `shouldBe` ["Cabal","base","template-haskell"] diff --git a/test/CaseSplitSpec.hs b/test/CaseSplitSpec.hs index 5e5db3f..395b5c2 100644 --- a/test/CaseSplitSpec.hs +++ b/test/CaseSplitSpec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} module CaseSplitSpec where import Language.Haskell.GhcMod @@ -12,6 +13,7 @@ main = do spec :: Spec spec = do describe "case split" $ do +#if __GLASGOW_HASKELL__ >= 708 it "does not blow up on HsWithBndrs panic" $ do withDirectory_ "test/data/case-split" $ do res <- runD $ splits "Vect.hs" 24 10 @@ -39,3 +41,41 @@ spec = do res `shouldBe` "38 21 38 59"++ " \"mlReverse' Nil accum = _mlReverse_body\NUL"++ " mlReverse' (Cons xs'1 xs'2) accum = _mlReverse_body\"\n" +#else + it "does not blow up on HsWithBndrs panic" $ do + withDirectory_ "test/data/case-split" $ do + res <- runD $ splits "Vect706.hs" 24 10 + res `shouldBe` "24 1 24 25"++ + " \"mlAppend Nil y = undefined\NUL"++ + "mlAppend (Cons x1 x2) y = undefined\"\n" + + it "works with case expressions" $ do + withDirectory_ "test/data/case-split" $ do + res <- runD $ splits "Vect706.hs" 28 20 + res `shouldBe` "28 19 28 34"++ + " \"Nil -> undefined\NUL"++ + " (Cons x'1 x'2) -> undefined\"\n" + + it "works with where clauses" $ do + withDirectory_ "test/data/case-split" $ do + res <- runD $ splits "Vect706.hs" 34 17 + res `shouldBe` "34 5 34 37"++ + " \"mlReverse' Nil accum = undefined\NUL"++ + " mlReverse' (Cons xs'1 xs'2) accum = undefined\"\n" + + it "works with let bindings" $ do + withDirectory_ "test/data/case-split" $ do + res <- runD $ splits "Vect706.hs" 38 33 + res `shouldBe` "38 21 38 53"++ + " \"mlReverse' Nil accum = undefined\NUL"++ + " mlReverse' (Cons xs'1 xs'2) accum = undefined\"\n" + +#endif + it "doesn't crash when source doesn't make sense" $ + withDirectory_ "test/data/case-split" $ do + res <- runD $ splits "Crash.hs" 4 6 +#if __GLASGOW_HASKELL__ < 710 + res `shouldBe` "4 1 4 19 \"test x = undefined\"\n" +#else + res `shouldBe` "" +#endif diff --git a/test/CheckSpec.hs b/test/CheckSpec.hs index 1ff26e2..9b1ea38 100644 --- a/test/CheckSpec.hs +++ b/test/CheckSpec.hs @@ -58,7 +58,7 @@ spec = do it "emits warnings generated in GHC's desugar stage" $ do withDirectory_ "test/data/check-missing-warnings" $ do res <- runD $ checkSyntax ["DesugarWarnings.hs"] - res `shouldBe` "DesugarWarnings.hs:4:9:Warning: Pattern match(es) are non-exhaustive\NULIn a case alternative: Patterns not matched: _ : _\n" + res `shouldSatisfy` ("DesugarWarnings.hs:4:9:Warning: Pattern match(es) are non-exhaustive\NULIn a case alternative: Patterns not matched:" `isPrefixOf`) #endif it "works with cabal builtin preprocessors" $ do @@ -71,7 +71,9 @@ spec = do it "Uses the right qualification style" $ do withDirectory_ "test/data/nice-qualification" $ do res <- runD $ checkSyntax ["NiceQualification.hs"] -#if __GLASGOW_HASKELL__ >= 708 +#if __GLASGOW_HASKELL__ >= 800 + res `shouldBe` "NiceQualification.hs:4:8:\8226 Couldn't match expected type \8216IO ()\8217 with actual type \8216[Char]\8217\NUL\8226 In the expression: \"wrong type\"\NUL In an equation for \8216main\8217: main = \"wrong type\"\n" +#elif __GLASGOW_HASKELL__ >= 708 res `shouldBe` "NiceQualification.hs:4:8:Couldn't match expected type \8216IO ()\8217 with actual type \8216[Char]\8217\NULIn the expression: \"wrong type\"\NULIn an equation for \8216main\8217: main = \"wrong type\"\n" #else res `shouldBe` "NiceQualification.hs:4:8:Couldn't match expected type `IO ()' with actual type `[Char]'\NULIn the expression: \"wrong type\"\NULIn an equation for `main': main = \"wrong type\"\n" diff --git a/test/FileMappingSpec.hs b/test/FileMappingSpec.hs index d6ba1bb..47c2a83 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/FlagSpec.hs b/test/FlagSpec.hs index af5438d..60b624b 100644 --- a/test/FlagSpec.hs +++ b/test/FlagSpec.hs @@ -9,6 +9,6 @@ import Prelude spec :: Spec spec = do describe "flags" $ do - it "contains at least `-fno-warn-orphans'" $ do + it "contains at least `-fprint-explicit-foralls" $ do f <- runD $ lines <$> flags - f `shouldContain` ["-fno-warn-orphans"] + f `shouldContain` ["-fprint-explicit-foralls"] diff --git a/test/InfoSpec.hs b/test/InfoSpec.hs index 3bdd5ae..de9f3e4 100644 --- a/test/InfoSpec.hs +++ b/test/InfoSpec.hs @@ -19,17 +19,31 @@ 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 +#if __GLASGOW_HASKELL__ >= 800 + res `shouldBe` "9 5 11 40 \"Int -> t -> t -> t\"\n7 1 11 40 \"Int -> Integer\"\n" +#else res `shouldBe` "9 5 11 40 \"Int -> a -> a -> a\"\n7 1 11 40 \"Int -> Integer\"\n" +#endif + + + 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 +#if __GLASGOW_HASKELL__ >= 800 + res `shouldBe` "9 5 11 40 \"Num t => Int -> t -> t -> t\"\n7 1 11 40 \"Int -> Integer\"\n" +#else + res `shouldBe` "9 5 11 40 \"Num a => Int -> a -> a -> a\"\n7 1 11 40 \"Int -> Integer\"\n" +#endif 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/MonadSpec.hs b/test/MonadSpec.hs index 5562e70..1110e76 100644 --- a/test/MonadSpec.hs +++ b/test/MonadSpec.hs @@ -23,16 +23,18 @@ spec = do mv_ex :: MVar (Either SomeException ()) <- newEmptyMVar - mv_startup_barrier :: MVar () <- newEmptyMVar + mv_startup_barrier :: MVar () + <- newEmptyMVar _t1 <- forkOS $ do - putMVar mv_startup_barrier () -- wait (inside GhcModT) for t2 to receive the exception - _ <- runD $ liftIO $ readMVar mv_ex + _ <- runD $ liftIO $ do + putMVar mv_startup_barrier () + readMVar mv_ex return () _t2 <- forkOS $ do - readMVar mv_startup_barrier -- wait for t1 to start up + readMVar mv_startup_barrier -- wait for t1 to be in GhcModT res <- try $ runD $ return () res' <- evaluate res putMVar mv_ex res' 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 diff --git a/test/data/case-split/Vect706.hs b/test/data/case-split/Vect706.hs new file mode 100644 index 0000000..756be88 --- /dev/null +++ b/test/data/case-split/Vect706.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DataKinds, TypeFamilies, TypeOperators, GADTs, KindSignatures #-} + +module Vect706 where + +data Nat = Z | S Nat + +type family (n :: Nat) :+ (m :: Nat) :: Nat +type instance Z :+ m = m +type instance S n :+ m = S (n :+ m) + +data Vect :: Nat -> * -> * where + VNil :: Vect Z a + (:::) :: a -> Vect n a -> Vect (S n) a + +vAppend :: Vect n a -> Vect m a -> Vect (n :+ m) a +vAppend x y = undefined + +lAppend :: [a] -> [a] -> [a] +lAppend x y = undefined + +data MyList a = Nil | Cons a (MyList a) + +mlAppend :: MyList a -> MyList a -> MyList a +mlAppend x y = undefined + +mlAppend2 :: MyList a -> MyList a -> MyList a +mlAppend2 x y = case x of + x' -> undefined + +mlReverse :: MyList a -> MyList a +mlReverse xs = mlReverse' xs Nil + where + mlReverse' :: MyList a -> MyList a -> MyList a + mlReverse' xs' accum = undefined + +mlReverse2 :: MyList a -> MyList a +mlReverse2 xs = let mlReverse' :: MyList a -> MyList a -> MyList a + mlReverse' xs' accum = undefined + in mlReverse' xs Nil diff --git a/test/data/pattern-synonyms/A.hs b/test/data/pattern-synonyms/A.hs index 75affb6..65ef800 100644 --- a/test/data/pattern-synonyms/A.hs +++ b/test/data/pattern-synonyms/A.hs @@ -1,4 +1,5 @@ {-# LANGUAGE PatternSynonyms #-} + module A where data SomeType a b = SomeType (a,b) diff --git a/test/data/pattern-synonyms/pattern-synonyms.cabal b/test/data/pattern-synonyms/pattern-synonyms.cabal index ab75969..a4afea2 100644 --- a/test/data/pattern-synonyms/pattern-synonyms.cabal +++ b/test/data/pattern-synonyms/pattern-synonyms.cabal @@ -22,4 +22,6 @@ library build-depends: base -- hs-source-dirs: default-language: Haskell2010 - ghc-options: -Wall \ No newline at end of file + ghc-options: -Wall + if impl(ghc >= 8.0.1) + ghc-options: -Wno-missing-pattern-synonym-signatures \ No newline at end of file diff --git a/test/data/stack-project/new-template.cabal b/test/data/stack-project/new-template.cabal index c71f211..feba619 100644 --- a/test/data/stack-project/new-template.cabal +++ b/test/data/stack-project/new-template.cabal @@ -16,7 +16,7 @@ cabal-version: >=1.10 library hs-source-dirs: src exposed-modules: Lib - build-depends: base >= 4.7 && < 5 + build-depends: base default-language: Haskell2010 executable new-template-exe