hasufell
/
ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

This commit is contained in:
Alan Zimmerman 2016-02-15 15:56:55 +02:00
parent b02dfb9ce3 20c999e098
commit c9e5a20a3e
10 changed files with 226 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.travis.yml
View File

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

12
Language/Haskell/GhcMod/DynFlags.hs
View File

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

121
Language/Haskell/GhcMod/DynFlagsTH.hs Normal file
View File

@ -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)

4
Language/Haskell/GhcMod/LightGhc.hs
View File

@ -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

2
Language/Haskell/GhcMod/Logger.hs
View File

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

38
Language/Haskell/GhcMod/Target.hs
View File

@ -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

28
NotCPP/Declarations.hs
View File

@ -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

11
NotCPP/LookupValueName.hs
View File

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

19
NotCPP/Utils.hs
View File

@ -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

33
ghc-mod.cabal
View File

@ -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