diff --git a/.travis.yml b/.travis.yml index c110a3c..9d870b0 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,6 +1,5 @@ language: haskell ghc: - - 7.4 - 7.6 - 7.8 diff --git a/Language/Haskell/GhcMod/DynFlags.hs b/Language/Haskell/GhcMod/DynFlags.hs index 4d54ae2..09975db 100644 --- a/Language/Haskell/GhcMod/DynFlags.hs +++ b/Language/Haskell/GhcMod/DynFlags.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, TemplateHaskell #-} module Language.Haskell.GhcMod.DynFlags where @@ -10,6 +10,7 @@ import GHC.Paths (libdir) import qualified Language.Haskell.GhcMod.Gap as Gap import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.DebugLogger +import Language.Haskell.GhcMod.DynFlagsTH import System.IO.Unsafe (unsafePerformIO) import Prelude @@ -102,7 +103,14 @@ setNoMaxRelevantBindings df = df { maxRelevantBinds = Nothing } setNoMaxRelevantBindings = id #endif -deferErrors :: DynFlags -> Ghc DynFlags +deferErrors :: Monad m => DynFlags -> m DynFlags deferErrors df = return $ Gap.setWarnTypedHoles $ Gap.setDeferTypedHoles $ Gap.setDeferTypeErrors $ setNoWarningFlags df + +---------------------------------------------------------------- + +deriveEqDynFlags [d| + eqDynFlags :: DynFlags -> DynFlags -> Bool + eqDynFlags = undefined + |] diff --git a/Language/Haskell/GhcMod/DynFlagsTH.hs b/Language/Haskell/GhcMod/DynFlagsTH.hs new file mode 100644 index 0000000..084396b --- /dev/null +++ b/Language/Haskell/GhcMod/DynFlagsTH.hs @@ -0,0 +1,121 @@ +-- ghc-mod: Making Haskell development *more* fun +-- Copyright (C) 2015 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +{-# LANGUAGE CPP, TemplateHaskell #-} +module Language.Haskell.GhcMod.DynFlagsTH where + +import Language.Haskell.TH.Syntax +import Control.Applicative +import Data.Maybe +import Data.Generics.Aliases +import Data.Generics.Schemes +import DynFlags +import Prelude + +deriveEqDynFlags :: Q [Dec] -> Q [Dec] +deriveEqDynFlags qds = do + ~(TyConI (DataD [] _ [] [ctor] _ )) <- reify ''DynFlags + let ~(RecC _ fs) = ctor + + a <- newName "a" + b <- newName "b" + + e <- AppE (VarE 'and) . ListE <$> sequence (catMaybes $ map (eq a b) fs) + + tysig@(SigD n _) :_ <- qds + + return $ [tysig, FunD n [Clause [VarP a, VarP b] (NormalB e) []]] + + where + eq :: Name -> Name -> (Name, Strict, Type) -> Maybe (Q Exp) + eq a b (fn@(Name (OccName fon) _), _, ft) + | not (isUneqable || isIgnored) = Just expr + | otherwise = Nothing + where + isUneqable = everything (||) (mkQ False hasUnEqable) ft + + hasUnEqable ArrowT = True + hasUnEqable (ConT (Name (OccName on) _)) + | any (==on) ignoredTypeNames = True + | any (==on) ignoredTypeOccNames = True + hasUnEqable _ = False + + isIgnored = fon `elem` ignoredNames + + ignoredNames = [ "pkgDatabase" -- 7.8 +#if __GLASGOW_HASKELL__ <= 706 + , "ways" -- 'Ways' is not exported :/ +#endif + ] + ignoredTypeNames = + [ "LogAction" + , "PackageState" + , "Hooks" + , "FlushOut" + , "FlushErr" + , "Settings" -- I think these can't cange at runtime + ] + ignoredTypeOccNames = [ "OnOff" ] + + fa = AppE (VarE fn) (VarE a) + fb = AppE (VarE fn) (VarE b) + expr = + case fon of + "rtsOptsEnabled" -> do + eqfn <- [| let eqfn RtsOptsNone RtsOptsNone = True + eqfn RtsOptsSafeOnly RtsOptsSafeOnly = True + eqfn RtsOptsAll RtsOptsAll = True + eqfn _ _ = False + in eqfn + |] + return $ AppE (AppE eqfn fa) fb + +#if __GLASGOW_HASKELL__ >= 710 + "sigOf" -> do + eqfn <- [| let eqfn NotSigOf NotSigOf = True + eqfn (SigOf a') (SigOf b') = a' == b' + eqfn (SigOfMap a') (SigOfMap b') = a' == b' + eqfn _ _ = False + in eqfn + |] + return $ AppE (AppE eqfn fa) fb +#endif + +#if __GLASGOW_HASKELL <= 706 + "profAuto" -> do + eqfn <- [| let eqfn NoProfAuto NoProfAuto = True + eqfn ProfAutoAll ProfAutoAll = True + eqfn ProfAutoTop ProfAutoTop = True + eqfn ProfAutoExports ProfAutoExports = True + eqfn ProfAutoCalls ProfAutoCalls = True + eqfn _ _ = False + in eqfn + |] + return $ AppE (AppE eqfn fa) fb +#endif + +#if __GLASGOW_HASKELL__ >= 706 + "language" -> do + eqfn <- [| let eqfn (Just Haskell98) (Just Haskell98) = True + eqfn (Just Haskell2010) (Just Haskell2010) = True + eqfn _ _ = False + in eqfn + |] + return $ AppE (AppE eqfn fa) fb +#endif + + _ -> + return $ InfixE (Just fa) (VarE '(==)) (Just fb) diff --git a/Language/Haskell/GhcMod/LightGhc.hs b/Language/Haskell/GhcMod/LightGhc.hs index 18aac05..6c53716 100644 --- a/Language/Haskell/GhcMod/LightGhc.hs +++ b/Language/Haskell/GhcMod/LightGhc.hs @@ -42,3 +42,7 @@ runLightGhc :: HscEnv -> LightGhc a -> IO a runLightGhc env action = do renv <- newIORef env flip runReaderT renv $ unLightGhc action + +runLightGhc' :: IORef HscEnv -> LightGhc a -> IO a +runLightGhc' renv action = do + flip runReaderT renv $ unLightGhc action diff --git a/Language/Haskell/GhcMod/Logger.hs b/Language/Haskell/GhcMod/Logger.hs index 10ebd5b..36d1995 100644 --- a/Language/Haskell/GhcMod/Logger.hs +++ b/Language/Haskell/GhcMod/Logger.hs @@ -169,6 +169,6 @@ checkErrorPrefix :: String checkErrorPrefix = "Dummy:0:0:Error:" warningAsErrorPrefixes :: [String] -warningAsErrorPrefixes = ["Couldn't match expected type" +warningAsErrorPrefixes = [ "Couldn't match expected type" , "Couldn't match type" , "No instance for"] diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 7985d1a..2e2d1ae 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -66,29 +66,41 @@ runGmPkgGhc action = do withLightHscEnv pkgOpts $ \env -> liftIO $ runLightGhc env action initSession :: IOish m - => [GHCOption] -> (DynFlags -> Ghc DynFlags) -> GhcModT m () + => [GHCOption] -> (forall gm. GhcMonad gm => DynFlags -> gm DynFlags) -> GhcModT m () initSession opts mdf = do s <- gmsGet case gmGhcSession s of - Just GmGhcSession {..} | gmgsOptions /= opts-> do - gmLog GmDebug "initSession" $ text "Flags changed, creating new session" - putNewSession s - Just _ -> return () Nothing -> do gmLog GmDebug "initSession" $ text "Session not initialized, creating new one" putNewSession s + Just GmGhcSession {..} -> do + gmLog GmDebug "initSession" $ text "Flags changed, creating new session" + crdl <- cradle + changed <- liftIO $ runLightGhc' gmgsSession $ do + df <- getSessionDynFlags + ndf <- initDF crdl + return $ ndf `eqDynFlags` df + if changed + then putNewSession s + else return () where - putNewSession s = do - rghc <- (liftIO . newIORef =<< newSession =<< cradle) - gmsPut s { gmGhcSession = Just $ GmGhcSession opts rghc } - - newSession Cradle { cradleTempDir } = liftIO $ do - runGhc (Just libdir) $ do + initDF Cradle { cradleTempDir } = do let setDf df = setTmpDir cradleTempDir <$> (mdf =<< addCmdOpts opts df) _ <- setSessionDynFlags =<< setDf =<< getSessionDynFlags + getSessionDynFlags + + putNewSession s = do + rghc <- (liftIO . newIORef =<< newSession) + gmsPut s { gmGhcSession = Just $ GmGhcSession opts rghc } + + newSession = do + crdl <- cradle + liftIO $ runGhc (Just libdir) $ do + _ <- initDF crdl getSession + -- | Drop the currently active GHC session, the next that requires a GHC session -- will initialize a new one. dropSession :: IOish m => GhcModT m () @@ -114,7 +126,7 @@ runGmlT fns action = runGmlT' fns return action -- of certain files or modules, with updated GHC flags runGmlT' :: IOish m => [Either FilePath ModuleName] - -> (DynFlags -> Ghc DynFlags) + -> (forall gm. GhcMonad gm => DynFlags -> gm DynFlags) -> GmlT m a -> GhcModT m a runGmlT' fns mdf action = runGmlTWith fns mdf id action @@ -124,7 +136,7 @@ runGmlT' fns mdf action = runGmlTWith fns mdf id action -- transformation runGmlTWith :: IOish m => [Either FilePath ModuleName] - -> (DynFlags -> Ghc DynFlags) + -> (forall gm. GhcMonad gm => DynFlags -> gm DynFlags) -> (GmlT m a -> GmlT m b) -> GmlT m a -> GhcModT m b diff --git a/NotCPP/Declarations.hs b/NotCPP/Declarations.hs index 1657a68..b57feae 100644 --- a/NotCPP/Declarations.hs +++ b/NotCPP/Declarations.hs @@ -104,18 +104,33 @@ boundNames decl = TySynD n _ _ -> [(TcClsName, n)] ClassD _ n _ _ _ -> [(TcClsName, n)] - FamilyD _ n _ _ -> [(TcClsName, n)] +#if __GLASGOW_HASKELL__ >= 800 + DataD _ n _ _ ctors _ -> +#else DataD _ n _ ctors _ -> +#endif [(TcClsName, n)] ++ map ((,) TcClsName) (conNames `concatMap` ctors) +#if __GLASGOW_HASKELL__ >= 800 + NewtypeD _ n _ _ ctor _ -> +#else NewtypeD _ n _ ctor _ -> +#endif [(TcClsName, n)] ++ map ((,) TcClsName) (conNames ctor) +#if __GLASGOW_HASKELL__ >= 800 + DataInstD _ _n _ _ ctors _ -> +#else DataInstD _ _n _ ctors _ -> +#endif map ((,) TcClsName) (conNames `concatMap` ctors) +#if __GLASGOW_HASKELL__ >= 800 + NewtypeInstD _ _n _ _ ctor _ -> +#else NewtypeInstD _ _n _ ctor _ -> +#endif map ((,) TcClsName) (conNames ctor) InstanceD _ _ty _ -> @@ -131,10 +146,19 @@ boundNames decl = #endif #if __GLASGOW_HASKELL__ >= 708 - ClosedTypeFamilyD n _ _ _ -> [(TcClsName, n)] RoleAnnotD _n _ -> error "notcpp: RoleAnnotD not supported yet" #endif +#if __GLASGOW_HASKELL__ >= 704 && __GLASGOW_HASKELL__ < 800 + FamilyD _ n _ _ -> [(TcClsName, n)] +#elif __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 800 + ClosedTypeFamilyD n _ _ _ -> [(TcClsName, n)] +#else + OpenTypeFamilyD (TypeFamilyHead n _ _ _) -> [(TcClsName, n)] + ClosedTypeFamilyD (TypeFamilyHead n _ _ _) _ -> [(TcClsName, n)] + +#endif + conNames :: Con -> [Name] conNames con = case con of diff --git a/NotCPP/LookupValueName.hs b/NotCPP/LookupValueName.hs index 72462c2..9132e99 100644 --- a/NotCPP/LookupValueName.hs +++ b/NotCPP/LookupValueName.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP, 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 @@ -25,8 +25,13 @@ bestValueGuess s = do case mi of Nothing -> no Just i -> case i of +#if __GLASGOW_HASKELL__ >= 800 + VarI n _ _ -> yes n + DataConI n _ _ -> yes n +#else VarI n _ _ _ -> yes n DataConI n _ _ _ -> yes n +#endif _ -> err ["unexpected info:", show i] where no = return Nothing @@ -34,5 +39,9 @@ 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 return []) diff --git a/NotCPP/Utils.hs b/NotCPP/Utils.hs index 9da7958..8557c4a 100644 --- a/NotCPP/Utils.hs +++ b/NotCPP/Utils.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP, TemplateHaskell #-} module NotCPP.Utils where import Control.Applicative ((<$>)) @@ -24,6 +24,19 @@ 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 -infoToExp (VarI n _ _ _) = Just (VarE n) -infoToExp (DataConI n _ _ _) = Just (ConE n) + +#if __GLASGOW_HASKELL__ >= 800 +infoToExp (VarI n _ _) = +#else +infoToExp (VarI 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/ghc-mod.cabal b/ghc-mod.cabal index deb1a38..c7b1f9f 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -117,6 +117,7 @@ Library Language.Haskell.GhcMod.DebugLogger Language.Haskell.GhcMod.Doc Language.Haskell.GhcMod.DynFlags + Language.Haskell.GhcMod.DynFlagsTH Language.Haskell.GhcMod.Error Language.Haskell.GhcMod.FileMapping Language.Haskell.GhcMod.FillSig @@ -162,24 +163,24 @@ Library System.Directory.ModTime Build-Depends: base < 5 && >= 4.0 , bytestring < 0.11 - , binary < 0.8 && >= 0.5.1.0 + , binary < 0.9 && >= 0.5.1.0 , containers < 0.6 , cabal-helper < 0.7 && >= 0.6.3.0 , deepseq < 1.5 , directory < 1.3 , filepath < 1.5 - , ghc < 7.11 + , ghc < 8.2 && >= 7.6 , ghc-paths < 0.2 , ghc-syb-utils < 0.3 , hlint < 1.10 && >= 1.9.26 , monad-journal < 0.8 && >= 0.4 , old-time < 1.2 , pretty < 1.2 - , process < 1.3 + , process < 1.5 , syb < 0.7 , temporary < 1.3 - , time < 1.6 - , transformers < 0.5 + , time < 1.7 + , transformers < 0.6 , transformers-base < 0.5 , mtl < 2.3 && >= 2.0 , monad-control < 1.1 && >= 1 @@ -192,12 +193,10 @@ Library , pipes == 4.1.* , safe < 0.4 && >= 0.3.9 , optparse-applicative >=0.11.0 && <0.13.0 + , template-haskell + , syb if impl(ghc < 7.8) Build-Depends: convertible - if impl(ghc < 7.5) - -- Only used to constrain random to a version that still works with GHC 7.4 - Build-Depends: random <= 1.0.1.1, - ghc-prim Executable ghc-mod Default-Language: Haskell2010 @@ -214,10 +213,10 @@ Executable ghc-mod , directory < 1.3 , filepath < 1.5 , pretty < 1.2 - , process < 1.3 + , process < 1.5 , split < 0.3 , mtl < 2.3 && >= 2.0 - , ghc < 7.11 + , ghc < 8.1 , monad-control ==1.0.* , fclabels ==2.0.* , optparse-applicative >=0.11.0 && <0.13.0 @@ -234,13 +233,13 @@ Executable ghc-modi Default-Extensions: ConstraintKinds, FlexibleContexts HS-Source-Dirs: src, . Build-Depends: base < 5 && >= 4.0 - , binary < 0.8 && >= 0.5.1.0 + , binary < 0.9 && >= 0.5.1.0 , deepseq < 1.5 , directory < 1.3 , filepath < 1.5 - , process < 1.3 + , process < 1.5 , old-time < 1.2 - , time < 1.6 + , time < 1.7 , ghc-mod Test-Suite doctest @@ -250,8 +249,6 @@ Test-Suite doctest Ghc-Options: -Wall Default-Extensions: ConstraintKinds, FlexibleContexts Main-Is: doctests.hs - if impl(ghc == 7.4.*) - Buildable: False Build-Depends: base , doctest >= 0.9.3 @@ -284,12 +281,8 @@ Test-Suite spec ShellParseSpec Build-Depends: hspec >= 2.0.0 - if impl(ghc == 7.4.*) - Build-Depends: executable-path X-Build-Depends-Like: CLibName - - Source-Repository head Type: git Location: https://github.com/kazu-yamamoto/ghc-mod.git