Housekeeping for GHC 8
- Remove some CPP needed only because of GHC 7.4 (which is not supported now, yey) - Move CPP for GHC 8 to Gap module
This commit is contained in:
Daniel Gröber
parent
3bf84fb64a
commit
31e3c0b500
|
|
@ -33,7 +33,7 @@ check files =
|
|||
runGmlTWith
|
||||
(map Left files)
|
||||
return
|
||||
((fmap fst <$>) . withLogger setNoMaxRelevantBindings)
|
||||
((fmap fst <$>) . withLogger Gap.setNoMaxRelevantBindings)
|
||||
(return ())
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@
|
|||
--
|
||||
-- You should have received a copy of the GNU Affero General Public License
|
||||
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE CPP, RankNTypes #-}
|
||||
module Language.Haskell.GhcMod.DebugLogger where
|
||||
|
||||
-- (c) The University of Glasgow 2005
|
||||
|
|
@ -62,11 +62,7 @@ import Language.Haskell.GhcMod.Gap
|
|||
import Prelude
|
||||
|
||||
debugLogAction :: (String -> IO ()) -> GmLogAction
|
||||
#if __GLASGOW_HASKELL__ >= 800
|
||||
debugLogAction putErr dflags _reason severity srcSpan style' msg
|
||||
#else
|
||||
debugLogAction putErr dflags severity srcSpan style' msg
|
||||
#endif
|
||||
debugLogAction putErr _reason dflags severity srcSpan style' msg
|
||||
= case severity of
|
||||
SevOutput -> printSDoc putErr msg style'
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
{-# LANGUAGE CPP, TemplateHaskell #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Language.Haskell.GhcMod.DynFlags where
|
||||
|
||||
|
|
@ -16,11 +16,7 @@ import Prelude
|
|||
|
||||
setEmptyLogger :: DynFlags -> DynFlags
|
||||
setEmptyLogger df =
|
||||
#if __GLASGOW_HASKELL__ >= 800
|
||||
Gap.setLogAction df $ \_ _ _ _ _ _ -> return ()
|
||||
#else
|
||||
Gap.setLogAction df $ \_ _ _ _ _ -> return ()
|
||||
#endif
|
||||
|
||||
setDebugLogger :: (String -> IO ()) -> DynFlags -> DynFlags
|
||||
setDebugLogger put df = do
|
||||
|
|
@ -99,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 $
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -83,11 +85,7 @@ import CoAxiom (coAxiomTyCon)
|
|||
#if __GLASGOW_HASKELL__ >= 708
|
||||
import FamInstEnv
|
||||
import ConLike (ConLike(..))
|
||||
#if __GLASGOW_HASKELL__ >= 800
|
||||
import PatSyn (PatSyn)
|
||||
#else
|
||||
import PatSyn (patSynType)
|
||||
#endif
|
||||
import PatSyn
|
||||
#else
|
||||
import TcRnTypes
|
||||
#endif
|
||||
|
|
@ -152,18 +150,25 @@ 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
|
||||
|
|
@ -212,23 +217,26 @@ toStringBuffer = liftIO . stringToStringBuffer . unlines
|
|||
|
||||
----------------------------------------------------------------
|
||||
|
||||
fOptions :: [String]
|
||||
ghcCmdOptions :: [String]
|
||||
#if __GLASGOW_HASKELL__ >= 710
|
||||
fOptions = [option | (FlagSpec option _ _ _) <- fFlags]
|
||||
#if __GLASGOW_HASKELL__ >= 800
|
||||
++ [option | (FlagSpec option _ _ _) <- wWarningFlags]
|
||||
-- this also includes -X options and all sorts of other things so the
|
||||
ghcCmdOptions = flagsForCompletion False
|
||||
#else
|
||||
++ [option | (FlagSpec option _ _ _) <- fWarningFlags]
|
||||
#endif
|
||||
++ [option | (FlagSpec option _ _ _) <- fLangFlags]
|
||||
#elif __GLASGOW_HASKELL__ >= 704
|
||||
fOptions = [option | (option,_,_) <- fFlags]
|
||||
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
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
|
@ -330,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
|
||||
|
||||
----------------------------------------------------------------
|
||||
----------------------------------------------------------------
|
||||
|
||||
|
|
@ -434,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
|
||||
|
|
@ -463,9 +488,11 @@ 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
|
||||
| GtPatSyn PatSyn
|
||||
#endif
|
||||
|
||||
fromTyThing :: TyThing -> GapThing
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE CPP, RankNTypes #-}
|
||||
|
||||
module Language.Haskell.GhcMod.Logger (
|
||||
withLogger
|
||||
|
|
@ -14,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
|
||||
|
|
@ -25,9 +25,8 @@ import HscTypes
|
|||
import Outputable
|
||||
import qualified GHC as G
|
||||
import Bag
|
||||
#if __GLASGOW_HASKELL__ >= 800
|
||||
import DynFlags (WarnReason)
|
||||
#endif
|
||||
import SrcLoc
|
||||
import FastString
|
||||
|
||||
import Language.Haskell.GhcMod.Convert
|
||||
import Language.Haskell.GhcMod.Doc (showPage)
|
||||
|
|
@ -62,20 +61,13 @@ readAndClearLogRef (LogRef ref) = do
|
|||
writeIORef ref emptyLog
|
||||
return $ b []
|
||||
|
||||
#if __GLASGOW_HASKELL__ >= 800
|
||||
appendLogRef :: (FilePath -> FilePath) -> DynFlags -> LogRef -> DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
|
||||
appendLogRef rfm df (LogRef ref) _ _reason sev src st msg = do
|
||||
#else
|
||||
appendLogRef :: (FilePath -> FilePath) -> DynFlags -> LogRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
|
||||
appendLogRef rfm df (LogRef ref) _ sev src st msg = do
|
||||
#endif
|
||||
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
|
||||
|
|
@ -142,44 +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
|
||||
#if __GLASGOW_HASKELL__ >= 800
|
||||
return $ showPage dflags st msg
|
||||
where
|
||||
msg = pprLocErrMsg err
|
||||
#else
|
||||
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
|
||||
#endif
|
||||
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:"
|
||||
|
|
|
|||
|
|
@ -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"]
|
||||
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -136,7 +136,7 @@ spec = do
|
|||
loadMappedFile "File.hs" "File_Redir_Lint.hs"
|
||||
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
|
||||
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"
|
||||
|
|
|
|||
|
|
@ -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"]
|
||||
|
|
|
|||
|
|
@ -20,12 +20,21 @@ spec = do
|
|||
it "shows types of the expression and its outers" $ do
|
||||
let tdir = "test/data/ghc-mod-check"
|
||||
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"
|
||||
|
|
|
|||
|
|
@ -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'
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
{-# LANGUAGE PatternSynonyms #-}
|
||||
|
||||
module A where
|
||||
|
||||
data SomeType a b = SomeType (a,b)
|
||||
|
|
|
|||
|
|
@ -22,4 +22,6 @@ library
|
|||
build-depends: base
|
||||
-- hs-source-dirs:
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall
|
||||
ghc-options: -Wall
|
||||
if impl(ghc >= 8.0.1)
|
||||
ghc-options: -Wno-missing-pattern-synonym-signatures
|
||||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue