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

Merge branch 'release-5.6.0.0' into release

Browse Source
This commit is contained in:
Daniel Gröber 2016-07-10 23:42:13 +02:00
commit 0893cb1466
62 changed files with 1254 additions and 485 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

3
Data/Binary/Generic.hs
View File

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

3
Language/Haskell/GhcMod/Boot.hs
View File

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

22
Language/Haskell/GhcMod/Browse.hs
View File

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

34
Language/Haskell/GhcMod/CaseSplit.hs
View File

@ -27,7 +27,9 @@ import Language.Haskell.GhcMod.SrcUtils
import Language.Haskell.GhcMod.Doc
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
@ -54,17 +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
t <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $
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 <- 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" $
@ -107,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
@ -167,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
@ -204,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

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

@ -33,7 +33,7 @@ check files =
runGmlTWith
(map Left files)
return
((fmap fst <$>) . withLogger setNoMaxRelevantBindings)
((fmap fst <$>) . withLogger Gap.setNoMaxRelevantBindings)
(return ())
----------------------------------------------------------------

66
Language/Haskell/GhcMod/Cradle.hs
View File

@ -34,24 +34,29 @@ import Control.Monad.Trans.Journal (runJournalT)
-- Find a cabal file by tracing ancestor directories.
-- Find a sandbox according to a cabal sandbox config
-- in a cabal directory.
findCradle :: (GmLog m, IOish m, GmOut m) => m Cradle
findCradle = findCradle' =<< liftIO getCurrentDirectory
findCradle :: (GmLog m, IOish m, GmOut m) => Programs -> m Cradle
findCradle progs = findCradle' progs =<< liftIO getCurrentDirectory
findCradleNoLog :: forall m. (IOish m, GmOut m) => m Cradle
findCradleNoLog = fst <$> (runJournalT findCradle :: m (Cradle, GhcModLog))
findCradleNoLog :: forall m. (IOish m, GmOut m) => Programs -> m Cradle
findCradleNoLog progs =
fst <$> (runJournalT (findCradle progs) :: m (Cradle, GhcModLog))
findCradle' :: (GmLog m, IOish m, GmOut m) => FilePath -> m Cradle
findCradle' dir = run $
msum [ stackCradle dir
, cabalCradle dir
findCradle' :: (GmLog m, IOish m, GmOut m) => Programs -> FilePath -> m Cradle
findCradle' Programs { stackProgram, cabalProgram } dir = run $
msum [ stackCradle stackProgram dir
, cabalCradle cabalProgram dir
, sandboxCradle dir
, plainCradle dir
]
where run a = fillTempDir =<< (fromJustNote "findCradle'" <$> runMaybeT a)
findSpecCradle :: (GmLog m, IOish m, GmOut m) => FilePath -> m Cradle
findSpecCradle dir = do
let cfs = [stackCradleSpec, cabalCradle, sandboxCradle]
findSpecCradle ::
(GmLog m, IOish m, GmOut m) => Programs -> FilePath -> m Cradle
findSpecCradle Programs { stackProgram, cabalProgram } dir = do
let cfs = [ stackCradleSpec stackProgram
, cabalCradle cabalProgram
, sandboxCradle
]
cs <- catMaybes <$> mapM (runMaybeT . ($ dir)) cfs
gcs <- filterM isNotGmCradle cs
fillTempDir =<< case gcs of
@ -69,12 +74,18 @@ fillTempDir crdl = do
tmpDir <- liftIO $ newTempDir (cradleRootDir crdl)
return crdl { cradleTempDir = tmpDir }
cabalCradle :: IOish m => FilePath -> MaybeT m Cradle
cabalCradle wdir = do
cabalFile <- MaybeT $ liftIO $ findCabalFile wdir
cabalCradle ::
(IOish m, GmLog m, GmOut m) => FilePath -> FilePath -> MaybeT m Cradle
cabalCradle cabalProg wdir = do
-- If cabal doesn't exist the user probably wants to use something else
whenM ((==Nothing) <$> liftIO (findExecutable cabalProg)) $ do
gmLog GmInfo "" $ text "'dist/setup-config' exists but 'cabal' executable wasn't found"
mzero
cabalFile <- MaybeT $ liftIO $ findCabalFile wdir
let cabalDir = takeDirectory cabalFile
gmLog GmInfo "" $ text "found Cabal project at" <+>: text cabalDir
return Cradle {
cradleProject = CabalProject
, cradleCurrentDir = wdir
@ -84,12 +95,19 @@ cabalCradle wdir = do
, cradleDistDir = "dist"
}
stackCradle :: (GmLog m, IOish m, GmOut m) => FilePath -> MaybeT m Cradle
stackCradle wdir = do
stackCradle ::
(IOish m, GmLog m, GmOut m) => FilePath -> FilePath -> MaybeT m Cradle
stackCradle stackProg wdir = do
#if !MIN_VERSION_ghc(7,8,0)
-- GHC < 7.8 is not supported by stack
mzero
#endif
-- If cabal doesn't exist the user probably wants to use something else
whenM ((==Nothing) <$> liftIO (findExecutable stackProg)) $ do
gmLog GmInfo "" $ text "'dist/setup-config' exists but 'cabal' executable wasn't found"
mzero
cabalFile <- MaybeT $ liftIO $ findCabalFile wdir
let cabalDir = takeDirectory cabalFile
@ -99,11 +117,12 @@ stackCradle wdir = do
-- If dist/setup-config already exists the user probably wants to use cabal
-- rather than stack, or maybe that's just me ;)
whenM (liftIO $ doesFileExist $ cabalDir </> setupConfigPath "dist") $ do
gmLog GmWarning "" $ text "'dist/setup-config' exists, ignoring Stack and using cabal-install instead."
gmLog GmWarning "" $ text "'dist/setup-config' exists, ignoring Stack and using cabal-install instead"
mzero
senv <- MaybeT $ getStackEnv cabalDir
gmLog GmInfo "" $ text "found Stack project at" <+>: text cabalDir
return Cradle {
cradleProject = StackProject senv
, cradleCurrentDir = wdir
@ -113,9 +132,10 @@ stackCradle wdir = do
, cradleDistDir = seDistDir senv
}
stackCradleSpec :: (GmLog m, IOish m, GmOut m) => FilePath -> MaybeT m Cradle
stackCradleSpec wdir = do
crdl <- stackCradle wdir
stackCradleSpec ::
(IOish m, GmLog m, GmOut m) => FilePath -> FilePath -> MaybeT m Cradle
stackCradleSpec stackProg wdir = do
crdl <- stackCradle stackProg wdir
case crdl of
Cradle { cradleProject = StackProject StackEnv { seDistDir } } -> do
b <- isGmDistDir seDistDir
@ -126,9 +146,10 @@ stackCradleSpec wdir = do
isGmDistDir dir =
liftIO $ not <$> doesFileExist (dir </> ".." </> "ghc-mod.cabal")
sandboxCradle :: IOish m => FilePath -> MaybeT m Cradle
sandboxCradle :: (IOish m, GmLog m, GmOut m) => FilePath -> MaybeT m Cradle
sandboxCradle wdir = do
sbDir <- MaybeT $ liftIO $ findCabalSandboxDir wdir
gmLog GmInfo "" $ text "Found sandbox project at" <+>: text sbDir
return Cradle {
cradleProject = SandboxProject
, cradleCurrentDir = wdir
@ -138,8 +159,9 @@ sandboxCradle wdir = do
, cradleDistDir = "dist"
}
plainCradle :: IOish m => FilePath -> MaybeT m Cradle
plainCradle :: (IOish m, GmLog m, GmOut m) => FilePath -> MaybeT m Cradle
plainCradle wdir = do
gmLog GmInfo "" $ text "Found no other project type, falling back to plain GHC project"
return $ Cradle {
cradleProject = PlainProject
, cradleCurrentDir = wdir

45
Language/Haskell/GhcMod/Debug.hs
View File

@ -3,11 +3,12 @@ module Language.Haskell.GhcMod.Debug (debugInfo, rootInfo, componentInfo) where
import Control.Arrow (first)
import Control.Applicative
import Control.Monad
import Control.Monad.Trans.Journal
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Char
import Data.Version
import Data.List.Split
import System.Directory
import Text.PrettyPrint
import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.Types
@ -17,6 +18,11 @@ import Language.Haskell.GhcMod.Pretty
import Language.Haskell.GhcMod.Utils
import Language.Haskell.GhcMod.Cradle
import Language.Haskell.GhcMod.Stack
import Language.Haskell.GhcMod.Output
import Paths_ghc_mod (version)
import Config (cProjectVersion)
----------------------------------------------------------------
@ -34,14 +40,20 @@ debugInfo = do
pkgOpts <- packageGhcOptions
readProc <- gmReadProcess
ghcVersion <- liftIO $
dropWhileEnd isSpace <$> readProc "ghc" ["--numeric-version"] ""
return $ unlines $
[ "Root directory: " ++ cradleRootDir
[ "Version: ghc-mod-" ++ showVersion version
, "Library GHC Version: " ++ cProjectVersion
, "System GHC Version: " ++ ghcVersion
, "Root directory: " ++ cradleRootDir
, "Current directory: " ++ cradleCurrentDir
, "GHC Package flags:\n" ++ render (nest 4 $
fsep $ map text pkgOpts)
, "GHC System libraries: " ++ ghcLibDir
, "GHC user options:\n" ++ render (nest 4 $
fsep $ map text optGhcUserOptions)
] ++ cabal
stackPaths :: IOish m => GhcModT m [String]
@ -63,9 +75,24 @@ cabalDebug = do
opts = Map.map gmcGhcOpts mcs
srcOpts = Map.map gmcGhcSrcOpts mcs
readProc <- gmReadProcess
cabalExists <- liftIO $ (/=Nothing) <$> findExecutable "cabal"
cabalInstVersion <-
if cabalExists
then liftIO $
dropWhileEnd isSpace <$> readProc "cabal" ["--numeric-version"] ""
else return ""
packages <- liftIO $ readProc "ghc-pkg" ["list", "--simple-output"] ""
let cabalPackages = filter ((== ["Cabal"]) . take 1 . splitOn "-") $ splitWhen isSpace packages
return $
[ "Cabal file: " ++ show cradleCabalFile
, "Project: " ++ show cradleProject
[ "cabal-install Version: " ++ cabalInstVersion
, "Cabal Library Versions:\n" ++ render (nest 4 $
fsep $ map text cabalPackages)
, "Cabal file: " ++ show cradleCabalFile
, "Project: " ++ show cradleProject
, "Cabal entrypoints:\n" ++ render (nest 4 $
mapDoc gmComponentNameDoc smpDoc entrypoints)
, "Cabal components:\n" ++ render (nest 4 $
@ -139,5 +166,7 @@ mapDoc kd ad m = vcat $
----------------------------------------------------------------
-- | Obtaining root information.
rootInfo :: forall m. (IOish m, GmOut m) => m String
rootInfo = (++"\n") . cradleRootDir <$> fst `liftM` (runJournalT findCradle :: m (Cradle, GhcModLog))
rootInfo :: forall m. (IOish m, GmOut m, GmEnv m) => m String
rootInfo = do
crdl <- findCradleNoLog =<< (optPrograms <$> options)
return $ cradleRootDir crdl ++ "\n"

18
Language/Haskell/GhcMod/DebugLogger.hs
View File

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

5
Language/Haskell/GhcMod/Doc.hs
View File

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

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

@ -1,4 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
module Language.Haskell.GhcMod.DynFlags where
@ -10,12 +10,13 @@ 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
setEmptyLogger :: DynFlags -> DynFlags
setEmptyLogger df =
Gap.setLogAction df $ \_ _ _ _ _ -> return ()
Gap.setLogAction df $ \_ _ _ _ _ _ -> return ()
setDebugLogger :: (String -> IO ()) -> DynFlags -> DynFlags
setDebugLogger put df = do
@ -94,15 +95,14 @@ 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 :: 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
|]

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

@ -0,0 +1,126 @@
-- 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
#if __GLASGOW_HASKELL__ <= 710
~(TyConI (DataD [] _ [] [ctor] _ ))
#else
~(TyConI (DataD [] _ [] _ [ctor] _ ))
#endif
<- 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 && __GLASGOW_HASKELL__ < 800
"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)

17
Language/Haskell/GhcMod/FileMapping.hs
View File

@ -46,8 +46,10 @@ loadMappedFileSource :: IOish m
-> GhcModT m ()
loadMappedFileSource from src = do
tmpdir <- cradleTempDir `fmap` cradle
enc <- liftIO . mkTextEncoding . optEncoding =<< options
to <- liftIO $ do
(fn, h) <- openTempFile tmpdir (takeFileName from)
hSetEncoding h enc
hPutStr h src
hClose h
return fn
@ -61,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,

46
Language/Haskell/GhcMod/FillSig.hs
View File

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

134
Language/Haskell/GhcMod/Find.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE CPP, DeriveGeneric #-}
{-# LANGUAGE CPP, BangPatterns, TupleSections, DeriveGeneric #-}
module Language.Haskell.GhcMod.Find
#ifndef SPEC
@ -18,6 +18,13 @@ module Language.Haskell.GhcMod.Find
#endif
where
import qualified GHC as G
import FastString
import Module
import OccName
import HscTypes
import Exception
import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.Gap
import Language.Haskell.GhcMod.Monad
@ -25,38 +32,56 @@ import Language.Haskell.GhcMod.Output
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Utils
import Language.Haskell.GhcMod.World
import qualified GHC as G
import Name
import Module
import Exception
import Language.Haskell.GhcMod.LightGhc
import Control.Applicative
import Control.DeepSeq
import Control.Monad
import Control.Monad.Trans.Control
import Control.Concurrent
import Control.DeepSeq
import Data.Function
import Data.List
import qualified Data.ByteString.Lazy as BS
import Data.Binary
import Data.Function
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import Data.IORef
import System.Directory.ModTime
import System.IO.Unsafe
import GHC.Generics (Generic)
import Data.Map (Map)
import qualified Data.Map as M
import System.Directory.ModTime
import Data.Set (Set)
import qualified Data.Set as S
import Language.Haskell.GhcMod.PathsAndFiles
import System.Directory
import Prelude
----------------------------------------------------------------
-- | Type of function and operation names.
type Symbol = String
type Symbol = BS.ByteString
type ModuleNameBS = BS.ByteString
-- | Database from 'Symbol' to \['ModuleString'\].
data SymbolDb = SymbolDb
{ sdTable :: Map Symbol [ModuleString]
{ sdTable :: Map Symbol (Set ModuleNameBS)
, 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
@ -67,19 +92,34 @@ isOutdated db =
-- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\]
-- which will be concatenated. 'loadSymbolDb' is called internally.
findSymbol :: IOish m => Symbol -> GhcModT m String
findSymbol sym = loadSymbolDb >>= lookupSymbol sym
findSymbol :: IOish m => String -> GhcModT m String
findSymbol sym = loadSymbolDb' >>= lookupSymbol sym
-- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\]
-- which will be concatenated.
lookupSymbol :: IOish m => Symbol -> SymbolDb -> GhcModT m String
lookupSymbol sym db = convert' $ lookupSym sym db
lookupSymbol :: IOish m => String -> SymbolDb -> GhcModT m String
lookupSymbol sym db = convert' $ lookupSym (fastStringToByteString $ mkFastString sym) db
lookupSym :: Symbol -> SymbolDb -> [ModuleString]
lookupSym sym db = M.findWithDefault [] sym $ sdTable db
lookupSym sym db = map (ModuleString . unpackFS . mkFastStringByteString') $ S.toList $ M.findWithDefault S.empty sym $ sdTable db
---------------------------------------------------------------
loadSymbolDb' :: IOish m => GhcModT m SymbolDb
loadSymbolDb' = do
cache <- symbolCache <$> cradle
let doLoad True = do
db <- decode <$> liftIO (LBS.readFile cache)
outdated <- isOutdated db
if outdated
then doLoad False
else return db
doLoad False = do
db <- loadSymbolDb
liftIO $ LBS.writeFile cache $ encode db
return db
doLoad =<< liftIO (doesFileExist cache)
-- | Loading a file and creates 'SymbolDb'.
loadSymbolDb :: IOish m => GhcModT m SymbolDb
loadSymbolDb = do
@ -95,9 +135,9 @@ loadSymbolDb = do
dumpSymbol :: IOish m => GhcModT m ()
dumpSymbol = do
ts <- liftIO getCurrentModTime
st <- runGmPkgGhc getGlobalSymbolTable
liftIO . BS.putStr $ encode SymbolDb {
sdTable = M.fromAscList st
st <- runGmPkgGhc $ (liftIO . getGlobalSymbolTable) =<< G.getSession
liftIO . LBS.putStr $ encode SymbolDb {
sdTable = st
, sdTimestamp = ts
}
@ -108,28 +148,42 @@ isOlderThan tCache files =
any (tCache <=) $ map tfTime files -- including equal just in case
-- | Browsing all functions in all system modules.
getGlobalSymbolTable :: LightGhc [(Symbol, [ModuleString])]
getGlobalSymbolTable = do
df <- G.getSessionDynFlags
let mods = listVisibleModules df
moduleInfos <- mapM G.getModuleInfo mods
return $ collectModules
$ extractBindings `concatMap` (moduleInfos `zip` mods)
getGlobalSymbolTable :: HscEnv -> IO (Map Symbol (Set ModuleNameBS))
getGlobalSymbolTable hsc_env =
foldM (extend hsc_env) M.empty $ listVisibleModules $ hsc_dflags hsc_env
extractBindings :: (Maybe G.ModuleInfo, G.Module)
-> [(Symbol, ModuleString)]
extractBindings (Nothing, _) = []
extractBindings (Just inf, mdl) =
map (\name -> (getOccString name, modStr)) names
where
names = G.modInfoExports inf
modStr = ModuleString $ moduleNameString $ moduleName mdl
extend :: HscEnv
-> Map Symbol (Set ModuleNameBS)
-> Module
-> IO (Map Symbol (Set ModuleNameBS))
extend hsc_env mm mdl = do
eps <- readIORef $ hsc_EPS hsc_env
modinfo <- unsafeInterleaveIO $ runLightGhc hsc_env $ do
G.getModuleInfo mdl <* liftIO (writeIORef (hsc_EPS hsc_env) eps)
collectModules :: [(Symbol, ModuleString)]
-> [(Symbol, [ModuleString])]
collectModules = map tieup . groupBy ((==) `on` fst) . sort
where
tieup x = (head (map fst x), map snd x)
return $ M.unionWith S.union mm $ extractBindings modinfo mdl
extractBindings :: Maybe G.ModuleInfo
-> G.Module
-> Map Symbol (Set ModuleNameBS)
extractBindings Nothing _ = M.empty
extractBindings (Just inf) mdl = M.fromList $ do
name <- G.modInfoExports inf
let sym = fastStringToByteString $ occNameFS $ G.getOccName name
mdls = S.singleton $ fastStringToByteString $ moduleNameFS $ moduleName mdl
return (sym, mdls)
mkFastStringByteString' :: BS.ByteString -> FastString
#if !MIN_VERSION_ghc(7,8,0)
fastStringToByteString :: FastString -> BS.ByteString
fastStringToByteString = BS.pack . bytesFS
mkFastStringByteString' = mkFastStringByteList . BS.unpack
#elif __GLASGOW_HASKELL__ == 708
mkFastStringByteString' = unsafePerformIO . mkFastStringByteString
#else
mkFastStringByteString' = mkFastStringByteString
#endif
----------------------------------------------------------------

8
Language/Haskell/GhcMod/Flag.hs
View File

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

146
Language/Haskell/GhcMod/Gap.hs
View File

@ -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)
@ -75,10 +78,14 @@ import qualified InstEnv
import qualified Pretty
import qualified StringBuffer as SB
#if __GLASGOW_HASKELL__ >= 710
import CoAxiom (coAxiomTyCon)
#endif
#if __GLASGOW_HASKELL__ >= 708
import FamInstEnv
import ConLike (ConLike(..))
import PatSyn (patSynType)
import PatSyn
#else
import TcRnTypes
#endif
@ -111,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
@ -141,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)
@ -198,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
----------------------------------------------------------------
@ -312,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
----------------------------------------------------------------
----------------------------------------------------------------
@ -357,28 +393,44 @@ pprInfo :: (FilePath -> FilePath) -> Bool -> (TyThing, GHC.Fixity, [ClsInst], [F
pprInfo m _ (thing, fixity, insts, famInsts)
= pprTyThingInContextLoc' thing
$$ show_fixity fixity
$$ InstEnv.pprInstances insts
$$ pprFamInsts famInsts
$$ vcat (map pprInstance' insts)
$$ vcat (map pprFamInst' famInsts)
#else
pprInfo :: (FilePath -> FilePath) -> PrintExplicitForalls -> (TyThing, GHC.Fixity, [ClsInst]) -> SDoc
pprInfo m pefas (thing, fixity, insts)
= pprTyThingInContextLoc' pefas thing
$$ show_fixity fixity
$$ vcat (map pprInstance insts)
$$ vcat (map pprInstance' insts)
#endif
where
show_fixity fx
| fx == defaultFixity = Outputable.empty
| otherwise = ppr fx <+> ppr (getName thing)
#if __GLASGOW_HASKELL__ >= 708
pprTyThingInContextLoc' thing' = hang (pprTyThingInContext thing') 2
(char '\t' <> ptext (sLit "--") <+> loc)
where loc = ptext (sLit "Defined") <+> pprNameDefnLoc' (getName thing')
pprTyThingInContextLoc' thing' = showWithLoc (pprDefinedAt' thing') (pprTyThingInContext thing')
#if __GLASGOW_HASKELL__ >= 710
pprFamInst' (FamInst { fi_flavor = DataFamilyInst rep_tc })
= pprTyThingInContextLoc (ATyCon rep_tc)
pprFamInst' (FamInst { fi_flavor = SynFamilyInst, fi_axiom = axiom
, fi_tys = lhs_tys, fi_rhs = rhs })
= showWithLoc (pprDefinedAt' (getName axiom)) $
hang (ptext (sLit "type instance") <+> pprTypeApp (coAxiomTyCon axiom) lhs_tys)
2 (equals <+> ppr rhs)
#else
pprTyThingInContextLoc' pefas' thing' = hang (pprTyThingInContext pefas' thing') 2
(char '\t' <> ptext (sLit "--") <+> loc)
where loc = ptext (sLit "Defined") <+> pprNameDefnLoc' (getName thing')
pprFamInst' ispec = showWithLoc (pprDefinedAt' (getName ispec)) (pprFamInstHdr ispec)
#endif
#else
pprTyThingInContextLoc' pefas' thing' = showWithLoc (pprDefinedAt' thing') (pprTyThingInContext pefas' thing')
#endif
showWithLoc loc doc
= hang doc 2 (char '\t' <> comment <+> loc)
-- The tab tries to make them line up a bit
where
comment = ptext (sLit "--")
pprInstance' ispec = hang (pprInstanceHdr ispec)
2 (ptext (sLit "--") <+> pprDefinedAt' (getName ispec))
pprDefinedAt' thing' = ptext (sLit "Defined") <+> pprNameDefnLoc' (getName thing')
pprNameDefnLoc' name
= case Name.nameSrcLoc name of
RealSrcLoc s -> ptext (sLit "at") <+> ppr (subst s)
@ -400,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
@ -429,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
@ -467,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)
@ -575,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<TypeChecker) :: PostTcType -> Bool
#endif
fixity = const (stage<Renamer) :: GHC.Fixity -> Bool
(r, s') = q x s0

1
Language/Haskell/GhcMod/HomeModuleGraph.hs
View File

@ -240,6 +240,7 @@ updateHomeModuleGraph' env smp0 = do
mns = map (unLoc . ideclName)
$ filter (isNothing . ideclPkgQual)
$ map unLoc hsmodImports
-- TODO: handle package qualifier "this"
liftIO $ Set.fromList . catMaybes <$> mapM (findModulePath env) mns
preprocessFile :: (IOish m, GmEnv m, GmState m) =>

26
Language/Haskell/GhcMod/Info.hs
View File

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

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

25
Language/Haskell/GhcMod/Lint.hs
View File

@ -6,11 +6,11 @@ import Language.Haskell.GhcMod.Logger (checkErrorPrefix)
import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Monad
import Language.Haskell.HLint (hlint)
import Language.Haskell.HLint3
import Language.Haskell.GhcMod.Utils (withMappedFile)
import Data.List (stripPrefix)
import Language.Haskell.Exts.SrcLoc (SrcLoc(..))
import System.IO
-- | Checking syntax of a target file using hlint.
-- Warnings and errors are returned.
@ -18,12 +18,17 @@ lint :: IOish m
=> LintOpts -- ^ Configuration parameters
-> FilePath -- ^ A target file.
-> GhcModT m String
lint opt file =
withMappedFile file $ \tempfile ->
liftIO (hlint $ tempfile : "--quiet" : optLintHlintOpts opt)
>>= mapM (replaceFileName tempfile)
>>= ghandle handler . pack
where
lint opt file = ghandle handler $
withMappedFile file $ \tempfile -> do
(flags, classify, hint) <- liftIO $ argsSettings $ optLintHlintOpts opt
hSrc <- liftIO $ openFile tempfile ReadMode
liftIO $ hSetEncoding hSrc (encoding flags)
res <- liftIO $ parseModuleEx flags file =<< Just `fmap` hGetContents hSrc
case res of
Right m -> pack . map show $ applyHints classify hint [m]
Left ParseError{parseErrorLocation=loc, parseErrorMessage=err} ->
return $ showSrcLoc loc ++ ":Error:" ++ err ++ "\n"
where
pack = convert' . map init -- init drops the last \n.
handler (SomeException e) = return $ checkErrorPrefix ++ show e ++ "\n"
replaceFileName fp s = return $ maybe (show s) (file++) $ stripPrefix fp (show s)
showSrcLoc (SrcLoc f l c) = concat [f, ":", show l, ":", show c]

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

@ -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,43 +134,56 @@ 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:"
warningAsErrorPrefixes :: [String]
warningAsErrorPrefixes = ["Couldn't match expected type"
warningAsErrorPrefixes = [ "Couldn't match expected type"
, "Couldn't match type"
, "No instance for"]

16
Language/Haskell/GhcMod/Monad.hs
View File

@ -53,11 +53,17 @@ import System.Directory
import System.IO.Unsafe
import Prelude
withGhcModEnv :: (IOish m, GmOut m) => FilePath -> Options -> ((GhcModEnv, GhcModLog) -> m a) -> m a
withGhcModEnv = withGhcModEnv' withCradle
withGhcModEnv :: (IOish m, GmOut m) => FilePath -> Options -> ((GhcModEnv, GhcModLog) -> m a) -> m a
withGhcModEnv dir opts f = withGhcModEnv' withCradle dir opts f
where
withCradle dir =
gbracket (runJournalT $ findCradle' dir) (liftIO . cleanupCradle . fst)
withCradle dir' =
gbracket
(runJournalT $ do
gmSetLogLevel $ ooptLogLevel $ optOutput opts
findCradle' (optPrograms opts) dir')
(liftIO . cleanupCradle . fst)
cwdLock :: MVar ThreadId
cwdLock = unsafePerformIO $ newEmptyMVar
@ -97,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.

2
Language/Haskell/GhcMod/Monad/Newtypes.hs
View File

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

2
src/GHCMod/Options/DocUtils.hs → Language/Haskell/GhcMod/Options/DocUtils.hs
View File

@ -14,7 +14,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/>.
module GHCMod.Options.DocUtils (
module Language.Haskell.GhcMod.Options.DocUtils (
($$),
($$$),
(<=>),

2
src/GHCMod/Options/Help.hs → Language/Haskell/GhcMod/Options/Help.hs
View File

@ -15,7 +15,7 @@
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE OverloadedStrings, FlexibleInstances, GeneralizedNewtypeDeriving #-}
module GHCMod.Options.Help where
module Language.Haskell.GhcMod.Options.Help where
import Options.Applicative
import Options.Applicative.Help.Pretty (Doc)

173
Language/Haskell/GhcMod/Options/Options.hs Normal file
View File

@ -0,0 +1,173 @@
-- ghc-mod: Making Haskell development *more* fun
-- Copyright (C) 2015 Nikolay Yakimov <root@livid.pp.ru>
--
-- 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 OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
module Language.Haskell.GhcMod.Options.Options (
globalArgSpec
, parseCmdLineOptions
) where
import Options.Applicative
import Options.Applicative.Types
import Language.Haskell.GhcMod.Types
import Control.Arrow
import Data.Char (toUpper, toLower)
import Data.List (intercalate)
import Language.Haskell.GhcMod.Read
import Language.Haskell.GhcMod.Options.DocUtils
import Language.Haskell.GhcMod.Options.Help
import Data.Monoid
import Prelude
-- | Parse a set of arguments according to the ghc-mod CLI flag spec, producing
-- @Options@ set accordingly.
parseCmdLineOptions :: [String] -> Maybe Options
parseCmdLineOptions = getParseResult . execParserPure (prefs mempty) (info globalArgSpec mempty)
splitOn :: Eq a => a -> [a] -> ([a], [a])
splitOn c = second (drop 1) . break (==c)
logLevelParser :: Parser GmLogLevel
logLevelParser =
logLevelSwitch <*>
logLevelOption
<||> silentSwitch
where
logLevelOption =
option parseLL
$$ long "verbose"
<=> metavar "LEVEL"
<=> value GmWarning
<=> showDefaultWith showLL
<=> help' $$$ do
"Set log level ("
<> int' (fromEnum (minBound :: GmLogLevel))
<> "-"
<> int' (fromEnum (maxBound :: GmLogLevel))
<> ")"
"You can also use strings (case-insensitive):"
para'
$ intercalate ", "
$ map showLL ([minBound..maxBound] :: [GmLogLevel])
logLevelSwitch =
repeatAp succ' . length <$> many $$ flag' ()
$$ short 'v'
<=> help "Increase log level"
silentSwitch = flag' GmSilent
$$ long "silent"
<=> short 's'
<=> help "Be silent, set log level to 'silent'"
showLL = drop 2 . map toLower . show
repeatAp f n = foldr (.) id (replicate n f)
succ' x | x == maxBound = x
| otherwise = succ x
parseLL = do
v <- readerAsk
let
il'= toEnum . min maxBound <$> readMaybe v
ll' = readMaybe ("Gm" ++ capFirst v)
maybe (readerError $ "Not a log level \"" ++ v ++ "\"") return $ ll' <|> il'
capFirst (h:t) = toUpper h : map toLower t
capFirst [] = []
outputOptsSpec :: Parser OutputOpts
outputOptsSpec = OutputOpts
<$> logLevelParser
<*> flag PlainStyle LispStyle
$$ long "tolisp"
<=> short 'l'
<=> help "Format output as an S-Expression"
<*> LineSeparator <$$> strOption
$$ long "boundary"
<=> long "line-separator"
<=> short 'b'
<=> metavar "SEP"
<=> value "\0"
<=> showDefault
<=> help "Output line separator"
<*> optional $$ splitOn ',' <$$> strOption
$$ long "line-prefix"
<=> metavar "OUT,ERR"
<=> help "Output prefixes"
programsArgSpec :: Parser Programs
programsArgSpec = Programs
<$> strOption
$$ long "with-ghc"
<=> value "ghc"
<=> showDefault
<=> help "GHC executable to use"
<*> strOption
$$ long "with-ghc-pkg"
<=> value "ghc-pkg"
<=> showDefault
<=> help "ghc-pkg executable to use (only needed when guessing from GHC path fails)"
<*> strOption
$$ long "with-cabal"
<=> value "cabal"
<=> showDefault
<=> help "cabal-install executable to use"
<*> strOption
$$ long "with-stack"
<=> value "stack"
<=> showDefault
<=> help "stack executable to use"
-- | An optparse-applicative @Parser@ sepcification for @Options@ so that
-- applications making use of the ghc-mod API can have a consistent way of
-- parsing global options.
globalArgSpec :: Parser Options
globalArgSpec = Options
<$> outputOptsSpec
<*> programsArgSpec
<*> many $$ strOption
$$ long "ghcOpt"
<=> long "ghc-option"
<=> short 'g'
<=> metavar "OPT"
<=> help "Option to be passed to GHC"
<*> many fileMappingSpec
<*> strOption
$$ long "encoding"
<=> value "UTF-8"
<=> showDefault
<=> help "I/O encoding"
where
fileMappingSpec =
getFileMapping . splitOn '=' <$> strOption
$$ long "map-file"
<=> metavar "MAPPING"
<=> fileMappingHelp
fileMappingHelp = help' $ do
"Redirect one file to another"
"--map-file \"file1.hs=file2.hs\""
indent 4 $ do
"can be used to tell ghc-mod"
\\ "that it should take source code"
\\ "for `file1.hs` from `file2.hs`."
"`file1.hs` can be either full path,"
\\ "or path relative to project root."
"`file2.hs` has to be either relative to project root,"
\\ "or full path (preferred)"
"--map-file \"file.hs\""
indent 4 $ do
"can be used to tell ghc-mod that it should take"
\\ "source code for `file.hs` from stdin. File end"
\\ "marker is `\\n\\EOT\\n`, i.e. `\\x0A\\x04\\x0A`."
\\ "`file.hs` may or may not exist, and should be"
\\ "either full path, or relative to project root."
getFileMapping = second (\i -> if null i then Nothing else Just i)

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

@ -220,7 +220,7 @@ packageCache = "package.cache"
-- | Filename of the symbol table cache file.
symbolCache :: Cradle -> FilePath
symbolCache crdl = cradleTempDir crdl </> symbolCacheFile
symbolCache crdl = cradleRootDir crdl </> cradleDistDir crdl </> symbolCacheFile
symbolCacheFile :: String
symbolCacheFile = "ghc-mod.symbol-cache"

3
Language/Haskell/GhcMod/Pretty.hs
View File

@ -32,7 +32,8 @@ gmRenderDoc = renderStyle docStyle
gmComponentNameDoc :: ChComponentName -> Doc
gmComponentNameDoc ChSetupHsName = text $ "Setup.hs"
gmComponentNameDoc ChLibName = text $ "library"
gmComponentNameDoc (ChLibName "") = text $ "library"
gmComponentNameDoc (ChLibName n) = text $ "library:" ++ n
gmComponentNameDoc (ChExeName n) = text $ "exe:" ++ n
gmComponentNameDoc (ChTestName n) = text $ "test:" ++ n
gmComponentNameDoc (ChBenchName n) = text $ "bench:" ++ n

109
Language/Haskell/GhcMod/SrcUtils.hs
View File

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

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

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

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

@ -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
@ -66,29 +69,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 +129,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 +139,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
@ -275,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
@ -451,7 +465,9 @@ loadTargets opts targetStrs = do
case target' of
HscNothing -> do
void $ load LoadAllTargets
mapM_ (parseModule >=> typecheckModule >=> desugarModule) mg
forM_ mg $
handleSourceError (gmLog GmDebug "loadTargets" . text . show)
. void . (parseModule >=> typecheckModule >=> desugarModule)
HscInterpreted -> do
void $ load LoadAllTargets
_ -> error ("loadTargets: unsupported hscTarget")
@ -477,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)))

16
Language/Haskell/GhcMod/Types.hs
View File

@ -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
@ -105,6 +105,7 @@ data Options = Options {
-- | GHC command line options set on the @ghc-mod@ command line
, optGhcUserOptions :: [GHCOption]
, optFileMappings :: [(FilePath, Maybe FilePath)]
, optEncoding :: String
} deriving (Show)
-- | A default 'Options'.
@ -124,6 +125,7 @@ defaultOptions = Options {
}
, optGhcUserOptions = []
, optFileMappings = []
, optEncoding = "UTF-8"
}
----------------------------------------------------------------
@ -132,7 +134,7 @@ data Project = CabalProject
| SandboxProject
| PlainProject
| StackProject StackEnv
deriving (Eq, Show)
deriving (Eq, Show, Ord)
isCabalHelperProject :: Project -> Bool
isCabalHelperProject StackProject {} = True
@ -144,7 +146,7 @@ data StackEnv = StackEnv {
, seBinPath :: [FilePath]
, seSnapshotPkgDb :: FilePath
, seLocalPkgDb :: FilePath
} deriving (Eq, Show)
} deriving (Eq, Show, Ord)
-- | The environment where this library is used.
data Cradle = Cradle {
@ -159,7 +161,7 @@ data Cradle = Cradle {
, cradleCabalFile :: Maybe FilePath
-- | The build info directory.
, cradleDistDir :: FilePath
} deriving (Eq, Show)
} deriving (Eq, Show, Ord)
data GmStream = GmOutStream | GmErrStream
deriving (Show)
@ -269,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
@ -386,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

6
Language/Haskell/GhcMod/World.hs
View File

@ -19,7 +19,7 @@ data World = World {
, worldCabalFile :: Maybe TimedFile
, worldCabalConfig :: Maybe TimedFile
, worldCabalSandboxConfig :: Maybe TimedFile
, worldSymbolCache :: Maybe TimedFile
, worldMappedFiles :: FileMappingMap
} deriving (Eq)
timedPackageCaches :: IOish m => GhcModT m [TimedFile]
@ -35,14 +35,14 @@ getCurrentWorld = do
mCabalFile <- liftIO $ timeFile `traverse` cradleCabalFile crdl
mCabalConfig <- liftIO $ timeMaybe (setupConfigFile crdl)
mCabalSandboxConfig <- liftIO $ timeMaybe (sandboxConfigFile crdl)
mSymbolCache <- liftIO $ timeMaybe (symbolCache crdl)
mFileMap <- getMMappedFiles
return World {
worldPackageCaches = pkgCaches
, worldCabalFile = mCabalFile
, worldCabalConfig = mCabalConfig
, worldCabalSandboxConfig = mCabalSandboxConfig
, worldSymbolCache = mSymbolCache
, worldMappedFiles = mFileMap
}
didWorldChange :: IOish m => World -> GhcModT m Bool

30
NotCPP/Declarations.hs
View File

@ -104,21 +104,36 @@ 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 _ ->
InstanceD {} -> -- _ _ty _
error "notcpp: Instance declarations are not supported yet"
ForeignD _ ->
error "notcpp: Foreign declarations are not supported yet"
@ -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

8
NotCPP/LookupValueName.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
-- | This module uses scope lookup techniques to either export
-- 'lookupValueName' from @Language.Haskell.TH@, or define
@ -25,8 +26,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 +40,5 @@ bestValueGuess s = do
err = fail . showString "NotCPP.bestValueGuess: " . unwords
$(recover [d| lookupValueName = bestValueGuess |] $ do
VarI _ _ _ _ <- reify (mkName "lookupValueName")
VarI{} <- reify (mkName "lookupValueName")
return [])

6
NotCPP/Utils.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
module NotCPP.Utils where
@ -24,6 +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 _ _) = Just (VarE n)
infoToExp (DataConI n _ _) = Just (ConE n)
#else
infoToExp (VarI n _ _ _) = Just (VarE n)
infoToExp (DataConI n _ _ _) = Just (ConE n)
#endif
infoToExp _ = Nothing

2
elisp/ghc.el
View File

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

57
ghc-mod.cabal
View File

@ -1,5 +1,5 @@
Name: ghc-mod
Version: 5.5.0.0
Version: 5.6.0.0
Author: Kazu Yamamoto <kazu@iij.ad.jp>,
Daniel Gröber <dxld@darkboxed.org>,
Alejandro Serrano <trupill@gmail.com>,
@ -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
@ -117,6 +126,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
@ -152,30 +162,34 @@ Library
Language.Haskell.GhcMod.Types
Language.Haskell.GhcMod.Utils
Language.Haskell.GhcMod.World
Language.Haskell.GhcMod.Options.Options
Language.Haskell.GhcMod.Options.DocUtils
Language.Haskell.GhcMod.Options.Help
Other-Modules: Paths_ghc_mod
Utils
Data.Binary.Generic
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
, cabal-helper < 0.8 && >= 0.7.1.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.8.61
, hlint < 1.10 && >= 1.9.27
, 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
@ -187,12 +201,13 @@ Library
, extra == 1.4.*
, 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
if impl(ghc >= 8.0)
Build-Depends: ghc-boot
Executable ghc-mod
Default-Language: Haskell2010
@ -201,9 +216,7 @@ Executable ghc-mod
, GHCMod.Options
, GHCMod.Options.Commands
, GHCMod.Version
, GHCMod.Options.DocUtils
, GHCMod.Options.ShellParse
, GHCMod.Options.Help
GHC-Options: -Wall -fno-warn-deprecations -threaded
Default-Extensions: ConstraintKinds, FlexibleContexts
HS-Source-Dirs: src
@ -211,10 +224,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
@ -231,13 +244,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
@ -247,8 +260,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
@ -281,12 +292,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

15
scripts/bump.sh
View File

@ -9,24 +9,32 @@ fi
VERSION=$1
if ! echo $VERSION | grep "^[0-9.]"; then
if ! echo $VERSION | grep -Eq "^[0-9.]*(-.+)?$"; then
echo "invalid version";
exit 1
fi
cd $(dirname $0)/..
git checkout release-$VERSION
sed -i 's/(defconst ghc-version ".*")/(defconst ghc-version "'"$VERSION"'")/' \
elisp/ghc.el
sed -r -i 's/^(Version:[[:space:]]*)[0-9.]+/\1'"$VERSION"'/' ghc-mod.cabal
git add elisp/ghc.el ghc-mod.cabal
git commit -m "Bump version to $VERSION"
git update-index -q --ignore-submodules --refresh
# If there are uncommitted changes do the bump commit
if ! git diff-index --cached --quiet HEAD --ignore-submodules --
then
git commit -m "Bump version to $VERSION" --allow-empty
fi
git checkout release
#git merge master
git merge -s recursive -X theirs master
git merge -s recursive -X theirs release-$VERSION
( tac ChangeLog; echo "\n$(date '+%Y-%m-%d') v$VERSION" ) | tac \
> ChangeLog.tmp
@ -38,5 +46,4 @@ emacs -q -nw ChangeLog
git add ChangeLog
git commit -m "ChangeLog"
git tag "v$VERSION"

15
src/GHCMod.hs
View File

@ -34,9 +34,12 @@ handler = flip gcatches
]
main :: IO ()
main = do
hSetEncoding stdout utf8
parseArgs >>= \res@(globalOptions, _) ->
main =
parseArgs >>= \res@(globalOptions, _) -> do
enc <- mkTextEncoding $ optEncoding globalOptions
hSetEncoding stdout enc
hSetEncoding stderr enc
hSetEncoding stdin enc
catches (progMain res) [
Handler $ \(e :: GhcModError) ->
runGmOutT globalOptions $ exitError $ renderStyle ghcModStyle (gmeDoc e)
@ -107,9 +110,7 @@ getFileSourceFromStdin = do
then fmap (x:) readStdin'
else return []
-- Someone please already rewrite the cmdline parsing code *weep* :'(
wrapGhcCommands :: (IOish m, GmOut m) => Options -> GhcModCommands -> m ()
wrapGhcCommands _opts CmdRoot = gmPutStr =<< rootInfo
wrapGhcCommands opts cmd =
handleGmError $ runGhcModT opts $ handler $ do
forM_ (reverse $ optFileMappings opts) $
@ -139,7 +140,7 @@ ghcCommands (CmdDebug) = debugInfo
ghcCommands (CmdDebugComponent ts) = componentInfo ts
ghcCommands (CmdBoot) = boot
-- ghcCommands (CmdNukeCaches) = nukeCaches >> return ""
-- ghcCommands (CmdRoot) = undefined -- handled in wrapGhcCommands
ghcCommands (CmdRoot) = rootInfo
ghcCommands (CmdLegacyInteractive) = legacyInteractive >> return ""
ghcCommands (CmdModules detail) = modules detail
ghcCommands (CmdDumpSym) = dumpSymbol >> return ""
@ -150,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

133
src/GHCMod/Options.hs
View File

@ -25,14 +25,10 @@ module GHCMod.Options (
import Options.Applicative
import Options.Applicative.Types
import Language.Haskell.GhcMod.Types
import Control.Arrow
import Data.Char (toUpper, toLower)
import Data.List (intercalate)
import Language.Haskell.GhcMod.Read
import GHCMod.Options.Commands
import GHCMod.Version
import GHCMod.Options.DocUtils
import GHCMod.Options.Help
import Language.Haskell.GhcMod.Options.DocUtils
import Language.Haskell.GhcMod.Options.Options
import GHCMod.Options.ShellParse
parseArgs :: IO (Options, GhcModCommands)
@ -74,128 +70,3 @@ helpVersion =
argAndCmdSpec :: Parser (Options, GhcModCommands)
argAndCmdSpec = (,) <$> globalArgSpec <*> commandsSpec
splitOn :: Eq a => a -> [a] -> ([a], [a])
splitOn c = second (drop 1) . break (==c)
logLevelParser :: Parser GmLogLevel
logLevelParser =
logLevelSwitch <*>
logLevelOption
<||> silentSwitch
where
logLevelOption =
option parseLL
$$ long "verbose"
<=> metavar "LEVEL"
<=> value GmWarning
<=> showDefaultWith showLL
<=> help' $$$ do
"Set log level ("
<> int' (fromEnum (minBound :: GmLogLevel))
<> "-"
<> int' (fromEnum (maxBound :: GmLogLevel))
<> ")"
"You can also use strings (case-insensitive):"
para'
$ intercalate ", "
$ map showLL ([minBound..maxBound] :: [GmLogLevel])
logLevelSwitch =
repeatAp succ' . length <$> many $$ flag' ()
$$ short 'v'
<=> help "Increase log level"
silentSwitch = flag' GmSilent
$$ long "silent"
<=> short 's'
<=> help "Be silent, set log level to 'silent'"
showLL = drop 2 . map toLower . show
repeatAp f n = foldr (.) id (replicate n f)
succ' x | x == maxBound = x
| otherwise = succ x
parseLL = do
v <- readerAsk
let
il'= toEnum . min maxBound <$> readMaybe v
ll' = readMaybe ("Gm" ++ capFirst v)
maybe (readerError $ "Not a log level \"" ++ v ++ "\"") return $ ll' <|> il'
capFirst (h:t) = toUpper h : map toLower t
capFirst [] = []
outputOptsSpec :: Parser OutputOpts
outputOptsSpec = OutputOpts
<$> logLevelParser
<*> flag PlainStyle LispStyle
$$ long "tolisp"
<=> short 'l'
<=> help "Format output as an S-Expression"
<*> LineSeparator <$$> strOption
$$ long "boundary"
<=> long "line-separator"
<=> short 'b'
<=> metavar "SEP"
<=> value "\0"
<=> showDefault
<=> help "Output line separator"
<*> optional $$ splitOn ',' <$$> strOption
$$ long "line-prefix"
<=> metavar "OUT,ERR"
<=> help "Output prefixes"
programsArgSpec :: Parser Programs
programsArgSpec = Programs
<$> strOption
$$ long "with-ghc"
<=> value "ghc"
<=> showDefault
<=> help "GHC executable to use"
<*> strOption
$$ long "with-ghc-pkg"
<=> value "ghc-pkg"
<=> showDefault
<=> help "ghc-pkg executable to use (only needed when guessing from GHC path fails)"
<*> strOption
$$ long "with-cabal"
<=> value "cabal"
<=> showDefault
<=> help "cabal-install executable to use"
<*> strOption
$$ long "with-stack"
<=> value "stack"
<=> showDefault
<=> help "stack executable to use"
globalArgSpec :: Parser Options
globalArgSpec = Options
<$> outputOptsSpec
<*> programsArgSpec
<*> many $$ strOption
$$ long "ghcOpt"
<=> long "ghc-option"
<=> short 'g'
<=> metavar "OPT"
<=> help "Option to be passed to GHC"
<*> many fileMappingSpec
where
fileMappingSpec =
getFileMapping . splitOn '=' <$> strOption
$$ long "map-file"
<=> metavar "MAPPING"
<=> fileMappingHelp
fileMappingHelp = help' $ do
"Redirect one file to another"
"--map-file \"file1.hs=file2.hs\""
indent 4 $ do
"can be used to tell ghc-mod"
\\ "that it should take source code"
\\ "for `file1.hs` from `file2.hs`."
"`file1.hs` can be either full path,"
\\ "or path relative to project root."
"`file2.hs` has to be either relative to project root,"
\\ "or full path (preferred)"
"--map-file \"file.hs\""
indent 4 $ do
"can be used to tell ghc-mod that it should take"
\\ "source code for `file.hs` from stdin. File end"
\\ "marker is `\\n\\EOT\\n`, i.e. `\\x0A\\x04\\x0A`."
\\ "`file.hs` may or may not exist, and should be"
\\ "either full path, or relative to project root."
getFileMapping = second (\i -> if null i then Nothing else Just i)

38
src/GHCMod/Options/Commands.hs
View File

@ -23,8 +23,8 @@ import Options.Applicative.Types
import Options.Applicative.Builder.Internal
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Read
import GHCMod.Options.DocUtils
import GHCMod.Options.Help
import Language.Haskell.GhcMod.Options.DocUtils
import Language.Haskell.GhcMod.Options.Help
type Symbol = String
type Expr = String
@ -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 <$>

5
stack-8.yaml Normal file
View File

@ -0,0 +1,5 @@
flags: {}
packages:
- '.'
extra-deps: []
resolver: nightly-2016-06-04

5
stack.yaml
View File

@ -1,6 +1,5 @@
flags: {}
packages:
- '.'
extra-deps:
- cabal-helper-0.6.2.0
resolver: lts-3.20
extra-deps: []
resolver: lts-5.3

6
test/CabalHelperSpec.hs
View File

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

40
test/CaseSplitSpec.hs
View File

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

6
test/CheckSpec.hs
View File

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

6
test/CradleSpec.hs
View File

@ -37,14 +37,14 @@ spec = do
it "returns the current directory" $ do
withDirectory_ "/" $ do
curDir <- stripLastDot <$> canonicalizePath "/"
res <- clean_ $ runGmOutDef findCradleNoLog
res <- clean_ $ runGmOutDef $ findCradleNoLog $ optPrograms defaultOptions
cradleCurrentDir res `shouldBe` curDir
cradleRootDir res `shouldBe` curDir
cradleCabalFile res `shouldBe` Nothing
it "finds a cabal file and a sandbox" $ do
withDirectory "test/data/cabal-project/subdir1/subdir2" $ \dir -> do
res <- relativeCradle dir <$> clean_ (runGmOutDef findCradleNoLog)
res <- relativeCradle dir <$> clean_ (runGmOutDef $ findCradleNoLog $ optPrograms defaultOptions)
cradleCurrentDir res `shouldBe`
"test/data/cabal-project/subdir1/subdir2"
@ -56,7 +56,7 @@ spec = do
it "works even if a sandbox config file is broken" $ do
withDirectory "test/data/broken-sandbox" $ \dir -> do
res <- relativeCradle dir <$> clean_ (runGmOutDef findCradleNoLog)
res <- relativeCradle dir <$> clean_ (runGmOutDef $ findCradleNoLog $ optPrograms defaultOptions)
cradleCurrentDir res `shouldBe`
"test" </> "data" </> "broken-sandbox"

22
test/FileMappingSpec.hs
View File

@ -123,24 +123,30 @@ spec = do
res <- runD $ do
loadMappedFile "File.hs" "File_Redir_Lint.hs"
lint defaultLintOpts "File.hs"
res `shouldBe` "File.hs:4:1: Error: Eta reduce\NULFound:\NUL func a b = (*) a b\NULWhy not:\NUL func = (*)\n"
res `shouldBe` "File.hs:4:1: Warning: Eta reduce\NULFound:\NUL func a b = (*) a b\NULWhy not:\NUL func = (*)\n"
it "lints in-memory file if one is specified and outputs original filename" $ do
withDirectory_ "test/data/file-mapping" $ do
res <- runD $ do
loadMappedFileSource "File.hs" "func a b = (++) a b\n"
lint defaultLintOpts "File.hs"
res `shouldBe` "File.hs:1:1: Error: Eta reduce\NULFound:\NUL func a b = (++) a b\NULWhy not:\NUL func = (++)\n"
res `shouldBe` "File.hs:1:1: Warning: Eta reduce\NULFound:\NUL func a b = (++) a b\NULWhy not:\NUL func = (++)\n"
it "shows types of the expression for redirected files" $ 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"
@ -184,14 +190,14 @@ spec = do
res <- runD $ do
loadMappedFile "File.hs" "File_Redir_Lint.hs"
lint defaultLintOpts "File.hs"
res `shouldBe` "File.hs:6:1: Error: Eta reduce\NULFound:\NUL func a b = (*) a b\NULWhy not:\NUL func = (*)\n"
res `shouldBe` "File.hs:6:1: Warning: Eta reduce\NULFound:\NUL func a b = (*) a b\NULWhy not:\NUL func = (*)\n"
it "lints in-memory file if one is specified and outputs original filename" $ do
withDirectory_ "test/data/file-mapping/preprocessor" $ do
src <- readFile "File_Redir_Lint.hs"
res <- runD $ do
loadMappedFileSource "File.hs" src
lint defaultLintOpts "File.hs"
res `shouldBe` "File.hs:6:1: Error: Eta reduce\NULFound:\NUL func a b = (*) a b\NULWhy not:\NUL func = (*)\n"
res `shouldBe` "File.hs:6:1: Warning: Eta reduce\NULFound:\NUL func a b = (*) a b\NULWhy not:\NUL func = (*)\n"
describe "literate haskell tests" $ do
it "checks redirected file if one is specified and outputs original filename" $ do
withDirectory_ "test/data/file-mapping/lhs" $ do
@ -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]\""]

1
test/FindSpec.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE OverloadedStrings #-}
module FindSpec where
import Language.Haskell.GhcMod.Find

4
test/FlagSpec.hs
View File

@ -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
test/InfoSpec.hs
View File

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

2
test/LintSpec.hs
View File

@ -9,7 +9,7 @@ spec = do
describe "lint" $ do
it "can detect a redundant import" $ do
res <- runD $ lint defaultLintOpts "test/data/hlint/hlint.hs"
res `shouldBe` "test/data/hlint/hlint.hs:4:8: Error: Redundant do\NULFound:\NUL do putStrLn \"Hello, world!\"\NULWhy not:\NUL putStrLn \"Hello, world!\"\n"
res `shouldBe` "test/data/hlint/hlint.hs:4:8: Warning: Redundant do\NULFound:\NUL do putStrLn \"Hello, world!\"\NULWhy not:\NUL putStrLn \"Hello, world!\"\n"
context "when no suggestions are given" $ do
it "doesn't output an empty line" $ do

15
test/MonadSpec.hs
View File

@ -23,6 +23,8 @@ spec = do
mv_ex :: MVar (Either SomeException ())
<- newEmptyMVar
mv_startup_barrier :: MVar ()
<- newEmptyMVar
mv_startup_barrier :: MVar () <- newEmptyMVar
_t1 <- forkOS $ do
@ -37,6 +39,19 @@ spec = do
res' <- evaluate res
putMVar mv_ex res'
_t1 <- forkOS $ do
-- wait (inside GhcModT) for t2 to receive the exception
_ <- runD $ liftIO $ do
putMVar mv_startup_barrier ()
readMVar mv_ex
return ()
_t2 <- forkOS $ do
readMVar mv_startup_barrier -- wait for t1 to be in GhcModT
res <- try $ runD $ return ()
res' <- evaluate res
putMVar mv_ex res'
ex <- takeMVar mv_ex
isLeft ex `shouldBe` True

4
test/PathsAndFilesSpec.hs
View File

@ -16,12 +16,12 @@ spec = do
describe "getSandboxDb" $ do
it "can parse a config file and extract the sandbox package-db" $ do
cwd <- getCurrentDirectory
Just crdl <- runMaybeT $ plainCradle "test/data/cabal-project"
Just crdl <- runLogDef $ runMaybeT $ plainCradle "test/data/cabal-project"
Just db <- getSandboxDb crdl
db `shouldSatisfy` isPkgDbAt (cwd </> "test/data/cabal-project/.cabal-sandbox")
it "returns Nothing if the sandbox config file is broken" $ do
Just crdl <- runMaybeT $ plainCradle "test/data/broken-sandbox"
Just crdl <- runLogDef $ runMaybeT $ plainCradle "test/data/broken-sandbox"
getSandboxDb crdl `shouldReturn` Nothing
describe "findCabalFile" $ do

15
test/TestUtils.hs
View File

@ -6,6 +6,7 @@ module TestUtils (
, runE
, runNullLog
, runGmOutDef
, runLogDef
, shouldReturnError
, isPkgDbAt
, isPkgConfDAt
@ -43,10 +44,6 @@ extract action = do
Right a -> return a
Left e -> error $ show e
withSpecCradle :: (IOish m, GmOut m) => FilePath -> ((Cradle, GhcModLog) -> m a) -> m a
withSpecCradle cradledir f = do
gbracket (runJournalT $ findSpecCradle cradledir) (liftIO . cleanupCradle . fst) f
runGhcModTSpec :: Options -> GhcModT IO a -> IO (Either GhcModError a, GhcModLog)
runGhcModTSpec opt action = do
dir <- getCurrentDirectory
@ -59,6 +56,13 @@ runGhcModTSpec' dir opt action = liftIO (canonicalizePath dir) >>= \dir' -> do
withGhcModEnv' withSpecCradle dir' opt $ \(env,_) -> do
first (fst <$>) <$> runGhcModT' env defaultGhcModState
(gmSetLogLevel (ooptLogLevel $ optOutput opt) >> action)
where
withSpecCradle :: (IOish m, GmOut m) => FilePath -> ((Cradle, GhcModLog) -> m a) -> m a
withSpecCradle cradledir f =
gbracket
(runJournalT $ findSpecCradle (optPrograms opt) cradledir)
(liftIO . cleanupCradle . fst) f
-- | Run GhcMod
run :: Options -> GhcModT IO a -> IO a
@ -88,6 +92,9 @@ runNullLog action = do
runGmOutDef :: IOish m => GmOutT m a -> m a
runGmOutDef = runGmOutT defaultOptions
runLogDef :: IOish m => GmOutT (JournalT GhcModLog m) a -> m a
runLogDef = fmap fst . runJournalT . runGmOutDef
shouldReturnError :: Show a
=> IO (Either GhcModError a, GhcModLog)
-> Expectation

4
test/data/case-split/Crash.hs Normal file
View File

@ -0,0 +1,4 @@
module Crash where
test :: Maybe a
test x = undefined

39
test/data/case-split/Vect706.hs Normal file
View File

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

1
test/data/pattern-synonyms/A.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE PatternSynonyms #-}
module A where
data SomeType a b = SomeType (a,b)

2
test/data/pattern-synonyms/pattern-synonyms.cabal
View File

@ -23,3 +23,5 @@ library
-- hs-source-dirs:
default-language: Haskell2010
ghc-options: -Wall
if impl(ghc >= 8.0.1)
ghc-options: -Wno-missing-pattern-synonym-signatures

2
test/data/stack-project/new-template.cabal
View File

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