Merge branch 'release-5.6.0.0' into release
This commit is contained in:
Daniel Gröber
commit
0893cb1466
@ -1,6 +1,5 @@
|
||||
language: haskell
|
||||
ghc:
|
||||
- 7.4
|
||||
- 7.6
|
||||
- 7.8
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 = [
|
||||
|
||||
@ -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
|
||||
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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -33,7 +33,7 @@ check files =
|
||||
runGmlTWith
|
||||
(map Left files)
|
||||
return
|
||||
((fmap fst <$>) . withLogger setNoMaxRelevantBindings)
|
||||
((fmap fst <$>) . withLogger Gap.setNoMaxRelevantBindings)
|
||||
(return ())
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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,8 +75,23 @@ 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
|
||||
[ "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)
|
||||
@ -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"
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
126
Language/Haskell/GhcMod/DynFlagsTH.hs
Normal 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)
|
||||
@ -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,
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
|
||||
@ -4,10 +4,6 @@ import qualified Language.Haskell.GhcMod.Gap as Gap
|
||||
import Language.Haskell.GhcMod.Convert
|
||||
import Language.Haskell.GhcMod.Monad
|
||||
|
||||
-- | Listing GHC flags. (e.g -fno-warn-orphans)
|
||||
|
||||
-- | Listing of GHC flags, same as @ghc@\'s @--show-options@ with @ghc >= 7.10@.
|
||||
flags :: IOish m => GhcModT m String
|
||||
flags = convert' [ "-f" ++ prefix ++ option
|
||||
| option <- Gap.fOptions
|
||||
, prefix <- ["","no-"]
|
||||
]
|
||||
flags = convert' Gap.ghcCmdOptions
|
||||
|
||||
@ -9,7 +9,7 @@ module Language.Haskell.GhcMod.Gap (
|
||||
, getSrcSpan
|
||||
, getSrcFile
|
||||
, withInteractiveContext
|
||||
, fOptions
|
||||
, ghcCmdOptions
|
||||
, toStringBuffer
|
||||
, showSeverityCaption
|
||||
, setCabalPkg
|
||||
@ -18,12 +18,14 @@ module Language.Haskell.GhcMod.Gap (
|
||||
, setDeferTypedHoles
|
||||
, setWarnTypedHoles
|
||||
, setDumpSplices
|
||||
, setNoMaxRelevantBindings
|
||||
, isDumpSplices
|
||||
, filterOutChildren
|
||||
, infoThing
|
||||
, pprInfo
|
||||
, HasType(..)
|
||||
, errorMsgSpan
|
||||
, setErrorMsgSpan
|
||||
, typeForUser
|
||||
, nameForUser
|
||||
, occNameForUser
|
||||
@ -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
|
||||
|
||||
@ -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) =>
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
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]
|
||||
|
||||
@ -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
|
||||
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 <- 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
|
||||
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"]
|
||||
|
||||
@ -54,10 +54,16 @@ import System.IO.Unsafe
|
||||
import Prelude
|
||||
|
||||
withGhcModEnv :: (IOish m, GmOut m) => FilePath -> Options -> ((GhcModEnv, GhcModLog) -> m a) -> m a
|
||||
withGhcModEnv = withGhcModEnv' withCradle
|
||||
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.
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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 (
|
||||
($$),
|
||||
($$$),
|
||||
(<=>),
|
||||
@ -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
173
Language/Haskell/GhcMod/Options/Options.hs
Normal 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)
|
||||
@ -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"
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)))
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 [])
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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")
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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"
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
5
stack-8.yaml
Normal file
@ -0,0 +1,5 @@
|
||||
flags: {}
|
||||
packages:
|
||||
- '.'
|
||||
extra-deps: []
|
||||
resolver: nightly-2016-06-04
|
||||
@ -1,6 +1,5 @@
|
||||
flags: {}
|
||||
packages:
|
||||
- '.'
|
||||
extra-deps:
|
||||
- cabal-helper-0.6.2.0
|
||||
resolver: lts-3.20
|
||||
extra-deps: []
|
||||
resolver: lts-5.3
|
||||
|
||||
@ -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"]
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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"
|
||||
|
||||
@ -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"
|
||||
|
||||
|
||||
@ -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,3 +1,4 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module FindSpec where
|
||||
|
||||
import Language.Haskell.GhcMod.Find
|
||||
|
||||
@ -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"]
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
4
test/data/case-split/Crash.hs
Normal file
@ -0,0 +1,4 @@
|
||||
module Crash where
|
||||
|
||||
test :: Maybe a
|
||||
test x = undefined
|
||||
39
test/data/case-split/Vect706.hs
Normal file
39
test/data/case-split/Vect706.hs
Normal 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,4 +1,5 @@
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
|
||||
module A where
|
||||
|
||||
data SomeType a b = SomeType (a,b)
|
||||
|
||||
@ -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
|
||||
@ -16,7 +16,7 @@ cabal-version: >=1.10
|
||||
library
|
||||
hs-source-dirs: src
|
||||
exposed-modules: Lib
|
||||
build-depends: base >= 4.7 && < 5
|
||||
build-depends: base
|
||||
default-language: Haskell2010
|
||||
|
||||
executable new-template-exe
|
||||
|
||||
Loading…
Reference in New Issue
Block a user