Merge remote-tracking branch 'dxld/master' into opts-in-lib

.travis.yml

@@ -1,6 +1,5 @@
 language: haskell
 ghc:
-  - 7.4
   - 7.6
   - 7.8
 

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
+ |]

Language/Haskell/GhcMod/DynFlagsTH.hs

@@ -0,0 +1,121 @@
+-- ghc-mod: Making Haskell development *more* fun
+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>
+--
+-- 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 <http://www.gnu.org/licenses/>.
+
+{-# 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)

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

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"]

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
+   initDF Cradle { cradleTempDir } = do
-     rghc <- (liftIO . newIORef =<< newSession =<< cradle)
-     gmsPut s { gmGhcSession = Just $ GmGhcSession opts rghc }
-
-   newSession Cradle { cradleTempDir } = liftIO $ do
-     runGhc (Just libdir) $ 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

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

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 [])

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

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
+                      , time              < 1.7
-                      , transformers      < 0.5
+                      , 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