diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,37 @@ +2017-05-26 v5.8.0.0 + * Fix logic bug in fix for excessive use of `map-file` + * Bump HLint to 2.x + * Reorganize Cabal file to make maintanance easier + * Merge #872, Do not log warning when Stack project is preferred + * Merge #873, Fix build on case-insensitive filesystems + * Fix 'debug' command when ghc(-pkg) not on PATH + * Rework README + * Reorganize modules as preparation for splitting off ghc-mod-core + * Remove dependency on 'pretty' and use GHC's pretty printer instead + * Merge #854, Fix for "ghc-mod doc" when usind with stack + * Merge #858, Fix Gap.fromTyThing returning GHC internal + representation instead of the user readable representation of + types + * Fix #774, 'find*File' searching all the way up to / + * Fix #778, Check directory permissions before reading in + findFileInParentsP + * Merge #817, fix #779, bad "ghc-mod check" performance + +2017-01-16 v5.7.0.0 + * Bump cabal-helper to 0.7.3.0 to support Cabal-1.24.1.0 + * Bump haskell-src-exts, optparse-applicative, pipes and extra + to be compatible with stackage. + +2016-07-29 v5.6.0.0 + * Bump cabal-helper to 0.7, adds support for Cabal-1.24 + * Merge #737, `map-file` caching issues + * Merge #767, Add `browse` option to show symbol "parents" + * Merge #731, Type constraints + * Fix #69 (via #731), Missing type constraints + * Fix #438, Case splitting not working + * Fix #790, Don't try to use 'cabal' or 'stack' when it's not installed + * Add support for GHC 8.0 + 2016-01-19 v5.5.0.0 * Fix #660, cabal-helper errors when no global GHC is installed (Stack) * Fix #665, Reinstate internally managed CWD (no more `ghc-mod root` @@ -29,9 +63,9 @@ super slowness) * Expose all internal modules because API will get a major redesign soon anyways - * ghc-mod(i) executable must now be run in project directory for - commands other than `root` - * Add --line-prefix option for multiplexing stdout/err onto one stream + * ghc-mod(i) executable must now be run in project directory for + commands other than `root` + * Add --line-prefix option for multiplexing stdout/err onto one stream 2015-08-14 v5.3.0.0 * Re-license majority of code under the AGPL-3 @@ -39,72 +73,72 @@ * Remove `cabalDependPackages', `cabalAllTargets' * Merge #434, Fix finding sandbox config file and directory. * Merge #431, Re-add output line separator global option for expand - command. + command. * Merge #470, Support for overriding the package-db stack * Merge #486, Fix ineffective cache invalidation for `find` 2014-12-31 v5.2.1.2 * Merge #377, Fix `browse` erroneously thinking haskell2010 identifiers are operators - * Fix incompatibility with monad-control >= 1.0.0 - * Fix temporary directories not being removed properly - * Merge #405, #408, a race condition in the Emacs frontend - * Merge #403, Support unicode quotes in module regexp + * Fix incompatibility with monad-control >= 1.0.0 + * Fix temporary directories not being removed properly + * Merge #405, #408, a race condition in the Emacs frontend + * Merge #403, Support unicode quotes in module regexp 2014-11-03 v5.2.1.1 - * Fix `findCabalFiles` thinking `$HOME/.cabal` is a cabal file. - * Support `where` clauses, `let` bindings and `case` expressions - in case splitting, #400 + * Fix `findCabalFiles` thinking `$HOME/.cabal` is a cabal file. + * Support `where` clauses, `let` bindings and `case` expressions + in case splitting, #400 2014-11-02 v5.2.1.0 - * Fix `newTempDir` on Windows - * GhcModT's liftIO instance now converts GhcMOdError exceptions - into monadic failures + * Fix `newTempDir` on Windows + * GhcModT's liftIO instance now converts GhcMOdError exceptions + into monadic failures 2014-10-30 v5.2.0.0 - * Return type of `loadSymbolDb` is now in GhcModT - * Function `dumpSymbol` now takes the path of the target directory - * Fix #387, Pattern match failure in GhcPkg - * Fix #386, `ghc-mod version` should not check `cabal configure` - * Fix #391, Error on command `-g` when used before command despite - --help output saying this is valid - * Fix formatting of `ghc-version` constant in the elisp code. in - version 5.1.1.0 the string was "v5.1.1.0" instead of "5.1.1.0". + * Return type of `loadSymbolDb` is now in GhcModT + * Function `dumpSymbol` now takes the path of the target directory + * Fix #387, Pattern match failure in GhcPkg + * Fix #386, `ghc-mod version` should not check `cabal configure` + * Fix #391, Error on command `-g` when used before command despite + --help output saying this is valid + * Fix formatting of `ghc-version` constant in the elisp code. in + version 5.1.1.0 the string was "v5.1.1.0" instead of "5.1.1.0". 2014-10-04 v5.1.1.0 - * Handle various consistency related issues: #222, #224, #326, #332 - * Add `isOutdated` to Language.Haskell.GhcMod + * Handle various consistency related issues: #222, #224, #326, #332 + * Add `isOutdated` to Language.Haskell.GhcMod 2014-09-17 v5.1.0.2 - * Fix building with haskell-src-exts < 1.16.0 + * Fix building with haskell-src-exts < 1.16.0 2014-09-16 v5.1.0.1 - * Fix building with haskell-src-exts-1.16.0 - * Loosen monad-journal dependency + * Fix building with haskell-src-exts-1.16.0 + * Loosen monad-journal dependency 2014-09-12 v5.1.0.0 - * GhcModError is now a recursive data type (`GMECabalConfigure`'s - type changed) - * GhcModT's MonadIO instance now converts IOError's to failures in - the ErrorT part of GhcModT on `liftIO`. - * Make `loadSymbolDb` polimorphic in the return types's monad. - * Add `hoistGhcModT` to Language.Haskell.GhcMod.Internal - * Fix `check` command for modules using `-XPatternSynonyms` - * Merge #364, Support cabal configuration flags + * GhcModError is now a recursive data type (`GMECabalConfigure`'s + type changed) + * GhcModT's MonadIO instance now converts IOError's to failures in + the ErrorT part of GhcModT on `liftIO`. + * Make `loadSymbolDb` polimorphic in the return types's monad. + * Add `hoistGhcModT` to Language.Haskell.GhcMod.Internal + * Fix `check` command for modules using `-XPatternSynonyms` + * Merge #364, Support cabal configuration flags 2014-08-29 v5.0.1.2 - * Merge #345, Try fixing duplicate errors - * Merge #344, elisp: Use advice to check syntax on save-buffer - * Merge #341, support `browse -d` in ghc-modi - * Merge #352, elisp: Fix C-u accidentally getting turned into a - prefix command + * Merge #345, Try fixing duplicate errors + * Merge #344, elisp: Use advice to check syntax on save-buffer + * Merge #341, support `browse -d` in ghc-modi + * Merge #352, elisp: Fix C-u accidentally getting turned into a + prefix command 2014-08-24 v5.0.1.1 - * Fix CaseSplitting faliure when using "fancy types" (see #336) - * Print error information in "spec" test suite when using `extract` + * Fix CaseSplitting faliure when using "fancy types" (see #336) + * Print error information in "spec" test suite when using `extract` 2014-08-20 v5.0.1 - * Fix missing file in "Data-Files" + * Fix missing file in "Data-Files" 2014-08-20 v5.0.0 * ghc-mod consumes much less memory than ghc-mod-4.1. diff --git a/Data/Binary/Generic.hs b/Data/Binary/Generic.hs deleted file mode 100644 --- a/Data/Binary/Generic.hs +++ /dev/null @@ -1,134 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP, FlexibleInstances, KindSignatures, - ScopedTypeVariables, TypeOperators, TypeSynonymInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Binary.Generic --- Copyright : Bryan O'Sullivan --- License : BSD3-style (see LICENSE) --- --- Maintainer : Bryan O'Sullivan --- Stability : unstable --- Portability : Only works with GHC 7.2 and newer --- --- Instances for supporting GHC generics. --- ------------------------------------------------------------------------------ -module Data.Binary.Generic where - -import Control.Applicative -import Data.Binary -import Data.Bits -import GHC.Generics -import Prelude - -class GGBinary f where - ggput :: f t -> Put - ggget :: Get (f t) - --- Type without constructors -instance GGBinary V1 where - ggput _ = return () - ggget = return undefined - --- Constructor without arguments -instance GGBinary U1 where - ggput U1 = return () - ggget = return U1 - --- Product: constructor with parameters -instance (GGBinary a, GGBinary b) => GGBinary (a :*: b) where - ggput (x :*: y) = ggput x >> ggput y - ggget = (:*:) <$> ggget <*> ggget - --- Metadata (constructor name, etc) -instance GGBinary a => GGBinary (M1 i c a) where - ggput = ggput . unM1 - ggget = M1 <$> ggget - --- Constants, additional parameters, and rank-1 recursion -instance Binary a => GGBinary (K1 i a) where - ggput = put . unK1 - ggget = K1 <$> get - --- Borrowed from the cereal package. - --- The following GGBinary instance for sums has support for serializing --- types with up to 2^64-1 constructors. It will use the minimal --- number of bytes needed to encode the constructor. For example when --- a type has 2^8 constructors or less it will use a single byte to --- encode the constructor. If it has 2^16 constructors or less it will --- use two bytes, and so on till 2^64-1. - -#define GUARD(WORD) (size - 1) <= fromIntegral (maxBound :: WORD) -#define PUTSUM(WORD) GUARD(WORD) = putSum (0 :: WORD) (fromIntegral size) -#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 - where - size = unTagged (sumSize :: Tagged (a :+: b) Word64) - {-# INLINE ggput #-} - - ggget | GETSUM(Word8) | GETSUM(Word16) | GETSUM(Word32) | GETSUM(Word64) - | otherwise = sizeError "decode" size - where - size = unTagged (sumSize :: Tagged (a :+: b) Word64) - {-# INLINE ggget #-} - -sizeError :: Show size => String -> size -> error -sizeError s size = - error $ "Can't " ++ s ++ " a type with " ++ show size ++ " constructors" - ------------------------------------------------------------------------- - -checkGetSum :: (Ord word, Num word, Bits word, GSum f) - => word -> word -> Get (f a) -checkGetSum size code | code < size = getSum code size - | otherwise = fail "Unknown encoding for constructor" -{-# INLINE checkGetSum #-} - -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 - getSum !code !size | code < sizeL = L1 <$> getSum code sizeL - | otherwise = R1 <$> getSum (code - sizeL) sizeR - where - sizeL = size `shiftR` 1 - sizeR = size - sizeL - {-# INLINE getSum #-} - - putSum !code !size s = case s of - L1 x -> putSum code sizeL x - R1 x -> putSum (code + sizeL) sizeR x - where - sizeL = size `shiftR` 1 - sizeR = size - sizeL - {-# INLINE putSum #-} - -instance GGBinary a => GSum (C1 c a) where - getSum _ _ = ggget - {-# INLINE getSum #-} - - putSum !code _ x = put code *> ggput x - {-# INLINE putSum #-} - ------------------------------------------------------------------------- - -class SumSize f where - sumSize :: Tagged f Word64 - -newtype Tagged (s :: * -> *) b = Tagged {unTagged :: b} - -instance (SumSize a, SumSize b) => SumSize (a :+: b) where - sumSize = Tagged $ unTagged (sumSize :: Tagged a Word64) + - unTagged (sumSize :: Tagged b Word64) - -instance SumSize (C1 c a) where - sumSize = Tagged 1 diff --git a/GhcMod.hs b/GhcMod.hs new file mode 100644 --- /dev/null +++ b/GhcMod.hs @@ -0,0 +1,92 @@ +-- | The ghc-mod library. + +module GhcMod ( + -- * Cradle + Cradle(..) + , Project(..) + , findCradle + -- * Options + , Options(..) + , LineSeparator(..) + , OutputStyle(..) + , FileMapping(..) + , defaultOptions + -- * Logging + , GmLogLevel + , increaseLogLevel + , decreaseLogLevel + , gmSetLogLevel + , gmLog + -- * Types + , ModuleString + , Expression(..) + , GhcPkgDb + , Symbol + , SymbolDb + , GhcModError(..) + -- * Monad Types + , GhcModT + , IOish + -- * Monad utilities + , runGhcModT + , withOptions + , dropSession + -- * 'GhcMod' utilities + , boot + , browse + , check + , checkSyntax + , debugInfo + , componentInfo + , expandTemplate + , info + , lint + , pkgDoc + , rootInfo + , types + , test + , splits + , sig + , refine + , auto + , modules + , languages + , flags + , findSymbol + , lookupSymbol + , dumpSymbol + -- * SymbolDb + , loadSymbolDb + , isOutdated + -- * Output + , gmPutStr + , gmErrStr + , gmPutStrLn + , gmErrStrLn + -- * FileMapping + , loadMappedFile + , loadMappedFileSource + , unloadMappedFile + ) where + +import GhcMod.Exe.Boot +import GhcMod.Exe.Browse +import GhcMod.Exe.CaseSplit +import GhcMod.Exe.Check +import GhcMod.Exe.Debug +import GhcMod.Exe.FillSig +import GhcMod.Exe.Find +import GhcMod.Exe.Flag +import GhcMod.Exe.Info +import GhcMod.Exe.Lang +import GhcMod.Exe.Lint +import GhcMod.Exe.Modules +import GhcMod.Exe.PkgDoc +import GhcMod.Exe.Test +import GhcMod.Cradle +import GhcMod.FileMapping +import GhcMod.Logging +import GhcMod.Monad +import GhcMod.Output +import GhcMod.Target +import GhcMod.Types diff --git a/GhcMod/Exe/Boot.hs b/GhcMod/Exe/Boot.hs new file mode 100644 --- /dev/null +++ b/GhcMod/Exe/Boot.hs @@ -0,0 +1,29 @@ +module GhcMod.Exe.Boot where + +import Control.Applicative +import Prelude + +import GhcMod.Exe.Browse +import GhcMod.Exe.Flag +import GhcMod.Exe.Lang +import GhcMod.Exe.Modules +import GhcMod.Monad +import 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 defaultBrowseOpts) preBrowsedModules] + +preBrowsedModules :: [String] +preBrowsedModules = [ + "Prelude" + , "Control.Applicative" + , "Control.Exception" + , "Control.Monad" + , "Data.Char" + , "Data.List" + , "Data.Maybe" + , "System.IO" + ] diff --git a/GhcMod/Exe/Browse.hs b/GhcMod/Exe/Browse.hs new file mode 100644 --- /dev/null +++ b/GhcMod/Exe/Browse.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE CPP #-} +module GhcMod.Exe.Browse ( + browse, + BrowseOpts(..) + ) where + +import Safe +import Control.Applicative +import Control.Exception (SomeException(..)) +import Data.Char +import Data.List +import Data.Maybe +import FastString +import GHC +import HscTypes +import qualified GHC as G +import GhcMod.Convert +import GhcMod.Doc (showPage, styleUnqualified) +import GhcMod.Gap as Gap +import GhcMod.Types +import GhcMod.Monad +import GhcMod.Logging +import Name (getOccString) +import Outputable +import TyCon (isAlgTyCon) +import Type (dropForAlls, splitFunTy_maybe, mkFunTy, isPredTy) +import Exception (ExceptionMonad, ghandle) +import Prelude +#if __GLASGOW_HASKELL__ >= 800 +import PatSyn (pprPatSynType) +#endif + +---------------------------------------------------------------- + +-- | Getting functions, classes, etc from a module. +browse :: forall m. IOish m + => BrowseOpts -- ^ Configuration parameters + -> String -- ^ A module name. (e.g. \"Data.List\", "base:Prelude") + -> GhcModT m String +browse opts pkgmdl = do + convert' . sort =<< go + where + -- TODO: Add API to Gm.Target to check if module is home module without + -- bringing up a GHC session as well then this can be made a lot cleaner + go = ghandle (\ex@(SomeException _) -> logException ex >> return []) $ do + goPkgModule `G.gcatch` (\(SomeException _) -> goHomeModule) + + logException ex = + gmLog GmException "browse" $ showToDoc ex + + goPkgModule = do + runGmPkgGhc $ + processExports opts =<< tryModuleInfo =<< G.findModule mdlname mpkgid + + goHomeModule = runGmlT [Right mdlname] $ do + processExports opts =<< tryModuleInfo =<< G.findModule mdlname Nothing + + tryModuleInfo m = fromJustNote "browse, tryModuleInfo" <$> G.getModuleInfo m + + (mpkg, mdl) = splitPkgMdl pkgmdl + mdlname = G.mkModuleName mdl + mpkgid = mkFastString <$> mpkg + +-- | +-- +-- >>> splitPkgMdl "base:Prelude" +-- (Just "base","Prelude") +-- >>> splitPkgMdl "Prelude" +-- (Nothing,"Prelude") +splitPkgMdl :: String -> (Maybe String,String) +splitPkgMdl pkgmdl = + case break (==':') pkgmdl of + (mdl, "") -> (Nothing, mdl) + (pkg, _:mdl) -> (Just pkg, mdl) + +-- Haskell 2010: +-- small -> ascSmall | uniSmall | _ +-- ascSmall -> a | b | ... | z +-- uniSmall -> any Unicode lowercase letter +-- varid -> (small {small | large | digit | ' }) + +isNotOp :: String -> Bool +isNotOp (h:_) = isAlpha h || (h == '_') +isNotOp _ = error "isNotOp" + +processExports :: (G.GhcMonad m, MonadIO m, ExceptionMonad m) + => BrowseOpts -> ModuleInfo -> m [String] +processExports opt minfo = do + let + removeOps + | optBrowseOperators opt = id + | otherwise = filter (isNotOp . getOccString) + mapM (showExport opt minfo) $ removeOps $ G.modInfoExports minfo + +showExport :: forall m. (G.GhcMonad m, MonadIO m, ExceptionMonad m) + => BrowseOpts -> ModuleInfo -> Name -> m String +showExport opt minfo e = do + mtype' <- mtype + return $ concat $ catMaybes [mqualified, Just $ formatOp $ getOccString e, mtype'] + where + mqualified = (G.moduleNameString (G.moduleName $ G.nameModule e) ++ ".") `justIf` optBrowseQualified opt + mtype :: m (Maybe String) + mtype + | 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 + 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" + | isNotOp nm = nm + | otherwise = "(" ++ nm ++ ")" + inOtherModule :: Name -> m (Maybe TyThing) + inOtherModule nm = do + G.getModuleInfo (G.nameModule nm) >> G.lookupGlobalName nm + justIf :: a -> Bool -> Maybe a + justIf x True = Just x + justIf _ False = Nothing + +showThing :: DynFlags -> TyThing -> Maybe String +showThing dflag tything = showThing' dflag (fromTyThing tything) + +showThing' :: DynFlags -> GapThing -> Maybe String +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 +formatType dflag a = showOutputable dflag (removeForAlls a) + +tyType :: TyCon -> Maybe String +tyType typ + | isAlgTyCon typ + && not (G.isNewTyCon typ) + && not (G.isClassTyCon typ) = Just "data" + | G.isNewTyCon typ = Just "newtype" + | G.isClassTyCon typ = Just "class" + | Gap.isSynTyCon typ = Just "type" + | otherwise = Nothing + +removeForAlls :: Type -> Type +removeForAlls ty = removeForAlls' ty' tty' + where + ty' = dropForAlls ty + tty' = splitFunTy_maybe ty' + +removeForAlls' :: Type -> Maybe (Type, Type) -> Type +removeForAlls' ty Nothing = ty +removeForAlls' ty (Just (pre, ftype)) + | isPredTy pre = mkFunTy pre (dropForAlls ftype) + | otherwise = ty + +showOutputable :: Outputable a => DynFlags -> a -> String +showOutputable dflag = unwords . lines . showPage dflag styleUnqualified . ppr diff --git a/GhcMod/Exe/CaseSplit.hs b/GhcMod/Exe/CaseSplit.hs new file mode 100644 --- /dev/null +++ b/GhcMod/Exe/CaseSplit.hs @@ -0,0 +1,261 @@ +{-# LANGUAGE CPP #-} + +module GhcMod.Exe.CaseSplit ( + splits + ) where + +import Data.List (find, intercalate) +import Data.Maybe (isJust) +import qualified Data.Text as T +import qualified Data.Text.IO as T (readFile) +import System.FilePath +import Prelude + +import qualified DataCon as Ty +import GHC (GhcMonad, LPat, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L)) +import qualified GHC as G +import Outputable (PprStyle) +import qualified TyCon as Ty +import qualified Type as Ty +import Exception + +import GhcMod.Convert +import GhcMod.DynFlags +import qualified GhcMod.Gap as Gap +import GhcMod.Monad +import GhcMod.SrcUtils +import GhcMod.Doc +import GhcMod.Logging +import GhcMod.Types +import GhcMod.Utils (withMappedFile) +import GhcMod.FileMapping (fileModSummaryWithMapping) +import Control.DeepSeq + +---------------------------------------------------------------- +-- CASE SPLITTING +---------------------------------------------------------------- + +data SplitInfo = SplitInfo G.Name SrcSpan (SrcSpan, Type) [SrcSpan] + | TySplitInfo G.Name SrcSpan (SrcSpan, Ty.Kind) +data SplitToTextInfo = SplitToTextInfo { sVarName :: String + , sBindingSpan :: SrcSpan + , sVarSpan :: SrcSpan + , sTycons :: [String] + } + +-- | Splitting a variable in a equation. +splits :: IOish m + => FilePath -- ^ A target file. + -> Int -- ^ Line number. + -> Int -- ^ Column number. + -> GhcModT m String +splits file lineNo colNo = + ghandle handler $ runGmlT' [Left file] deferErrors $ do + oopts <- outputOpts + crdl <- cradle + style <- getStyle + dflag <- G.getSessionDynFlags + modSum <- fileModSummaryWithMapping (cradleCurrentDir crdl file) + 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) + where + handler (SomeException ex) = do + gmLog GmException "splits" $ + text "" $$ nest 4 (showToDoc ex) + emptyResult =<< outputOpts + +---------------------------------------------------------------- +-- a. Code for getting the information of the variable + +getSrcSpanTypeForSplit :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SplitInfo) +getSrcSpanTypeForSplit modSum lineNo colNo = do + fn <- getSrcSpanTypeForFnSplit modSum lineNo colNo + if isJust fn + then return fn + else getSrcSpanTypeForTypeSplit modSum lineNo colNo + +-- Information for a function case split +getSrcSpanTypeForFnSplit :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SplitInfo) +getSrcSpanTypeForFnSplit modSum lineNo colNo = do + p@ParsedModule{pm_parsed_source = _pms} <- G.parseModule modSum + tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p + let varPat = find isPatternVar $ listifySpans tcs (lineNo, colNo) :: Maybe (LPat Id) + match = last $ listifySpans tcs (lineNo, colNo) :: Gap.GLMatchI + case varPat of + Nothing -> return Nothing + Just varPat' -> do + varT <- Gap.getType tcm varPat' -- Finally we get the type of the var + case varT of + Just varT' -> +#if __GLASGOW_HASKELL__ >= 710 + let (L matchL (G.Match _ _ _ (G.GRHSs rhsLs _))) = match +#else + let (L matchL (G.Match _ _ (G.GRHSs rhsLs _))) = match +#endif + in return $ Just (SplitInfo (getPatternVarName varPat') matchL varT' (map G.getLoc rhsLs) ) + _ -> return Nothing + +isPatternVar :: LPat Id -> Bool +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 +getSrcSpanTypeForTypeSplit :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SplitInfo) +getSrcSpanTypeForTypeSplit _modSum _lineNo _colNo = return Nothing + +---------------------------------------------------------------- +-- b. Code for getting the possible constructors + +getTyCons :: DynFlags -> PprStyle -> G.Name -> G.Type -> [String] +getTyCons dflag style name ty | Just (tyCon, _) <- Ty.splitTyConApp_maybe ty = + let name' = showName dflag style name -- Convert name to string + in getTyCon dflag style name' tyCon +getTyCons dflag style name _ = [showName dflag style name] + +-- Write cases for one type +getTyCon :: DynFlags -> PprStyle -> String -> Ty.TyCon -> [String] +-- 1. Non-matcheable type constructors +getTyCon _ _ name tyCon | isNotMatcheableTyCon tyCon = [name] +-- 2. Special cases +-- 2.1. Tuples +getTyCon _ _ name tyCon | Ty.isTupleTyCon tyCon = + let [uniqueDataCon] = Ty.tyConDataCons tyCon + tupleArity = Ty.dataConSourceArity uniqueDataCon + -- Deal with both boxed and unboxed tuples + isUnboxed = Ty.isUnboxedTupleTyCon tyCon + startSign = if isUnboxed then "(#" else "(" + endSign = if isUnboxed then "#)" else ")" + in [ startSign ++ intercalate "," (map (\n -> name ++ show n) [1 .. tupleArity]) ++ endSign ] +-- 3. General case +getTyCon dflag style name tyCon = map (getDataCon dflag style name) (Ty.tyConDataCons tyCon) + +-- These type constructors should not be matched against +isNotMatcheableTyCon :: Ty.TyCon -> Bool +isNotMatcheableTyCon ty = Ty.isPrimTyCon ty -- Primitive types, such as Int# + || Ty.isFunTyCon ty -- Function types + +-- Write case for one constructor +getDataCon :: DynFlags -> PprStyle -> String -> Ty.DataCon -> String +-- 1. Infix constructors +getDataCon dflag style vName dcon | Ty.dataConIsInfix dcon = + let dName = showName dflag style $ Ty.dataConName dcon + in case Ty.dataConSourceArity dcon of + 0 -> dName + 1 -> vName ++ dName + n -> if dName == ":" -- Special case for lists + then vName ++ ":" ++ vName ++ "s" + else newVar vName 1 ++ " " ++ dName ++ " " ++ newVars vName 2 (n-1) +-- 2. Non-record, non-infix syntax +getDataCon dflag style vName dcon | [] <- Ty.dataConFieldLabels dcon = + let dName = showName dflag style $ Ty.dataConName dcon + in if last dName == '#' -- Special case for I#, C# and so on + then vName + else case Ty.dataConSourceArity dcon of + 0 -> dName + _ -> dName ++ " " ++ newVarsSpecialSingleton vName 1 (Ty.dataConSourceArity 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 +newVar :: String -> Int -> String +newVar v n = v ++ show n + +-- Create a list of variables which start with the same prefix +newVars :: String -> Int -> Int -> String +newVars _ _ 0 = "" +newVars v s 1 = newVar v s +newVars v s m = newVar v s ++ " " ++ newVars v (s+1) (m-1) + +-- Create a list of variables which start with the same prefix +-- Special case for a single variable, in which case no number is adjoint +newVarsSpecialSingleton :: String -> Int -> Int -> String +newVarsSpecialSingleton v _ 1 = v +newVarsSpecialSingleton v start n = newVars v start n + +showFieldNames :: DynFlags -> PprStyle -> String -> [G.Name] -> String +showFieldNames _ _ _ [] = "" -- This should never happen +showFieldNames dflag style v (x:xs) = let fName = showName dflag style x + fAcc = fName ++ " = " ++ v ++ "_" ++ fName + in case xs of + [] -> fAcc + _ -> fAcc ++ ", " ++ showFieldNames dflag style v xs + +---------------------------------------------------------------- +-- c. Code for performing the case splitting + +genCaseSplitTextFile :: (MonadIO m, GhcMonad m) => + FilePath -> SplitToTextInfo -> m String +genCaseSplitTextFile file info = liftIO $ do + t <- T.readFile file + return $ getCaseSplitText (T.lines t) info + +getCaseSplitText :: [T.Text] -> SplitToTextInfo -> String +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 + -- The newly generated bindings need to be indented to align with the + -- original binding. + replaced' = head replaced : map (indentBindingTo sBS) (tail replaced) + in T.unpack $ T.intercalate (T.pack "\n") (concat replaced') + +getBindingText :: [T.Text] -> SrcSpan -> [T.Text] +getBindingText t srcSpan = + let Just (sl,sc,el,ec) = Gap.getSrcSpan srcSpan + lines_ = drop (sl - 1) $ take el t + in if sl == el + then -- only one line + [T.drop (sc - 1) $ T.take ec $ head lines_] + else -- several lines + let (first,rest,last_) = (head lines_, tail $ init lines_, last lines_) + in T.drop (sc - 1) first : rest ++ [T.take ec last_] + +srcSpanDifference :: SrcSpan -> SrcSpan -> (Int,Int,Int,Int) +srcSpanDifference b v = + let Just (bsl,bsc,_ ,_) = Gap.getSrcSpan b + Just (vsl,vsc,vel,vec) = Gap.getSrcSpan v + in (vsl - bsl, vsc - bsc, vel - bsl, vec - bsc) -- assume variable in one line + +replaceVarWithTyCon :: [T.Text] -> (Int,Int,Int,Int) -> String -> String -> [T.Text] +replaceVarWithTyCon t (vsl,vsc,_,vec) varname tycon = + let tycon' = if ' ' `elem` tycon || ':' `elem` tycon then "(" ++ tycon ++ ")" else tycon + lengthDiff = length tycon' - length varname + tycon'' = T.pack $ if lengthDiff < 0 then tycon' ++ replicate (-lengthDiff) ' ' else tycon' + spacesToAdd = if lengthDiff < 0 then 0 else lengthDiff + in zipWith (\n line -> if n < vsl + then line -- before variable starts + else if n == vsl + then T.take vsc line `T.append` tycon'' `T.append` T.drop vec line + else T.replicate spacesToAdd (T.pack " ") `T.append` line) + [0 ..] t + +indentBindingTo :: SrcSpan -> [T.Text] -> [T.Text] +indentBindingTo bndLoc binds = + let Just (_,sl,_,_) = Gap.getSrcSpan bndLoc + indent = (T.replicate (sl - 1) (T.pack " ") `T.append`) + in indent (head binds) : tail binds diff --git a/GhcMod/Exe/Check.hs b/GhcMod/Exe/Check.hs new file mode 100644 --- /dev/null +++ b/GhcMod/Exe/Check.hs @@ -0,0 +1,57 @@ +module GhcMod.Exe.Check ( + checkSyntax + , check + , expandTemplate + , expand + ) where + +import Control.Applicative +import Prelude +import GhcMod.DynFlags +import qualified GhcMod.Gap as Gap +import GhcMod.Logger +import GhcMod.Monad + +---------------------------------------------------------------- + +-- | Checking syntax of a target file using GHC. +-- Warnings and errors are returned. +checkSyntax :: IOish m + => [FilePath] -- ^ The target files. + -> GhcModT m String +checkSyntax [] = return "" +checkSyntax files = either id id <$> check files + +---------------------------------------------------------------- + +-- | Checking syntax of a target file using GHC. +-- Warnings and errors are returned. +check :: IOish m + => [FilePath] -- ^ The target files. + -> GhcModT m (Either String String) +check files = + runGmlTWith + (map Left files) + return + ((fmap fst <$>) . withLogger Gap.setNoMaxRelevantBindings) + (return ()) + +---------------------------------------------------------------- + +-- | Expanding Haskell Template. +expandTemplate :: IOish m + => [FilePath] -- ^ The target files. + -> GhcModT m String +expandTemplate [] = return "" +expandTemplate files = either id id <$> expand files + +---------------------------------------------------------------- + +-- | Expanding Haskell Template. +expand :: IOish m => [FilePath] -> GhcModT m (Either String String) +expand files = + runGmlTWith + (map Left files) + return + ((fmap fst <$>) . withLogger (Gap.setDumpSplices . setNoWarningFlags)) + (return ()) diff --git a/GhcMod/Exe/Debug.hs b/GhcMod/Exe/Debug.hs new file mode 100644 --- /dev/null +++ b/GhcMod/Exe/Debug.hs @@ -0,0 +1,182 @@ +module GhcMod.Exe.Debug (debugInfo, rootInfo, componentInfo) where + +import Control.Arrow (first) +import Control.Applicative +import Control.Monad +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Char +import Data.Maybe +import Data.Version +import Data.List.Split +import System.Directory + +import GhcMod.Exe.Internal +import GhcMod.Cradle +import GhcMod.Monad +import GhcMod.Output +import GhcMod.Pretty +import GhcMod.Stack +import GhcMod.Target +import GhcMod.Types +import GhcMod.Utils + +import Paths_ghc_mod (version) + +import Config (cProjectVersion) +import Pretty + +---------------------------------------------------------------- + +-- | Obtaining debug information. +debugInfo :: IOish m => GhcModT m String +debugInfo = do + Options {..} <- options + Cradle {..} <- cradle + + [ghcPath, ghcPkgPath] <- liftIO $ + case cradleProject of + StackProject se -> + catMaybes <$> sequence [getStackGhcPath se, getStackGhcPkgPath se] + _ -> + return ["ghc", "ghc-pkg"] + + cabal <- + case cradleProject of + CabalProject -> cabalDebug ghcPkgPath + StackProject {} -> (++) <$> stackPaths <*> cabalDebug ghcPkgPath + _ -> return [] + + pkgOpts <- packageGhcOptions + + readProc <- gmReadProcess + + ghcVersion <- liftIO $ + dropWhileEnd isSpace <$> readProc ghcPath ["--numeric-version"] "" + + return $ unlines $ + [ "Version: ghc-mod-" ++ showVersion version + , "Library GHC Version: " ++ cProjectVersion + , "System GHC Version: " ++ ghcVersion + , "Root directory: " ++ cradleRootDir + , "Current directory: " ++ cradleCurrentDir + , "GHC Package flags:\n" ++ renderGm (nest 4 $ + fsep $ map text pkgOpts) + , "GHC System libraries: " ++ ghcLibDir + ] ++ cabal + +stackPaths :: IOish m => GhcModT m [String] +stackPaths = do + Cradle { cradleProject = StackProject senv } <- cradle + ghc <- getStackGhcPath senv + ghcPkg <- getStackGhcPkgPath senv + return $ + [ "Stack ghc executable: " ++ show ghc + , "Stack ghc-pkg executable:" ++ show ghcPkg + ] + +cabalDebug :: IOish m => FilePath -> GhcModT m [String] +cabalDebug ghcPkgPath = do + Cradle {..} <- cradle + mcs <- cabalResolvedComponents + let entrypoints = Map.map gmcEntrypoints mcs + graphs = Map.map gmcHomeModuleGraph mcs + 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 ghcPkgPath ["list", "--simple-output"] "" + let cabalPackages = filter ((== ["Cabal"]) . take 1 . splitOn "-") $ splitWhen isSpace packages + + return $ + [ "cabal-install Version: " ++ cabalInstVersion + , "Cabal Library Versions:\n" ++ renderGm (nest 4 $ + fsep $ map text cabalPackages) + , "Cabal file: " ++ show cradleCabalFile + , "Project: " ++ show cradleProject + , "Cabal entrypoints:\n" ++ renderGm (nest 4 $ + mapDoc gmComponentNameDoc smpDoc entrypoints) + , "Cabal components:\n" ++ renderGm (nest 4 $ + mapDoc gmComponentNameDoc graphDoc graphs) + , "GHC Cabal options:\n" ++ renderGm (nest 4 $ + mapDoc gmComponentNameDoc (fsep . map text) opts) + , "GHC search path options:\n" ++ renderGm (nest 4 $ + mapDoc gmComponentNameDoc (fsep . map text) srcOpts) + ] + +componentInfo :: IOish m => [String] -> GhcModT m String +componentInfo ts = do + -- TODO: most of this is copypasta of targetGhcOptions. Factor out more + -- useful function from there. + crdl <- cradle + sefnmn <- Set.fromList `liftM` mapM guessModuleFile ts + mcs <- cabalResolvedComponents + let + mdlcs = moduleComponents mcs `zipMap` Set.toList sefnmn + candidates = findCandidates $ map snd mdlcs + cn = pickComponent candidates + opts <- targetGhcOptions crdl sefnmn + + return $ unlines $ + [ "Matching Components:\n" ++ renderGm (nest 4 $ + alistDoc (either text mnDoc) (setDoc gmComponentNameDoc) mdlcs) + , "Picked Component:\n" ++ renderGm (nest 4 $ + gmComponentNameDoc cn) + , "GHC Cabal options:\n" ++ renderGm (nest 4 $ fsep $ map text opts) + ] + where + zipMap f l = l `zip` (f `map` l) + +guessModuleFile :: MonadIO m => String -> m (Either FilePath ModuleName) +guessModuleFile m + | (isUpper . head .&&. (all $ all $ isAlphaNum .||. (=='.')) . splitOn ".") m = + return $ Right $ mkModuleName m + where + infixr 1 .||. + infixr 2 .&&. + (.||.) = liftA2 (||) + (.&&.) = liftA2 (&&) + +guessModuleFile str = Left `liftM` liftIO (canonFilePath str) + +graphDoc :: GmModuleGraph -> Doc +graphDoc GmModuleGraph{..} = + mapDoc mpDoc smpDoc' gmgGraph + where + smpDoc' smp = vcat $ map mpDoc' $ Set.toList smp + mpDoc' = text . moduleNameString . mpModule + +setDoc :: (a -> Doc) -> Set.Set a -> Doc +setDoc f s = vcat $ map f $ Set.toList s + +smpDoc :: Set.Set ModulePath -> Doc +smpDoc smp = setDoc mpDoc smp + +mpDoc :: ModulePath -> Doc +mpDoc (ModulePath mn fn) = text (moduleNameString mn) <+> parens (text fn) + +mnDoc :: ModuleName -> Doc +mnDoc mn = text (moduleNameString mn) + +alistDoc :: Ord k => (k -> Doc) -> (a -> Doc) -> [(k, a)] -> Doc +alistDoc fk fa alist = mapDoc fk fa (Map.fromList alist) + +mapDoc :: (k -> Doc) -> (a -> Doc) -> Map.Map k a -> Doc +mapDoc kd ad m = vcat $ + map (uncurry ($+$)) $ map (first kd) $ Map.toList $ Map.map (nest 4 . ad) m +---------------------------------------------------------------- + +-- | Obtaining root information. +rootInfo :: forall m. (IOish m, GmOut m, GmEnv m) => m String +rootInfo = do + crdl <- findCradleNoLog =<< (optPrograms <$> options) + liftIO $ cleanupCradle crdl + return $ cradleRootDir crdl ++ "\n" diff --git a/GhcMod/Exe/FillSig.hs b/GhcMod/Exe/FillSig.hs new file mode 100644 --- /dev/null +++ b/GhcMod/Exe/FillSig.hs @@ -0,0 +1,590 @@ +{-# LANGUAGE CPP, MultiParamTypeClasses, FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} + +module GhcMod.Exe.FillSig ( + sig + , refine + , auto + ) where + +import Data.Char (isSymbol) +import Data.Function (on) +import Data.Functor +import Data.List (find, nub, sortBy) +import qualified Data.Map as M +import Data.Maybe (catMaybes) +import Prelude + +import Exception (ghandle, SomeException(..)) +import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, + SrcSpan, Type, GenLocated(L)) +import Pretty (($$), text, nest) +import qualified GHC as G +import qualified Name as G +import Outputable (PprStyle) +import qualified Type as Ty +import qualified HsBinds as Ty +import qualified Class as Ty +import qualified Var as Ty +import qualified HsPat as Ty +import qualified Language.Haskell.Exts as HE +import Djinn.GHC + +import qualified GhcMod.Gap as Gap +import GhcMod.Convert +import GhcMod.DynFlags +import GhcMod.Monad +import GhcMod.SrcUtils +import GhcMod.Logging (gmLog) +import GhcMod.Pretty (showToDoc) +import GhcMod.Doc +import GhcMod.Types +import GhcMod.FileMapping (fileModSummaryWithMapping) + +#if __GLASGOW_HASKELL__ >= 710 +import GHC (unLoc) +#endif + +---------------------------------------------------------------- +-- INTIAL CODE FROM FUNCTION OR INSTANCE SIGNATURE +---------------------------------------------------------------- + +-- Possible signatures we can find: function or instance +data SigInfo + = Signature SrcSpan [G.RdrName] (G.HsType G.RdrName) + | InstanceDecl SrcSpan G.Class + | TyFamDecl SrcSpan G.RdrName TyFamType {- True if closed -} [G.RdrName] + +-- Signature for fallback operation via haskell-src-exts +data HESigInfo + = HESignature HE.SrcSpan [HE.Name HE.SrcSpanInfo] (HE.Type HE.SrcSpanInfo) + | HEFamSignature + HE.SrcSpan + TyFamType + (HE.Name HE.SrcSpanInfo) + [HE.Name HE.SrcSpanInfo] + +data TyFamType = Closed | Open | Data +initialTyFamString :: TyFamType -> (String, String) +initialTyFamString Closed = ("instance", "") +initialTyFamString Open = ("function", "type instance ") +initialTyFamString Data = ("function", "data instance ") + +-- | Create a initial body from a signature. +sig :: IOish m + => FilePath -- ^ A target file. + -> Int -- ^ Line number. + -> Int -- ^ Column number. + -> GhcModT m String +sig file lineNo colNo = + runGmlT' [Left file] deferErrors $ ghandle fallback $ do + oopts <- outputOpts + style <- getStyle + dflag <- G.getSessionDynFlags + modSum <- fileModSummaryWithMapping file + whenFound oopts (getSignature modSum lineNo colNo) $ \s -> + case s of + Signature loc names ty -> + ("function", fourInts loc, map (initialBody dflag style ty) names) + + InstanceDecl loc cls -> + let body x = initialBody dflag style (G.idType x) x + in ("instance", fourInts loc, body `map` Ty.classMethods cls) + + TyFamDecl loc name flavour vars -> + let (rTy, initial) = initialTyFamString flavour + body = initialFamBody dflag style name vars + in (rTy, fourInts loc, [initial ++ body]) + where + fallback (SomeException _) = do + oopts <- outputOpts + -- Code cannot be parsed by ghc module + -- Fallback: try to get information via haskell-src-exts + whenFound oopts (getSignatureFromHE file lineNo colNo) $ \x -> case x of + HESignature loc names ty -> + ("function", fourIntsHE loc, map (initialBody undefined undefined ty) names) + HEFamSignature loc flavour name vars -> + let (rTy, initial) = initialTyFamString flavour + in (rTy, fourIntsHE loc, [initial ++ initialFamBody undefined undefined name vars]) + +---------------------------------------------------------------- +-- a. Code for getting the information + +-- Get signature from ghc parsing and typechecking +getSignature :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SigInfo) +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__ >= 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)))] -> +#endif + -- We found a type signature + return $ Just $ Signature loc (map G.unLoc names) ty + [L _ (G.InstD _)] -> do + -- We found an instance declaration + TypecheckedModule{tm_renamed_source = Just tcs + ,tm_checked_module_info = minfo} <- G.typecheckModule p + let lst = listifyRenamedSpans tcs (lineNo, colNo) + case Gap.getClass lst of + Just (clsName,loc) -> obtainClassInfo minfo clsName loc + _ -> return Nothing +#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 +#else + [L loc (G.TyClD (G.TyFamily info (L _ name) vars _))] -> do +#endif +#if __GLASGOW_HASKELL__ >= 708 + let flavour = case info of + G.ClosedTypeFamily _ -> Closed + G.OpenTypeFamily -> Open + G.DataFamily -> Data +#else + let flavour = case info of -- Closed type families where introduced in GHC 7.8 + G.TypeFamily -> Open + G.DataFamily -> Data +#endif + +#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 +#elif __GLASGOW_HASKELL__ >= 706 + getTyFamVarName x = case x of + L _ (G.UserTyVar n) -> n + L _ (G.KindedTyVar n _) -> n +#else + getTyFamVarName x = case x of -- In GHC 7.4, HsTyVarBndr's have an extra arg + L _ (G.UserTyVar n _) -> n + L _ (G.KindedTyVar n _ _) -> n +#endif + in return $ Just (TyFamDecl loc name flavour $ map getTyFamVarName vars) + _ -> return Nothing + where obtainClassInfo :: GhcMonad m => G.ModuleInfo -> G.Name -> SrcSpan -> m (Maybe SigInfo) + obtainClassInfo minfo clsName loc = do + tyThing <- G.modInfoLookupName minfo clsName + return $ do Ty.ATyCon clsCon <- tyThing -- In Maybe + cls <- G.tyConClass_maybe clsCon + return $ InstanceDecl loc cls + +-- Get signature from haskell-src-exts +getSignatureFromHE :: (MonadIO m, GhcMonad m) => + FilePath -> Int -> Int -> m (Maybe HESigInfo) +getSignatureFromHE file lineNo colNo = do + presult <- liftIO $ HE.parseFile file + return $ case presult of + HE.ParseOk (HE.Module _ _ _ _ mdecls) -> do + decl <- find (typeSigInRangeHE lineNo colNo) mdecls + case decl of + HE.TypeSig (HE.SrcSpanInfo s _) names ty -> + return $ HESignature s names ty + + HE.TypeFamDecl (HE.SrcSpanInfo s _) declHead _ _ -> + let (name, tys) = dHeadTyVars declHead in + return $ HEFamSignature s Open name (map cleanTyVarBind tys) + + HE.DataFamDecl (HE.SrcSpanInfo s _) _ declHead _ -> + let (name, tys) = dHeadTyVars declHead in + return $ HEFamSignature s Open name (map cleanTyVarBind tys) + _ -> fail "" + _ -> Nothing + where cleanTyVarBind (HE.KindedVar _ n _) = n + cleanTyVarBind (HE.UnkindedVar _ n) = n + +#if MIN_VERSION_haskell_src_exts(1,16,0) + dHeadTyVars :: HE.DeclHead l -> (HE.Name l, [HE.TyVarBind l]) + dHeadTyVars (HE.DHead _ name) = (name, []) + dHeadTyVars (HE.DHApp _ r ty) = (++[ty]) `fmap` (dHeadTyVars r) + dHeadTyVars (HE.DHInfix _ ty name) = (name, [ty]) + dHeadTyVars (HE.DHParen _ r) = dHeadTyVars r +#else + dHeadTyVars :: HE.DeclHead l -> (HE.Name l, [HE.TyVarBind l]) + dHeadTyVars (HE.DHead _ n tys) = (n, tys) +#endif + +---------------------------------------------------------------- +-- b. Code for generating initial code + +-- A list of function arguments, and whether they are functions or normal +-- arguments is built from either a function signature or an instance signature +data FnArg = FnArgFunction | FnArgNormal | FnExplicitName String + +initialBody :: FnArgsInfo ty name => DynFlags -> PprStyle -> ty -> name -> String +initialBody dflag style ty name = + initialBody' (getFnName dflag style name) (getFnArgs ty) + +initialBody' :: String -> [FnArg] -> String +initialBody' fname args = + initialHead fname args ++ " = " ++ n ++ "_body" + where n = if isSymbolName fname then "" else '_':fname + +initialFamBody :: FnArgsInfo ty name + => DynFlags -> PprStyle -> name -> [name] -> String +initialFamBody dflag style name args = + initialHead fnName fnArgs ++ " = ()" + where fnName = getFnName dflag style name + fnArgs = map (FnExplicitName . getFnName dflag style) args + +initialHead :: String -> [FnArg] -> String +initialHead fname args = + case initialBodyArgs args infiniteVars infiniteFns of + [] -> fname + arglist -> if isSymbolName fname + then head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist) + else fname ++ " " ++ unwords arglist + +initialBodyArgs :: [FnArg] -> [String] -> [String] -> [String] +initialBodyArgs [] _ _ = [] +initialBodyArgs (FnArgFunction:xs) vs (f:fs) = f : initialBodyArgs xs vs fs +initialBodyArgs (FnArgNormal:xs) (v:vs) fs = v : initialBodyArgs xs vs fs +initialBodyArgs (FnExplicitName n:xs) vs fs = n : initialBodyArgs xs vs fs +initialBodyArgs _ _ _ = + error "initialBodyArgs: This should never happen" -- Lists are infinite + +initialHead1 :: String -> [FnArg] -> [String] -> String +initialHead1 fname args elts = + case initialBodyArgs1 args elts of + [] -> fname + arglist + | isSymbolName fname -> + head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist) + | otherwise -> + fname ++ " " ++ unwords arglist + +initialBodyArgs1 :: [FnArg] -> [String] -> [String] +initialBodyArgs1 args elts = take (length args) elts + +-- Getting the initial body of function and instances differ +-- This is because for functions we only use the parsed file +-- (so the full file doesn't have to be type correct) +-- but for instances we need to get information about the class + +class FnArgsInfo ty name | ty -> name, name -> ty where + getFnName :: DynFlags -> PprStyle -> name -> String + getFnArgs :: ty -> [FnArg] + +instance FnArgsInfo (G.HsType G.RdrName) (G.RdrName) where + getFnName dflag style name = showOccName dflag style $ Gap.occName name +#if __GLASGOW_HASKELL__ >= 800 + getFnArgs (G.HsForAllTy _ (L _ iTy)) +#elif __GLASGOW_HASKELL__ >= 710 + getFnArgs (G.HsForAllTy _ _ _ _ (L _ iTy)) +#else + getFnArgs (G.HsForAllTy _ _ _ (L _ iTy)) +#endif + = getFnArgs iTy + + getFnArgs (G.HsParTy (L _ iTy)) = getFnArgs iTy + 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__ >= 800 + (G.HsForAllTy _ (L _ iTy)) -> +#elif __GLASGOW_HASKELL__ >= 710 + (G.HsForAllTy _ _ _ _ (L _ iTy)) -> +#else + (G.HsForAllTy _ _ _ (L _ iTy)) -> +#endif + fnarg iTy + + (G.HsParTy (L _ iTy)) -> fnarg iTy + (G.HsFunTy _ _) -> True + _ -> False + getFnArgs _ = [] + +instance FnArgsInfo (HE.Type HE.SrcSpanInfo) (HE.Name HE.SrcSpanInfo) where + getFnName _ _ (HE.Ident _ s) = s + getFnName _ _ (HE.Symbol _ s) = s + getFnArgs (HE.TyForall _ _ _ iTy) = getFnArgs iTy + getFnArgs (HE.TyParen _ iTy) = getFnArgs iTy + getFnArgs (HE.TyFun _ lTy rTy) = + (if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy + where fnarg ty = case ty of + (HE.TyForall _ _ _ iTy) -> fnarg iTy + (HE.TyParen _ iTy) -> fnarg iTy + (HE.TyFun _ _ _) -> True + _ -> False + getFnArgs _ = [] + +instance FnArgsInfo Type Id where + getFnName dflag style method = showOccName dflag style $ G.getOccName method + getFnArgs = getFnArgs' . Ty.dropForAlls + where getFnArgs' ty | Just (lTy,rTy) <- Ty.splitFunTy_maybe ty = + maybe (if Ty.isPredTy lTy then getFnArgs' rTy else FnArgNormal:getFnArgs' rTy) + (\_ -> FnArgFunction:getFnArgs' rTy) + $ Ty.splitFunTy_maybe lTy + + getFnArgs' ty | Just (_,iTy) <- Ty.splitForAllTy_maybe ty = + getFnArgs' iTy + + getFnArgs' _ = [] + +-- Infinite supply of variable and function variable names +infiniteVars, infiniteFns :: [String] +infiniteVars = infiniteSupply ["x","y","z","t","u","v","w"] +infiniteFns = infiniteSupply ["f","g","h"] +infiniteSupply :: [String] -> [String] +infiniteSupply initialSupply = + initialSupply ++ concatMap (\n -> map (\v -> v ++ show n) initialSupply) + ([1 .. ] :: [Integer]) + +-- Check whether a String is a symbol name +isSymbolName :: String -> Bool +isSymbolName (c:_) = c `elem` "!#$%&*+./<=>?@\\^|-~" || isSymbol c +isSymbolName [] = error "This should never happen" + + +---------------------------------------------------------------- +-- REWRITE A HOLE / UNDEFINED VIA A FUNCTION +---------------------------------------------------------------- + +refine :: IOish m + => FilePath -- ^ A target file. + -> Int -- ^ Line number. + -> Int -- ^ Column number. + -> Expression -- ^ A Haskell expression. + -> GhcModT m String +refine file lineNo colNo (Expression expr) = + ghandle handler $ + runGmlT' [Left file] deferErrors $ do + oopts <- outputOpts + style <- getStyle + dflag <- G.getSessionDynFlags + modSum <- fileModSummaryWithMapping file + p <- G.parseModule modSum + tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p + ety <- G.exprType expr + whenFound oopts (findVar dflag style tcm tcs lineNo colNo) $ + \(loc, name, rty, paren) -> + let eArgs = getFnArgs ety + rArgs = getFnArgs rty + diffArgs' = length eArgs - length rArgs + diffArgs = if diffArgs' < 0 then 0 else diffArgs' + iArgs = take diffArgs eArgs + txt = initialHead1 expr iArgs (infinitePrefixSupply name) + in (fourInts loc, doParen paren txt) + where + handler (SomeException ex) = do + gmLog GmException "refining" $ + text "" $$ nest 4 (showToDoc ex) + emptyResult =<< outputOpts + +-- Look for the variable in the specified position +findVar + :: GhcMonad m + => DynFlags + -> PprStyle + -> G.TypecheckedModule + -> G.TypecheckedSource + -> Int + -> Int + -> 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) + | name == "undefined" || head name == '_' -> + return $ Just (s, name, typ, b) + where + name = getFnName dflag style i + -- If inside an App, we need parenthesis + b = case others of + L _ (G.HsApp (L _ a1) (L _ a2)):_ -> + isSearchedVar i a1 || isSearchedVar i a2 + _ -> False + _ -> return Nothing + _ -> return Nothing + where + lst :: [G.LHsExpr Id] + lst = sortBy (cmp `on` G.getLoc) $ listifySpans tcs (lineNo, colNo) + +infinitePrefixSupply :: String -> [String] +infinitePrefixSupply "undefined" = repeat "undefined" +infinitePrefixSupply p = map (\n -> p ++ "_" ++ show n) ([1 ..] :: [Integer]) + +doParen :: Bool -> String -> String +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 + + +---------------------------------------------------------------- +-- REFINE AUTOMATICALLY +---------------------------------------------------------------- + +auto :: IOish m + => FilePath -- ^ A target file. + -> Int -- ^ Line number. + -> Int -- ^ Column number. + -> GhcModT m String +auto file lineNo colNo = + ghandle handler $ runGmlT' [Left file] deferErrors $ do + oopts <- outputOpts + style <- getStyle + dflag <- G.getSessionDynFlags + modSum <- fileModSummaryWithMapping file + p <- G.parseModule modSum + tcm@TypecheckedModule { + tm_typechecked_source = tcs + , tm_checked_module_info = minfo + } <- G.typecheckModule p + whenFound' oopts (findVar dflag style tcm tcs lineNo colNo) $ \(loc, _name, rty, paren) -> do + topLevel <- getEverythingInTopLevel minfo + let (f,pats) = getPatsForVariable tcs (lineNo,colNo) + -- Remove self function to prevent recursion, and id to trim + -- cases + filterFn (n,_) = let funName = G.getOccString n + recName = G.getOccString (G.getName f) + in funName `notElem` recName:notWantedFuns + -- Find without using other functions in top-level + localBnds = M.unions $ + map (\(L _ pat) -> getBindingsForPat pat) pats + lbn = filter filterFn (M.toList localBnds) + djinnsEmpty <- djinn True (Just minfo) lbn rty (Max 10) 100000 + let -- Find with the entire top-level + almostEnv = M.toList $ M.union localBnds topLevel + env = filter filterFn almostEnv + djinns <- djinn True (Just minfo) env rty (Max 10) 100000 + return ( fourInts loc + , map (doParen paren) $ nub (djinnsEmpty ++ djinns)) + where + handler (SomeException ex) = do + gmLog GmException "auto-refining" $ + text "" $$ nest 4 (showToDoc ex) + emptyResult =<< outputOpts + +-- Functions we do not want in completions +notWantedFuns :: [String] +notWantedFuns = ["id", "asTypeOf", "const"] + +-- Get all things defined in top-level +getEverythingInTopLevel :: GhcMonad m => G.ModuleInfo -> m (M.Map G.Name Type) +getEverythingInTopLevel m = do + let modInfo = tyThingsToInfo (G.modInfoTyThings m) + topNames = G.modInfoTopLevelScope m + case topNames of + Just topNames' -> do topThings <- mapM G.lookupGlobalName topNames' + let topThings' = catMaybes topThings + topInfo = tyThingsToInfo topThings' + return $ M.union modInfo topInfo + Nothing -> return modInfo + +tyThingsToInfo :: [Ty.TyThing] -> M.Map G.Name Type +tyThingsToInfo [] = M.empty +tyThingsToInfo (G.AnId i : xs) = + M.insert (G.getName i) (Ty.varType i) (tyThingsToInfo xs) +-- Getting information about constructors is not needed +-- because they will be added by djinn-ghc when traversing types +-- #if __GLASGOW_HASKELL__ >= 708 +-- tyThingToInfo (G.AConLike (G.RealDataCon con)) = return [(Ty.dataConName con, Ty.dataConUserType con)] +-- #else +-- tyThingToInfo (G.AConLike con) = return [(Ty.dataConName con, Ty.dataConUserType con)] +-- #endif +tyThingsToInfo (_:xs) = tyThingsToInfo xs + +-- Find the Id of the function and the pattern where the hole is located +getPatsForVariable :: G.TypecheckedSource -> (Int,Int) -> (Id, [Ty.LPat Id]) +getPatsForVariable tcs (lineNo, colNo) = + let (L _ bnd:_) = sortBy (cmp `on` G.getLoc) $ + listifySpans tcs (lineNo, colNo) :: [G.LHsBind Id] + in case bnd of + G.PatBind { Ty.pat_lhs = L ploc pat } -> case pat of + Ty.ConPatIn (L _ i) _ -> (i, [L ploc pat]) + _ -> (error "This should never happen", []) + G.FunBind { Ty.fun_id = L _ funId } -> + let m = sortBy (cmp `on` G.getLoc) $ listifySpans tcs (lineNo, colNo) +#if __GLASGOW_HASKELL__ >= 708 + :: [G.LMatch Id (G.LHsExpr Id)] +#else + :: [G.LMatch Id] +#endif +#if __GLASGOW_HASKELL__ >= 710 + (L _ (G.Match _ pats _ _):_) = m +#else + (L _ (G.Match pats _ _):_) = m +#endif + in (funId, pats) + _ -> (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)) = + M.insert (G.getName a) (Ty.varType a) (getBindingsForPat i) +#if __GLASGOW_HASKELL__ >= 708 +getBindingsForPat (Ty.ListPat l _ _) = + M.unions $ map (\(L _ i) -> getBindingsForPat i) l +#else +getBindingsForPat (Ty.ListPat l _) = + M.unions $ map (\(L _ i) -> getBindingsForPat i) l +#endif +getBindingsForPat (Ty.TuplePat l _ _) = + M.unions $ map (\(L _ i) -> getBindingsForPat i) l +getBindingsForPat (Ty.PArrPat l _) = + M.unions $ map (\(L _ i) -> getBindingsForPat i) l +getBindingsForPat (Ty.ViewPat _ (L _ i) _) = getBindingsForPat i +getBindingsForPat (Ty.SigPatIn (L _ i) _) = getBindingsForPat i +getBindingsForPat (Ty.SigPatOut (L _ i) _) = getBindingsForPat i +getBindingsForPat (Ty.ConPatIn (L _ i) d) = + M.insert (G.getName i) (Ty.varType i) (getBindingsForRecPat d) +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 + unLoc' = unLoc +#else + unLoc' = id +#endif + getBindingsForRecFields [] = M.empty + getBindingsForRecFields (Ty.HsRecField {Ty.hsRecFieldArg = (L _ a)}:fs) = + M.union (getBindingsForPat a) (getBindingsForRecFields fs) diff --git a/GhcMod/Exe/Find.hs b/GhcMod/Exe/Find.hs new file mode 100644 --- /dev/null +++ b/GhcMod/Exe/Find.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE CPP, BangPatterns, TupleSections, DeriveGeneric #-} + +module GhcMod.Exe.Find + ( Symbol + , SymbolDb + , loadSymbolDb + , lookupSymbol + , dumpSymbol + , findSymbol + , lookupSym + , isOutdated + -- * Load 'SymbolDb' asynchronously + , AsyncSymbolDb + , newAsyncSymbolDb + , getAsyncSymbolDb + ) where + +import qualified GHC as G +import FastString +import Module +import OccName +import HscTypes +import Exception + +import GhcMod.Convert +import GhcMod.Gap +import GhcMod.Monad +import GhcMod.Output +import GhcMod.Types +import GhcMod.Utils +import GhcMod.World +import GhcMod.LightGhc + +import Control.Applicative +import Control.DeepSeq +import Control.Monad +import Control.Monad.Trans.Control +import Control.Concurrent + +import Data.List +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 Data.Set (Set) +import qualified Data.Set as S +import GhcMod.PathsAndFiles +import System.Directory +import Prelude + +---------------------------------------------------------------- + +-- | Type of function and operation names. +type Symbol = BS.ByteString +type ModuleNameBS = BS.ByteString + +-- | Database from 'Symbol' to \['ModuleString'\]. +data SymbolDb = SymbolDb + { 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 +isOutdated db = + isOlderThan (sdTimestamp db) <$> timedPackageCaches + +---------------------------------------------------------------- + +-- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\] +-- which will be concatenated. 'loadSymbolDb' is called internally. +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 => String -> SymbolDb -> GhcModT m String +lookupSymbol sym db = convert' $ lookupSym (fastStringToByteString $ mkFastString sym) db + +lookupSym :: Symbol -> SymbolDb -> [ModuleString] +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 + ghcMod <- liftIO ghcModExecutable + readProc <- gmReadProcess' + out <- liftIO $ readProc ghcMod ["--verbose", "error", "dumpsym"] "" + return $!! decode out + +---------------------------------------------------------------- +-- used 'ghc-mod dumpsym' + +-- | Dumps a 'Binary' representation of 'SymbolDb' to stdout +dumpSymbol :: IOish m => GhcModT m () +dumpSymbol = do + ts <- liftIO getCurrentModTime + st <- runGmPkgGhc $ getGlobalSymbolTable + liftIO . LBS.putStr $ encode SymbolDb { + sdTable = st + , sdTimestamp = ts + } + +-- | Check whether given file is older than any file from the given set. +-- Returns True if given file does not exist. +isOlderThan :: ModTime -> [TimedFile] -> Bool +isOlderThan tCache files = + any (tCache <=) $ map tfTime files -- including equal just in case + +-- | Browsing all functions in all system modules. +getGlobalSymbolTable :: (G.GhcMonad m, MonadIO m) + => m (Map Symbol (Set ModuleNameBS)) +getGlobalSymbolTable = + foldM extend M.empty =<< (listVisibleModules <$> G.getSessionDynFlags) + +extend :: (G.GhcMonad m, MonadIO m) + => Map Symbol (Set ModuleNameBS) + -> Module + -> m (Map Symbol (Set ModuleNameBS)) +extend mm mdl = do + hsc_env <- G.getSession + eps <- liftIO $ readIORef $ hsc_EPS hsc_env + modinfo <- liftIO $ unsafeInterleaveIO $ runLightGhc hsc_env $ do + G.getModuleInfo mdl <* liftIO (writeIORef (hsc_EPS hsc_env) eps) + 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 + +---------------------------------------------------------------- + +data AsyncSymbolDb = AsyncSymbolDb (MVar (Either SomeException SymbolDb)) + +asyncLoadSymbolDb :: IOish m + => MVar (Either SomeException SymbolDb) + -> GhcModT m () +asyncLoadSymbolDb mv = void $ + liftBaseWith $ \run -> forkIO $ void $ run $ do + edb <- gtry loadSymbolDb + liftIO $ putMVar mv edb + +newAsyncSymbolDb :: IOish m => GhcModT m AsyncSymbolDb +newAsyncSymbolDb = do + mv <- liftIO newEmptyMVar + asyncLoadSymbolDb mv + return $ AsyncSymbolDb mv + +getAsyncSymbolDb :: forall m. IOish m => AsyncSymbolDb -> GhcModT m SymbolDb +getAsyncSymbolDb (AsyncSymbolDb mv) = do + db <- liftIO $ handleEx <$> takeMVar mv + outdated <- isOutdated db + if outdated + then do + asyncLoadSymbolDb mv + liftIO $ handleEx <$> readMVar mv + else do + liftIO $ putMVar mv $ Right db + return db + where + handleEx edb = + case edb of + Left ex -> throw ex + Right db -> db diff --git a/GhcMod/Exe/Flag.hs b/GhcMod/Exe/Flag.hs new file mode 100644 --- /dev/null +++ b/GhcMod/Exe/Flag.hs @@ -0,0 +1,9 @@ +module GhcMod.Exe.Flag where + +import qualified GhcMod.Gap as Gap +import GhcMod.Convert +import GhcMod.Monad + +-- | Listing of GHC flags, same as @ghc@\'s @--show-options@ with @ghc >= 7.10@. +flags :: IOish m => GhcModT m String +flags = convert' Gap.ghcCmdOptions diff --git a/GhcMod/Exe/Info.hs b/GhcMod/Exe/Info.hs new file mode 100644 --- /dev/null +++ b/GhcMod/Exe/Info.hs @@ -0,0 +1,79 @@ +module GhcMod.Exe.Info ( + info + , types + ) where + +import Data.Function (on) +import Data.List (sortBy) +import System.FilePath +import Exception (ghandle, SomeException(..)) +import GHC (GhcMonad, SrcSpan) +import Prelude +import qualified GHC as G + +import qualified GhcMod.Gap as Gap +import GhcMod.Convert +import GhcMod.Doc +import GhcMod.DynFlags +import GhcMod.Gap +import GhcMod.Logging +import GhcMod.Monad +import GhcMod.SrcUtils +import GhcMod.Types +import GhcMod.Utils (mkRevRedirMapFunc) +import GhcMod.FileMapping (fileModSummaryWithMapping) + +---------------------------------------------------------------- + +-- | Obtaining information of a target expression. (GHCi's info:) +info :: IOish m + => FilePath -- ^ A target file. + -> Expression -- ^ A Haskell expression. + -> GhcModT m String +info file expr = + ghandle handler $ + runGmlT' [Left file] deferErrors $ + withInteractiveContext $ do + convert' =<< body + where + handler (SomeException ex) = do + gmLog GmException "info" $ text "" $$ nest 4 (showToDoc ex) + convert' "Cannot show info" + + body :: (GhcMonad m, GmState m, GmEnv m) => m String + body = do + m <- mkRevRedirMapFunc + sdoc <- Gap.infoThing m expr + st <- getStyle + dflag <- G.getSessionDynFlags + return $ showPage dflag st sdoc + +---------------------------------------------------------------- + +-- | Obtaining type of a target expression. (GHCi's type:) +types :: IOish m + => Bool -- ^ Include constraints into type signature + -> FilePath -- ^ A target file. + -> Int -- ^ Line number. + -> Int -- ^ Column number. + -> GhcModT m String +types withConstraints file lineNo colNo = + ghandle handler $ + runGmlT' [Left file] deferErrors $ + withInteractiveContext $ do + crdl <- cradle + modSum <- fileModSummaryWithMapping (cradleCurrentDir crdl file) + srcSpanTypes <- getSrcSpanType withConstraints modSum lineNo colNo + dflag <- G.getSessionDynFlags + st <- getStyle + convert' $ map (toTup dflag st) $ sortBy (cmp `on` fst) srcSpanTypes + where + handler (SomeException ex) = do + gmLog GmException "types" $ showToDoc ex + return [] + +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) diff --git a/GhcMod/Exe/Internal.hs b/GhcMod/Exe/Internal.hs new file mode 100644 --- /dev/null +++ b/GhcMod/Exe/Internal.hs @@ -0,0 +1,73 @@ +-- | Low level access to the ghc-mod library. + +module GhcMod.Exe.Internal ( + -- * Types + GHCOption + , IncludeDir + , GmlT(..) + , MonadIO(..) + , GmEnv(..) + -- * Various Paths + , ghcLibDir + , ghcModExecutable + -- * Logging + , withLogger + , setNoWarningFlags + , setAllWarningFlags + -- * Environment, state and logging + , GhcModEnv(..) + , GhcModState + , GhcModLog + , GmLog(..) + , GmLogLevel(..) + , gmSetLogLevel + -- * Monad utilities + , runGhcModT' + , hoistGhcModT + , runGmlT + , runGmlT' + , gmlGetSession + , gmlSetSession + , loadTargets + , cabalResolvedComponents + -- ** Accessing 'GhcModEnv' and 'GhcModState' + , options + , cradle + , targetGhcOptions + , withOptions + -- * 'GhcModError' + , gmeDoc + -- * World + , World + , getCurrentWorld + , didWorldChange + -- * Cabal Helper + , ModulePath(..) + , GmComponent(..) + , GmComponentType(..) + , GmModuleGraph(..) + , prepareCabalHelper + -- * Misc stuff + , GHandler(..) + , gcatches + -- * FileMapping + , module GhcMod.FileMapping + ) where + +import GHC.Paths (libdir) + +import GhcMod.Target +import GhcMod.DynFlags +import GhcMod.Error +import GhcMod.Logger +import GhcMod.Logging +import GhcMod.Monad +import GhcMod.Types +import GhcMod.Utils +import GhcMod.World +import GhcMod.CabalHelper +import GhcMod.FileMapping + +-- | Obtaining the directory for ghc system libraries. +ghcLibDir :: FilePath +ghcLibDir = libdir diff --git a/GhcMod/Exe/Lang.hs b/GhcMod/Exe/Lang.hs new file mode 100644 --- /dev/null +++ b/GhcMod/Exe/Lang.hs @@ -0,0 +1,10 @@ +module GhcMod.Exe.Lang where + +import DynFlags (supportedLanguagesAndExtensions) +import GhcMod.Convert +import GhcMod.Monad + +-- | Listing language extensions. + +languages :: IOish m => GhcModT m String +languages = convert' supportedLanguagesAndExtensions diff --git a/GhcMod/Exe/Lint.hs b/GhcMod/Exe/Lint.hs new file mode 100644 --- /dev/null +++ b/GhcMod/Exe/Lint.hs @@ -0,0 +1,30 @@ +module GhcMod.Exe.Lint where + +import Exception (ghandle) +import Control.Exception (SomeException(..)) +import GhcMod.Logger (checkErrorPrefix) +import GhcMod.Convert +import GhcMod.Types +import GhcMod.Monad +import Language.Haskell.HLint3 + +import GhcMod.Utils (withMappedFile) +import Language.Haskell.Exts.SrcLoc (SrcSpan(..)) + +-- | Checking syntax of a target file using hlint. +-- Warnings and errors are returned. +lint :: IOish m + => LintOpts -- ^ Configuration parameters + -> FilePath -- ^ A target file. + -> GhcModT m String +lint opt file = ghandle handler $ + withMappedFile file $ \tempfile -> do + res <- liftIO $ hlint $ "--quiet" : tempfile : optLintHlintOpts opt + pack . map (show . substFile file tempfile) $ res + where + pack = convert' . map init -- init drops the last \n. + handler (SomeException e) = return $ checkErrorPrefix ++ show e ++ "\n" + substFile orig temp idea + | srcSpanFilename (ideaSpan idea) == temp + = idea{ideaSpan=(ideaSpan idea){srcSpanFilename = orig}} + substFile _ _ idea = idea diff --git a/GhcMod/Exe/Modules.hs b/GhcMod/Exe/Modules.hs new file mode 100644 --- /dev/null +++ b/GhcMod/Exe/Modules.hs @@ -0,0 +1,27 @@ +module GhcMod.Exe.Modules (modules) where + +import Control.Arrow +import Data.List +import GhcMod.Convert +import GhcMod.Types +import GhcMod.Monad +import GhcMod.Gap ( listVisibleModuleNames + , lookupModulePackageInAllPackages + ) + +import qualified GHC as G + +---------------------------------------------------------------- + +-- | Listing installed modules. +modules :: (IOish m, Gm m) + => Bool -- ^ 'detailed', if 'True', also prints packages that modules belong to. + -> m String +modules detailed = do + df <- runGmPkgGhc G.getSessionDynFlags + let mns = listVisibleModuleNames df + pmnss = map (first moduleNameString) $ zip mns (modulePkg df `map` mns) + convert' $ nub [ if detailed then pkg ++ " " ++ mn else mn + | (mn, pkgs) <- pmnss, pkg <- pkgs ] + where + modulePkg df = lookupModulePackageInAllPackages df diff --git a/GhcMod/Exe/PkgDoc.hs b/GhcMod/Exe/PkgDoc.hs new file mode 100644 --- /dev/null +++ b/GhcMod/Exe/PkgDoc.hs @@ -0,0 +1,29 @@ +module GhcMod.Exe.PkgDoc (pkgDoc) where + +import GhcMod.Types +import GhcMod.GhcPkg +import GhcMod.Monad +import GhcMod.Output + +import Control.Applicative +import Prelude + +-- | Obtaining the package name and the doc path of a module. +pkgDoc :: IOish m => String -> GhcModT m String +pkgDoc mdl = do + ghcPkg <- getGhcPkgProgram + readProc <- gmReadProcess + pkgDbStack <- getPackageDbStack + pkg <- liftIO $ trim <$> readProc ghcPkg (toModuleOpts pkgDbStack) "" + if pkg == "" then + return "\n" + else do + htmlpath <- liftIO $ readProc ghcPkg (toDocDirOpts pkg pkgDbStack) "" + let ret = pkg ++ " " ++ drop 14 htmlpath + return ret + where + toModuleOpts dbs = ["find-module", mdl, "--simple-output"] + ++ ghcPkgDbStackOpts dbs + toDocDirOpts pkg dbs = ["field", pkg, "haddock-html"] + ++ ghcPkgDbStackOpts dbs + trim = takeWhile (`notElem` " \n") diff --git a/GhcMod/Exe/Test.hs b/GhcMod/Exe/Test.hs new file mode 100644 --- /dev/null +++ b/GhcMod/Exe/Test.hs @@ -0,0 +1,45 @@ +module GhcMod.Exe.Test where + +import Control.Applicative +import Data.List +import System.FilePath +import System.Directory +import Prelude + +import GhcMod.Types +import GhcMod.Monad +import GhcMod.DynFlags + +import GHC +import GHC.Exception +import OccName + +test :: IOish m + => FilePath -> GhcModT m String +test f = runGmlT' [Left f] (fmap setHscInterpreted . deferErrors) $ do + mg <- getModuleGraph + root <- cradleRootDir <$> cradle + f' <- makeRelative root <$> liftIO (canonicalizePath f) + let Just ms = find ((==Just f') . ml_hs_file . ms_location) mg + mdl = ms_mod ms + mn = moduleName mdl + + Just mi <- getModuleInfo mdl + let exs = map (occNameString . getOccName) $ modInfoExports mi + cqs = filter ("prop_" `isPrefixOf`) exs + + setContext [ IIDecl $ simpleImportDecl mn + , IIDecl $ simpleImportDecl $ mkModuleName "Test.QuickCheck" + ] + + _res <- mapM runTest cqs + + return "" + +runTest :: GhcMonad m => String -> m (Maybe SomeException) +runTest fn = do + res <- runStmt ("quickCheck " ++ fn) RunToCompletion + return $ case res of + RunOk [] -> Nothing + RunException se -> Just se + _ -> error "runTest" diff --git a/LICENSE b/LICENSE deleted file mode 100644 --- a/LICENSE +++ /dev/null @@ -1,6 +0,0 @@ -ghc-mod was originally licensed under the BSD3 but the primary license has been -changed to the AGPL3, files originally contributed under the BSD3 license remain -under this license and can generally be identified by the lack of a GPL header. - -See the files COPYING.BSD3 and COPYING.AGPL3 in the source distribution for -copies of the two licenses. diff --git a/Language/Haskell/GhcMod.hs b/Language/Haskell/GhcMod.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod.hs +++ /dev/null @@ -1,92 +0,0 @@ --- | The ghc-mod library. - -module Language.Haskell.GhcMod ( - -- * Cradle - Cradle(..) - , Project(..) - , findCradle - -- * Options - , Options(..) - , LineSeparator(..) - , OutputStyle(..) - , FileMapping(..) - , defaultOptions - -- * Logging - , GmLogLevel - , increaseLogLevel - , decreaseLogLevel - , gmSetLogLevel - , gmLog - -- * Types - , ModuleString - , Expression(..) - , GhcPkgDb - , Symbol - , SymbolDb - , GhcModError(..) - -- * Monad Types - , GhcModT - , IOish - -- * Monad utilities - , runGhcModT - , withOptions - , dropSession - -- * 'GhcMod' utilities - , boot - , browse - , check - , checkSyntax - , debugInfo - , componentInfo - , expandTemplate - , info - , lint - , pkgDoc - , rootInfo - , types - , test - , splits - , sig - , refine - , auto - , modules - , languages - , flags - , findSymbol - , lookupSymbol - , dumpSymbol - -- * SymbolDb - , loadSymbolDb - , isOutdated - -- * Output - , gmPutStr - , gmErrStr - , gmPutStrLn - , gmErrStrLn - -- * FileMapping - , loadMappedFile - , loadMappedFileSource - , unloadMappedFile - ) where - -import Language.Haskell.GhcMod.Boot -import Language.Haskell.GhcMod.Browse -import Language.Haskell.GhcMod.CaseSplit -import Language.Haskell.GhcMod.Check -import Language.Haskell.GhcMod.Cradle -import Language.Haskell.GhcMod.Debug -import Language.Haskell.GhcMod.FillSig -import Language.Haskell.GhcMod.Find -import Language.Haskell.GhcMod.Flag -import Language.Haskell.GhcMod.Info -import Language.Haskell.GhcMod.Lang -import Language.Haskell.GhcMod.Lint -import Language.Haskell.GhcMod.Logging -import Language.Haskell.GhcMod.Modules -import Language.Haskell.GhcMod.Monad -import Language.Haskell.GhcMod.PkgDoc -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Target -import Language.Haskell.GhcMod.Output -import Language.Haskell.GhcMod.FileMapping -import Language.Haskell.GhcMod.Test diff --git a/Language/Haskell/GhcMod/Boot.hs b/Language/Haskell/GhcMod/Boot.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Boot.hs +++ /dev/null @@ -1,27 +0,0 @@ -module Language.Haskell.GhcMod.Boot where - -import Control.Applicative -import Prelude -import Language.Haskell.GhcMod.Browse -import Language.Haskell.GhcMod.Flag -import Language.Haskell.GhcMod.Lang -import Language.Haskell.GhcMod.Monad -import Language.Haskell.GhcMod.Modules - --- | 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] - -preBrowsedModules :: [String] -preBrowsedModules = [ - "Prelude" - , "Control.Applicative" - , "Control.Exception" - , "Control.Monad" - , "Data.Char" - , "Data.List" - , "Data.Maybe" - , "System.IO" - ] diff --git a/Language/Haskell/GhcMod/Browse.hs b/Language/Haskell/GhcMod/Browse.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Browse.hs +++ /dev/null @@ -1,155 +0,0 @@ -module Language.Haskell.GhcMod.Browse ( - browse, - BrowseOpts(..) - ) where - -import Safe -import Control.Applicative -import Control.Exception (SomeException(..)) -import Data.Char -import Data.List -import Data.Maybe -import FastString -import GHC -import qualified GHC as G -import Language.Haskell.GhcMod.Convert -import Language.Haskell.GhcMod.Doc (showPage, styleUnqualified) -import Language.Haskell.GhcMod.Gap as Gap -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Monad -import Language.Haskell.GhcMod.Logging -import Name (getOccString) -import Outputable -import TyCon (isAlgTyCon) -import Type (dropForAlls, splitFunTy_maybe, mkFunTy, isPredTy) -import Exception (ExceptionMonad, ghandle) -import Prelude - ----------------------------------------------------------------- - --- | Getting functions, classes, etc from a module. -browse :: forall m. IOish m - => BrowseOpts -- ^ Configuration parameters - -> String -- ^ A module name. (e.g. \"Data.List\", "base:Prelude") - -> GhcModT m String -browse opts pkgmdl = do - convert' . sort =<< go - where - -- TODO: Add API to Gm.Target to check if module is home module without - -- bringing up a GHC session as well then this can be made a lot cleaner - go = ghandle (\ex@(SomeException _) -> logException ex >> return []) $ do - goPkgModule `G.gcatch` (\(SomeException _) -> goHomeModule) - - logException ex = - gmLog GmException "browse" $ showDoc ex - - goPkgModule = do - runGmPkgGhc $ - processExports opts =<< tryModuleInfo =<< G.findModule mdlname mpkgid - - goHomeModule = runGmlT [Right mdlname] $ do - processExports opts =<< tryModuleInfo =<< G.findModule mdlname Nothing - - tryModuleInfo m = fromJustNote "browse, tryModuleInfo" <$> G.getModuleInfo m - - (mpkg, mdl) = splitPkgMdl pkgmdl - mdlname = G.mkModuleName mdl - mpkgid = mkFastString <$> mpkg - --- | --- --- >>> splitPkgMdl "base:Prelude" --- (Just "base","Prelude") --- >>> splitPkgMdl "Prelude" --- (Nothing,"Prelude") -splitPkgMdl :: String -> (Maybe String,String) -splitPkgMdl pkgmdl = - case break (==':') pkgmdl of - (mdl, "") -> (Nothing, mdl) - (pkg, _:mdl) -> (Just pkg, mdl) - --- Haskell 2010: --- small -> ascSmall | uniSmall | _ --- ascSmall -> a | b | ... | z --- uniSmall -> any Unicode lowercase letter --- varid -> (small {small | large | digit | ' }) - -isNotOp :: String -> Bool -isNotOp (h:_) = isAlpha h || (h == '_') -isNotOp _ = error "isNotOp" - -processExports :: (G.GhcMonad m, MonadIO m, ExceptionMonad m) - => BrowseOpts -> ModuleInfo -> m [String] -processExports opt minfo = do - let - removeOps - | optBrowseOperators opt = id - | otherwise = filter (isNotOp . getOccString) - mapM (showExport opt minfo) $ removeOps $ G.modInfoExports minfo - -showExport :: forall m. (G.GhcMonad m, MonadIO m, ExceptionMonad m) - => BrowseOpts -> ModuleInfo -> Name -> m String -showExport opt minfo e = do - mtype' <- mtype - return $ concat $ catMaybes [mqualified, Just $ formatOp $ getOccString e, mtype'] - where - mqualified = (G.moduleNameString (G.moduleName $ G.nameModule e) ++ ".") `justIf` optBrowseQualified opt - mtype :: m (Maybe String) - mtype - | optBrowseDetailed opt = do - tyInfo <- G.modInfoLookupName minfo e - -- If nothing found, load dependent module and lookup global - tyResult <- maybe (inOtherModule e) (return . Just) tyInfo - dflag <- G.getSessionDynFlags - return $ do - typeName <- tyResult >>= showThing dflag - (" :: " ++ typeName) `justIf` optBrowseDetailed opt - | otherwise = return Nothing - formatOp nm - | null nm = error "formatOp" - | isNotOp nm = nm - | otherwise = "(" ++ nm ++ ")" - inOtherModule :: Name -> m (Maybe TyThing) - inOtherModule nm = do - G.getModuleInfo (G.nameModule nm) >> G.lookupGlobalName nm - justIf :: a -> Bool -> Maybe a - justIf x True = Just x - justIf _ False = Nothing - -showThing :: DynFlags -> TyThing -> Maybe String -showThing dflag tything = showThing' dflag (fromTyThing tything) - -showThing' :: DynFlags -> GapThing -> Maybe String -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) -showThing' _ _ = Nothing - -formatType :: DynFlags -> Type -> String -formatType dflag a = showOutputable dflag (removeForAlls a) - -tyType :: TyCon -> Maybe String -tyType typ - | isAlgTyCon typ - && not (G.isNewTyCon typ) - && not (G.isClassTyCon typ) = Just "data" - | G.isNewTyCon typ = Just "newtype" - | G.isClassTyCon typ = Just "class" - | Gap.isSynTyCon typ = Just "type" - | otherwise = Nothing - -removeForAlls :: Type -> Type -removeForAlls ty = removeForAlls' ty' tty' - where - ty' = dropForAlls ty - tty' = splitFunTy_maybe ty' - -removeForAlls' :: Type -> Maybe (Type, Type) -> Type -removeForAlls' ty Nothing = ty -removeForAlls' ty (Just (pre, ftype)) - | isPredTy pre = mkFunTy pre (dropForAlls ftype) - | otherwise = ty - -showOutputable :: Outputable a => DynFlags -> a -> String -showOutputable dflag = unwords . lines . showPage dflag styleUnqualified . ppr diff --git a/Language/Haskell/GhcMod/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/CabalHelper.hs +++ /dev/null @@ -1,310 +0,0 @@ --- ghc-mod: Making Haskell development *more* fun --- Copyright (C) 2015 Daniel Gröber --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU Affero General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU Affero General Public License for more details. --- --- You should have received a copy of the GNU Affero General Public License --- along with this program. If not, see . - -{-# LANGUAGE CPP #-} -module Language.Haskell.GhcMod.CabalHelper -#ifndef SPEC - ( getComponents - , getGhcMergedPkgOptions - , getCabalPackageDbStack - , prepareCabalHelper - , withAutogen - ) -#endif - where - -import Control.Applicative -import Control.Monad -import Control.Category ((.)) -import Data.Maybe -import Data.Monoid -import Data.Version -import Data.Binary (Binary) -import Data.Traversable -import Distribution.Helper hiding (Programs(..)) -import qualified Distribution.Helper as CH -import qualified Language.Haskell.GhcMod.Types as T -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Monad.Types -import Language.Haskell.GhcMod.Utils -import Language.Haskell.GhcMod.PathsAndFiles -import Language.Haskell.GhcMod.Logging -import Language.Haskell.GhcMod.Output -import Language.Haskell.GhcMod.CustomPackageDb -import Language.Haskell.GhcMod.Stack -import System.FilePath -import System.Process -import System.Exit -import Prelude hiding ((.)) - -import Paths_ghc_mod as GhcMod - --- | Only package related GHC options, sufficient for things that don't need to --- access home modules -getGhcMergedPkgOptions :: (Applicative m, IOish m, Gm m) - => m [GHCOption] -getGhcMergedPkgOptions = chCached $ \distdir -> Cached { - cacheLens = Just (lGmcMergedPkgOptions . lGmCaches), - cacheFile = mergedPkgOptsCacheFile distdir, - cachedAction = \_tcf (_progs, _projdir, _ver) _ma -> do - opts <- runCHQuery ghcMergedPkgOptions - return ([setupConfigPath distdir], opts) - } - -getCabalPackageDbStack :: (IOish m, Gm m) => m [GhcPkgDb] -getCabalPackageDbStack = chCached $ \distdir -> Cached { - cacheLens = Just (lGmcPackageDbStack . lGmCaches), - cacheFile = pkgDbStackCacheFile distdir, - cachedAction = \_tcf (_progs, _projdir, _ver) _ma -> do - crdl <- cradle - dbs <- map chPkgToGhcPkg <$> - runCHQuery packageDbStack - return ([setupConfigFile crdl, sandboxConfigFile crdl], dbs) - } - -chPkgToGhcPkg :: ChPkgDb -> GhcPkgDb -chPkgToGhcPkg ChPkgGlobal = GlobalDb -chPkgToGhcPkg ChPkgUser = UserDb -chPkgToGhcPkg (ChPkgSpecific f) = PackageDb f - --- | Primary interface to cabal-helper and intended single entrypoint to --- constructing 'GmComponent's --- --- The Component\'s 'gmcHomeModuleGraph' will be empty and has to be resolved by --- 'resolveGmComponents'. -getComponents :: (Applicative m, IOish m, Gm m) - => m [GmComponent 'GMCRaw ChEntrypoint] -getComponents = chCached $ \distdir -> Cached { - cacheLens = Just (lGmcComponents . lGmCaches), - cacheFile = cabalHelperCacheFile distdir, - cachedAction = \ _tcf (_progs, _projdir, _ver) _ma -> do - runCHQuery $ do - q <- join7 - <$> ghcOptions - <*> ghcPkgOptions - <*> ghcSrcOptions - <*> ghcLangOptions - <*> entrypoints - <*> entrypoints - <*> sourceDirs - let cs = flip map q $ curry8 (GmComponent mempty) - return ([setupConfigPath distdir], cs) - } - where - curry8 fn (a, (b, (c, (d, (e, (f, (g, h))))))) = fn a b c d e f g h - - join7 a b c d e f = join' a . join' b . join' c . join' d . join' e . join' f - join' :: Eq a => [(a,b)] -> [(a,c)] -> [(a,(b,c))] - join' lb lc = [ (a, (b, c)) - | (a, b) <- lb - , (a', c) <- lc - , a == a' - ] - -getQueryEnv :: (IOish m, GmOut m, GmEnv m) => m QueryEnv -getQueryEnv = do - crdl <- cradle - progs <- patchStackPrograms crdl =<< (optPrograms <$> options) - readProc <- gmReadProcess - let projdir = cradleRootDir crdl - distdir = projdir cradleDistDir crdl - return (defaultQueryEnv projdir distdir) { - qeReadProcess = readProc - , qePrograms = helperProgs progs - } - -runCHQuery :: (IOish m, GmOut m, GmEnv m) => Query m b -> m b -runCHQuery a = do - qe <- getQueryEnv - runQuery qe a - - -prepareCabalHelper :: (IOish m, GmEnv m, GmOut m, GmLog m) => m () -prepareCabalHelper = do - crdl <- cradle - when (isCabalHelperProject $ cradleProject crdl) $ - withCabal $ prepare' =<< getQueryEnv - -withAutogen :: (IOish m, GmEnv m, GmOut m, GmLog m) => m a -> m a -withAutogen action = do - gmLog GmDebug "" $ strDoc $ "making sure autogen files exist" - crdl <- cradle - let projdir = cradleRootDir crdl - distdir = projdir cradleDistDir crdl - - (pkgName', _) <- runCHQuery packageId - - mCabalFile <- liftIO $ timeFile `traverse` cradleCabalFile crdl - mCabalMacroHeader <- liftIO $ timeMaybe (distdir macrosHeaderPath) - mCabalPathsModule <- liftIO $ timeMaybe (distdir autogenModulePath pkgName') - - when (mCabalMacroHeader < mCabalFile || mCabalPathsModule < mCabalFile) $ do - gmLog GmDebug "" $ strDoc $ "autogen files out of sync" - writeAutogen - - action - - where - writeAutogen = do - gmLog GmDebug "" $ strDoc $ "writing Cabal autogen files" - writeAutogenFiles' =<< getQueryEnv - - -withCabal :: (IOish m, GmEnv m, GmOut m, GmLog m) => m a -> m a -withCabal action = do - crdl <- cradle - mCabalFile <- liftIO $ timeFile `traverse` cradleCabalFile crdl - mCabalConfig <- liftIO $ timeMaybe (setupConfigFile crdl) - mCabalSandboxConfig <- liftIO $ timeMaybe (sandboxConfigFile crdl) - - let haveSetupConfig = isJust mCabalConfig - - cusPkgDb <- getCustomPkgDbStack - (flgs, pkgDbStackOutOfSync) <- do - if haveSetupConfig - then runCHQuery $ do - flgs <- nonDefaultConfigFlags - pkgDb <- map chPkgToGhcPkg <$> packageDbStack - return (flgs, fromMaybe False $ (pkgDb /=) <$> cusPkgDb) - else return ([], False) - - when (isSetupConfigOutOfDate mCabalFile mCabalConfig) $ - gmLog GmDebug "" $ strDoc $ "setup configuration is out of date" - - when (isSetupConfigOutOfDate mCabalSandboxConfig mCabalConfig) $ - gmLog GmDebug "" $ strDoc $ "sandbox configuration is out of date" - - when pkgDbStackOutOfSync $ - gmLog GmDebug "" $ strDoc $ "package-db stack out of sync with ghc-mod.package-db-stack" - - when ( isSetupConfigOutOfDate mCabalFile mCabalConfig - || pkgDbStackOutOfSync - || isSetupConfigOutOfDate mCabalSandboxConfig mCabalConfig) $ do - proj <- cradleProject <$> cradle - opts <- options - case proj of - CabalProject -> do - gmLog GmDebug "" $ strDoc "reconfiguring Cabal project" - cabalReconfigure (optPrograms opts) crdl flgs - StackProject {} -> do - gmLog GmDebug "" $ strDoc "reconfiguring Stack project" - -- TODO: we could support flags for stack too, but it seems - -- you're supposed to put those in stack.yaml so detecting which - -- flags to pass down would be more difficult - - -- "--flag PACKAGE:[-]FLAG Override flags set in stack.yaml - -- (applies to local packages and extra-deps)" - - stackReconfigure crdl (optPrograms opts) - _ -> - error $ "withCabal: unsupported project type: " ++ show proj - - action - - where - cabalReconfigure progs crdl flgs = do - readProc <- gmReadProcess - withDirectory_ (cradleRootDir crdl) $ do - cusPkgStack <- maybe [] ((PackageDb "clear"):) <$> getCustomPkgDbStack - let progOpts = - [ "--with-ghc=" ++ T.ghcProgram progs ] - -- Only pass ghc-pkg if it was actually set otherwise we - -- might break cabal's guessing logic - ++ if T.ghcPkgProgram progs /= T.ghcPkgProgram (optPrograms defaultOptions) - then [ "--with-ghc-pkg=" ++ T.ghcPkgProgram progs ] - else [] - ++ map pkgDbArg cusPkgStack - ++ flagOpt - - toFlag (f, True) = f - toFlag (f, False) = '-':f - flagOpt = ["--flags", unwords $ map toFlag flgs] - - liftIO $ void $ readProc (T.cabalProgram progs) ("configure":progOpts) "" - stackReconfigure crdl progs = do - withDirectory_ (cradleRootDir crdl) $ do - supported <- haveStackSupport - if supported - then do - spawn [T.stackProgram progs, "build", "--only-dependencies", "."] - spawn [T.stackProgram progs, "build", "--only-configure", "."] - else - gmLog GmWarning "" $ strDoc $ "Stack project configuration is out of date, please reconfigure manually using 'stack build' as your stack version is too old (need at least 0.1.4.0)" - - spawn [] = return () - spawn (exe:args) = do - readProc <- gmReadProcess - liftIO $ void $ readProc exe args "" - - haveStackSupport = do - (rv, _, _) <- - liftIO $ readProcessWithExitCode "stack" ["--numeric-version"] "" - case rv of - ExitSuccess -> return True - ExitFailure _ -> return False - - - -pkgDbArg :: GhcPkgDb -> String -pkgDbArg GlobalDb = "--package-db=global" -pkgDbArg UserDb = "--package-db=user" -pkgDbArg (PackageDb p) = "--package-db=" ++ p - --- * Neither file exists -> should return False: --- @Nothing < Nothing = False@ --- (since we don't need to @cabal configure@ when no cabal file exists.) --- --- * Cabal file doesn't exist (impossible since cabal-helper is only used with --- cabal projects) -> should return False --- @Just cc < Nothing = False@ --- --- * dist/setup-config doesn't exist yet -> should return True: --- @Nothing < Just cf = True@ --- --- * Both files exist --- @Just cc < Just cf = cc < cf = cc `olderThan` cf@ -isSetupConfigOutOfDate :: Maybe TimedFile -> Maybe TimedFile -> Bool -isSetupConfigOutOfDate worldCabalFile worldCabalConfig = do - worldCabalConfig < worldCabalFile - -helperProgs :: Programs -> CH.Programs -helperProgs progs = CH.Programs { - cabalProgram = T.cabalProgram progs, - ghcProgram = T.ghcProgram progs, - ghcPkgProgram = T.ghcPkgProgram progs - } - -chCached :: (Applicative m, IOish m, Gm m, Binary a) - => (FilePath -> Cached m GhcModState ChCacheData a) -> m a -chCached c = do - projdir <- cradleRootDir <$> cradle - distdir <- (projdir ) . cradleDistDir <$> cradle - d <- cacheInputData projdir - withCabal $ cached projdir (c distdir) d - where - -- we don't need to include the distdir in the cache input because when it - -- changes the cache files will be gone anyways ;) - cacheInputData projdir = do - opts <- options - crdl <- cradle - progs' <- patchStackPrograms crdl (optPrograms opts) - return $ ( helperProgs progs' - , projdir - , (showVersion gmVer, chVer) - ) - - gmVer = GhcMod.version - chVer = VERSION_cabal_helper diff --git a/Language/Haskell/GhcMod/Caching.hs b/Language/Haskell/GhcMod/Caching.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Caching.hs +++ /dev/null @@ -1,141 +0,0 @@ --- ghc-mod: Making Haskell development *more* fun --- Copyright (C) 2015 Daniel Gröber --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU Affero General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU Affero General Public License for more details. --- --- You should have received a copy of the GNU Affero General Public License --- along with this program. If not, see . -{-# LANGUAGE CPP, OverloadedStrings #-} -module Language.Haskell.GhcMod.Caching ( - module Language.Haskell.GhcMod.Caching - , module Language.Haskell.GhcMod.Caching.Types - ) where - -import Control.Arrow (first) -import Control.Monad -import Control.Monad.Trans.Maybe -#if !MIN_VERSION_binary(0,7,0) -import Control.Exception -#endif -import Data.Maybe -import Data.Binary hiding (get) -import Data.Version -import Data.Label -import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS8 -import System.FilePath -import System.Directory.ModTime -import Utils (TimedFile(..), timeMaybe, mightExist) -import Paths_ghc_mod (version) -import Prelude - -import Language.Haskell.GhcMod.Monad.Types -import Language.Haskell.GhcMod.Caching.Types -import Language.Haskell.GhcMod.Logging - --- | Cache a MonadIO action with proper invalidation. -cached :: forall m a d. (Gm m, MonadIO m, Binary a, Eq d, Binary d, Show d) - => FilePath -- ^ Directory to prepend to 'cacheFile' - -> Cached m GhcModState d a -- ^ Cache descriptor - -> d - -> m a -cached dir cd d = do - mcc <- readCache - case mcc of - Nothing -> do - t <- liftIO $ getCurrentModTime - writeCache (TimedCacheFiles t []) Nothing "cache missing or unreadable" - Just (t, ifs, d', a) | d /= d' -> do - tcfs <- timeCacheInput dir ifs - writeCache (TimedCacheFiles t tcfs) (Just a) $ "input data changed" -- ++ " was: " ++ show d ++ " is: " ++ show d' - Just (t, ifs, _, a) -> do - tcfs <- timeCacheInput dir ifs - case invalidatingInputFiles $ TimedCacheFiles t tcfs of - [] -> return a - _ -> writeCache (TimedCacheFiles t tcfs) (Just a) "input files changed" - - where - cacheHeader = BS8.pack $ "Written by ghc-mod " ++ showVersion version ++ "\n" - - lbsToStrict = BS.concat . LBS.toChunks - lbsFromStrict bs = LBS.fromChunks [bs] - - writeCache tcfs ma cause = do - (ifs', a) <- (cachedAction cd) tcfs d ma - t <- liftIO $ getCurrentModTime - gmLog GmDebug "" $ (text "regenerating cache") <+>: text (cacheFile cd) - <+> parens (text cause) - case cacheLens cd of - Nothing -> return () - Just label -> do - gmLog GmDebug "" $ (text "writing memory cache") <+>: text (cacheFile cd) - setLabel label $ Just (t, ifs', d, a) - - let c = BS.append cacheHeader $ lbsToStrict $ encode (t, ifs', d, a) - - liftIO $ BS.writeFile (dir cacheFile cd) c - - return a - - setLabel l x = do - s <- gmsGet - gmsPut $ set l x s - - readCache :: m (Maybe (ModTime, [FilePath], d, a)) - readCache = runMaybeT $ do - case cacheLens cd of - Just label -> do - c <- MaybeT (get label `liftM` gmsGet) `mplus` readCacheFromFile - setLabel label $ Just c - return c - Nothing -> - readCacheFromFile - - readCacheFromFile :: MaybeT m (ModTime, [FilePath], d, a) - readCacheFromFile = do - f <- MaybeT $ liftIO $ mightExist $ cacheFile cd - readCacheFromFile' f - - readCacheFromFile' :: FilePath -> MaybeT m (ModTime, [FilePath], d, a) - readCacheFromFile' f = MaybeT $ do - gmLog GmDebug "" $ (text "reading cache") <+>: text (cacheFile cd) - cc <- liftIO $ BS.readFile f - case first BS8.words $ BS8.span (/='\n') cc of - (["Written", "by", "ghc-mod", ver], rest) - | BS8.unpack ver == showVersion version -> - either (const Nothing) Just - `liftM` decodeE (lbsFromStrict $ BS.drop 1 rest) - _ -> return Nothing - - decodeE b = do -#if MIN_VERSION_binary(0,7,0) - return $ case decodeOrFail b of - Left (_rest, _offset, errmsg) -> Left errmsg - Right (_reset, _offset, a) -> Right a -#else - ea <- liftIO $ try $ evaluate $ decode b - return $ case ea of - Left (ErrorCall errmsg) -> Left errmsg - Right a -> Right a - -#endif - -timeCacheInput :: MonadIO m => FilePath -> [FilePath] -> m [TimedFile] -timeCacheInput dir ifs = liftIO $ do - ins <- (timeMaybe . (dir )) `mapM` ifs - return $ catMaybes ins - -invalidatingInputFiles :: TimedCacheFiles -> [FilePath] -invalidatingInputFiles (TimedCacheFiles tcreated tcfs) = - map tfPath $ - -- get input files older than tcfile - filter ((TimedFile "" tcreated)<) tcfs diff --git a/Language/Haskell/GhcMod/Caching/Types.hs b/Language/Haskell/GhcMod/Caching/Types.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Caching/Types.hs +++ /dev/null @@ -1,67 +0,0 @@ --- ghc-mod: Making Haskell development *more* fun --- Copyright (C) 2015 Daniel Gröber --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU Affero General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU Affero General Public License for more details. --- --- You should have received a copy of the GNU Affero General Public License --- along with this program. If not, see . -module Language.Haskell.GhcMod.Caching.Types where - -import Utils -import Data.Label -import System.Directory.ModTime -import Distribution.Helper - -type CacheContents d a = Maybe (ModTime, [FilePath], d, a) -type CacheLens s d a = s :-> CacheContents d a - -data Cached m s d a = Cached { - cacheFile :: FilePath, - cacheLens :: Maybe (CacheLens s d a), - cachedAction :: TimedCacheFiles - -> d - -> Maybe a - -> m ([FilePath], a) - - -- ^ @cachedAction tcf data ma@ - -- - -- * @tcf@: Input file timestamps. Not technically necessary, just an - -- optimizazion when knowing which input files changed can make updating the - -- cache faster - -- - -- * @data@: Arbitrary static input data to cache action. Can be used to - -- invalidate the cache using something other than file timestamps - -- i.e. environment tool version numbers - -- - -- * @ma@: Cached data if it existed - -- - -- Returns: - -- - -- * @fst@: Input files used in generating the cache - -- - -- * @snd@: Cache data, will be stored alongside the static input data in the - -- 'cacheFile' - -- - -- The cached action, will only run if one of the following is true: - -- - -- * 'cacheFile' doesn\'t exist yet - -- * 'cacheFile' exists and 'inputData' changed - -- * any files returned by the cached action changed - } - -data TimedCacheFiles = TimedCacheFiles { - tcCreated :: ModTime, - -- ^ 'cacheFile' timestamp - tcFiles :: [TimedFile] - -- ^ Timestamped files returned by the cached action - } deriving (Eq, Ord) - -type ChCacheData = (Programs, FilePath, (String, String)) diff --git a/Language/Haskell/GhcMod/CaseSplit.hs b/Language/Haskell/GhcMod/CaseSplit.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/CaseSplit.hs +++ /dev/null @@ -1,251 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Language.Haskell.GhcMod.CaseSplit ( - splits - ) where - -import Data.List (find, intercalate) -import Data.Maybe (isJust) -import qualified Data.Text as T -import qualified Data.Text.IO as T (readFile) -import System.FilePath -import Prelude - -import qualified DataCon as Ty -import GHC (GhcMonad, LPat, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L)) -import qualified GHC as G -import Outputable (PprStyle) -import qualified TyCon as Ty -import qualified Type as Ty -import Exception - -import Language.Haskell.GhcMod.Convert -import Language.Haskell.GhcMod.DynFlags -import qualified Language.Haskell.GhcMod.Gap as Gap -import Language.Haskell.GhcMod.Monad -import Language.Haskell.GhcMod.SrcUtils -import Language.Haskell.GhcMod.Doc -import Language.Haskell.GhcMod.Logging -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.FileMapping (fileModSummaryWithMapping) - ----------------------------------------------------------------- --- CASE SPLITTING ----------------------------------------------------------------- - -data SplitInfo = SplitInfo G.Name SrcSpan (SrcSpan, Type) [SrcSpan] - | TySplitInfo G.Name SrcSpan (SrcSpan, Ty.Kind) -data SplitToTextInfo = SplitToTextInfo { sVarName :: String - , sBindingSpan :: SrcSpan - , sVarSpan :: SrcSpan - , sTycons :: [String] - } - --- | Splitting a variable in a equation. -splits :: IOish m - => FilePath -- ^ A target file. - -> Int -- ^ Line number. - -> Int -- ^ Column number. - -> GhcModT m String -splits file lineNo colNo = - ghandle handler $ runGmlT' [Left file] deferErrors $ do - oopts <- outputOpts - crdl <- cradle - 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 $ - 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) - where - handler (SomeException ex) = do - gmLog GmException "splits" $ - text "" $$ nest 4 (showDoc ex) - emptyResult =<< outputOpts - ----------------------------------------------------------------- --- a. Code for getting the information of the variable - -getSrcSpanTypeForSplit :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SplitInfo) -getSrcSpanTypeForSplit modSum lineNo colNo = do - fn <- getSrcSpanTypeForFnSplit modSum lineNo colNo - if isJust fn - then return fn - else getSrcSpanTypeForTypeSplit modSum lineNo colNo - --- Information for a function case split -getSrcSpanTypeForFnSplit :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SplitInfo) -getSrcSpanTypeForFnSplit modSum lineNo colNo = do - p@ParsedModule{pm_parsed_source = _pms} <- G.parseModule modSum - tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p - let varPat = find isPatternVar $ listifySpans tcs (lineNo, colNo) :: Maybe (LPat Id) - match = last $ listifySpans tcs (lineNo, colNo) :: Gap.GLMatchI - case varPat of - Nothing -> return Nothing - Just varPat' -> do - varT <- Gap.getType tcm varPat' -- Finally we get the type of the var - case varT of - Just varT' -> -#if __GLASGOW_HASKELL__ >= 710 - let (L matchL (G.Match _ _ _ (G.GRHSs rhsLs _))) = match -#else - let (L matchL (G.Match _ _ (G.GRHSs rhsLs _))) = match -#endif - in return $ Just (SplitInfo (getPatternVarName varPat') matchL varT' (map G.getLoc rhsLs) ) - _ -> return Nothing - -isPatternVar :: LPat Id -> Bool -isPatternVar (L _ (G.VarPat _)) = True -isPatternVar _ = False - -getPatternVarName :: LPat Id -> G.Name -getPatternVarName (L _ (G.VarPat vName)) = G.getName vName -getPatternVarName _ = error "This should never happened" - --- TODO: Information for a type family case split -getSrcSpanTypeForTypeSplit :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SplitInfo) -getSrcSpanTypeForTypeSplit _modSum _lineNo _colNo = return Nothing - ----------------------------------------------------------------- --- b. Code for getting the possible constructors - -getTyCons :: DynFlags -> PprStyle -> G.Name -> G.Type -> [String] -getTyCons dflag style name ty | Just (tyCon, _) <- Ty.splitTyConApp_maybe ty = - let name' = showName dflag style name -- Convert name to string - in getTyCon dflag style name' tyCon -getTyCons dflag style name _ = [showName dflag style name] - --- Write cases for one type -getTyCon :: DynFlags -> PprStyle -> String -> Ty.TyCon -> [String] --- 1. Non-matcheable type constructors -getTyCon _ _ name tyCon | isNotMatcheableTyCon tyCon = [name] --- 2. Special cases --- 2.1. Tuples -getTyCon _ _ name tyCon | Ty.isTupleTyCon tyCon = - let [uniqueDataCon] = Ty.tyConDataCons tyCon - tupleArity = Ty.dataConSourceArity uniqueDataCon - -- Deal with both boxed and unboxed tuples - isUnboxed = Ty.isUnboxedTupleTyCon tyCon - startSign = if isUnboxed then "(#" else "(" - endSign = if isUnboxed then "#)" else ")" - in [ startSign ++ intercalate "," (map (\n -> name ++ show n) [1 .. tupleArity]) ++ endSign ] --- 3. General case -getTyCon dflag style name tyCon = map (getDataCon dflag style name) (Ty.tyConDataCons tyCon) - --- These type constructors should not be matched against -isNotMatcheableTyCon :: Ty.TyCon -> Bool -isNotMatcheableTyCon ty = Ty.isPrimTyCon ty -- Primitive types, such as Int# - || Ty.isFunTyCon ty -- Function types - --- Write case for one constructor -getDataCon :: DynFlags -> PprStyle -> String -> Ty.DataCon -> String --- 1. Infix constructors -getDataCon dflag style vName dcon | Ty.dataConIsInfix dcon = - let dName = showName dflag style $ Ty.dataConName dcon - in case Ty.dataConSourceArity dcon of - 0 -> dName - 1 -> vName ++ dName - n -> if dName == ":" -- Special case for lists - then vName ++ ":" ++ vName ++ "s" - else newVar vName 1 ++ " " ++ dName ++ " " ++ newVars vName 2 (n-1) --- 2. Non-record, non-infix syntax -getDataCon dflag style vName dcon | [] <- Ty.dataConFieldLabels dcon = - let dName = showName dflag style $ Ty.dataConName dcon - in if last dName == '#' -- Special case for I#, C# and so on - then vName - else case Ty.dataConSourceArity dcon of - 0 -> dName - _ -> dName ++ " " ++ newVarsSpecialSingleton vName 1 (Ty.dataConSourceArity dcon) --- 3. Records -getDataCon dflag style vName dcon = - let dName = showName dflag style $ Ty.dataConName dcon - flds = Ty.dataConFieldLabels dcon - in dName ++ " { " ++ showFieldNames dflag style vName flds ++ " }" - --- Create a new variable by adjoining a number -newVar :: String -> Int -> String -newVar v n = v ++ show n - --- Create a list of variables which start with the same prefix -newVars :: String -> Int -> Int -> String -newVars _ _ 0 = "" -newVars v s 1 = newVar v s -newVars v s m = newVar v s ++ " " ++ newVars v (s+1) (m-1) - --- Create a list of variables which start with the same prefix --- Special case for a single variable, in which case no number is adjoint -newVarsSpecialSingleton :: String -> Int -> Int -> String -newVarsSpecialSingleton v _ 1 = v -newVarsSpecialSingleton v start n = newVars v start n - -showFieldNames :: DynFlags -> PprStyle -> String -> [G.Name] -> String -showFieldNames _ _ _ [] = "" -- This should never happen -showFieldNames dflag style v (x:xs) = let fName = showName dflag style x - fAcc = fName ++ " = " ++ v ++ "_" ++ fName - in case xs of - [] -> fAcc - _ -> fAcc ++ ", " ++ showFieldNames dflag style v xs - ----------------------------------------------------------------- --- c. Code for performing the case splitting - -genCaseSplitTextFile :: (MonadIO m, GhcMonad m) => - FilePath -> SplitToTextInfo -> m String -genCaseSplitTextFile file info = liftIO $ do - t <- T.readFile file - return $ getCaseSplitText (T.lines t) info - -getCaseSplitText :: [T.Text] -> SplitToTextInfo -> String -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 - -- The newly generated bindings need to be indented to align with the - -- original binding. - replaced' = head replaced : map (indentBindingTo sBS) (tail replaced) - in T.unpack $ T.intercalate (T.pack "\n") (concat replaced') - -getBindingText :: [T.Text] -> SrcSpan -> [T.Text] -getBindingText t srcSpan = - let Just (sl,sc,el,ec) = Gap.getSrcSpan srcSpan - lines_ = drop (sl - 1) $ take el t - in if sl == el - then -- only one line - [T.drop (sc - 1) $ T.take ec $ head lines_] - else -- several lines - let (first,rest,last_) = (head lines_, tail $ init lines_, last lines_) - in T.drop (sc - 1) first : rest ++ [T.take ec last_] - -srcSpanDifference :: SrcSpan -> SrcSpan -> (Int,Int,Int,Int) -srcSpanDifference b v = - let Just (bsl,bsc,_ ,_) = Gap.getSrcSpan b - Just (vsl,vsc,vel,vec) = Gap.getSrcSpan v - in (vsl - bsl, vsc - bsc, vel - bsl, vec - bsc) -- assume variable in one line - -replaceVarWithTyCon :: [T.Text] -> (Int,Int,Int,Int) -> String -> String -> [T.Text] -replaceVarWithTyCon t (vsl,vsc,_,vec) varname tycon = - let tycon' = if ' ' `elem` tycon || ':' `elem` tycon then "(" ++ tycon ++ ")" else tycon - lengthDiff = length tycon' - length varname - tycon'' = T.pack $ if lengthDiff < 0 then tycon' ++ replicate (-lengthDiff) ' ' else tycon' - spacesToAdd = if lengthDiff < 0 then 0 else lengthDiff - in zipWith (\n line -> if n < vsl - then line -- before variable starts - else if n == vsl - then T.take vsc line `T.append` tycon'' `T.append` T.drop vec line - else T.replicate spacesToAdd (T.pack " ") `T.append` line) - [0 ..] t - -indentBindingTo :: SrcSpan -> [T.Text] -> [T.Text] -indentBindingTo bndLoc binds = - let Just (_,sl,_,_) = Gap.getSrcSpan bndLoc - indent = (T.replicate (sl - 1) (T.pack " ") `T.append`) - in indent (head binds) : tail binds diff --git a/Language/Haskell/GhcMod/Check.hs b/Language/Haskell/GhcMod/Check.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Check.hs +++ /dev/null @@ -1,57 +0,0 @@ -module Language.Haskell.GhcMod.Check ( - checkSyntax - , check - , expandTemplate - , expand - ) where - -import Control.Applicative -import Prelude -import Language.Haskell.GhcMod.DynFlags -import qualified Language.Haskell.GhcMod.Gap as Gap -import Language.Haskell.GhcMod.Logger -import Language.Haskell.GhcMod.Monad - ----------------------------------------------------------------- - --- | Checking syntax of a target file using GHC. --- Warnings and errors are returned. -checkSyntax :: IOish m - => [FilePath] -- ^ The target files. - -> GhcModT m String -checkSyntax [] = return "" -checkSyntax files = either id id <$> check files - ----------------------------------------------------------------- - --- | Checking syntax of a target file using GHC. --- Warnings and errors are returned. -check :: IOish m - => [FilePath] -- ^ The target files. - -> GhcModT m (Either String String) -check files = - runGmlTWith - (map Left files) - return - ((fmap fst <$>) . withLogger setNoMaxRelevantBindings) - (return ()) - ----------------------------------------------------------------- - --- | Expanding Haskell Template. -expandTemplate :: IOish m - => [FilePath] -- ^ The target files. - -> GhcModT m String -expandTemplate [] = return "" -expandTemplate files = either id id <$> expand files - ----------------------------------------------------------------- - --- | Expanding Haskell Template. -expand :: IOish m => [FilePath] -> GhcModT m (Either String String) -expand files = - runGmlTWith - (map Left files) - return - ((fmap fst <$>) . withLogger (Gap.setDumpSplices . setNoWarningFlags)) - (return ()) diff --git a/Language/Haskell/GhcMod/Convert.hs b/Language/Haskell/GhcMod/Convert.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Convert.hs +++ /dev/null @@ -1,140 +0,0 @@ -{-# LANGUAGE CPP, FlexibleInstances, FlexibleContexts #-} - -module Language.Haskell.GhcMod.Convert (convert, convert', emptyResult, whenFound, whenFound') where - -import Language.Haskell.GhcMod.Monad.Types -import Language.Haskell.GhcMod.Types - -import Control.Applicative -import Prelude - -type Builder = String -> String - --- | --- --- >>> replace '"' "\\\"" "foo\"bar" "" --- "foo\\\"bar" -replace :: Char -> String -> String -> Builder -replace _ _ [] = id -replace c cs (x:xs) - | x == c = (cs ++) . replace c cs xs - | otherwise = (x :) . replace c cs xs - -inter :: Char -> [Builder] -> Builder -inter _ [] = id -inter c bs = foldr1 (\x y -> x . (c:) . y) bs - -convert' :: (ToString a, IOish m, GmEnv m) => a -> m String -convert' x = flip convert x . optOutput <$> options - -convert :: ToString a => OutputOpts -> a -> String -convert opt@OutputOpts { ooptStyle = LispStyle } x = toLisp opt x "\n" -convert opt@OutputOpts { ooptStyle = PlainStyle } x - | str == "\n" = "" - | otherwise = str - where - str = toPlain opt x "\n" - -class ToString a where - toLisp :: OutputOpts -> a -> Builder - toPlain :: OutputOpts -> a -> Builder - -lineSep :: OutputOpts -> String -lineSep oopts = interpret lsep - where - interpret s = read $ "\"" ++ s ++ "\"" - LineSeparator lsep = ooptLineSeparator oopts - --- | --- --- >>> toLisp (optOutput defaultOptions) "fo\"o" "" --- "\"fo\\\"o\"" --- >>> toPlain (optOutput defaultOptions) "foo" "" --- "foo" -instance ToString String where - toLisp oopts = quote oopts - toPlain oopts = replace '\n' (lineSep oopts) - --- | --- --- >>> toLisp (optOutput defaultOptions) ["foo", "bar", "ba\"z"] "" --- "(\"foo\" \"bar\" \"ba\\\"z\")" --- >>> toPlain (optOutput defaultOptions) ["foo", "bar", "baz"] "" --- "foo\nbar\nbaz" -instance ToString [String] where - toLisp oopts = toSexp1 oopts - toPlain oopts = inter '\n' . map (toPlain oopts) - -instance ToString [ModuleString] where - toLisp oopts = toLisp oopts . map getModuleString - toPlain oopts = toPlain oopts . map getModuleString - --- | --- --- >>> let inp = [((1,2,3,4),"foo"),((5,6,7,8),"bar")] :: [((Int,Int,Int,Int),String)] --- >>> toLisp (optOutput defaultOptions) inp "" --- "((1 2 3 4 \"foo\") (5 6 7 8 \"bar\"))" --- >>> toPlain (optOutput defaultOptions) inp "" --- "1 2 3 4 \"foo\"\n5 6 7 8 \"bar\"" -instance ToString [((Int,Int,Int,Int),String)] where - toLisp oopts = toSexp2 . map toS - where - toS x = ('(' :) . tupToString oopts x . (')' :) - toPlain oopts = inter '\n' . map (tupToString oopts) - -instance ToString ((Int,Int,Int,Int),String) where - toLisp oopts x = ('(' :) . tupToString oopts x . (')' :) - toPlain oopts x = tupToString oopts x - -instance ToString ((Int,Int,Int,Int),[String]) where - toLisp oopts (x,s) = ('(' :) . fourIntsToString x . - (' ' :) . toLisp oopts s . (')' :) - toPlain oopts (x,s) = fourIntsToString x . ('\n' :) . toPlain oopts s - -instance ToString (String, (Int,Int,Int,Int),[String]) where - toLisp oopts (s,x,y) = toSexp2 [toLisp oopts s, ('(' :) . fourIntsToString x . (')' :), toLisp oopts y] - toPlain oopts (s,x,y) = inter '\n' [toPlain oopts s, fourIntsToString x, toPlain oopts y] - -toSexp1 :: OutputOpts -> [String] -> Builder -toSexp1 oopts ss = ('(' :) . inter ' ' (map (quote oopts) ss) . (')' :) - -toSexp2 :: [Builder] -> Builder -toSexp2 ss = ('(' :) . inter ' ' ss . (')' :) - -fourIntsToString :: (Int,Int,Int,Int) -> Builder -fourIntsToString (a,b,c,d) = (show a ++) . (' ' :) - . (show b ++) . (' ' :) - . (show c ++) . (' ' :) - . (show d ++) - -tupToString :: OutputOpts -> ((Int,Int,Int,Int),String) -> Builder -tupToString oopts ((a,b,c,d),s) = (show a ++) . (' ' :) - . (show b ++) . (' ' :) - . (show c ++) . (' ' :) - . (show d ++) . (' ' :) - . quote oopts s -- fixme: quote is not necessary - -quote :: OutputOpts -> String -> Builder -quote oopts str = ("\"" ++) . (quote' str ++) . ("\"" ++) - where - lsep = lineSep oopts - quote' [] = [] - quote' (x:xs) - | x == '\n' = lsep ++ quote' xs - | x == '\\' = "\\\\" ++ quote' xs - | x == '"' = "\\\"" ++ quote' xs - | otherwise = x : quote' xs - ----------------------------------------------------------------- - --- Empty result to be returned when no info can be gathered -emptyResult :: Monad m => OutputOpts -> m String -emptyResult oopts = return $ convert oopts ([] :: [String]) - --- Return an emptyResult when Nothing -whenFound :: (Monad m, ToString b) => OutputOpts -> m (Maybe a) -> (a -> b) -> m String -whenFound oopts from f = maybe (emptyResult oopts) (return . convert oopts . f) =<< from - --- Return an emptyResult when Nothing, inside a monad -whenFound' :: (Monad m, ToString b) => OutputOpts -> m (Maybe a) -> (a -> m b) -> m String -whenFound' oopts from f = maybe (emptyResult oopts) (\x -> do y <- f x ; return (convert oopts y)) =<< from diff --git a/Language/Haskell/GhcMod/Cradle.hs b/Language/Haskell/GhcMod/Cradle.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Cradle.hs +++ /dev/null @@ -1,150 +0,0 @@ -{-# LANGUAGE CPP #-} -module Language.Haskell.GhcMod.Cradle -#ifndef SPEC - ( - findCradle - , findCradle' - , findCradleNoLog - , findSpecCradle - , cleanupCradle - ) -#endif - where - -import Language.Haskell.GhcMod.PathsAndFiles -import Language.Haskell.GhcMod.Monad.Types -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Utils -import Language.Haskell.GhcMod.Stack -import Language.Haskell.GhcMod.Logging -import Language.Haskell.GhcMod.Error - -import Safe -import Control.Applicative -import Control.Monad.Trans.Maybe -import Data.Maybe -import System.Directory -import System.FilePath -import Prelude -import Control.Monad.Trans.Journal (runJournalT) - ----------------------------------------------------------------- - --- | Finding 'Cradle'. --- 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 - -findCradleNoLog :: forall m. (IOish m, GmOut m) => m Cradle -findCradleNoLog = fst <$> (runJournalT findCradle :: m (Cradle, GhcModLog)) - -findCradle' :: (GmLog m, IOish m, GmOut m) => FilePath -> m Cradle -findCradle' dir = run $ - msum [ stackCradle dir - , cabalCradle 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] - cs <- catMaybes <$> mapM (runMaybeT . ($ dir)) cfs - gcs <- filterM isNotGmCradle cs - fillTempDir =<< case gcs of - [] -> fromJust <$> runMaybeT (plainCradle dir) - c:_ -> return c - where - isNotGmCradle crdl = - liftIO $ not <$> doesFileExist (cradleRootDir crdl "ghc-mod.cabal") - -cleanupCradle :: Cradle -> IO () -cleanupCradle crdl = removeDirectoryRecursive $ cradleTempDir crdl - -fillTempDir :: IOish m => Cradle -> m Cradle -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 - - let cabalDir = takeDirectory cabalFile - - return Cradle { - cradleProject = CabalProject - , cradleCurrentDir = wdir - , cradleRootDir = cabalDir - , cradleTempDir = error "tmpDir" - , cradleCabalFile = Just cabalFile - , cradleDistDir = "dist" - } - -stackCradle :: (GmLog m, IOish m, GmOut m) => FilePath -> MaybeT m Cradle -stackCradle wdir = do -#if !MIN_VERSION_ghc(7,8,0) - -- GHC < 7.8 is not supported by stack - mzero -#endif - cabalFile <- MaybeT $ liftIO $ findCabalFile wdir - - let cabalDir = takeDirectory cabalFile - - _stackConfigFile <- MaybeT $ liftIO $ findStackConfigFile cabalDir - - -- 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." - mzero - - senv <- MaybeT $ getStackEnv cabalDir - - return Cradle { - cradleProject = StackProject senv - , cradleCurrentDir = wdir - , cradleRootDir = cabalDir - , cradleTempDir = error "tmpDir" - , cradleCabalFile = Just cabalFile - , cradleDistDir = seDistDir senv - } - -stackCradleSpec :: (GmLog m, IOish m, GmOut m) => FilePath -> MaybeT m Cradle -stackCradleSpec wdir = do - crdl <- stackCradle wdir - case crdl of - Cradle { cradleProject = StackProject StackEnv { seDistDir } } -> do - b <- isGmDistDir seDistDir - when b mzero - return crdl - _ -> error "stackCradleSpec" - where - isGmDistDir dir = - liftIO $ not <$> doesFileExist (dir ".." "ghc-mod.cabal") - -sandboxCradle :: IOish m => FilePath -> MaybeT m Cradle -sandboxCradle wdir = do - sbDir <- MaybeT $ liftIO $ findCabalSandboxDir wdir - return Cradle { - cradleProject = SandboxProject - , cradleCurrentDir = wdir - , cradleRootDir = sbDir - , cradleTempDir = error "tmpDir" - , cradleCabalFile = Nothing - , cradleDistDir = "dist" - } - -plainCradle :: IOish m => FilePath -> MaybeT m Cradle -plainCradle wdir = do - return $ Cradle { - cradleProject = PlainProject - , cradleCurrentDir = wdir - , cradleRootDir = wdir - , cradleTempDir = error "tmpDir" - , cradleCabalFile = Nothing - , cradleDistDir = "dist" - } diff --git a/Language/Haskell/GhcMod/CustomPackageDb.hs b/Language/Haskell/GhcMod/CustomPackageDb.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/CustomPackageDb.hs +++ /dev/null @@ -1,38 +0,0 @@ --- ghc-mod: Making Haskell development *more* fun --- Copyright (C) 2015 Daniel Gröber --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU Affero General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU Affero General Public License for more details. --- --- You should have received a copy of the GNU Affero General Public License --- along with this program. If not, see . -module Language.Haskell.GhcMod.CustomPackageDb where - -import Control.Applicative -import Control.Monad -import Control.Category ((.)) -import Data.Maybe -import Data.Traversable -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Monad.Types -import Language.Haskell.GhcMod.PathsAndFiles -import Prelude hiding ((.)) - -parseCustomPackageDb :: String -> [GhcPkgDb] -parseCustomPackageDb src = map parsePkgDb $ filter (not . null) $ lines src - where - parsePkgDb "global" = GlobalDb - parsePkgDb "user" = UserDb - parsePkgDb s = PackageDb s - -getCustomPkgDbStack :: (MonadIO m, GmEnv m) => m (Maybe [GhcPkgDb]) -getCustomPkgDbStack = do - mCusPkgDbFile <- liftIO . (traverse readFile <=< findCustomPackageDbFile) . cradleRootDir =<< cradle - return $ parseCustomPackageDb <$> mCusPkgDbFile diff --git a/Language/Haskell/GhcMod/Debug.hs b/Language/Haskell/GhcMod/Debug.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Debug.hs +++ /dev/null @@ -1,143 +0,0 @@ -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.List.Split -import Text.PrettyPrint -import Language.Haskell.GhcMod.Monad -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Internal -import Language.Haskell.GhcMod.Target -import Language.Haskell.GhcMod.Pretty -import Language.Haskell.GhcMod.Utils -import Language.Haskell.GhcMod.Cradle -import Language.Haskell.GhcMod.Stack - ----------------------------------------------------------------- - --- | Obtaining debug information. -debugInfo :: IOish m => GhcModT m String -debugInfo = do - Options {..} <- options - Cradle {..} <- cradle - - cabal <- - case cradleProject of - CabalProject -> cabalDebug - StackProject {} -> (++) <$> stackPaths <*> cabalDebug - _ -> return [] - - pkgOpts <- packageGhcOptions - - return $ unlines $ - [ "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] -stackPaths = do - Cradle { cradleProject = StackProject senv } <- cradle - ghc <- getStackGhcPath senv - ghcPkg <- getStackGhcPkgPath senv - return $ - [ "Stack ghc executable: " ++ show ghc - , "Stack ghc-pkg executable:" ++ show ghcPkg - ] - -cabalDebug :: IOish m => GhcModT m [String] -cabalDebug = do - Cradle {..} <- cradle - mcs <- cabalResolvedComponents - let entrypoints = Map.map gmcEntrypoints mcs - graphs = Map.map gmcHomeModuleGraph mcs - opts = Map.map gmcGhcOpts mcs - srcOpts = Map.map gmcGhcSrcOpts mcs - - return $ - [ "Cabal file: " ++ show cradleCabalFile - , "Project: " ++ show cradleProject - , "Cabal entrypoints:\n" ++ render (nest 4 $ - mapDoc gmComponentNameDoc smpDoc entrypoints) - , "Cabal components:\n" ++ render (nest 4 $ - mapDoc gmComponentNameDoc graphDoc graphs) - , "GHC Cabal options:\n" ++ render (nest 4 $ - mapDoc gmComponentNameDoc (fsep . map text) opts) - , "GHC search path options:\n" ++ render (nest 4 $ - mapDoc gmComponentNameDoc (fsep . map text) srcOpts) - ] - -componentInfo :: IOish m => [String] -> GhcModT m String -componentInfo ts = do - -- TODO: most of this is copypasta of targetGhcOptions. Factor out more - -- useful function from there. - crdl <- cradle - sefnmn <- Set.fromList `liftM` mapM guessModuleFile ts - mcs <- cabalResolvedComponents - let - mdlcs = moduleComponents mcs `zipMap` Set.toList sefnmn - candidates = findCandidates $ map snd mdlcs - cn = pickComponent candidates - opts <- targetGhcOptions crdl sefnmn - - return $ unlines $ - [ "Matching Components:\n" ++ render (nest 4 $ - alistDoc (either text mnDoc) (setDoc gmComponentNameDoc) mdlcs) - , "Picked Component:\n" ++ render (nest 4 $ - gmComponentNameDoc cn) - , "GHC Cabal options:\n" ++ render (nest 4 $ fsep $ map text opts) - ] - where - zipMap f l = l `zip` (f `map` l) - -guessModuleFile :: MonadIO m => String -> m (Either FilePath ModuleName) -guessModuleFile m - | (isUpper . head .&&. (all $ all $ isAlphaNum .||. (=='.')) . splitOn ".") m = - return $ Right $ mkModuleName m - where - infixr 1 .||. - infixr 2 .&&. - (.||.) = liftA2 (||) - (.&&.) = liftA2 (&&) - -guessModuleFile str = Left `liftM` liftIO (canonFilePath str) - -graphDoc :: GmModuleGraph -> Doc -graphDoc GmModuleGraph{..} = - mapDoc mpDoc smpDoc' gmgGraph - where - smpDoc' smp = vcat $ map mpDoc' $ Set.toList smp - mpDoc' = text . moduleNameString . mpModule - -setDoc :: (a -> Doc) -> Set.Set a -> Doc -setDoc f s = vcat $ map f $ Set.toList s - -smpDoc :: Set.Set ModulePath -> Doc -smpDoc smp = setDoc mpDoc smp - -mpDoc :: ModulePath -> Doc -mpDoc (ModulePath mn fn) = text (moduleNameString mn) <+> parens (text fn) - -mnDoc :: ModuleName -> Doc -mnDoc mn = text (moduleNameString mn) - -alistDoc :: Ord k => (k -> Doc) -> (a -> Doc) -> [(k, a)] -> Doc -alistDoc fk fa alist = mapDoc fk fa (Map.fromList alist) - -mapDoc :: (k -> Doc) -> (a -> Doc) -> Map.Map k a -> Doc -mapDoc kd ad m = vcat $ - map (uncurry ($+$)) $ map (first kd) $ Map.toList $ Map.map (nest 4 . ad) m ----------------------------------------------------------------- - --- | Obtaining root information. -rootInfo :: forall m. (IOish m, GmOut m) => m String -rootInfo = (++"\n") . cradleRootDir <$> fst `liftM` (runJournalT findCradle :: m (Cradle, GhcModLog)) diff --git a/Language/Haskell/GhcMod/DebugLogger.hs b/Language/Haskell/GhcMod/DebugLogger.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/DebugLogger.hs +++ /dev/null @@ -1,138 +0,0 @@ --- ghc-mod: Making Haskell development *more* fun --- Copyright (C) 2015 Daniel Gröber --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU Affero General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU Affero General Public License for more details. --- --- You should have received a copy of the GNU Affero General Public License --- along with this program. If not, see . -{-# LANGUAGE CPP #-} -module Language.Haskell.GhcMod.DebugLogger where - --- (c) The University of Glasgow 2005 --- --- The Glasgow Haskell Compiler License --- --- Copyright 2002, The University Court of the University of Glasgow. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- - Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright notice, --- this list of conditions and the following disclaimer in the documentation --- and/or other materials provided with the distribution. --- --- - Neither name of the University nor the names of its contributors may be --- used to endorse or promote products derived from this software without --- specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF --- GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, --- INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND --- FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE --- UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT --- LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY --- OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH --- DAMAGE. - -import GHC -import FastString -import Pretty -import Outputable (SDoc, PprStyle, runSDoc, initSDocContext, blankLine) -import qualified Outputable -import ErrUtils - -import Language.Haskell.GhcMod.Error -import Language.Haskell.GhcMod.Gap -import Prelude - -debugLogAction :: (String -> IO ()) -> GmLogAction -debugLogAction putErr dflags severity srcSpan style msg - = case severity of - SevOutput -> printSDoc putErr msg style - -#if __GLASGOW_HASKELL__ >= 706 - SevDump -> printSDoc putErr (msg Outputable.$$ blankLine) style -#endif - -#if __GLASGOW_HASKELL__ >= 708 - SevInteractive -> let - putStrSDoc = debugLogActionHPutStrDoc dflags putErr - in - putStrSDoc msg style -#endif - SevInfo -> printErrs putErr msg style - SevFatal -> printErrs putErr msg style - _ -> do putErr "\n" -#if __GLASGOW_HASKELL__ >= 706 - printErrs putErr (mkLocMessage severity srcSpan msg) style -#else - printErrs putErr (mkLocMessage srcSpan msg) style -#endif - -- careful (#2302): printErrs prints in UTF-8, - -- whereas converting to string first and using - -- hPutStr would just emit the low 8 bits of - -- each unicode char. - where -#if __GLASGOW_HASKELL__ >= 706 - printSDoc put = debugLogActionHPrintDoc dflags put - printErrs put = debugLogActionHPrintDoc dflags put -#endif - - -#if __GLASGOW_HASKELL__ >= 706 - -debugLogActionHPrintDoc :: DynFlags -> (String -> IO ()) -> SDoc -> PprStyle -> IO () -debugLogActionHPrintDoc dflags put d sty - = debugLogActionHPutStrDoc dflags put (d Outputable.$$ Outputable.text "") sty - -- Adds a newline - -debugLogActionHPutStrDoc :: DynFlags -> (String -> IO ()) -> SDoc -> PprStyle -> IO () -debugLogActionHPutStrDoc dflags put d sty - = gmPrintDoc_ Pretty.PageMode (pprCols dflags) put doc - where -- Don't add a newline at the end, so that successive - -- calls to this log-action can output all on the same line - doc = runSDoc d (initSDocContext dflags sty) - -#else - -printSDoc = printErrs - -printErrs :: (String -> IO ()) -> SDoc -> PprStyle -> IO () -printErrs put doc sty = do - gmPrintDoc PageMode 100 put (runSDoc doc (initSDocContext sty)) - -#endif - -gmPrintDoc :: Mode -> Int -> (String -> IO ()) -> Doc -> IO () --- printDoc adds a newline to the end -gmPrintDoc mode cols put doc = gmPrintDoc_ mode cols put (doc $$ text "") - -gmPrintDoc_ :: Mode -> Int -> (String -> IO ()) -> Doc -> IO () -gmPrintDoc_ mode pprCols putS doc - = fullRender mode pprCols 1.5 put done doc - where - put (Chr c) next = putS [c] >> next - put (Str s) next = putS s >> next - put (PStr s) next = putS (unpackFS s) >> next -#if __GLASGOW_HASKELL__ >= 708 - put (ZStr s) next = putS (zString s) >> next -#endif - put (LStr s _l) next = putS (unpackLitString s) >> next - - done = return () -- hPutChar hdl '\n' diff --git a/Language/Haskell/GhcMod/Doc.hs b/Language/Haskell/GhcMod/Doc.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Doc.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Language.Haskell.GhcMod.Doc where - -import GHC -import Language.Haskell.GhcMod.Gap (withStyle, showDocWith) -import Outputable -import Pretty (Mode(..)) - -showPage :: DynFlags -> PprStyle -> SDoc -> String -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 - return $ mkUserStyle unqual AllTheWay - -styleUnqualified :: PprStyle -styleUnqualified = mkUserStyle neverQualify AllTheWay diff --git a/Language/Haskell/GhcMod/DynFlags.hs b/Language/Haskell/GhcMod/DynFlags.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/DynFlags.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Language.Haskell.GhcMod.DynFlags where - -import Control.Applicative -import Control.Monad -import GHC -import qualified GHC as G -import GHC.Paths (libdir) -import qualified Language.Haskell.GhcMod.Gap as Gap -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.DebugLogger -import System.IO.Unsafe (unsafePerformIO) -import Prelude - -setEmptyLogger :: DynFlags -> DynFlags -setEmptyLogger df = - Gap.setLogAction df $ \_ _ _ _ _ -> return () - -setDebugLogger :: (String -> IO ()) -> DynFlags -> DynFlags -setDebugLogger put df = do - Gap.setLogAction df (debugLogAction put) - --- * Fast --- * Friendly to foreign export --- * Not friendly to -XTemplateHaskell and -XPatternSynonyms --- * Uses little memory -setHscNothing :: DynFlags -> DynFlags -setHscNothing df = df { - ghcMode = CompManager - , ghcLink = NoLink - , hscTarget = HscNothing - , optLevel = 0 - } - --- * Slow --- * Not friendly to foreign export --- * Friendly to -XTemplateHaskell and -XPatternSynonyms --- * Uses lots of memory -setHscInterpreted :: DynFlags -> DynFlags -setHscInterpreted df = df { - ghcMode = CompManager - , ghcLink = LinkInMemory - , hscTarget = HscInterpreted - , optLevel = 0 - } - --- | Parse command line ghc options and add them to the 'DynFlags' passed -addCmdOpts :: GhcMonad m => [GHCOption] -> DynFlags -> m DynFlags -addCmdOpts cmdOpts df = - fst3 <$> G.parseDynamicFlags df (map G.noLoc cmdOpts) - where - fst3 (a,_,_) = a - ----------------------------------------------------------------- - -withDynFlags :: GhcMonad m - => (DynFlags -> DynFlags) - -> m a - -> m a -withDynFlags setFlags body = G.gbracket setup teardown (\_ -> body) - where - setup = do - dflags <- G.getSessionDynFlags - void $ G.setSessionDynFlags (setFlags dflags) - return dflags - teardown = void . G.setSessionDynFlags - -withCmdFlags :: GhcMonad m => [GHCOption] -> m a -> m a -withCmdFlags flags body = G.gbracket setup teardown (\_ -> body) - where - setup = do - dflags <- G.getSessionDynFlags - void $ G.setSessionDynFlags =<< addCmdOpts flags dflags - return dflags - teardown = void . G.setSessionDynFlags - ----------------------------------------------------------------- - --- | Set 'DynFlags' equivalent to "-w:". -setNoWarningFlags :: DynFlags -> DynFlags -setNoWarningFlags df = df { warningFlags = Gap.emptyWarnFlags} - --- | Set 'DynFlags' equivalent to "-Wall". -setAllWarningFlags :: DynFlags -> DynFlags -setAllWarningFlags df = df { warningFlags = allWarningFlags } - -allWarningFlags :: Gap.WarnFlags -allWarningFlags = unsafePerformIO $ - G.runGhc (Just libdir) $ do - df <- G.getSessionDynFlags - df' <- addCmdOpts ["-Wall"] df - return $ G.warningFlags df' - ----------------------------------------------------------------- - --- | 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 df = return $ - Gap.setWarnTypedHoles $ Gap.setDeferTypedHoles $ - Gap.setDeferTypeErrors $ setNoWarningFlags df diff --git a/Language/Haskell/GhcMod/Error.hs b/Language/Haskell/GhcMod/Error.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Error.hs +++ /dev/null @@ -1,160 +0,0 @@ --- ghc-mod: Making Haskell development *more* fun --- Copyright (C) 2015 Daniel Gröber --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU Affero General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU Affero General Public License for more details. --- --- You should have received a copy of the GNU Affero General Public License --- along with this program. If not, see . - -{-# LANGUAGE ExistentialQuantification #-} -module Language.Haskell.GhcMod.Error ( - GhcModError(..) - , GmError - , gmeDoc - , ghcExceptionDoc - , liftMaybe - , overrideError - , modifyError - , modifyError' - , modifyGmError - , tryFix - , GHandler(..) - , gcatches - , module Control.Monad.Error - , module Control.Exception - ) where - -import Control.Arrow hiding ((<+>)) -import Control.Exception -import Control.Monad.Error hiding (MonadIO, liftIO) -import qualified Data.Set as Set -import Data.List -import Data.Version -import System.Process (showCommandForUser) -import Text.PrettyPrint -import Text.Printf - -import Exception -import Panic -import Config (cProjectVersion, cHostPlatformString) -import Paths_ghc_mod (version) - -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Pretty - -type GmError m = MonadError GhcModError m - -gmeDoc :: GhcModError -> Doc -gmeDoc e = case e of - GMENoMsg -> - text "Unknown error" - GMEString msg -> - text msg - GMECabalConfigure msg -> - text "Configuring cabal project failed" <+>: gmeDoc msg - GMEStackConfigure msg -> - text "Configuring stack project failed" <+>: gmeDoc msg - GMEStackBootstrap msg -> - text "Bootstrapping stack project environment failed" <+>: gmeDoc msg - GMECabalCompAssignment ctx -> - text "Could not find a consistent component assignment for modules:" $$ - (nest 4 $ foldr ($+$) empty $ map ctxDoc ctx) $$ - text "" $$ - (if all (Set.null . snd) ctx - then noComponentSuggestions - else empty) $$ - text "- To find out which components ghc-mod knows about try:" $$ - nest 4 (backticks $ text "ghc-mod debug") - - where - noComponentSuggestions = - text "- Are some of these modules part of a test and or benchmark?\ - \ Try enabling them:" $$ - nest 4 (backticks $ text "cabal configure --enable-tests [--enable-benchmarks]") - - backticks d = char '`' <> d <> char '`' - ctxDoc = moduleDoc *** compsDoc - >>> first (<> colon) >>> uncurry (flip hang 4) - - moduleDoc (Left fn) = - text "File " <> quotes (text fn) - moduleDoc (Right mdl) = - text "Module " <> quotes (text $ moduleNameString mdl) - - compsDoc sc | Set.null sc = text "has no known components" - compsDoc sc = fsep $ punctuate comma $ - map gmComponentNameDoc $ Set.toList sc - GMEProcess _fn cmd args emsg -> let c = showCommandForUser cmd args in - case emsg of - Right err -> - text (printf "Launching system command `%s` failed: " c) - <> gmeDoc err - Left rv -> text $ - printf "Launching system command `%s` failed (exited with %d)" c rv - GMENoCabalFile -> - text "No cabal file found." - GMETooManyCabalFiles cfs -> - text $ "Multiple cabal files found. Possible cabal files: \"" - ++ intercalate "\", \"" cfs ++"\"." - -ghcExceptionDoc :: GhcException -> Doc -ghcExceptionDoc e@(CmdLineError _) = - text $ ": " ++ showGhcException e "" -ghcExceptionDoc (UsageError str) = strDoc str -ghcExceptionDoc (Panic msg) = vcat $ map text $ lines $ printf "\ -\GHC panic! (the 'impossible' happened)\n\ -\ ghc-mod version %s\n\ -\ GHC library version %s for %s:\n\ -\ %s\n\ -\\n\ -\Please report this as a bug: %s\n" - gmVer ghcVer platform msg url - where - gmVer = showVersion version - ghcVer = cProjectVersion - platform = cHostPlatformString - url = "https://github.com/kazu-yamamoto/ghc-mod/issues" :: String - -ghcExceptionDoc e = text $ showGhcException e "" - -liftMaybe :: MonadError e m => e -> m (Maybe a) -> m a -liftMaybe e action = maybe (throwError e) return =<< action - -overrideError :: MonadError e m => e -> m a -> m a -overrideError e action = modifyError (const e) action - -modifyError :: MonadError e m => (e -> e) -> m a -> m a -modifyError f action = action `catchError` \e -> throwError $ f e - -infixr 0 `modifyError'` -modifyError' :: MonadError e m => m a -> (e -> e) -> m a -modifyError' = flip modifyError - -modifyGmError :: (MonadIO m, ExceptionMonad m) - => (GhcModError -> GhcModError) -> m a -> m a -modifyGmError f a = gcatch a $ \(ex :: GhcModError) -> liftIO $ throwIO (f ex) - -tryFix :: MonadError e m => m a -> (e -> m ()) -> m a -tryFix action f = do - action `catchError` \e -> f e >> action - -data GHandler m a = forall e . Exception e => GHandler (e -> m a) - -gcatches :: (MonadIO m, ExceptionMonad m) => m a -> [GHandler m a] -> m a -gcatches io handlers = io `gcatch` gcatchesHandler handlers - -gcatchesHandler :: (MonadIO m, ExceptionMonad m) - => [GHandler m a] -> SomeException -> m a -gcatchesHandler handlers e = foldr tryHandler (liftIO $ throw e) handlers - where tryHandler (GHandler handler) res - = case fromException e of - Just e' -> handler e' - Nothing -> res diff --git a/Language/Haskell/GhcMod/FileMapping.hs b/Language/Haskell/GhcMod/FileMapping.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/FileMapping.hs +++ /dev/null @@ -1,103 +0,0 @@ -module Language.Haskell.GhcMod.FileMapping - ( loadMappedFile - , loadMappedFileSource - , unloadMappedFile - , mapFile - , fileModSummaryWithMapping - ) where - -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Monad.Types -import Language.Haskell.GhcMod.Gap -import Language.Haskell.GhcMod.HomeModuleGraph -import Language.Haskell.GhcMod.Utils - -import System.IO -import System.FilePath -import System.Directory - -import Control.Monad.Trans.Maybe -import GHC -import Control.Monad - -{- | maps 'FilePath', given as first argument to take source from -'FilePath' given as second argument. Works exactly the same as -first form of `--map-file` CLI option. - -\'from\' can be either full path, or path relative to project root. -\'to\' has to be either relative to project root, or full path (preferred) --} -loadMappedFile :: IOish m - => FilePath -- ^ \'from\', file that will be mapped - -> FilePath -- ^ \'to\', file to take source from - -> GhcModT m () -loadMappedFile from to = loadMappedFile' from to False - -{- | -maps 'FilePath', given as first argument to have source as given -by second argument. - -\'from\' may or may not exist, and should be either full path, -or relative to project root. --} -loadMappedFileSource :: IOish m - => FilePath -- ^ \'from\', file that will be mapped - -> String -- ^ \'src\', source - -> GhcModT m () -loadMappedFileSource from src = do - tmpdir <- cradleTempDir `fmap` cradle - to <- liftIO $ do - (fn, h) <- openTempFile tmpdir (takeFileName from) - hPutStr h src - hClose h - return fn - loadMappedFile' from to True - -loadMappedFile' :: IOish m => FilePath -> FilePath -> Bool -> GhcModT m () -loadMappedFile' from to isTemp = do - cfn <- getCanonicalFileNameSafe from - unloadMappedFile' cfn - crdl <- cradle - 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 _ (Target tid@(TargetFile filePath _) taoc _) = do - mapping <- lookupMMappedFile filePath - 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 - -mkMappedTarget :: (IOish m, GmState m, GmEnv m, GhcMonad m) => - Maybe FilePath -> TargetId -> Bool -> Maybe FileMapping -> m Target -mkMappedTarget _ _ taoc (Just to) = - return $ mkTarget (TargetFile (fmPath to) Nothing) taoc Nothing -mkMappedTarget _ tid taoc _ = return $ mkTarget tid taoc Nothing - -{-| -unloads previously mapped file \'file\', so that it's no longer mapped, -and removes any temporary files created when file was -mapped. - -\'file\' should be either full path, or relative to project root. --} -unloadMappedFile :: IOish m - => FilePath -- ^ \'file\', file to unmap - -> GhcModT m () -unloadMappedFile = getCanonicalFileNameSafe >=> unloadMappedFile' - -unloadMappedFile' :: IOish m => FilePath -> GhcModT m () -unloadMappedFile' cfn = void $ runMaybeT $ do - fm <- MaybeT $ lookupMMappedFile cfn - liftIO $ when (fmTemp fm) $ removeFile (fmPath fm) - delMMappedFile cfn - -fileModSummaryWithMapping :: (IOish m, GmState m, GhcMonad m, GmEnv m) => - FilePath -> m ModSummary -fileModSummaryWithMapping fn = - withMappedFile fn $ \fn' -> fileModSummary fn' diff --git a/Language/Haskell/GhcMod/FillSig.hs b/Language/Haskell/GhcMod/FillSig.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/FillSig.hs +++ /dev/null @@ -1,554 +0,0 @@ -{-# LANGUAGE CPP, MultiParamTypeClasses, FunctionalDependencies #-} -{-# LANGUAGE FlexibleInstances #-} - -module Language.Haskell.GhcMod.FillSig ( - sig - , refine - , auto - ) where - -import Data.Char (isSymbol) -import Data.Function (on) -import Data.Functor -import Data.List (find, nub, sortBy) -import qualified Data.Map as M -import Data.Maybe (catMaybes) -import Text.PrettyPrint (($$), text, nest) -import Prelude - -import Exception (ghandle, SomeException(..)) -import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, - SrcSpan, Type, GenLocated(L)) -import qualified GHC as G -import qualified Name as G -import Outputable (PprStyle) -import qualified Type as Ty -import qualified HsBinds as Ty -import qualified Class as Ty -import qualified Var as Ty -import qualified HsPat as Ty -import qualified Language.Haskell.Exts.Annotated as HE -import Djinn.GHC - -import qualified Language.Haskell.GhcMod.Gap as Gap -import Language.Haskell.GhcMod.Convert -import Language.Haskell.GhcMod.DynFlags -import Language.Haskell.GhcMod.Monad -import Language.Haskell.GhcMod.SrcUtils -import Language.Haskell.GhcMod.Logging (gmLog) -import Language.Haskell.GhcMod.Pretty (showDoc) -import Language.Haskell.GhcMod.Doc -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.FileMapping (fileModSummaryWithMapping) - -#if __GLASGOW_HASKELL__ >= 710 -import GHC (unLoc) -#endif - ----------------------------------------------------------------- --- INTIAL CODE FROM FUNCTION OR INSTANCE SIGNATURE ----------------------------------------------------------------- - --- Possible signatures we can find: function or instance -data SigInfo - = Signature SrcSpan [G.RdrName] (G.HsType G.RdrName) - | InstanceDecl SrcSpan G.Class - | TyFamDecl SrcSpan G.RdrName TyFamType {- True if closed -} [G.RdrName] - --- Signature for fallback operation via haskell-src-exts -data HESigInfo - = HESignature HE.SrcSpan [HE.Name HE.SrcSpanInfo] (HE.Type HE.SrcSpanInfo) - | HEFamSignature - HE.SrcSpan - TyFamType - (HE.Name HE.SrcSpanInfo) - [HE.Name HE.SrcSpanInfo] - -data TyFamType = Closed | Open | Data -initialTyFamString :: TyFamType -> (String, String) -initialTyFamString Closed = ("instance", "") -initialTyFamString Open = ("function", "type instance ") -initialTyFamString Data = ("function", "data instance ") - --- | Create a initial body from a signature. -sig :: IOish m - => FilePath -- ^ A target file. - -> Int -- ^ Line number. - -> Int -- ^ Column number. - -> GhcModT m String -sig file lineNo colNo = - runGmlT' [Left file] deferErrors $ ghandle fallback $ do - oopts <- outputOpts - style <- getStyle - dflag <- G.getSessionDynFlags - modSum <- fileModSummaryWithMapping file - whenFound oopts (getSignature modSum lineNo colNo) $ \s -> - case s of - Signature loc names ty -> - ("function", fourInts loc, map (initialBody dflag style ty) names) - - InstanceDecl loc cls -> - let body x = initialBody dflag style (G.idType x) x - in ("instance", fourInts loc, body `map` Ty.classMethods cls) - - TyFamDecl loc name flavour vars -> - let (rTy, initial) = initialTyFamString flavour - body = initialFamBody dflag style name vars - in (rTy, fourInts loc, [initial ++ body]) - where - fallback (SomeException _) = do - oopts <- outputOpts - -- Code cannot be parsed by ghc module - -- Fallback: try to get information via haskell-src-exts - whenFound oopts (getSignatureFromHE file lineNo colNo) $ \x -> case x of - HESignature loc names ty -> - ("function", fourIntsHE loc, map (initialBody undefined undefined ty) names) - HEFamSignature loc flavour name vars -> - let (rTy, initial) = initialTyFamString flavour - in (rTy, fourIntsHE loc, [initial ++ initialFamBody undefined undefined name vars]) - ----------------------------------------------------------------- --- a. Code for getting the information - --- Get signature from ghc parsing and typechecking -getSignature :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SigInfo) -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 - [L loc (G.SigD (Ty.TypeSig names (L _ ty) _))] -> -#else - [L loc (G.SigD (Ty.TypeSig names (L _ ty)))] -> -#endif - -- We found a type signature - return $ Just $ Signature loc (map G.unLoc names) ty - [L _ (G.InstD _)] -> do - -- We found an instance declaration - TypecheckedModule{tm_renamed_source = Just tcs - ,tm_checked_module_info = minfo} <- G.typecheckModule p - let lst = listifyRenamedSpans tcs (lineNo, colNo) - case Gap.getClass lst of - Just (clsName,loc) -> obtainClassInfo minfo clsName loc - _ -> return Nothing -#if __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 -#else - [L loc (G.TyClD (G.TyFamily info (L _ name) vars _))] -> do -#endif -#if __GLASGOW_HASKELL__ >= 708 - let flavour = case info of - G.ClosedTypeFamily _ -> Closed - G.OpenTypeFamily -> Open - G.DataFamily -> Data -#else - let flavour = case info of -- Closed type families where introduced in GHC 7.8 - G.TypeFamily -> Open - G.DataFamily -> Data -#endif - -#if __GLASGOW_HASKELL__ >= 710 - getTyFamVarName x = case x of - L _ (G.UserTyVar n) -> n - L _ (G.KindedTyVar (G.L _ n) _) -> n -#elif __GLASGOW_HASKELL__ >= 706 - getTyFamVarName x = case x of - L _ (G.UserTyVar n) -> n - L _ (G.KindedTyVar n _) -> n -#else - getTyFamVarName x = case x of -- In GHC 7.4, HsTyVarBndr's have an extra arg - L _ (G.UserTyVar n _) -> n - L _ (G.KindedTyVar n _ _) -> n -#endif - in return $ Just (TyFamDecl loc name flavour $ map getTyFamVarName vars) - _ -> return Nothing - where obtainClassInfo :: GhcMonad m => G.ModuleInfo -> G.Name -> SrcSpan -> m (Maybe SigInfo) - obtainClassInfo minfo clsName loc = do - tyThing <- G.modInfoLookupName minfo clsName - return $ do Ty.ATyCon clsCon <- tyThing -- In Maybe - cls <- G.tyConClass_maybe clsCon - return $ InstanceDecl loc cls - --- Get signature from haskell-src-exts -getSignatureFromHE :: (MonadIO m, GhcMonad m) => - FilePath -> Int -> Int -> m (Maybe HESigInfo) -getSignatureFromHE file lineNo colNo = do - presult <- liftIO $ HE.parseFile file - return $ case presult of - HE.ParseOk (HE.Module _ _ _ _ mdecls) -> do - decl <- find (typeSigInRangeHE lineNo colNo) mdecls - case decl of - HE.TypeSig (HE.SrcSpanInfo s _) names ty -> - return $ HESignature s names ty - - HE.TypeFamDecl (HE.SrcSpanInfo s _) declHead _ -> - let (name, tys) = dHeadTyVars declHead in - return $ HEFamSignature s Open name (map cleanTyVarBind tys) - - HE.DataFamDecl (HE.SrcSpanInfo s _) _ declHead _ -> - let (name, tys) = dHeadTyVars declHead in - return $ HEFamSignature s Open name (map cleanTyVarBind tys) - _ -> fail "" - _ -> Nothing - where cleanTyVarBind (HE.KindedVar _ n _) = n - cleanTyVarBind (HE.UnkindedVar _ n) = n - -#if MIN_VERSION_haskell_src_exts(1,16,0) - dHeadTyVars :: HE.DeclHead l -> (HE.Name l, [HE.TyVarBind l]) - dHeadTyVars (HE.DHead _ name) = (name, []) - dHeadTyVars (HE.DHApp _ r ty) = (++[ty]) `fmap` (dHeadTyVars r) - dHeadTyVars (HE.DHInfix _ ty name) = (name, [ty]) - dHeadTyVars (HE.DHParen _ r) = dHeadTyVars r -#else - dHeadTyVars :: HE.DeclHead l -> (HE.Name l, [HE.TyVarBind l]) - dHeadTyVars (HE.DHead _ n tys) = (n, tys) -#endif - ----------------------------------------------------------------- --- b. Code for generating initial code - --- A list of function arguments, and whether they are functions or normal --- arguments is built from either a function signature or an instance signature -data FnArg = FnArgFunction | FnArgNormal | FnExplicitName String - -initialBody :: FnArgsInfo ty name => DynFlags -> PprStyle -> ty -> name -> String -initialBody dflag style ty name = - initialBody' (getFnName dflag style name) (getFnArgs ty) - -initialBody' :: String -> [FnArg] -> String -initialBody' fname args = - initialHead fname args ++ " = " ++ n ++ "_body" - where n = if isSymbolName fname then "" else '_':fname - -initialFamBody :: FnArgsInfo ty name - => DynFlags -> PprStyle -> name -> [name] -> String -initialFamBody dflag style name args = - initialHead fnName fnArgs ++ " = ()" - where fnName = getFnName dflag style name - fnArgs = map (FnExplicitName . getFnName dflag style) args - -initialHead :: String -> [FnArg] -> String -initialHead fname args = - case initialBodyArgs args infiniteVars infiniteFns of - [] -> fname - arglist -> if isSymbolName fname - then head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist) - else fname ++ " " ++ unwords arglist - -initialBodyArgs :: [FnArg] -> [String] -> [String] -> [String] -initialBodyArgs [] _ _ = [] -initialBodyArgs (FnArgFunction:xs) vs (f:fs) = f : initialBodyArgs xs vs fs -initialBodyArgs (FnArgNormal:xs) (v:vs) fs = v : initialBodyArgs xs vs fs -initialBodyArgs (FnExplicitName n:xs) vs fs = n : initialBodyArgs xs vs fs -initialBodyArgs _ _ _ = - error "initialBodyArgs: This should never happen" -- Lists are infinite - -initialHead1 :: String -> [FnArg] -> [String] -> String -initialHead1 fname args elts = - case initialBodyArgs1 args elts of - [] -> fname - arglist - | isSymbolName fname -> - head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist) - | otherwise -> - fname ++ " " ++ unwords arglist - -initialBodyArgs1 :: [FnArg] -> [String] -> [String] -initialBodyArgs1 args elts = take (length args) elts - --- Getting the initial body of function and instances differ --- This is because for functions we only use the parsed file --- (so the full file doesn't have to be type correct) --- but for instances we need to get information about the class - -class FnArgsInfo ty name | ty -> name, name -> ty where - getFnName :: DynFlags -> PprStyle -> name -> String - getFnArgs :: ty -> [FnArg] - -instance FnArgsInfo (G.HsType G.RdrName) (G.RdrName) where - getFnName dflag style name = showOccName dflag style $ Gap.occName name -#if __GLASGOW_HASKELL__ >= 710 - getFnArgs (G.HsForAllTy _ _ _ _ (L _ iTy)) -#else - getFnArgs (G.HsForAllTy _ _ _ (L _ iTy)) -#endif - = getFnArgs iTy - - getFnArgs (G.HsParTy (L _ iTy)) = getFnArgs iTy - 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 - (G.HsForAllTy _ _ _ _ (L _ iTy)) -> -#else - (G.HsForAllTy _ _ _ (L _ iTy)) -> -#endif - fnarg iTy - - (G.HsParTy (L _ iTy)) -> fnarg iTy - (G.HsFunTy _ _) -> True - _ -> False - getFnArgs _ = [] - -instance FnArgsInfo (HE.Type HE.SrcSpanInfo) (HE.Name HE.SrcSpanInfo) where - getFnName _ _ (HE.Ident _ s) = s - getFnName _ _ (HE.Symbol _ s) = s - getFnArgs (HE.TyForall _ _ _ iTy) = getFnArgs iTy - getFnArgs (HE.TyParen _ iTy) = getFnArgs iTy - getFnArgs (HE.TyFun _ lTy rTy) = - (if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy - where fnarg ty = case ty of - (HE.TyForall _ _ _ iTy) -> fnarg iTy - (HE.TyParen _ iTy) -> fnarg iTy - (HE.TyFun _ _ _) -> True - _ -> False - getFnArgs _ = [] - -instance FnArgsInfo Type Id where - getFnName dflag style method = showOccName dflag style $ G.getOccName method - getFnArgs = getFnArgs' . Ty.dropForAlls - where getFnArgs' ty | Just (lTy,rTy) <- Ty.splitFunTy_maybe ty = - maybe (if Ty.isPredTy lTy then getFnArgs' rTy else FnArgNormal:getFnArgs' rTy) - (\_ -> FnArgFunction:getFnArgs' rTy) - $ Ty.splitFunTy_maybe lTy - - getFnArgs' ty | Just (_,iTy) <- Ty.splitForAllTy_maybe ty = - getFnArgs' iTy - - getFnArgs' _ = [] - --- Infinite supply of variable and function variable names -infiniteVars, infiniteFns :: [String] -infiniteVars = infiniteSupply ["x","y","z","t","u","v","w"] -infiniteFns = infiniteSupply ["f","g","h"] -infiniteSupply :: [String] -> [String] -infiniteSupply initialSupply = - initialSupply ++ concatMap (\n -> map (\v -> v ++ show n) initialSupply) - ([1 .. ] :: [Integer]) - --- Check whether a String is a symbol name -isSymbolName :: String -> Bool -isSymbolName (c:_) = c `elem` "!#$%&*+./<=>?@\\^|-~" || isSymbol c -isSymbolName [] = error "This should never happen" - - ----------------------------------------------------------------- --- REWRITE A HOLE / UNDEFINED VIA A FUNCTION ----------------------------------------------------------------- - -refine :: IOish m - => FilePath -- ^ A target file. - -> Int -- ^ Line number. - -> Int -- ^ Column number. - -> Expression -- ^ A Haskell expression. - -> GhcModT m String -refine file lineNo colNo (Expression expr) = - ghandle handler $ - runGmlT' [Left file] deferErrors $ do - oopts <- outputOpts - style <- getStyle - dflag <- G.getSessionDynFlags - modSum <- fileModSummaryWithMapping file - p <- G.parseModule modSum - tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p - ety <- G.exprType expr - whenFound oopts (findVar dflag style tcm tcs lineNo colNo) $ - \(loc, name, rty, paren) -> - let eArgs = getFnArgs ety - rArgs = getFnArgs rty - diffArgs' = length eArgs - length rArgs - diffArgs = if diffArgs' < 0 then 0 else diffArgs' - iArgs = take diffArgs eArgs - txt = initialHead1 expr iArgs (infinitePrefixSupply name) - in (fourInts loc, doParen paren txt) - where - handler (SomeException ex) = do - gmLog GmException "refining" $ - text "" $$ nest 4 (showDoc ex) - emptyResult =<< outputOpts - --- Look for the variable in the specified position -findVar - :: GhcMonad m - => DynFlags - -> PprStyle - -> G.TypecheckedModule - -> G.TypecheckedSource - -> Int - -> Int - -> m (Maybe (SrcSpan, String, Type, Bool)) -findVar dflag style tcm tcs lineNo colNo = - case lst of - e@(L _ (G.HsVar i)):others -> do - tyInfo <- Gap.getType tcm e - case tyInfo of - Just (s, typ) - | name == "undefined" || head name == '_' -> - return $ Just (s, name, typ, b) - where - name = getFnName dflag style i - -- If inside an App, we need parenthesis - b = case others of - L _ (G.HsApp (L _ a1) (L _ a2)):_ -> - isSearchedVar i a1 || isSearchedVar i a2 - _ -> False - _ -> return Nothing - _ -> return Nothing - where - lst :: [G.LHsExpr Id] - lst = sortBy (cmp `on` G.getLoc) $ listifySpans tcs (lineNo, colNo) - -infinitePrefixSupply :: String -> [String] -infinitePrefixSupply "undefined" = repeat "undefined" -infinitePrefixSupply p = map (\n -> p ++ "_" ++ show n) ([1 ..] :: [Integer]) - -doParen :: Bool -> String -> String -doParen False s = s -doParen True s = if ' ' `elem` s then '(':s ++ ")" else s - -isSearchedVar :: Id -> G.HsExpr Id -> Bool -isSearchedVar i (G.HsVar i2) = i == i2 -isSearchedVar _ _ = False - - ----------------------------------------------------------------- --- REFINE AUTOMATICALLY ----------------------------------------------------------------- - -auto :: IOish m - => FilePath -- ^ A target file. - -> Int -- ^ Line number. - -> Int -- ^ Column number. - -> GhcModT m String -auto file lineNo colNo = - ghandle handler $ runGmlT' [Left file] deferErrors $ do - oopts <- outputOpts - style <- getStyle - dflag <- G.getSessionDynFlags - modSum <- fileModSummaryWithMapping file - p <- G.parseModule modSum - tcm@TypecheckedModule { - tm_typechecked_source = tcs - , tm_checked_module_info = minfo - } <- G.typecheckModule p - whenFound' oopts (findVar dflag style tcm tcs lineNo colNo) $ \(loc, _name, rty, paren) -> do - topLevel <- getEverythingInTopLevel minfo - let (f,pats) = getPatsForVariable tcs (lineNo,colNo) - -- Remove self function to prevent recursion, and id to trim - -- cases - filterFn (n,_) = let funName = G.getOccString n - recName = G.getOccString (G.getName f) - in funName `notElem` recName:notWantedFuns - -- Find without using other functions in top-level - localBnds = M.unions $ - map (\(L _ pat) -> getBindingsForPat pat) pats - lbn = filter filterFn (M.toList localBnds) - djinnsEmpty <- djinn True (Just minfo) lbn rty (Max 10) 100000 - let -- Find with the entire top-level - almostEnv = M.toList $ M.union localBnds topLevel - env = filter filterFn almostEnv - djinns <- djinn True (Just minfo) env rty (Max 10) 100000 - return ( fourInts loc - , map (doParen paren) $ nub (djinnsEmpty ++ djinns)) - where - handler (SomeException ex) = do - gmLog GmException "auto-refining" $ - text "" $$ nest 4 (showDoc ex) - emptyResult =<< outputOpts - --- Functions we do not want in completions -notWantedFuns :: [String] -notWantedFuns = ["id", "asTypeOf", "const"] - --- Get all things defined in top-level -getEverythingInTopLevel :: GhcMonad m => G.ModuleInfo -> m (M.Map G.Name Type) -getEverythingInTopLevel m = do - let modInfo = tyThingsToInfo (G.modInfoTyThings m) - topNames = G.modInfoTopLevelScope m - case topNames of - Just topNames' -> do topThings <- mapM G.lookupGlobalName topNames' - let topThings' = catMaybes topThings - topInfo = tyThingsToInfo topThings' - return $ M.union modInfo topInfo - Nothing -> return modInfo - -tyThingsToInfo :: [Ty.TyThing] -> M.Map G.Name Type -tyThingsToInfo [] = M.empty -tyThingsToInfo (G.AnId i : xs) = - M.insert (G.getName i) (Ty.varType i) (tyThingsToInfo xs) --- Getting information about constructors is not needed --- because they will be added by djinn-ghc when traversing types --- #if __GLASGOW_HASKELL__ >= 708 --- tyThingToInfo (G.AConLike (G.RealDataCon con)) = return [(Ty.dataConName con, Ty.dataConUserType con)] --- #else --- tyThingToInfo (G.AConLike con) = return [(Ty.dataConName con, Ty.dataConUserType con)] --- #endif -tyThingsToInfo (_:xs) = tyThingsToInfo xs - --- Find the Id of the function and the pattern where the hole is located -getPatsForVariable :: G.TypecheckedSource -> (Int,Int) -> (Id, [Ty.LPat Id]) -getPatsForVariable tcs (lineNo, colNo) = - let (L _ bnd:_) = sortBy (cmp `on` G.getLoc) $ - listifySpans tcs (lineNo, colNo) :: [G.LHsBind Id] - in case bnd of - G.PatBind { Ty.pat_lhs = L ploc pat } -> case pat of - Ty.ConPatIn (L _ i) _ -> (i, [L ploc pat]) - _ -> (error "This should never happen", []) - G.FunBind { Ty.fun_id = L _ funId } -> - let m = sortBy (cmp `on` G.getLoc) $ listifySpans tcs (lineNo, colNo) -#if __GLASGOW_HASKELL__ >= 708 - :: [G.LMatch Id (G.LHsExpr Id)] -#else - :: [G.LMatch Id] -#endif -#if __GLASGOW_HASKELL__ >= 710 - (L _ (G.Match _ pats _ _):_) = m -#else - (L _ (G.Match pats _ _):_) = m -#endif - in (funId, pats) - _ -> (error "This should never happen", []) - -getBindingsForPat :: Ty.Pat Id -> M.Map G.Name Type -getBindingsForPat (Ty.VarPat i) = M.singleton (G.getName i) (Ty.varType i) -getBindingsForPat (Ty.LazyPat (L _ l)) = getBindingsForPat l -getBindingsForPat (Ty.BangPat (L _ b)) = getBindingsForPat b -getBindingsForPat (Ty.AsPat (L _ a) (L _ i)) = - M.insert (G.getName a) (Ty.varType a) (getBindingsForPat i) -#if __GLASGOW_HASKELL__ >= 708 -getBindingsForPat (Ty.ListPat l _ _) = - M.unions $ map (\(L _ i) -> getBindingsForPat i) l -#else -getBindingsForPat (Ty.ListPat l _) = - M.unions $ map (\(L _ i) -> getBindingsForPat i) l -#endif -getBindingsForPat (Ty.TuplePat l _ _) = - M.unions $ map (\(L _ i) -> getBindingsForPat i) l -getBindingsForPat (Ty.PArrPat l _) = - M.unions $ map (\(L _ i) -> getBindingsForPat i) l -getBindingsForPat (Ty.ViewPat _ (L _ i) _) = getBindingsForPat i -getBindingsForPat (Ty.SigPatIn (L _ i) _) = getBindingsForPat i -getBindingsForPat (Ty.SigPatOut (L _ i) _) = getBindingsForPat i -getBindingsForPat (Ty.ConPatIn (L _ i) d) = - M.insert (G.getName i) (Ty.varType i) (getBindingsForRecPat d) -getBindingsForPat (Ty.ConPatOut { Ty.pat_args = d }) = getBindingsForRecPat d -getBindingsForPat _ = M.empty - -getBindingsForRecPat :: Ty.HsConPatDetails Id -> M.Map G.Name Type -getBindingsForRecPat (Ty.PrefixCon args) = - M.unions $ map (\(L _ i) -> getBindingsForPat i) args -getBindingsForRecPat (Ty.InfixCon (L _ a1) (L _ a2)) = - M.union (getBindingsForPat a1) (getBindingsForPat a2) -getBindingsForRecPat (Ty.RecCon (Ty.HsRecFields { Ty.rec_flds = fields })) = - getBindingsForRecFields (map unLoc' fields) - where -#if __GLASGOW_HASKELL__ >= 710 - unLoc' = unLoc -#else - unLoc' = id -#endif - getBindingsForRecFields [] = M.empty - getBindingsForRecFields (Ty.HsRecField {Ty.hsRecFieldArg = (L _ a)}:fs) = - M.union (getBindingsForPat a) (getBindingsForRecFields fs) diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Find.hs +++ /dev/null @@ -1,167 +0,0 @@ -{-# LANGUAGE CPP, DeriveGeneric #-} - -module Language.Haskell.GhcMod.Find -#ifndef SPEC - ( Symbol - , SymbolDb - , loadSymbolDb - , lookupSymbol - , dumpSymbol - , findSymbol - , lookupSym - , isOutdated - -- * Load 'SymbolDb' asynchronously - , AsyncSymbolDb - , newAsyncSymbolDb - , getAsyncSymbolDb - ) -#endif - where - -import Language.Haskell.GhcMod.Convert -import Language.Haskell.GhcMod.Gap -import Language.Haskell.GhcMod.Monad -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 Control.Applicative -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 GHC.Generics (Generic) -import Data.Map (Map) -import qualified Data.Map as M -import System.Directory.ModTime -import Prelude - ----------------------------------------------------------------- - --- | Type of function and operation names. -type Symbol = String --- | Database from 'Symbol' to \['ModuleString'\]. -data SymbolDb = SymbolDb - { sdTable :: Map Symbol [ModuleString] - , sdTimestamp :: ModTime - } deriving (Generic) - -instance Binary SymbolDb -instance NFData SymbolDb - -isOutdated :: IOish m => SymbolDb -> GhcModT m Bool -isOutdated db = - isOlderThan (sdTimestamp db) <$> timedPackageCaches - ----------------------------------------------------------------- - --- | 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 - --- | 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 - -lookupSym :: Symbol -> SymbolDb -> [ModuleString] -lookupSym sym db = M.findWithDefault [] sym $ sdTable db - ---------------------------------------------------------------- - --- | Loading a file and creates 'SymbolDb'. -loadSymbolDb :: IOish m => GhcModT m SymbolDb -loadSymbolDb = do - ghcMod <- liftIO ghcModExecutable - readProc <- gmReadProcess' - out <- liftIO $ readProc ghcMod ["--verbose", "error", "dumpsym"] "" - return $!! decode out - ----------------------------------------------------------------- --- used 'ghc-mod dumpsym' - --- | Dumps a 'Binary' representation of 'SymbolDb' to stdout -dumpSymbol :: IOish m => GhcModT m () -dumpSymbol = do - ts <- liftIO getCurrentModTime - st <- runGmPkgGhc getGlobalSymbolTable - liftIO . BS.putStr $ encode SymbolDb { - sdTable = M.fromAscList st - , sdTimestamp = ts - } - --- | Check whether given file is older than any file from the given set. --- Returns True if given file does not exist. -isOlderThan :: ModTime -> [TimedFile] -> Bool -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) - -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 - -collectModules :: [(Symbol, ModuleString)] - -> [(Symbol, [ModuleString])] -collectModules = map tieup . groupBy ((==) `on` fst) . sort - where - tieup x = (head (map fst x), map snd x) - ----------------------------------------------------------------- - -data AsyncSymbolDb = AsyncSymbolDb (MVar (Either SomeException SymbolDb)) - -asyncLoadSymbolDb :: IOish m - => MVar (Either SomeException SymbolDb) - -> GhcModT m () -asyncLoadSymbolDb mv = void $ - liftBaseWith $ \run -> forkIO $ void $ run $ do - edb <- gtry loadSymbolDb - liftIO $ putMVar mv edb - -newAsyncSymbolDb :: IOish m => GhcModT m AsyncSymbolDb -newAsyncSymbolDb = do - mv <- liftIO newEmptyMVar - asyncLoadSymbolDb mv - return $ AsyncSymbolDb mv - -getAsyncSymbolDb :: forall m. IOish m => AsyncSymbolDb -> GhcModT m SymbolDb -getAsyncSymbolDb (AsyncSymbolDb mv) = do - db <- liftIO $ handleEx <$> takeMVar mv - outdated <- isOutdated db - if outdated - then do - asyncLoadSymbolDb mv - liftIO $ handleEx <$> readMVar mv - else do - liftIO $ putMVar mv $ Right db - return db - where - handleEx edb = - case edb of - Left ex -> throw ex - Right db -> db diff --git a/Language/Haskell/GhcMod/Flag.hs b/Language/Haskell/GhcMod/Flag.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Flag.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Language.Haskell.GhcMod.Flag where - -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) - -flags :: IOish m => GhcModT m String -flags = convert' [ "-f" ++ prefix ++ option - | option <- Gap.fOptions - , prefix <- ["","no-"] - ] diff --git a/Language/Haskell/GhcMod/Gap.hs b/Language/Haskell/GhcMod/Gap.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Gap.hs +++ /dev/null @@ -1,577 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, CPP, ScopedTypeVariables, RankNTypes #-} - -module Language.Haskell.GhcMod.Gap ( - Language.Haskell.GhcMod.Gap.ClsInst - , mkTarget - , withStyle - , GmLogAction - , setLogAction - , getSrcSpan - , getSrcFile - , withInteractiveContext - , fOptions - , toStringBuffer - , showSeverityCaption - , setCabalPkg - , setHideAllPackages - , setDeferTypeErrors - , setDeferTypedHoles - , setWarnTypedHoles - , setDumpSplices - , isDumpSplices - , filterOutChildren - , infoThing - , pprInfo - , HasType(..) - , errorMsgSpan - , typeForUser - , nameForUser - , occNameForUser - , deSugar - , showDocWith - , GapThing(..) - , fromTyThing - , fileModSummary - , WarnFlags - , emptyWarnFlags - , GLMatch - , GLMatchI - , getClass - , occName - , listVisibleModuleNames - , listVisibleModules - , lookupModulePackageInAllPackages - , Language.Haskell.GhcMod.Gap.isSynTyCon - , parseModuleHeader - , mkErrStyle' - ) where - -import Control.Applicative hiding (empty) -import Control.Monad (filterM) -import CoreSyn (CoreExpr) -import Data.List (intersperse) -import Data.Maybe (catMaybes) -import Data.Time.Clock (UTCTime) -import Data.Traversable hiding (mapM) -import DataCon (dataConRepType) -import Desugar (deSugarExpr) -import DynFlags -import ErrUtils -import Exception -import FastString -import GhcMonad -import HscTypes -import NameSet -import OccName -import Outputable -import PprTyThing -import StringBuffer -import TcType -import Var (varType) -import System.Directory - -import qualified Name -import qualified InstEnv -import qualified Pretty -import qualified StringBuffer as SB - -#if __GLASGOW_HASKELL__ >= 708 -import FamInstEnv -import ConLike (ConLike(..)) -import PatSyn (patSynType) -#else -import TcRnTypes -#endif - -#if __GLASGOW_HASKELL__ >= 706 -import GHC hiding (ClsInst) -#else -import GHC hiding (Instance) -import Control.Arrow hiding ((<+>)) -import Data.Convertible -import RdrName (rdrNameOcc) -#endif - -#if __GLASGOW_HASKELL__ < 710 -import UniqFM (eltsUFM) -import Module -#endif - -#if __GLASGOW_HASKELL__ >= 704 -import qualified Data.IntSet as I (IntSet, empty) -#endif - -#if __GLASGOW_HASKELL__ < 706 -import Control.DeepSeq (NFData(rnf)) -import Data.ByteString.Lazy.Internal (ByteString(..)) -#endif - -import Bag -import Lexer as L -import Parser -import SrcLoc -import Packages - -import Language.Haskell.GhcMod.Types (Expression(..)) -import Prelude - ----------------------------------------------------------------- ----------------------------------------------------------------- --- -#if __GLASGOW_HASKELL__ >= 706 -type ClsInst = InstEnv.ClsInst -#else -type ClsInst = InstEnv.Instance -#endif - -mkTarget :: TargetId -> Bool -> Maybe (SB.StringBuffer, UTCTime) -> Target -#if __GLASGOW_HASKELL__ >= 706 -mkTarget = Target -#else -mkTarget tid allowObjCode = Target tid allowObjCode . (fmap . second) convert -#endif - ----------------------------------------------------------------- ----------------------------------------------------------------- - -withStyle :: DynFlags -> PprStyle -> SDoc -> Pretty.Doc -#if __GLASGOW_HASKELL__ >= 706 -withStyle = withPprStyleDoc -#else -withStyle _ = withPprStyleDoc -#endif - -#if __GLASGOW_HASKELL__ >= 706 -type GmLogAction = LogAction -#else -type GmLogAction = DynFlags -> LogAction -#endif - -setLogAction :: DynFlags -> GmLogAction -> DynFlags -setLogAction df f = -#if __GLASGOW_HASKELL__ >= 706 - df { log_action = f } -#else - df { log_action = f df } -#endif - -showDocWith :: DynFlags -> Pretty.Mode -> Pretty.Doc -> String -#if __GLASGOW_HASKELL__ >= 708 --- Pretty.showDocWith disappeard. --- https://github.com/ghc/ghc/commit/08a3536e4246e323fbcd8040e0b80001950fe9bc -showDocWith dflags mode = Pretty.showDoc mode (pprCols dflags) -#else -showDocWith _ = Pretty.showDocWith -#endif - ----------------------------------------------------------------- ----------------------------------------------------------------- - -getSrcSpan :: SrcSpan -> Maybe (Int,Int,Int,Int) -#if __GLASGOW_HASKELL__ >= 702 -getSrcSpan (RealSrcSpan spn) -#else -getSrcSpan spn | isGoodSrcSpan spn -#endif - = Just (srcSpanStartLine spn - , srcSpanStartCol spn - , srcSpanEndLine spn - , srcSpanEndCol spn) -getSrcSpan _ = Nothing - -getSrcFile :: SrcSpan -> Maybe String -#if __GLASGOW_HASKELL__ >= 702 -getSrcFile (RealSrcSpan spn) = Just . unpackFS . srcSpanFile $ spn -#else -getSrcFile spn | isGoodSrcSpan spn = Just . unpackFS . srcSpanFile $ spn -#endif -getSrcFile _ = Nothing - ----------------------------------------------------------------- - -toStringBuffer :: GhcMonad m => [String] -> m StringBuffer -#if __GLASGOW_HASKELL__ >= 702 -toStringBuffer = return . stringToStringBuffer . unlines -#else -toStringBuffer = liftIO . stringToStringBuffer . unlines -#endif - ----------------------------------------------------------------- - -fOptions :: [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] - ++ [option | (option,_,_) <- fWarningFlags] - ++ [option | (option,_,_) <- fLangFlags] -#else -fOptions = [option | (option,_,_,_) <- fFlags] - ++ [option | (option,_,_,_) <- fWarningFlags] - ++ [option | (option,_,_,_) <- fLangFlags] -#endif - ----------------------------------------------------------------- ----------------------------------------------------------------- - -fileModSummary :: GhcMonad m => FilePath -> m ModSummary -fileModSummary file' = do - mss <- getModuleGraph - file <- liftIO $ canonicalizePath file' - [ms] <- liftIO $ flip filterM mss $ \m -> - (Just file==) <$> canonicalizePath `traverse` ml_hs_file (ms_location m) - return ms - -withInteractiveContext :: GhcMonad m => m a -> m a -withInteractiveContext action = gbracket setup teardown body - where - setup = getContext - teardown = setCtx - body _ = do - topImports >>= setCtx - action - topImports = do - ms <- filterM moduleIsInterpreted =<< map ms_mod <$> getModuleGraph - let iis = map (IIModule . modName) ms -#if __GLASGOW_HASKELL__ >= 704 - return iis -#else - return (iis,[]) -#endif -#if __GLASGOW_HASKELL__ >= 706 - modName = moduleName - setCtx = setContext -#elif __GLASGOW_HASKELL__ >= 704 - modName = id - setCtx = setContext -#else - modName = ms_mod - setCtx = uncurry setContext -#endif - -showSeverityCaption :: Severity -> String -#if __GLASGOW_HASKELL__ >= 706 -showSeverityCaption SevWarning = "Warning: " -showSeverityCaption _ = "" -#else -showSeverityCaption = const "" -#endif - ----------------------------------------------------------------- ----------------------------------------------------------------- - -setCabalPkg :: DynFlags -> DynFlags -#if __GLASGOW_HASKELL__ >= 708 -setCabalPkg dflag = gopt_set dflag Opt_BuildingCabalPackage -#else -setCabalPkg dflag = dopt_set dflag Opt_BuildingCabalPackage -#endif - ----------------------------------------------------------------- - -setHideAllPackages :: DynFlags -> DynFlags -#if __GLASGOW_HASKELL__ >= 708 -setHideAllPackages df = gopt_set df Opt_HideAllPackages -#else -setHideAllPackages df = dopt_set df Opt_HideAllPackages -#endif - ----------------------------------------------------------------- - -setDumpSplices :: DynFlags -> DynFlags -setDumpSplices dflag = dopt_set dflag Opt_D_dump_splices - -isDumpSplices :: DynFlags -> Bool -isDumpSplices dflag = dopt Opt_D_dump_splices dflag - ----------------------------------------------------------------- - - -setDeferTypeErrors :: DynFlags -> DynFlags -#if __GLASGOW_HASKELL__ >= 708 -setDeferTypeErrors dflag = gopt_set dflag Opt_DeferTypeErrors -#elif __GLASGOW_HASKELL__ >= 706 -setDeferTypeErrors dflag = dopt_set dflag Opt_DeferTypeErrors -#else -setDeferTypeErrors = id -#endif - -setDeferTypedHoles :: DynFlags -> DynFlags -#if __GLASGOW_HASKELL__ >= 710 -setDeferTypedHoles dflag = gopt_set dflag Opt_DeferTypedHoles -#else -setDeferTypedHoles = id -#endif - -setWarnTypedHoles :: DynFlags -> DynFlags -#if __GLASGOW_HASKELL__ >= 708 -setWarnTypedHoles dflag = wopt_set dflag Opt_WarnTypedHoles -#else -setWarnTypedHoles = id -#endif - ----------------------------------------------------------------- ----------------------------------------------------------------- - -class HasType a where - getType :: GhcMonad m => TypecheckedModule -> a -> m (Maybe (SrcSpan, Type)) - - -instance HasType (LHsBind Id) where -#if __GLASGOW_HASKELL__ >= 708 - getType _ (L spn FunBind{fun_matches = m}) = return $ Just (spn, typ) - where in_tys = mg_arg_tys m - out_typ = mg_res_ty m - typ = mkFunTys in_tys out_typ -#else - getType _ (L spn FunBind{fun_matches = MatchGroup _ typ}) = return $ Just (spn, typ) -#endif - getType _ _ = return Nothing - ----------------------------------------------------------------- ----------------------------------------------------------------- --- from ghc/InteractiveUI.hs - -filterOutChildren :: (a -> TyThing) -> [a] -> [a] -filterOutChildren get_thing xs - = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)] - where - implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)] - -infoThing :: GhcMonad m => (FilePath -> FilePath) -> Expression -> m SDoc -infoThing m (Expression str) = do - names <- parseName str -#if __GLASGOW_HASKELL__ >= 708 - mb_stuffs <- mapM (getInfo False) names - let filtered = filterOutChildren (\(t,_f,_i,_fam) -> t) (catMaybes mb_stuffs) -#else - mb_stuffs <- mapM getInfo names - let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs) -#endif - return $ vcat (intersperse (text "") $ map (pprInfo m False) filtered) - -#if __GLASGOW_HASKELL__ >= 708 -pprInfo :: (FilePath -> FilePath) -> Bool -> (TyThing, GHC.Fixity, [ClsInst], [FamInst]) -> SDoc -pprInfo m _ (thing, fixity, insts, famInsts) - = pprTyThingInContextLoc' thing - $$ show_fixity fixity - $$ InstEnv.pprInstances insts - $$ pprFamInsts 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) -#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') -#else - pprTyThingInContextLoc' pefas' thing' = hang (pprTyThingInContext pefas' thing') 2 - (char '\t' <> ptext (sLit "--") <+> loc) - where loc = ptext (sLit "Defined") <+> pprNameDefnLoc' (getName thing') -#endif - pprNameDefnLoc' name - = case Name.nameSrcLoc name of - RealSrcLoc s -> ptext (sLit "at") <+> ppr (subst s) - UnhelpfulLoc s - | Name.isInternalName name || Name.isSystemName name - -> ptext (sLit "at") <+> ftext s - | otherwise - -> ptext (sLit "in") <+> quotes (ppr (nameModule name)) - where subst s = mkRealSrcLoc (realFP s) (srcLocLine s) (srcLocCol s) - realFP = mkFastString . m . unpackFS . srcLocFile - ----------------------------------------------------------------- ----------------------------------------------------------------- - -errorMsgSpan :: ErrMsg -> SrcSpan -#if __GLASGOW_HASKELL__ >= 708 -errorMsgSpan = errMsgSpan -#else -errorMsgSpan = head . errMsgSpans -#endif - -typeForUser :: Type -> SDoc -#if __GLASGOW_HASKELL__ >= 708 -typeForUser = pprTypeForUser -#else -typeForUser = pprTypeForUser False -#endif - -nameForUser :: Name -> SDoc -nameForUser = pprOccName . getOccName - -occNameForUser :: OccName -> SDoc -occNameForUser = pprOccName - -deSugar :: TypecheckedModule -> LHsExpr Id -> HscEnv - -> IO (Maybe CoreExpr) -#if __GLASGOW_HASKELL__ >= 708 -deSugar _ e hs_env = snd <$> deSugarExpr hs_env e -#else -deSugar tcm e hs_env = snd <$> deSugarExpr hs_env modu rn_env ty_env e - where - modu = ms_mod $ pm_mod_summary $ tm_parsed_module tcm - tcgEnv = fst $ tm_internals_ tcm - rn_env = tcg_rdr_env tcgEnv - ty_env = tcg_type_env tcgEnv -#endif - ----------------------------------------------------------------- ----------------------------------------------------------------- - -data GapThing = GtA Type | GtT TyCon | GtN - -fromTyThing :: TyThing -> GapThing -fromTyThing (AnId i) = GtA $ varType i -#if __GLASGOW_HASKELL__ >= 708 -fromTyThing (AConLike (RealDataCon d)) = GtA $ dataConRepType d -fromTyThing (AConLike (PatSynCon p)) = GtA $ patSynType p -#else -fromTyThing (ADataCon d) = GtA $ dataConRepType d -#endif -fromTyThing (ATyCon t) = GtT t -fromTyThing _ = GtN - ----------------------------------------------------------------- ----------------------------------------------------------------- - -#if __GLASGOW_HASKELL__ >= 704 -type WarnFlags = I.IntSet -emptyWarnFlags :: WarnFlags -emptyWarnFlags = I.empty -#else -type WarnFlags = [WarningFlag] -emptyWarnFlags :: WarnFlags -emptyWarnFlags = [] -#endif - ----------------------------------------------------------------- ----------------------------------------------------------------- - -#if __GLASGOW_HASKELL__ >= 708 -type GLMatch = LMatch RdrName (LHsExpr RdrName) -type GLMatchI = LMatch Id (LHsExpr Id) -#else -type GLMatch = LMatch RdrName -type GLMatchI = LMatch Id -#endif - -getClass :: [LInstDecl Name] -> Maybe (Name, SrcSpan) -#if __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) -getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsAppTy (L _ (HsTyVar className)) _))}))] = Just (className, loc) -#elif __GLASGOW_HASKELL__ >= 708 --- 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) -getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsAppTy (L _ (HsTyVar className)) _))}))] = Just (className, loc) -#elif __GLASGOW_HASKELL__ >= 706 -getClass [L loc (ClsInstD (L _ (HsForAllTy _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _)))) _ _ _)] = Just (className, loc) -getClass[L loc (ClsInstD (L _ (HsAppTy (L _ (HsTyVar className)) _)) _ _ _)] = Just (className, loc) -#else -getClass [L loc (InstDecl (L _ (HsForAllTy _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _)))) _ _ _)] = Just (className, loc) -getClass [L loc (InstDecl (L _ (HsAppTy (L _ (HsTyVar className)) _)) _ _ _)] = Just (className, loc) -#endif -getClass _ = Nothing - -#if __GLASGOW_HASKELL__ < 706 -occName :: RdrName -> OccName -occName = rdrNameOcc -#endif - ----------------------------------------------------------------- - -#if __GLASGOW_HASKELL__ < 710 --- Copied from ghc/InteractiveUI.hs -allExposedPackageConfigs :: DynFlags -> [PackageConfig] -allExposedPackageConfigs df = filter exposed $ eltsUFM $ pkgIdMap $ pkgState df - -allExposedModules :: DynFlags -> [ModuleName] -allExposedModules df = concat $ map exposedModules $ allExposedPackageConfigs df - -listVisibleModuleNames :: DynFlags -> [ModuleName] -listVisibleModuleNames = allExposedModules -#endif - -lookupModulePackageInAllPackages :: - DynFlags -> ModuleName -> [String] -lookupModulePackageInAllPackages df mn = -#if __GLASGOW_HASKELL__ >= 710 - unpackSPId . sourcePackageId . snd <$> lookupModuleInAllPackages df mn - where - unpackSPId (SourcePackageId fs) = unpackFS fs -#else - unpackPId . sourcePackageId . fst <$> lookupModuleInAllPackages df mn - where - unpackPId pid = packageIdString $ mkPackageId pid --- n ++ "-" ++ showVersion v -#endif - -listVisibleModules :: DynFlags -> [GHC.Module] -listVisibleModules df = let -#if __GLASGOW_HASKELL__ >= 710 - modNames = listVisibleModuleNames df - mods = [ m | mn <- modNames, (m, _) <- lookupModuleInAllPackages df mn ] -#else - pkgCfgs = allExposedPackageConfigs df - mods = [ mkModule pid modname | p <- pkgCfgs - , let pid = packageConfigId p - , modname <- exposedModules p ] -#endif - in mods - -isSynTyCon :: TyCon -> Bool -#if __GLASGOW_HASKELL__ >= 710 -isSynTyCon = GHC.isTypeSynonymTyCon -#else -isSynTyCon = GHC.isSynTyCon -#endif - - -parseModuleHeader - :: String -- ^ Haskell module source text (full Unicode is supported) - -> DynFlags - -> FilePath -- ^ the filename (for source locations) - -> Either ErrorMessages (WarningMessages, Located (HsModule RdrName)) -parseModuleHeader str dflags filename = - let - loc = mkRealSrcLoc (mkFastString filename) 1 1 - buf = stringToStringBuffer str - in - case L.unP Parser.parseHeader (mkPState dflags buf loc) of - - PFailed sp err -> -#if __GLASGOW_HASKELL__ >= 706 - Left (unitBag (mkPlainErrMsg dflags sp err)) -#else - Left (unitBag (mkPlainErrMsg sp err)) -#endif - - POk pst rdr_module -> - let (warns,_) = getMessages pst in - Right (warns, rdr_module) - -mkErrStyle' :: DynFlags -> PrintUnqualified -> PprStyle -#if __GLASGOW_HASKELL__ >= 706 -mkErrStyle' = Outputable.mkErrStyle -#else -mkErrStyle' _ = Outputable.mkErrStyle -#endif - -#if __GLASGOW_HASKELL__ < 706 -instance NFData ByteString where - rnf Empty = () - rnf (Chunk _ b) = rnf b -#endif diff --git a/Language/Haskell/GhcMod/GhcPkg.hs b/Language/Haskell/GhcMod/GhcPkg.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/GhcPkg.hs +++ /dev/null @@ -1,109 +0,0 @@ -{-# LANGUAGE BangPatterns, ScopedTypeVariables, TupleSections #-} -module Language.Haskell.GhcMod.GhcPkg ( - ghcPkgDbOpt - , ghcPkgDbStackOpts - , ghcDbStackOpts - , ghcDbOpt - , getPackageDbStack - , getPackageCachePaths - , getGhcPkgProgram - ) where - -import Config (cProjectVersion, cTargetPlatformString, cProjectVersionInt) -import Control.Applicative -import Data.List.Split (splitOn) -import Data.Maybe -import Exception (handleIO) -import System.Directory (doesDirectoryExist, getAppUserDataDirectory) -import System.FilePath (()) -import Prelude - -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Monad.Types -import Language.Haskell.GhcMod.CabalHelper -import Language.Haskell.GhcMod.PathsAndFiles -import Language.Haskell.GhcMod.CustomPackageDb -import Language.Haskell.GhcMod.Stack - -ghcVersion :: Int -ghcVersion = read cProjectVersionInt - ----------------------------------------------------------------- - --- | Get options needed to add a list of package dbs to ghc-pkg's db stack -ghcPkgDbStackOpts :: [GhcPkgDb] -- ^ Package db stack - -> [String] -ghcPkgDbStackOpts dbs = ghcPkgDbOpt `concatMap` dbs - --- | Get options needed to add a list of package dbs to ghc's db stack -ghcDbStackOpts :: [GhcPkgDb] -- ^ Package db stack - -> [String] -ghcDbStackOpts dbs = ghcDbOpt `concatMap` dbs - ----------------------------------------------------------------- - -ghcPkgDbOpt :: GhcPkgDb -> [String] -ghcPkgDbOpt GlobalDb = ["--global"] -ghcPkgDbOpt UserDb = ["--user"] -ghcPkgDbOpt (PackageDb pkgDb) - | ghcVersion < 706 = ["--no-user-package-conf", "--package-conf=" ++ pkgDb] - | otherwise = ["--no-user-package-db", "--package-db=" ++ pkgDb] - -ghcDbOpt :: GhcPkgDb -> [String] -ghcDbOpt GlobalDb - | ghcVersion < 706 = ["-global-package-conf"] - | otherwise = ["-global-package-db"] -ghcDbOpt UserDb - | ghcVersion < 706 = ["-user-package-conf"] - | otherwise = ["-user-package-db"] -ghcDbOpt (PackageDb pkgDb) - | ghcVersion < 706 = ["-no-user-package-conf", "-package-conf", pkgDb] - | otherwise = ["-no-user-package-db", "-package-db", pkgDb] - ----------------------------------------------------------------- - -getGhcPkgProgram :: IOish m => GhcModT m FilePath -getGhcPkgProgram = do - crdl <- cradle - progs <- optPrograms <$> options - case cradleProject crdl of - (StackProject senv) -> do - Just ghcPkg <- getStackGhcPkgPath senv - return ghcPkg - _ -> - return $ ghcPkgProgram progs - -getPackageDbStack :: IOish m => GhcModT m [GhcPkgDb] -getPackageDbStack = do - crdl <- cradle - mCusPkgStack <- getCustomPkgDbStack - stack <- case cradleProject crdl of - PlainProject -> - return [GlobalDb, UserDb] - SandboxProject -> do - Just db <- liftIO $ getSandboxDb crdl - return $ [GlobalDb, db] - CabalProject -> - getCabalPackageDbStack - (StackProject StackEnv {..}) -> - return $ map PackageDb [seSnapshotPkgDb, seLocalPkgDb] - return $ fromMaybe stack mCusPkgStack - -getPackageCachePaths :: IOish m => FilePath -> GhcModT m [FilePath] -getPackageCachePaths sysPkgCfg = do - pkgDbStack <- getPackageDbStack - catMaybes <$> (liftIO . resolvePackageConfig sysPkgCfg) `mapM` pkgDbStack - --- TODO: use PkgConfRef ---- Copied from ghc module `Packages' unfortunately it's not exported :/ -resolvePackageConfig :: FilePath -> GhcPkgDb -> IO (Maybe FilePath) -resolvePackageConfig sysPkgCfg GlobalDb = return $ Just sysPkgCfg -resolvePackageConfig _ UserDb = handleIO (\_ -> return Nothing) $ do - appdir <- getAppUserDataDirectory "ghc" - let dir = appdir (target_arch ++ '-':target_os ++ '-':cProjectVersion) - pkgconf = dir "package.conf.d" - exist <- doesDirectoryExist pkgconf - return $ if exist then Just pkgconf else Nothing - where - [target_arch,_,target_os] = splitOn "-" cTargetPlatformString -resolvePackageConfig _ (PackageDb name) = return $ Just name diff --git a/Language/Haskell/GhcMod/HomeModuleGraph.hs b/Language/Haskell/GhcMod/HomeModuleGraph.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/HomeModuleGraph.hs +++ /dev/null @@ -1,269 +0,0 @@ --- ghc-mod: Making Haskell development *more* fun --- Copyright (C) 2015 Daniel Gröber --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU Affero General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU Affero General Public License for more details. --- --- You should have received a copy of the GNU Affero General Public License --- along with this program. If not, see . - -{-# LANGUAGE ScopedTypeVariables, RecordWildCards #-} -module Language.Haskell.GhcMod.HomeModuleGraph ( - GmModuleGraph(..) - , ModulePath(..) - , mkFileMap - , mkModuleMap - , mkMainModulePath - , findModulePath - , findModulePathSet - , fileModuleName - , canonicalizeModulePath - , homeModuleGraph - , updateHomeModuleGraph - , canonicalizeModuleGraph - , reachable - , moduleGraphToDot - ) where - -import DriverPipeline -import DynFlags -import ErrUtils -import Exception -import Finder -import GHC -import HscTypes - -import Control.Arrow ((&&&)) -import Control.Applicative -import Control.Monad -import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) -import Control.Monad.State.Strict (execStateT) -import Control.Monad.State.Class -import Data.Maybe -import Data.Monoid as Monoid -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Set (Set) -import qualified Data.Set as Set -import System.FilePath -import System.Directory -import System.IO -import Prelude - -import Language.Haskell.GhcMod.Logging -import Language.Haskell.GhcMod.Logger -import Language.Haskell.GhcMod.Monad.Types -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Utils (withMappedFile) -import Language.Haskell.GhcMod.Gap (parseModuleHeader) - --- | Turn module graph into a graphviz dot file --- --- @dot -Tpng -o modules.png modules.dot@ -moduleGraphToDot :: GmModuleGraph -> String -moduleGraphToDot GmModuleGraph { gmgGraph } = - "digraph {\n" ++ concatMap edges (Map.toList graph) ++ "}\n" - where - graph = Map.map (Set.mapMonotonic mpPath) - $ Map.mapKeysMonotonic mpPath gmgGraph - edges :: (FilePath, (Set FilePath)) -> String - edges (f, sf) = - concatMap (\f' -> " \""++ f ++"\" -> \""++ f' ++"\"\n") (Set.toList sf) - -data S = S { - sErrors :: [(ModulePath, ErrorMessages)], - sWarnings :: [(ModulePath, WarningMessages)], - sGraph :: GmModuleGraph -} - -defaultS :: S -defaultS = S [] [] mempty - -putErr :: MonadState S m - => (ModulePath, ErrorMessages) -> m () -putErr e = do - s <- get - put s { sErrors = e:sErrors s} - -putWarn :: MonadState S m - => (ModulePath, ErrorMessages) -> m () -putWarn w = do - s <- get - put s { sWarnings = w:sWarnings s} - -gmgLookupMP :: MonadState S m => ModulePath -> m (Maybe (Set ModulePath)) -gmgLookupMP k = (Map.lookup k . gmgGraph . sGraph) `liftM` get - -graphUnion :: MonadState S m => GmModuleGraph -> m () -graphUnion gmg = do - s <- get - put s { sGraph = sGraph s `mappend` gmg } - -reachable :: Set ModulePath -> GmModuleGraph -> Set ModulePath -reachable smp0 GmModuleGraph {..} = go smp0 - where - go smp = let - δsmp = Set.unions $ - collapseMaybeSet . flip Map.lookup gmgGraph <$> Set.toList smp - smp' = smp `Set.union` δsmp - in if smp == smp' then smp' else go smp' - -pruneUnreachable :: Set ModulePath -> GmModuleGraph -> GmModuleGraph -pruneUnreachable smp0 gmg@GmModuleGraph {..} = let - r = reachable smp0 gmg - in - GmModuleGraph { - gmgGraph = Map.filterWithKey (\k _ -> k `Set.member` r) gmgGraph - } - -collapseMaybeSet :: Maybe (Set a) -> Set a -collapseMaybeSet = maybe Set.empty id - -homeModuleGraph :: (IOish m, Gm m) - => HscEnv -> Set ModulePath -> m GmModuleGraph -homeModuleGraph env smp = updateHomeModuleGraph env mempty smp smp - -mkMainModulePath :: FilePath -> ModulePath -mkMainModulePath = ModulePath (mkModuleName "Main") - -findModulePath :: HscEnv -> ModuleName -> IO (Maybe ModulePath) -findModulePath env mn = do - fmap (ModulePath mn) <$> find env mn - -findModulePathSet :: HscEnv -> [ModuleName] -> IO (Set ModulePath) -findModulePathSet env mns = do - Set.fromList . catMaybes <$> findModulePath env `mapM` mns - -find :: MonadIO m => HscEnv -> ModuleName -> m (Maybe FilePath) -find env mn = liftIO $ do - res <- findHomeModule env mn - case res of - -- TODO: handle SOURCE imports (hs-boot stuff): addBootSuffixLocn loc - Found loc@ModLocation { ml_hs_file = Just _ } _mod -> - return $ normalise <$> ml_hs_file loc - _ -> return Nothing - - -canonicalizeModulePath :: ModulePath -> IO ModulePath -canonicalizeModulePath (ModulePath mn fp) = ModulePath mn <$> canonicalizePath fp - -canonicalizeModuleGraph :: MonadIO m => GmModuleGraph -> m GmModuleGraph -canonicalizeModuleGraph GmModuleGraph {..} = liftIO $ do - GmModuleGraph . Map.fromList <$> mapM fmg (Map.toList gmgGraph) - where - fmg (mp, smp) = liftM2 (,) (canonicalizeModulePath mp) (Set.fromList <$> mapM canonicalizeModulePath (Set.toList smp)) - - -updateHomeModuleGraph :: (IOish m, Gm m) - => HscEnv - -> GmModuleGraph - -> Set ModulePath -- ^ Initial set of modules - -> Set ModulePath -- ^ Updated set of modules - -> m GmModuleGraph -updateHomeModuleGraph env GmModuleGraph {..} smp sump = do - -- TODO: It would be good if we could retain information about modules that - -- stop to compile after we've already successfully parsed them at some - -- point. Figure out a way to delete the modules about to be updated only - -- after we're sure they won't fail to parse .. or something. Should probably - -- push this whole prune logic deep into updateHomeModuleGraph' - (pruneUnreachable smp . sGraph) `liftM` runS (updateHomeModuleGraph' env sump) - where - runS = flip execStateT defaultS { sGraph = graph' } - graph' = GmModuleGraph { - gmgGraph = Set.foldr Map.delete gmgGraph sump - } - -mkFileMap :: Set ModulePath -> Map FilePath ModulePath -mkFileMap smp = Map.fromList $ map (mpPath &&& id) $ Set.toList smp - -mkModuleMap :: Set ModulePath -> Map ModuleName ModulePath -mkModuleMap smp = Map.fromList $ map (mpModule &&& id) $ Set.toList smp - -updateHomeModuleGraph' - :: forall m. (MonadState S m, IOish m, Gm m) - => HscEnv - -> Set ModulePath -- ^ Initial set of modules - -> m () -updateHomeModuleGraph' env smp0 = do - go `mapM_` Set.toList smp0 - where - go :: ModulePath -> m () - go mp = do - msmp <- gmgLookupMP mp - case msmp of - Just _ -> return () - Nothing -> do - smp <- collapseMaybeSet `liftM` step mp - - graphUnion GmModuleGraph { - gmgGraph = Map.singleton mp smp - } - - mapM_ go (Set.toList smp) - - step :: ModulePath -> m (Maybe (Set ModulePath)) - step mp = runMaybeT $ do - (dflags, ppsrc_fn) <- MaybeT preprocess' - src <- liftIO $ readFile ppsrc_fn - imports mp src dflags - where - preprocess' :: m (Maybe (DynFlags, FilePath)) - preprocess' = do - let fn = mpPath mp - ep <- preprocessFile env fn - case ep of - Right (_, x) -> return $ Just x - Left errs -> do - -- TODO: Remember these and present them as proper errors if this is - -- the file the user is looking at. - gmLog GmWarning ("preprocess " ++ show fn) $ Monoid.mempty $+$ (vcat $ map text errs) - return Nothing - - - imports :: ModulePath -> String -> DynFlags -> MaybeT m (Set ModulePath) - imports mp@ModulePath {..} src dflags = - case parseModuleHeader src dflags mpPath of - Left err -> do - putErr (mp, err) - mzero - - Right (ws, lmdl) -> do - putWarn (mp, ws) - let HsModule {..} = unLoc lmdl - mns = map (unLoc . ideclName) - $ filter (isNothing . ideclPkgQual) - $ map unLoc hsmodImports - liftIO $ Set.fromList . catMaybes <$> mapM (findModulePath env) mns - -preprocessFile :: (IOish m, GmEnv m, GmState m) => - HscEnv -> FilePath -> m (Either [String] ([String], (DynFlags, FilePath))) -preprocessFile env file = - withLogger' env $ \setDf -> do - withMappedFile file $ \fn -> do - let env' = env { hsc_dflags = setDf (hsc_dflags env) } - liftIO $ preprocess env' (fn, Nothing) - -fileModuleName :: (IOish m, GmEnv m, GmState m) => - HscEnv -> FilePath -> m (Either [String] (Maybe ModuleName)) -fileModuleName env fn = do - let handler = liftIO . handle (\(_ :: SomeException) -> return $ Right Nothing) - ep <- preprocessFile env fn - case ep of - Left errs -> do - return $ Left errs - Right (_warns, (dflags, procdFile)) -> leftM (errBagToStrList env) =<< handler (do - src <- readFile procdFile - case parseModuleHeader src dflags procdFile of - Left errs -> return $ Left errs - Right (_, lmdl) -> do - let HsModule {..} = unLoc lmdl - return $ Right $ unLoc <$> hsmodName) - where - leftM f = either (return . Left <=< f) (return . Right) diff --git a/Language/Haskell/GhcMod/Info.hs b/Language/Haskell/GhcMod/Info.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Info.hs +++ /dev/null @@ -1,85 +0,0 @@ -module Language.Haskell.GhcMod.Info ( - info - , types - ) where - -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 Prelude -import qualified GHC as G -import qualified Language.Haskell.GhcMod.Gap as Gap - -import Language.Haskell.GhcMod.Convert -import Language.Haskell.GhcMod.Doc -import Language.Haskell.GhcMod.DynFlags -import Language.Haskell.GhcMod.Gap -import Language.Haskell.GhcMod.Logging -import Language.Haskell.GhcMod.Monad -import Language.Haskell.GhcMod.SrcUtils -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Utils (mkRevRedirMapFunc) -import Language.Haskell.GhcMod.FileMapping (fileModSummaryWithMapping) - ----------------------------------------------------------------- - --- | Obtaining information of a target expression. (GHCi's info:) -info :: IOish m - => FilePath -- ^ A target file. - -> Expression -- ^ A Haskell expression. - -> GhcModT m String -info file expr = - ghandle handler $ - runGmlT' [Left file] deferErrors $ - withInteractiveContext $ do - convert' =<< body - where - handler (SomeException ex) = do - gmLog GmException "info" $ text "" $$ nest 4 (showDoc ex) - convert' "Cannot show info" - - body :: (GhcMonad m, GmState m, GmEnv m) => m String - body = do - m <- mkRevRedirMapFunc - sdoc <- Gap.infoThing m expr - st <- getStyle - dflag <- G.getSessionDynFlags - return $ showPage dflag st sdoc - ----------------------------------------------------------------- - --- | Obtaining type of a target expression. (GHCi's type:) -types :: IOish m - => FilePath -- ^ A target file. - -> Int -- ^ Line number. - -> Int -- ^ Column number. - -> GhcModT m String -types file lineNo colNo = - ghandle handler $ - runGmlT' [Left file] deferErrors $ - withInteractiveContext $ do - crdl <- cradle - modSum <- fileModSummaryWithMapping (cradleCurrentDir crdl file) - srcSpanTypes <- getSrcSpanType modSum lineNo colNo - dflag <- G.getSessionDynFlags - st <- getStyle - convert' $ map (toTup dflag st) $ sortBy (cmp `on` fst) srcSpanTypes - where - handler (SomeException ex) = do - 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] diff --git a/Language/Haskell/GhcMod/Internal.hs b/Language/Haskell/GhcMod/Internal.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Internal.hs +++ /dev/null @@ -1,73 +0,0 @@ --- | Low level access to the ghc-mod library. - -module Language.Haskell.GhcMod.Internal ( - -- * Types - GHCOption - , IncludeDir - , GmlT(..) - , MonadIO(..) - , GmEnv(..) - -- * Various Paths - , ghcLibDir - , ghcModExecutable - -- * Logging - , withLogger - , setNoWarningFlags - , setAllWarningFlags - -- * Environment, state and logging - , GhcModEnv(..) - , GhcModState - , GhcModLog - , GmLog(..) - , GmLogLevel(..) - , gmSetLogLevel - -- * Monad utilities - , runGhcModT' - , hoistGhcModT - , runGmlT - , runGmlT' - , gmlGetSession - , gmlSetSession - , loadTargets - , cabalResolvedComponents - -- ** Accessing 'GhcModEnv' and 'GhcModState' - , options - , cradle - , targetGhcOptions - , withOptions - -- * 'GhcModError' - , gmeDoc - -- * World - , World - , getCurrentWorld - , didWorldChange - -- * Cabal Helper - , ModulePath(..) - , GmComponent(..) - , GmComponentType(..) - , GmModuleGraph(..) - , prepareCabalHelper - -- * Misc stuff - , GHandler(..) - , gcatches - -- * FileMapping - , module Language.Haskell.GhcMod.FileMapping - ) where - -import GHC.Paths (libdir) - -import Language.Haskell.GhcMod.Target -import Language.Haskell.GhcMod.DynFlags -import Language.Haskell.GhcMod.Error -import Language.Haskell.GhcMod.Logger -import Language.Haskell.GhcMod.Logging -import Language.Haskell.GhcMod.Monad -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Utils -import Language.Haskell.GhcMod.World -import Language.Haskell.GhcMod.CabalHelper -import Language.Haskell.GhcMod.FileMapping - --- | Obtaining the directory for ghc system libraries. -ghcLibDir :: FilePath -ghcLibDir = libdir diff --git a/Language/Haskell/GhcMod/Lang.hs b/Language/Haskell/GhcMod/Lang.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Lang.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Language.Haskell.GhcMod.Lang where - -import DynFlags (supportedLanguagesAndExtensions) -import Language.Haskell.GhcMod.Convert -import Language.Haskell.GhcMod.Monad - --- | Listing language extensions. - -languages :: IOish m => GhcModT m String -languages = convert' supportedLanguagesAndExtensions diff --git a/Language/Haskell/GhcMod/LightGhc.hs b/Language/Haskell/GhcMod/LightGhc.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/LightGhc.hs +++ /dev/null @@ -1,44 +0,0 @@ -module Language.Haskell.GhcMod.LightGhc where - -import Control.Monad.Reader (runReaderT) -import Data.IORef - -import GHC -import GHC.Paths (libdir) -import StaticFlags -import SysTools -import DynFlags -import HscMain -import HscTypes - -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Monad.Types -import Language.Haskell.GhcMod.DynFlags - -withLightHscEnv :: forall m a. IOish m - => [GHCOption] -> (HscEnv -> m a) -> m a -withLightHscEnv opts action = gbracket initEnv teardownEnv action - where - teardownEnv :: HscEnv -> m () - teardownEnv env = liftIO $ do - let dflags = hsc_dflags env - cleanTempFiles dflags - cleanTempDirs dflags - - initEnv :: m HscEnv - initEnv = liftIO $ do - initStaticOpts - settings <- initSysTools (Just libdir) - dflags <- initDynFlags (defaultDynFlags settings) - env <- newHscEnv dflags - dflags' <- runLightGhc env $ do - -- HomeModuleGraph and probably all other clients get into all sorts of - -- trouble if the package state isn't initialized here - _ <- setSessionDynFlags =<< addCmdOpts opts =<< getSessionDynFlags - getSessionDynFlags - newHscEnv dflags' - -runLightGhc :: HscEnv -> LightGhc a -> IO a -runLightGhc env action = do - renv <- newIORef env - flip runReaderT renv $ unLightGhc action diff --git a/Language/Haskell/GhcMod/Lint.hs b/Language/Haskell/GhcMod/Lint.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Lint.hs +++ /dev/null @@ -1,29 +0,0 @@ -module Language.Haskell.GhcMod.Lint where - -import Exception (ghandle) -import Control.Exception (SomeException(..)) -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.GhcMod.Utils (withMappedFile) - -import Data.List (stripPrefix) - --- | Checking syntax of a target file using hlint. --- Warnings and errors are returned. -lint :: IOish m - => LintOpts -- ^ Configuration parameters - -> FilePath -- ^ A target file. - -> GhcModT m String -lint opt file = - withMappedFile file $ \tempfile -> - liftIO (hlint $ tempfile : "--quiet" : optLintHlintOpts opt) - >>= mapM (replaceFileName tempfile) - >>= ghandle handler . pack - where - 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) diff --git a/Language/Haskell/GhcMod/Logger.hs b/Language/Haskell/GhcMod/Logger.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Logger.hs +++ /dev/null @@ -1,174 +0,0 @@ -module Language.Haskell.GhcMod.Logger ( - withLogger - , withLogger' - , checkErrorPrefix - , errsToStr - , errBagToStrList - ) where - -import Control.Arrow -import Control.Applicative -import Data.Ord -import Data.List -import Data.Maybe -import Data.Function -import Control.Monad.Reader (Reader, asks, runReader) -import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef) -import System.FilePath (normalise) -import Text.PrettyPrint - -import ErrUtils -import GHC -import HscTypes -import Outputable -import qualified GHC as G -import Bag - -import Language.Haskell.GhcMod.Convert -import Language.Haskell.GhcMod.Doc (showPage) -import Language.Haskell.GhcMod.DynFlags (withDynFlags) -import Language.Haskell.GhcMod.Monad.Types -import Language.Haskell.GhcMod.Error -import Language.Haskell.GhcMod.Utils (mkRevRedirMapFunc) -import qualified Language.Haskell.GhcMod.Gap as Gap -import Prelude - -type Builder = [String] -> [String] - -data Log = Log [String] Builder - -newtype LogRef = LogRef (IORef Log) - -data GmPprEnv = GmPprEnv { gpeDynFlags :: DynFlags - , gpeMapFile :: FilePath -> FilePath - } - -type GmPprEnvM a = Reader GmPprEnv a - -emptyLog :: Log -emptyLog = Log [] id - -newLogRef :: IO LogRef -newLogRef = LogRef <$> newIORef emptyLog - -readAndClearLogRef :: LogRef -> IO [String] -readAndClearLogRef (LogRef ref) = do - Log _ b <- readIORef ref - 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 - modifyIORef ref update - where - gpe = GmPprEnv { - gpeDynFlags = df - , gpeMapFile = rfm - } - l = runReader (ppMsg st src sev msg) gpe - - update lg@(Log ls b) - | l `elem` ls = lg - | otherwise = Log (l:ls) (b . (l:)) - ----------------------------------------------------------------- - --- | Logged messages are returned as 'String'. --- Right is success and Left is failure. -withLogger :: (GmGhc m, GmEnv m, GmOut m, GmState m) - => (DynFlags -> DynFlags) - -> m a - -> m (Either String (String, a)) -withLogger f action = do - env <- G.getSession - oopts <- outputOpts - let conv = convert oopts - eres <- withLogger' env $ \setDf -> - withDynFlags (f . setDf) action - return $ either (Left . conv) (Right . first conv) eres - -withLogger' :: (IOish m, GmState m, GmEnv m) - => HscEnv -> ((DynFlags -> DynFlags) -> m a) -> m (Either [String] ([String], a)) -withLogger' env action = do - logref <- liftIO $ newLogRef - - rfm <- mkRevRedirMapFunc - - let setLogger df = Gap.setLogAction df $ appendLogRef rfm df logref - handlers = [ - GHandler $ \ex -> return $ Left $ runReader (sourceError ex) gpe, - GHandler $ \ex -> return $ Left [render $ ghcExceptionDoc ex] - ] - gpe = GmPprEnv { - gpeDynFlags = hsc_dflags env - , gpeMapFile = rfm - } - - a <- gcatches (Right <$> action setLogger) handlers - ls <- liftIO $ readAndClearLogRef logref - - return ((,) ls <$> a) - -errBagToStrList :: (IOish m, GmState m, GmEnv m) => HscEnv -> Bag ErrMsg -> m [String] -errBagToStrList env errs = do - rfm <- mkRevRedirMapFunc - return $ runReader - (errsToStr (sortMsgBag errs)) - GmPprEnv{ gpeDynFlags = hsc_dflags env, gpeMapFile = rfm } - ----------------------------------------------------------------- - --- | Converting 'SourceError' to 'String'. -sourceError :: SourceError -> GmPprEnvM [String] -sourceError = errsToStr . sortMsgBag . srcErrorMessages - -errsToStr :: [ErrMsg] -> GmPprEnvM [String] -errsToStr = mapM ppErrMsg - -sortMsgBag :: Bag ErrMsg -> [ErrMsg] -sortMsgBag bag = sortBy (compare `on` Gap.errorMsgSpan) $ bagToList bag - ----------------------------------------------------------------- - -ppErrMsg :: ErrMsg -> GmPprEnvM String -ppErrMsg err = do - dflags <- asks gpeDynFlags - 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 - -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 - -ppMsgPrefix :: SrcSpan -> Severity -> String -> GmPprEnvM String -ppMsgPrefix spn sev cts = do - dflags <- asks gpeDynFlags - mr <- asks gpeMapFile - let defaultPrefix - | Gap.isDumpSplices dflags = "" - | otherwise = checkErrorPrefix - return $ fromMaybe defaultPrefix $ do - (line,col,_,_) <- Gap.getSrcSpan spn - file <- mr <$> normalise <$> Gap.getSrcFile spn - let severityCaption = Gap.showSeverityCaption sev - pref0 | or (map (\x -> x `isPrefixOf` cts) warningAsErrorPrefixes) - = file ++ ":" ++ show line ++ ":" ++ show col ++ ":" - | otherwise = file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ severityCaption - return pref0 - -checkErrorPrefix :: String -checkErrorPrefix = "Dummy:0:0:Error:" - -warningAsErrorPrefixes :: [String] -warningAsErrorPrefixes = ["Couldn't match expected type" - , "Couldn't match type" - , "No instance for"] diff --git a/Language/Haskell/GhcMod/Logging.hs b/Language/Haskell/GhcMod/Logging.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Logging.hs +++ /dev/null @@ -1,114 +0,0 @@ --- ghc-mod: Making Haskell development *more* fun --- Copyright (C) 2015 Daniel Gröber --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU Affero General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU Affero General Public License for more details. --- --- You should have received a copy of the GNU Affero General Public License --- along with this program. If not, see . - -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Language.Haskell.GhcMod.Logging ( - module Language.Haskell.GhcMod.Logging - , module Language.Haskell.GhcMod.Pretty - , GmLogLevel(..) - , module Text.PrettyPrint - , module Data.Monoid - ) where - -import Control.Applicative hiding (empty) -import Control.Monad -import Control.Monad.Trans.Class -import Data.List -import Data.Char -import Data.Monoid -import Data.Maybe -import System.IO -import System.FilePath -import Text.PrettyPrint hiding (style, (<>)) -import Prelude - -import Language.Haskell.GhcMod.Monad.Types -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Pretty -import Language.Haskell.GhcMod.Output - -gmSetLogLevel :: GmLog m => GmLogLevel -> m () -gmSetLogLevel level = - gmlJournal $ GhcModLog (Just level) (Last Nothing) [] - -gmGetLogLevel :: forall m. GmLog m => m GmLogLevel -gmGetLogLevel = do - GhcModLog { gmLogLevel = Just level } <- gmlHistory - return level - -gmSetDumpLevel :: GmLog m => Bool -> m () -gmSetDumpLevel level = - gmlJournal $ GhcModLog Nothing (Last (Just level)) [] - - -increaseLogLevel :: GmLogLevel -> GmLogLevel -increaseLogLevel l | l == maxBound = l -increaseLogLevel l = succ l - -decreaseLogLevel :: GmLogLevel -> GmLogLevel -decreaseLogLevel l | l == minBound = l -decreaseLogLevel l = pred l - --- | --- >>> Just GmDebug <= Nothing --- False --- >>> Just GmException <= Just GmDebug --- True --- >>> Just GmDebug <= Just GmException --- False -gmLog :: (MonadIO m, GmLog m, GmOut m) => GmLogLevel -> String -> Doc -> m () -gmLog level loc' doc = do - GhcModLog { gmLogLevel = Just level' } <- gmlHistory - - let loc | loc' == "" = empty - | otherwise = text loc' <+>: empty - msgDoc = sep [loc, doc] - msg = dropWhileEnd isSpace $ gmRenderDoc $ gmLogLevelDoc level <+>: msgDoc - - when (level <= level') $ gmErrStrLn msg - gmLogQuiet level loc' doc - -gmLogQuiet :: GmLog m => GmLogLevel -> String -> Doc -> m () -gmLogQuiet level loc doc = - gmlJournal (GhcModLog Nothing (Last Nothing) [(level, loc, doc)]) - -gmAppendLogQuiet :: GmLog m => GhcModLog -> m () -gmAppendLogQuiet GhcModLog { gmLogMessages } = - forM_ gmLogMessages $ \(level, loc, doc) -> gmLogQuiet level loc doc - -gmVomit :: (MonadIO m, GmLog m, GmOut m, GmEnv m) => String -> Doc -> String -> m () -gmVomit filename doc content = do - gmLog GmVomit "" $ doc <+>: text content - - GhcModLog { gmLogVomitDump = Last mdump } - <- gmlHistory - - dir <- cradleTempDir `liftM` cradle - when (fromMaybe False mdump) $ - liftIO $ writeFile (dir filename) content - - -newtype LogDiscardT m a = LogDiscardT { runLogDiscard :: m a } - deriving (Functor, Applicative, Monad) - -instance MonadTrans LogDiscardT where - lift = LogDiscardT - -instance Monad m => GmLog (LogDiscardT m) where - gmlJournal = const $ return () - gmlHistory = return mempty - gmlClear = return () diff --git a/Language/Haskell/GhcMod/Modules.hs b/Language/Haskell/GhcMod/Modules.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Modules.hs +++ /dev/null @@ -1,27 +0,0 @@ -module Language.Haskell.GhcMod.Modules (modules) where - -import Control.Arrow -import Data.List -import Language.Haskell.GhcMod.Convert -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Monad -import Language.Haskell.GhcMod.Gap ( listVisibleModuleNames - , lookupModulePackageInAllPackages - ) - -import qualified GHC as G - ----------------------------------------------------------------- - --- | Listing installed modules. -modules :: (IOish m, Gm m) - => Bool -- ^ 'detailed', if 'True', also prints packages that modules belong to. - -> m String -modules detailed = do - df <- runGmPkgGhc G.getSessionDynFlags - let mns = listVisibleModuleNames df - pmnss = map (first moduleNameString) $ zip mns (modulePkg df `map` mns) - convert' $ nub [ if detailed then pkg ++ " " ++ mn else mn - | (mn, pkgs) <- pmnss, pkg <- pkgs ] - where - modulePkg df = lookupModulePackageInAllPackages df diff --git a/Language/Haskell/GhcMod/Monad.hs b/Language/Haskell/GhcMod/Monad.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Monad.hs +++ /dev/null @@ -1,142 +0,0 @@ --- ghc-mod: Making Haskell development *more* fun --- Copyright (C) 2015 Daniel Gröber --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU Affero General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU Affero General Public License for more details. --- --- You should have received a copy of the GNU Affero General Public License --- along with this program. If not, see . - -{-# LANGUAGE CPP #-} -module Language.Haskell.GhcMod.Monad ( - runGmOutT - , runGmOutT' - , runGhcModT - , runGhcModT' - , hoistGhcModT - , runGmlT - , runGmlT' - , runGmlTWith - , runGmPkgGhc - , withGhcModEnv - , withGhcModEnv' - , module Language.Haskell.GhcMod.Monad.Types - ) where - -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Monad.Types -import Language.Haskell.GhcMod.Error -import Language.Haskell.GhcMod.Logging -import Language.Haskell.GhcMod.Cradle -import Language.Haskell.GhcMod.Target -import Language.Haskell.GhcMod.Output - -import Control.Arrow (first) -import Control.Applicative - -import Control.Concurrent - -import Control.Monad.Reader (runReaderT) -import Control.Monad.State.Strict (runStateT) -import Control.Monad.Trans.Journal (runJournalT) - -import Exception - -import System.Directory -import System.IO.Unsafe -import Prelude - -withGhcModEnv :: (IOish m, GmOut m) => FilePath -> Options -> ((GhcModEnv, GhcModLog) -> m a) -> m a -withGhcModEnv = withGhcModEnv' withCradle - where - withCradle dir = - gbracket (runJournalT $ findCradle' dir) (liftIO . cleanupCradle . fst) - -cwdLock :: MVar ThreadId -cwdLock = unsafePerformIO $ newEmptyMVar -{-# NOINLINE cwdLock #-} - -withGhcModEnv' :: (IOish m, GmOut m) => (FilePath -> ((Cradle, GhcModLog) -> m a) -> m a) -> FilePath -> Options -> ((GhcModEnv, GhcModLog) -> m a) -> m a -withGhcModEnv' withCradle dir opts f = - withCradle dir $ \(crdl,lg) -> - withCradleRootDir crdl $ - f (GhcModEnv opts crdl, lg) - where - swapCurrentDirectory ndir = do - odir <- canonicalizePath =<< getCurrentDirectory - setCurrentDirectory ndir - return odir - - withCradleRootDir (cradleRootDir -> projdir) a = do - success <- liftIO $ tryPutMVar cwdLock =<< myThreadId - if not success - then error "withGhcModEnv': using ghc-mod from multiple threads is not supported!" - else gbracket setup teardown (const a) - where - setup = liftIO $ swapCurrentDirectory projdir - - teardown odir = liftIO $ do - setCurrentDirectory odir - void $ takeMVar cwdLock - -runGmOutT :: IOish m => Options -> GmOutT m a -> m a -runGmOutT opts ma = do - gmo@GhcModOut{..} <- GhcModOut (optOutput opts) <$> liftIO newChan - let action = runGmOutT' gmo ma - case ooptLinePrefix $ optOutput opts of - Nothing -> action - Just pfxs -> - gbracket_ (liftIO $ forkIO $ stdoutGateway pfxs gmoChan) - (const $ liftIO $ flushStdoutGateway gmoChan) - action - -runGmOutT' :: IOish m => GhcModOut -> GmOutT m a -> m a -runGmOutT' gmo ma = flip runReaderT gmo $ unGmOutT ma - --- | Run a @GhcModT m@ computation. -runGhcModT :: IOish m - => Options - -> GhcModT m a - -> m (Either GhcModError a, GhcModLog) -runGhcModT opt action = liftIO (getCurrentDirectory >>= canonicalizePath) >>= \dir' -> do - runGmOutT opt $ - withGhcModEnv dir' opt $ \(env,lg) -> - first (fst <$>) <$> runGhcModT' env defaultGhcModState (do - gmSetLogLevel (ooptLogLevel $ optOutput opt) - gmAppendLogQuiet lg - action) - --- | @hoistGhcModT result@. Embed a GhcModT computation's result into a GhcModT --- computation. Note that if the computation that returned @result@ modified the --- state part of GhcModT this cannot be restored. -hoistGhcModT :: IOish m - => (Either GhcModError a, GhcModLog) - -> GhcModT m a -hoistGhcModT (r,l) = do - gmlJournal l >> case r of - Left e -> throwError e - Right a -> return a - - --- | Run a computation inside @GhcModT@ providing the RWST environment and --- initial state. This is a low level function, use it only if you know what to --- do with 'GhcModEnv' and 'GhcModState'. --- --- You should probably look at 'runGhcModT' instead. -runGhcModT' :: IOish m - => GhcModEnv - -> GhcModState - -> GhcModT m a - -> GmOutT m (Either GhcModError (a, GhcModState), GhcModLog) -runGhcModT' r s a = do - flip runReaderT r $ runJournalT $ runErrorT $ runStateT (unGmT a) s - -gbracket_ :: ExceptionMonad m => m a -> (a -> m b) -> m c -> m c -gbracket_ ma mb mc = gbracket ma mb (const mc) diff --git a/Language/Haskell/GhcMod/Monad/Compat.hs_h b/Language/Haskell/GhcMod/Monad/Compat.hs_h deleted file mode 100644 --- a/Language/Haskell/GhcMod/Monad/Compat.hs_h +++ /dev/null @@ -1,28 +0,0 @@ --- ghc-mod: Making Haskell development *more* fun --- Copyright (C) 2015,2016 Daniel Gröber --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU Affero General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU Affero General Public License for more details. --- --- You should have received a copy of the GNU Affero General Public License --- along with this program. If not, see . - --- MonadUtils of GHC 7.6 or earlier defines its own MonadIO. --- RWST does not automatically become an instance of MonadIO. --- MonadUtils of GHC 7.8 or later imports MonadIO in Monad.Control.IO.Class. --- So, RWST automatically becomes an instance of -#if __GLASGOW_HASKELL__ < 708 --- 'CoreMonad.MonadIO' and 'Control.Monad.IO.Class.MonadIO' are different --- classes before ghc 7.8 -#define DIFFERENT_MONADIO 1 - --- RWST doen't have a MonadIO instance before ghc 7.8 -#define MONADIO_INSTANCES 1 -#endif diff --git a/Language/Haskell/GhcMod/Monad/Env.hs b/Language/Haskell/GhcMod/Monad/Env.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Monad/Env.hs +++ /dev/null @@ -1,68 +0,0 @@ --- ghc-mod: Making Haskell development *more* fun --- Copyright (C) 2015,2016 Daniel Gröber --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU Affero General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU Affero General Public License for more details. --- --- You should have received a copy of the GNU Affero General Public License --- along with this program. If not, see . - -{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-} -{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} - -module Language.Haskell.GhcMod.Monad.Env where - -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Monad.Newtypes - -import Control.Monad -import Control.Monad.Trans.Journal (JournalT) -import Control.Monad.State.Strict (StateT(..)) -import Control.Monad.Error (ErrorT(..)) -import Control.Monad.Reader.Class -import Control.Monad.Trans.Class (MonadTrans(..)) -import Prelude - -class Monad m => GmEnv m where - gmeAsk :: m GhcModEnv - gmeAsk = gmeReader id - - gmeReader :: (GhcModEnv -> a) -> m a - gmeReader f = f `liftM` gmeAsk - - gmeLocal :: (GhcModEnv -> GhcModEnv) -> m a -> m a - {-# MINIMAL (gmeAsk | gmeReader), gmeLocal #-} - -instance Monad m => GmEnv (GmT m) where - gmeAsk = GmT ask - gmeReader = GmT . reader - gmeLocal f a = GmT $ local f (unGmT a) - -instance GmEnv m => GmEnv (GmOutT m) where - gmeAsk = lift gmeAsk - gmeReader = lift . gmeReader - gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma)) - -instance GmEnv m => GmEnv (StateT s m) where - gmeAsk = lift gmeAsk - gmeReader = lift . gmeReader - gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma)) - -instance GmEnv m => GmEnv (JournalT GhcModLog m) where - gmeAsk = lift gmeAsk - gmeReader = lift . gmeReader - gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma)) - -instance GmEnv m => GmEnv (ErrorT GhcModError m) where - gmeAsk = lift gmeAsk - gmeReader = lift . gmeReader - gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma)) - -deriving instance (Monad m, GmEnv (GhcModT m)) => GmEnv (GmlT m) diff --git a/Language/Haskell/GhcMod/Monad/Log.hs b/Language/Haskell/GhcMod/Monad/Log.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Monad/Log.hs +++ /dev/null @@ -1,71 +0,0 @@ --- ghc-mod: Making Haskell development *more* fun --- Copyright (C) 2015,2016 Daniel Gröber --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU Affero General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU Affero General Public License for more details. --- --- You should have received a copy of the GNU Affero General Public License --- along with this program. If not, see . - -{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-} -{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} - -module Language.Haskell.GhcMod.Monad.Log where - -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Monad.Newtypes - -import Control.Monad -import Control.Monad.Trans.Journal (JournalT) -import Control.Monad.Reader (ReaderT(..)) -import Control.Monad.State.Strict (StateT(..)) -import Control.Monad.Error (Error, ErrorT(..)) -import Control.Monad.Trans.Maybe (MaybeT(..)) -import Control.Monad.Journal.Class (MonadJournal(..)) -import Control.Monad.Trans.Class (MonadTrans(..)) -import Prelude - -class Monad m => GmLog m where - gmlJournal :: GhcModLog -> m () - gmlHistory :: m GhcModLog - gmlClear :: m () - -instance Monad m => GmLog (JournalT GhcModLog m) where - gmlJournal = journal - gmlHistory = history - gmlClear = clear - -instance Monad m => GmLog (GmT m) where - gmlJournal = GmT . lift . lift . journal - gmlHistory = GmT $ lift $ lift history - gmlClear = GmT $ lift $ lift clear - -instance (Monad m, GmLog m) => GmLog (ReaderT r m) where - gmlJournal = lift . gmlJournal - gmlHistory = lift gmlHistory - gmlClear = lift gmlClear - -instance (Monad m, GmLog m) => GmLog (StateT s m) where - gmlJournal = lift . gmlJournal - gmlHistory = lift gmlHistory - gmlClear = lift gmlClear - -instance (Monad m, GmLog m, Error e) => GmLog (ErrorT e m) where - gmlJournal = lift . gmlJournal - gmlHistory = lift gmlHistory - gmlClear = lift gmlClear - -instance (Monad m, GmLog m) => GmLog (MaybeT m) where - gmlJournal = lift . gmlJournal - gmlHistory = lift gmlHistory - gmlClear = lift gmlClear - -deriving instance GmLog m => GmLog (GmOutT m) -deriving instance (Monad m, GmLog (GhcModT m)) => GmLog (GmlT m) diff --git a/Language/Haskell/GhcMod/Monad/Newtypes.hs b/Language/Haskell/GhcMod/Monad/Newtypes.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Monad/Newtypes.hs +++ /dev/null @@ -1,176 +0,0 @@ --- ghc-mod: Making Haskell development *more* fun --- Copyright (C) 2015,2016 Daniel Gröber --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU Affero General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU Affero General Public License for more details. --- --- You should have received a copy of the GNU Affero General Public License --- along with this program. If not, see . - -{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, DeriveFunctor #-} -{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, UndecidableInstances #-} -{-# LANGUAGE RankNTypes, FlexibleInstances #-} - -module Language.Haskell.GhcMod.Monad.Newtypes where - -#include "Compat.hs_h" - -import Language.Haskell.GhcMod.Types - -import GHC - -import Control.Applicative -import Control.Monad - -import Control.Monad.Reader (ReaderT(..)) -import Control.Monad.Error (ErrorT(..), MonadError(..)) -import Control.Monad.State.Strict (StateT(..)) -import Control.Monad.Trans.Journal (JournalT) -import Control.Monad.Reader.Class -import Control.Monad.State.Class (MonadState(..)) -import Control.Monad.Journal.Class (MonadJournal(..)) -import Control.Monad.Trans.Class (MonadTrans(..)) -import Control.Monad.Trans.Control -import Control.Monad.Base (MonadBase(..), liftBase) - -import Data.IORef -import Prelude - -type GhcModT m = GmT (GmOutT m) - -newtype GmOutT m a = GmOutT { - unGmOutT :: ReaderT GhcModOut m a - } deriving ( Functor - , Applicative - , Alternative - , Monad - , MonadPlus - , MonadTrans - ) - -newtype GmT m a = GmT { - unGmT :: StateT GhcModState - (ErrorT GhcModError - (JournalT GhcModLog - (ReaderT GhcModEnv m) ) ) a - } deriving ( Functor - , Applicative - , Alternative - , Monad - , MonadPlus - , MonadError GhcModError - ) - -newtype GmlT m a = GmlT { unGmlT :: GhcModT m a } - deriving ( Functor - , Applicative - , Alternative - , Monad - , MonadPlus - , MonadError GhcModError - ) - -newtype LightGhc a = LightGhc { unLightGhc :: ReaderT (IORef HscEnv) IO a } - deriving ( Functor - , Applicative - , Monad - ) - --- GmOutT ---------------------------------------- -instance (MonadBaseControl IO m) => MonadBase IO (GmOutT m) where - liftBase = GmOutT . liftBase - -instance (MonadBaseControl IO m) => MonadBaseControl IO (GmOutT m) where - type StM (GmOutT m) a = StM (ReaderT GhcModEnv m) a - liftBaseWith = defaultLiftBaseWith - restoreM = defaultRestoreM - {-# INLINE liftBaseWith #-} - {-# INLINE restoreM #-} - -instance MonadTransControl GmOutT where - type StT GmOutT a = StT (ReaderT GhcModEnv) a - liftWith = defaultLiftWith GmOutT unGmOutT - restoreT = defaultRestoreT GmOutT - - --- GmlT ------------------------------------------ -instance (MonadBaseControl IO m) => MonadBase IO (GmlT m) where - liftBase = GmlT . liftBase - -instance (MonadBaseControl IO m) => MonadBaseControl IO (GmlT m) where - type StM (GmlT m) a = StM (GmT m) a - liftBaseWith = defaultLiftBaseWith - restoreM = defaultRestoreM - {-# INLINE liftBaseWith #-} - {-# INLINE restoreM #-} - -instance MonadTransControl GmlT where - type StT GmlT a = StT GmT a - liftWith f = GmlT $ - liftWith $ \runGm -> - liftWith $ \runEnv -> - f $ \ma -> runEnv $ runGm $ unGmlT ma - restoreT = GmlT . restoreT . restoreT - -instance MonadTrans GmlT where - lift = GmlT . lift . lift - --- GmT ------------------------------------------ - -instance forall r m. MonadReader r m => MonadReader r (GmT m) where - local f ma = gmLiftWithInner (\run -> local f (run ma)) - ask = gmLiftInner ask - -instance MonadState s m => MonadState s (GmT m) where - get = GmT $ lift $ lift $ lift get - put = GmT . lift . lift . lift . put - state = GmT . lift . lift . lift . state - -instance Monad m => MonadJournal GhcModLog (GmT m) where - journal w = GmT $ lift $ lift $ (journal w) - history = GmT $ lift $ lift $ history - clear = GmT $ lift $ lift $ clear - -instance (MonadBaseControl IO m) => MonadBase IO (GmT m) where - liftBase = GmT . liftBase - -instance (MonadBaseControl IO m) => MonadBaseControl IO (GmT m) where - type StM (GmT m) a = - StM (StateT GhcModState - (ErrorT GhcModError - (JournalT GhcModLog - (ReaderT GhcModEnv m) ) ) ) a - liftBaseWith f = GmT (liftBaseWith $ \runInBase -> - f $ runInBase . unGmT) - restoreM = GmT . restoreM - {-# INLINE liftBaseWith #-} - {-# INLINE restoreM #-} - -instance MonadTransControl GmT where - type StT GmT a = (Either GhcModError (a, GhcModState), GhcModLog) - liftWith f = GmT $ - liftWith $ \runS -> - liftWith $ \runE -> - liftWith $ \runJ -> - liftWith $ \runR -> - f $ \ma -> runR $ runJ $ runE $ runS $ unGmT ma - restoreT = GmT . restoreT . restoreT . restoreT . restoreT - {-# INLINE liftWith #-} - {-# INLINE restoreT #-} - -instance MonadTrans GmT where - lift = GmT . lift . lift . lift . lift - -gmLiftInner :: Monad m => m a -> GmT m a -gmLiftInner = GmT . lift . lift . lift . lift - -gmLiftWithInner :: (MonadTransControl t, Monad m, Monad (t m)) - => (Run t -> m (StT t a)) -> t m a -gmLiftWithInner f = liftWith f >>= restoreT . return diff --git a/Language/Haskell/GhcMod/Monad/Orphans.hs b/Language/Haskell/GhcMod/Monad/Orphans.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Monad/Orphans.hs +++ /dev/null @@ -1,83 +0,0 @@ --- ghc-mod: Making Haskell development *more* fun --- Copyright (C) 2015,2016 Daniel Gröber --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU Affero General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU Affero General Public License for more details. --- --- You should have received a copy of the GNU Affero General Public License --- along with this program. If not, see . - -{-# LANGUAGE CPP, UndecidableInstances, StandaloneDeriving #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Language.Haskell.GhcMod.Monad.Orphans where - -#include "Compat.hs_h" - -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Monad.Newtypes - -#if DIFFERENT_MONADIO -import qualified MonadUtils as GHC (MonadIO(..)) -#endif -import qualified Control.Monad.IO.Class as MTL - -import Control.Monad.Reader (ReaderT(..)) -import Control.Monad.State.Strict (StateT(..)) -import Control.Monad.Trans.Journal (JournalT) -import Control.Monad.Trans.Maybe (MaybeT(..)) -import Control.Monad.Error (Error(..), ErrorT(..)) - --------------------------------------------------- --- Miscellaneous instances - -#if DIFFERENT_MONADIO -instance MTL.MonadIO m => GHC.MonadIO (ReaderT x m) where - liftIO = MTL.liftIO -instance MTL.MonadIO m => GHC.MonadIO (StateT x m) where - liftIO = MTL.liftIO -instance (Error e, MTL.MonadIO m) => GHC.MonadIO (ErrorT e m) where - liftIO = MTL.liftIO -instance MTL.MonadIO m => GHC.MonadIO (JournalT x m) where - liftIO = MTL.liftIO -instance MTL.MonadIO m => GHC.MonadIO (MaybeT m) where - liftIO = MTL.liftIO -deriving instance MTL.MonadIO m => GHC.MonadIO (GmOutT m) -deriving instance MTL.MonadIO m => GHC.MonadIO (GmT m) -deriving instance MTL.MonadIO m => GHC.MonadIO (GmlT m) -deriving instance GHC.MonadIO LightGhc -#endif - -deriving instance MTL.MonadIO m => MTL.MonadIO (GmOutT m) -deriving instance MTL.MonadIO m => MTL.MonadIO (GmT m) -deriving instance MTL.MonadIO m => MTL.MonadIO (GmlT m) -deriving instance MTL.MonadIO LightGhc - -instance MonadIO IO where - liftIO = id -instance MonadIO m => MonadIO (ReaderT x m) where - liftIO = MTL.liftIO -instance MonadIO m => MonadIO (StateT x m) where - liftIO = MTL.liftIO -instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where - liftIO = MTL.liftIO -instance MonadIO m => MonadIO (JournalT x m) where - liftIO = MTL.liftIO -instance MonadIO m => MonadIO (MaybeT m) where - liftIO = MTL.liftIO -instance MonadIOC m => MonadIO (GmOutT m) where - liftIO = MTL.liftIO -instance MonadIOC m => MonadIO (GmT m) where - liftIO = MTL.liftIO -instance MonadIOC m => MonadIO (GmlT m) where - liftIO = MTL.liftIO -instance MonadIO LightGhc where - liftIO = MTL.liftIO diff --git a/Language/Haskell/GhcMod/Monad/Out.hs b/Language/Haskell/GhcMod/Monad/Out.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Monad/Out.hs +++ /dev/null @@ -1,52 +0,0 @@ --- ghc-mod: Making Haskell development *more* fun --- Copyright (C) 2015,2016 Daniel Gröber --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU Affero General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU Affero General Public License for more details. --- --- You should have received a copy of the GNU Affero General Public License --- along with this program. If not, see . - -{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-} -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-} - -module Language.Haskell.GhcMod.Monad.Out where - -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Monad.Newtypes - -import Control.Monad -import Control.Monad.State.Strict (StateT(..)) -import Control.Monad.Trans.Journal (JournalT) -import Control.Monad.Trans.Maybe (MaybeT(..)) -import Control.Monad.Reader.Class -import Control.Monad.Trans.Class (MonadTrans(..)) -import Prelude - -class Monad m => GmOut m where - gmoAsk :: m GhcModOut - -instance Monad m => GmOut (GmOutT m) where - gmoAsk = GmOutT ask - -instance Monad m => GmOut (GmlT m) where - gmoAsk = GmlT $ lift $ GmOutT ask - -instance GmOut m => GmOut (GmT m) where - gmoAsk = lift gmoAsk - -instance GmOut m => GmOut (StateT s m) where - gmoAsk = lift gmoAsk - -instance GmOut m => GmOut (JournalT w m) where - gmoAsk = lift gmoAsk - -instance GmOut m => GmOut (MaybeT m) where - gmoAsk = lift gmoAsk diff --git a/Language/Haskell/GhcMod/Monad/State.hs b/Language/Haskell/GhcMod/Monad/State.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Monad/State.hs +++ /dev/null @@ -1,67 +0,0 @@ --- ghc-mod: Making Haskell development *more* fun --- Copyright (C) 2015,2016 Daniel Gröber --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU Affero General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU Affero General Public License for more details. --- --- You should have received a copy of the GNU Affero General Public License --- along with this program. If not, see . - -{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-} -{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} - -module Language.Haskell.GhcMod.Monad.State where - -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Monad.Newtypes - -import Control.Monad -import Control.Monad.State.Strict (StateT(..)) -import Control.Monad.Trans.Maybe (MaybeT(..)) -import Control.Monad.State.Class (MonadState(..)) -import Control.Monad.Trans.Class (MonadTrans(..)) -import Prelude - -class Monad m => GmState m where - gmsGet :: m GhcModState - gmsGet = gmsState (\s -> (s, s)) - - gmsPut :: GhcModState -> m () - gmsPut s = gmsState (\_ -> ((), s)) - - gmsState :: (GhcModState -> (a, GhcModState)) -> m a - gmsState f = do - s <- gmsGet - let ~(a, s') = f s - gmsPut s' - return a - {-# MINIMAL gmsState | gmsGet, gmsPut #-} - -instance GmState m => GmState (StateT s m) where - gmsGet = lift gmsGet - gmsPut = lift . gmsPut - gmsState = lift . gmsState - -instance Monad m => GmState (StateT GhcModState m) where - gmsGet = get - gmsPut = put - gmsState = state - -instance Monad m => GmState (GmT m) where - gmsGet = GmT get - gmsPut = GmT . put - gmsState = GmT . state - -instance GmState m => GmState (MaybeT m) where - gmsGet = MaybeT $ Just `liftM` gmsGet - gmsPut = MaybeT . (Just `liftM`) . gmsPut - gmsState = MaybeT . (Just `liftM`) . gmsState - -deriving instance (Monad m, GmState (GhcModT m)) => GmState (GmlT m) diff --git a/Language/Haskell/GhcMod/Monad/Types.hs b/Language/Haskell/GhcMod/Monad/Types.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Monad/Types.hs +++ /dev/null @@ -1,239 +0,0 @@ --- ghc-mod: Making Haskell development *more* fun --- Copyright (C) 2015 Daniel Gröber --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU Affero General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU Affero General Public License for more details. --- --- You should have received a copy of the GNU Affero General Public License --- along with this program. If not, see . - -{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, RankNTypes #-} -{-# LANGUAGE TypeFamilies, UndecidableInstances, BangPatterns #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Language.Haskell.GhcMod.Monad.Types ( - -- * Monad Types - GhcModT - , GmOutT(..) - , GmT(..) - , GmlT(..) - , LightGhc(..) - , GmGhc - , IOish - -- * Environment, state and logging - , GhcModEnv(..) - , GhcModState(..) - , GhcModCaches(..) - , defaultGhcModState - , GmGhcSession(..) - , GmComponent(..) - -- * Accessing 'GhcModEnv', 'GhcModState' and 'GhcModLog' - , GmLogLevel(..) - , GhcModLog(..) - , GhcModError(..) - , Gm - , GmEnv(..) - , GmState(..) - , GmLog(..) - , GmOut(..) - , cradle - , options - , outputOpts - , withOptions - , getMMappedFiles - , setMMappedFiles - , addMMappedFile - , delMMappedFile - , lookupMMappedFile - , getMMappedFilePaths - -- * Re-exporting convenient stuff - , MonadIO - , liftIO - , gmlGetSession - , gmlSetSession - ) where - -#include "Compat.hs_h" - -import Language.Haskell.GhcMod.Types - -import Language.Haskell.GhcMod.Monad.Env -import Language.Haskell.GhcMod.Monad.State -import Language.Haskell.GhcMod.Monad.Log -import Language.Haskell.GhcMod.Monad.Out -import Language.Haskell.GhcMod.Monad.Newtypes -import Language.Haskell.GhcMod.Monad.Orphans () - -import Safe - -import GHC -import DynFlags -import Exception -import HscTypes - -import Control.Applicative -import Control.Monad - -import Control.Monad.Reader (ReaderT(..)) -import Control.Monad.State.Strict (StateT(..)) -import Control.Monad.Trans.Journal (JournalT) -import Control.Monad.Trans.Maybe (MaybeT) - -import Control.Monad.Trans.Control - -import Control.Monad.Reader.Class - -import qualified Data.Map as M -import Data.Maybe -import Data.Monoid -import Data.IORef -import Prelude - -type Gm m = (GmEnv m, GmState m, GmLog m, GmOut m) - --------------------------------------------------- --- GHC API instances ----------------------------- - --- GHC cannot prove the following instances to be decidable automatically using --- the FlexibleContexts extension as they violate the second Paterson Condition, --- namely that: The assertion has fewer constructors and variables (taken --- together and counting repetitions) than the head. Specifically the --- @MonadBaseControl IO m@ constraint in 'IOish' is causing this violation. - -type GmGhc m = (IOish m, GhcMonad m) - -instance (MonadIO m, MonadBaseControl IO m) => GhcMonad (GmlT m) where - getSession = gmlGetSession - setSession = gmlSetSession - --- | Get the underlying GHC session -gmlGetSession :: (MonadIO m, MonadBaseControl IO m) => GmlT m HscEnv -gmlGetSession = do - ref <- gmgsSession . fromJustNote "gmlGetSession" . gmGhcSession <$> gmsGet - liftIO $ readIORef ref - --- | Set the underlying GHC session -gmlSetSession :: (MonadIO m, MonadBaseControl IO m) => HscEnv -> GmlT m () -gmlSetSession a = do - ref <- gmgsSession . fromJustNote "gmlSetSession" . gmGhcSession <$> gmsGet - liftIO $ flip writeIORef a ref - -instance GhcMonad LightGhc where - getSession = (liftIO . readIORef) =<< LightGhc ask - setSession a = (liftIO . flip writeIORef a) =<< LightGhc ask - -#if __GLASGOW_HASKELL__ >= 706 -instance (MonadIO m, MonadBaseControl IO m) => HasDynFlags (GmlT m) where - getDynFlags = hsc_dflags <$> getSession - -instance HasDynFlags LightGhc where - getDynFlags = hsc_dflags <$> getSession -#endif - -instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (GmOutT m) where - gcatch act handler = control $ \run -> - run act `gcatch` (run . handler) - - gmask = liftBaseOp gmask . liftRestore - where liftRestore f r = f $ liftBaseOp_ r - -instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (GmT m) where - gcatch act handler = control $ \run -> - run act `gcatch` (run . handler) - - gmask = liftBaseOp gmask . liftRestore - where liftRestore f r = f $ liftBaseOp_ r - -instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (GmlT m) where - gcatch act handler = control $ \run -> - run act `gcatch` (run . handler) - - gmask = liftBaseOp gmask . liftRestore - where liftRestore f r = f $ liftBaseOp_ r - -instance ExceptionMonad LightGhc where - gcatch act handl = - LightGhc $ unLightGhc act `gcatch` \e -> unLightGhc (handl e) - gmask f = - LightGhc $ gmask $ \io_restore ->let - g_restore (LightGhc m) = LightGhc $ io_restore m - in - unLightGhc (f g_restore) - - -instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (StateT s m) where - gcatch act handler = control $ \run -> - run act `gcatch` (run . handler) - - gmask = liftBaseOp gmask . liftRestore - where liftRestore f r = f $ liftBaseOp_ r - -instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (ReaderT s m) where - gcatch act handler = control $ \run -> - run act `gcatch` (run . handler) - - gmask = liftBaseOp gmask . liftRestore - where liftRestore f r = f $ liftBaseOp_ r - -instance (Monoid w, MonadIO m, MonadBaseControl IO m) => ExceptionMonad (JournalT w m) where - gcatch act handler = control $ \run -> - run act `gcatch` (run . handler) - - gmask = liftBaseOp gmask . liftRestore - where liftRestore f r = f $ liftBaseOp_ r - -instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (MaybeT m) where - gcatch act handler = control $ \run -> - run act `gcatch` (run . handler) - - gmask = liftBaseOp gmask . liftRestore - where liftRestore f r = f $ liftBaseOp_ r - - ----------------------------------------------------------------- - -options :: GmEnv m => m Options -options = gmOptions `liftM` gmeAsk - -outputOpts :: GmOut m => m OutputOpts -outputOpts = gmoOptions `liftM` gmoAsk - -cradle :: GmEnv m => m Cradle -cradle = gmCradle `liftM` gmeAsk - -getMMappedFiles :: GmState m => m FileMappingMap -getMMappedFiles = gmMMappedFiles `liftM` gmsGet - -setMMappedFiles :: GmState m => FileMappingMap -> m () -setMMappedFiles mf = (\s -> gmsPut s { gmMMappedFiles = mf } ) =<< gmsGet - -addMMappedFile :: GmState m => FilePath -> FileMapping -> m () -addMMappedFile t fm = - getMMappedFiles >>= setMMappedFiles . M.insert t fm - -delMMappedFile :: GmState m => FilePath -> m () -delMMappedFile t = - getMMappedFiles >>= setMMappedFiles . M.delete t - -lookupMMappedFile :: GmState m => FilePath -> m (Maybe FileMapping) -lookupMMappedFile t = - M.lookup t `liftM` getMMappedFiles - -getMMappedFilePaths :: GmState m => m [FilePath] -getMMappedFilePaths = M.keys `liftM` getMMappedFiles - -withOptions :: GmEnv m => (Options -> Options) -> m a -> m a -withOptions changeOpt action = gmeLocal changeEnv action - where - changeEnv e = e { gmOptions = changeOpt opt } - where - opt = gmOptions e diff --git a/Language/Haskell/GhcMod/Output.hs b/Language/Haskell/GhcMod/Output.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Output.hs +++ /dev/null @@ -1,243 +0,0 @@ --- ghc-mod: Making Haskell development *more* fun --- Copyright (C) 2015 Daniel Gröber --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU Affero General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU Affero General Public License for more details. --- --- You should have received a copy of the GNU Affero General Public License --- along with this program. If not, see . - --- Derived from process:System.Process --- Copyright (c) The University of Glasgow 2004-2008 - -{-# LANGUAGE FlexibleInstances #-} -module Language.Haskell.GhcMod.Output ( - gmPutStr - , gmErrStr - , gmPutStrLn - , gmErrStrLn - - , gmPutStrIO - , gmErrStrIO - - , gmReadProcess - , gmReadProcess' - - , stdoutGateway - , flushStdoutGateway - ) where - -import Data.List -import Data.ByteString.Lazy (ByteString) -import qualified Data.ByteString.Lazy as BS -import qualified Data.Label as L -import qualified Data.Label.Base as LB -import System.IO -import System.Exit -import System.Process -import Control.Monad -import Control.Monad.State.Strict -import Control.DeepSeq -import Control.Exception -import Control.Concurrent (forkIO, killThread) -import Control.Concurrent.MVar -import Control.Concurrent.Chan -import Pipes -import Pipes.Lift -import Prelude - -import Language.Haskell.GhcMod.Types hiding (LineSeparator, MonadIO(..)) -import Language.Haskell.GhcMod.Monad.Types hiding (MonadIO(..)) -import Language.Haskell.GhcMod.Gap () - -class ProcessOutput a where - hGetContents' :: Handle -> IO a - -instance ProcessOutput String where - hGetContents' = hGetContents - -instance ProcessOutput ByteString where - hGetContents' = BS.hGetContents - -outputFns :: (GmOut m, MonadIO m') - => m (String -> m' (), String -> m' ()) -outputFns = - outputFns' `liftM` gmoAsk - -outputFns' :: - MonadIO m => GhcModOut -> (String -> m (), String -> m ()) -outputFns' (GhcModOut oopts c) = let - OutputOpts {..} = oopts - in - case ooptLinePrefix of - Nothing -> stdioOutputFns - Just _ -> chanOutputFns c - -stdioOutputFns :: MonadIO m => (String -> m (), String -> m ()) -stdioOutputFns = - ( liftIO . putStr - , liftIO . hPutStr stderr - ) - -chanOutputFns :: MonadIO m - => Chan (Either (MVar ()) (GmStream, String)) - -> (String -> m (), String -> m ()) -chanOutputFns c = (write GmOutStream, write GmErrStream) - where - write stream s = liftIO $ writeChan c $ Right $ (stream,s) - -gmPutStr, gmPutStrLn, gmErrStr, gmErrStrLn - :: (MonadIO m, GmOut m) => String -> m () - -gmPutStr str = do - putOut <- gmPutStrIO - putOut str - -gmErrStr str = do - putErr <- gmErrStrIO - putErr str - -gmPutStrLn = gmPutStr . (++"\n") -gmErrStrLn = gmErrStr . (++"\n") - -gmPutStrIO, gmErrStrIO :: (GmOut m, MonadIO mi) => m (String -> mi ()) - -gmPutStrIO = fst `liftM` outputFns -gmErrStrIO = snd `liftM` outputFns - - -gmReadProcess :: GmOut m => m (FilePath -> [String] -> String -> IO String) -gmReadProcess = do - GhcModOut {..} <- gmoAsk - case ooptLinePrefix gmoOptions of - Just _ -> - readProcessStderrChan - Nothing -> - return $ readProcess - -gmReadProcess' :: GmOut m => m (FilePath -> [String] -> String -> IO ByteString) -gmReadProcess' = readProcessStderrChan - -flushStdoutGateway :: Chan (Either (MVar ()) (GmStream, String)) -> IO () -flushStdoutGateway c = do - mv <- newEmptyMVar - writeChan c $ Left mv - takeMVar mv - -type Line = String - -stdoutGateway :: (String, String) -> Chan (Either (MVar ()) (GmStream, String)) -> IO () -stdoutGateway (outPf, errPf) chan = do - runEffect $ commandProc >-> evalStateP ("","") seperateStreams - where - commandProc :: Producer (Either (MVar ()) (GmStream, String)) IO () - commandProc = do - cmd <- liftIO $ readChan chan - case cmd of - Left mv -> do - yield $ Left mv - Right input -> do - yield $ Right input - commandProc - - seperateStreams :: Consumer (Either (MVar ()) (GmStream, String)) (StateT (String, String) IO) () - seperateStreams = do - ecmd <- await - case ecmd of - Left mv -> do - -- flush buffers - (\s -> lift $ zoom (streamLens s) $ sGetLine Nothing) - `mapM_` [GmOutStream, GmErrStream] - - liftIO $ putMVar mv () - Right (stream, str) -> do - ls <- lift $ zoom (streamLens stream) $ sGetLine (Just str) - case ls of - [] -> return () - _ -> liftIO $ putStr $ unlines $ map (streamPf stream++) ls - - liftIO $ hFlush stdout - seperateStreams - - sGetLine :: (Maybe String) -> StateT String IO [Line] - sGetLine mstr' = do - buf <- get - let mstr = (buf++) `liftM` mstr' - case mstr of - Nothing -> put "" >> return [buf] - Just "" -> return [] - Just s | last s == '\n' -> put "" >> return (lines s) - | otherwise -> do - let (p:ls') = reverse $ lines s - put p - return $ reverse $ ls' - - streamLens GmOutStream = LB.fst - streamLens GmErrStream = LB.snd - - streamPf GmOutStream = outPf - streamPf GmErrStream = errPf - -zoom :: Monad m => (f L.:-> o) -> StateT o m a -> StateT f m a -zoom l (StateT a) = - StateT $ \f -> do - (a', s') <- a $ L.get l f - return (a', L.set l s' f) - -readProcessStderrChan :: - (GmOut m, ProcessOutput a, NFData a) => m (FilePath -> [String] -> String -> IO a) -readProcessStderrChan = do - (_, e :: String -> IO ()) <- outputFns - return $ readProcessStderrChan' e - -readProcessStderrChan' :: (ProcessOutput a, NFData a) => - (String -> IO ()) -> FilePath -> [String] -> String -> IO a -readProcessStderrChan' putErr exe args input = do - let cp = (proc exe args) { - std_out = CreatePipe - , std_err = CreatePipe - , std_in = CreatePipe - } - (Just i, Just o, Just e, h) <- createProcess cp - - _ <- forkIO $ reader e - - output <- hGetContents' o - withForkWait (evaluate $ rnf output) $ \waitOut -> do - - -- now write any input - unless (null input) $ - ignoreSEx $ hPutStr i input - -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE - ignoreSEx $ hClose i - - -- wait on the output - waitOut - hClose o - - res <- waitForProcess h - case res of - ExitFailure rv -> - throw $ GMEProcess "readProcessStderrChan" exe args $ Left rv - ExitSuccess -> - return output - where - ignoreSEx = handle (\(SomeException _) -> return ()) - reader h = ignoreSEx $ do - putErr . (++"\n") =<< hGetLine h - reader h - -withForkWait :: IO () -> (IO () -> IO a) -> IO a -withForkWait async body = do - waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ())) - mask $ \restore -> do - tid <- forkIO $ try (restore async) >>= putMVar waitVar - let wait = takeMVar waitVar >>= either throwIO return - restore (body wait) `onException` killThread tid diff --git a/Language/Haskell/GhcMod/PathsAndFiles.hs b/Language/Haskell/GhcMod/PathsAndFiles.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/PathsAndFiles.hs +++ /dev/null @@ -1,250 +0,0 @@ --- ghc-mod: Making Haskell development *more* fun --- Copyright (C) 2015 Daniel Gröber --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU Affero General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU Affero General Public License for more details. --- --- You should have received a copy of the GNU Affero General Public License --- along with this program. If not, see . - -module Language.Haskell.GhcMod.PathsAndFiles ( - module Language.Haskell.GhcMod.PathsAndFiles - , module Language.Haskell.GhcMod.Caching - ) where - -import Config (cProjectVersion) -import Control.Arrow (second) -import Control.Applicative -import Control.Exception as E -import Control.Monad -import Data.List -import Data.Char -import Data.Maybe -import Data.Traversable hiding (mapM) -import Distribution.Helper (buildPlatform) -import System.Directory -import System.FilePath -import System.Process - -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Caching -import qualified Language.Haskell.GhcMod.Utils as U -import Utils (mightExist) -import Prelude - --- | Guaranteed to be a path to a directory with no trailing slash. -type DirPath = FilePath - --- | Guaranteed to be the name of a file only (no slashes). -type FileName = String - -newtype UnString = UnString { unString :: String } - -instance Show UnString where - show = unString - -instance Read UnString where - readsPrec _ = \str -> [(UnString str, "")] - --- | @findCabalFiles dir@. Searches for a @.cabal@ files in @dir@'s parent --- directories. The first parent directory containing more than one cabal file --- is assumed to be the project directory. If only one cabal file exists in this --- directory it is returned otherwise @findCabalFiles@ throws 'GMENoCabalFile' --- or 'GMETooManyCabalFiles' -findCabalFile :: FilePath -> IO (Maybe FilePath) -findCabalFile dir = do - -- List of directories and all cabal file candidates - dcs <- findFileInParentsP isCabalFile dir :: IO ([(DirPath, [FileName])]) - let css = uncurry appendDir `map` dcs :: [[FilePath]] - case find (not . null) css of - Nothing -> return Nothing - Just cfs@(_:_:_) -> throw $ GMETooManyCabalFiles cfs - Just (a:_) -> return (Just a) - Just [] -> error "findCabalFile" - where - appendDir :: DirPath -> [FileName] -> [FilePath] - appendDir d fs = (d ) `map` fs - -findStackConfigFile :: FilePath -> IO (Maybe FilePath) -findStackConfigFile dir = do - fs <- map (second listToMaybe) <$> findFileInParentsP (=="stack.yaml") dir - case find (isJust . snd) fs of - Nothing -> return Nothing - Just (d, Just a) -> return $ Just $ d a - Just (_, Nothing) -> error "findStackConfigFile" - --- | Get path to sandbox config file -getSandboxDb :: Cradle -> IO (Maybe GhcPkgDb) -getSandboxDb crdl = do - mConf <-traverse readFile =<< mightExist (sandboxConfigFile crdl) - bp <- buildPlatform readProcess - return $ PackageDb . fixPkgDbVer bp <$> (extractSandboxDbDir =<< mConf) - - where - fixPkgDbVer bp dir = - case takeFileName dir == ghcSandboxPkgDbDir bp of - True -> dir - False -> takeDirectory dir ghcSandboxPkgDbDir bp - --- | Extract the sandbox package db directory from the cabal.sandbox.config --- file. Exception is thrown if the sandbox config file is broken. -extractSandboxDbDir :: String -> Maybe FilePath -extractSandboxDbDir conf = extractValue <$> parse conf - where - key = "package-db:" - keyLen = length key - - parse = listToMaybe . filter (key `isPrefixOf`) . lines - extractValue = U.dropWhileEnd isSpace . dropWhile isSpace . drop keyLen - - --- | --- >>> isCabalFile "/home/user/.cabal" --- False -isCabalFile :: FilePath -> Bool -isCabalFile f = takeExtension' f == ".cabal" - --- | --- >>> takeExtension' "/some/dir/bla.cabal" --- ".cabal" --- --- >>> takeExtension' "some/reldir/bla.cabal" --- ".cabal" --- --- >>> takeExtension' "bla.cabal" --- ".cabal" --- --- >>> takeExtension' ".cabal" --- "" -takeExtension' :: FilePath -> String -takeExtension' p = - if takeFileName p == takeExtension p - then "" -- just ".cabal" is not a valid cabal file - else takeExtension p - --- | @findFileInParentsP p dir@ Look for files satisfying @p@ in @dir@ and all --- it's parent directories. -findFileInParentsP :: (FilePath -> Bool) -> FilePath - -> IO [(DirPath, [FileName])] -findFileInParentsP p dir' = U.makeAbsolute' dir' >>= \dir -> - getFilesP p `zipMapM` parents dir - --- | @getFilesP p dir@. Find all __files__ satisfying @p@ in @.cabal@ in @dir@. -getFilesP :: (FilePath -> Bool) -> DirPath -> IO [FileName] -getFilesP p dir = filterM p' =<< getDirectoryContents dir - where - p' fn = do - (p fn && ) <$> doesFileExist (dir fn) - -findCabalSandboxDir :: FilePath -> IO (Maybe FilePath) -findCabalSandboxDir dir = do - dss <- findFileInParentsP isSandboxConfig dir - return $ case find (not . null . snd) $ dss of - Just (sbDir, _:_) -> Just sbDir - _ -> Nothing - - where - isSandboxConfig = (==sandboxConfigFileName) - -zipMapM :: Monad m => (a -> m c) -> [a] -> m [(a,c)] -zipMapM f as = mapM (\a -> liftM ((,) a) $ f a) as - --- | @parents dir@. Returns all parent directories of @dir@ including @dir@. --- --- Examples --- --- >>> parents "foo" --- ["foo"] --- --- >>> parents "/foo" --- ["/foo","/"] --- --- >>> parents "/foo/bar" --- ["/foo/bar","/foo","/"] --- --- >>> parents "foo/bar" --- ["foo/bar","foo"] -parents :: FilePath -> [FilePath] -parents "" = [] -parents dir' = - let (drive, dir) = splitDrive $ normalise $ dropTrailingPathSeparator dir' - in map (joinDrive drive) $ parents' $ filter (/=".") $ splitDirectories dir - where - parents' :: [String] -> [FilePath] - parents' [] | isAbsolute dir' = "":[] - parents' [] = [] - parents' dir = [joinPath dir] ++ parents' (init dir) - ----------------------------------------------------------------- - -setupConfigFile :: Cradle -> FilePath -setupConfigFile crdl = - cradleRootDir crdl setupConfigPath (cradleDistDir crdl) - -sandboxConfigFile :: Cradle -> FilePath -sandboxConfigFile crdl = cradleRootDir crdl sandboxConfigFileName - -sandboxConfigFileName :: String -sandboxConfigFileName = "cabal.sandbox.config" - --- | Path to 'LocalBuildInfo' file, usually @dist/setup-config@ -setupConfigPath :: FilePath -> FilePath -setupConfigPath dist = dist "setup-config" - -- localBuildInfoFile defaultDistPref - -macrosHeaderPath :: FilePath -macrosHeaderPath = autogenModulesDir "cabal_macros.h" - -autogenModulePath :: String -> String -autogenModulePath pkg_name = - autogenModulesDir ("Paths_" ++ map fixchar pkg_name) <.> ".hs" - where fixchar '-' = '_' - fixchar c = c - -autogenModulesDir :: FilePath -autogenModulesDir = "build" "autogen" - -ghcSandboxPkgDbDir :: String -> String -ghcSandboxPkgDbDir buildPlatf = do - buildPlatf ++ "-ghc-" ++ cProjectVersion ++ "-packages.conf.d" - -packageCache :: String -packageCache = "package.cache" - --- | Filename of the symbol table cache file. -symbolCache :: Cradle -> FilePath -symbolCache crdl = cradleTempDir crdl symbolCacheFile - -symbolCacheFile :: String -symbolCacheFile = "ghc-mod.symbol-cache" - -resolvedComponentsCacheFile :: FilePath -> FilePath -resolvedComponentsCacheFile dist = - setupConfigPath dist <.> "ghc-mod.resolved-components" - -cabalHelperCacheFile :: FilePath -> FilePath -cabalHelperCacheFile dist = - setupConfigPath dist <.> "ghc-mod.cabal-components" - -mergedPkgOptsCacheFile :: FilePath -> FilePath -mergedPkgOptsCacheFile dist = - setupConfigPath dist <.> "ghc-mod.package-options" - -pkgDbStackCacheFile :: FilePath -> FilePath -pkgDbStackCacheFile dist = - setupConfigPath dist <.> "ghc-mod.package-db-stack" - --- | @findCustomPackageDbFile dir@. Searches for a @ghc-mod.package-db-stack@ file in @dir@. --- If it exists in the given directory it is returned otherwise @findCradleFile@ --- returns @Nothing@ -findCustomPackageDbFile :: FilePath -> IO (Maybe FilePath) -findCustomPackageDbFile directory = do - let path = directory "ghc-mod.package-db-stack" - mightExist path diff --git a/Language/Haskell/GhcMod/PkgDoc.hs b/Language/Haskell/GhcMod/PkgDoc.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/PkgDoc.hs +++ /dev/null @@ -1,29 +0,0 @@ -module Language.Haskell.GhcMod.PkgDoc (pkgDoc) where - -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.GhcPkg -import Language.Haskell.GhcMod.Monad -import Language.Haskell.GhcMod.Output - -import Control.Applicative -import Prelude - --- | Obtaining the package name and the doc path of a module. -pkgDoc :: IOish m => String -> GhcModT m String -pkgDoc mdl = do - ghcPkg <- getGhcPkgProgram - readProc <- gmReadProcess - pkgDbStack <- getPackageDbStack - pkg <- liftIO $ trim <$> readProc ghcPkg (toModuleOpts pkgDbStack) "" - if pkg == "" then - return "\n" - else do - htmlpath <- liftIO $ readProc ghcPkg (toDocDirOpts pkg pkgDbStack) "" - let ret = pkg ++ " " ++ drop 14 htmlpath - return ret - where - toModuleOpts dbs = ["find-module", mdl, "--simple-output"] - ++ ghcPkgDbStackOpts dbs - toDocDirOpts pkg dbs = ["field", pkg, "haddock-html"] - ++ ghcPkgDbStackOpts dbs - trim = takeWhile (`notElem` " \n") diff --git a/Language/Haskell/GhcMod/Pretty.hs b/Language/Haskell/GhcMod/Pretty.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Pretty.hs +++ /dev/null @@ -1,74 +0,0 @@ --- ghc-mod: Making Haskell development *more* fun --- Copyright (C) 2015 Daniel Gröber --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU Affero General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU Affero General Public License for more details. --- --- You should have received a copy of the GNU Affero General Public License --- along with this program. If not, see . - -module Language.Haskell.GhcMod.Pretty where - -import Control.Arrow hiding ((<+>)) -import Data.Char -import Data.List -import Distribution.Helper -import Text.PrettyPrint - -import Language.Haskell.GhcMod.Types - -docStyle :: Style -docStyle = style { ribbonsPerLine = 1.2 } - -gmRenderDoc :: Doc -> String -gmRenderDoc = renderStyle docStyle - -gmComponentNameDoc :: ChComponentName -> Doc -gmComponentNameDoc ChSetupHsName = text $ "Setup.hs" -gmComponentNameDoc ChLibName = text $ "library" -gmComponentNameDoc (ChExeName n) = text $ "exe:" ++ n -gmComponentNameDoc (ChTestName n) = text $ "test:" ++ n -gmComponentNameDoc (ChBenchName n) = text $ "bench:" ++ n - -gmLogLevelDoc :: GmLogLevel -> Doc -gmLogLevelDoc GmSilent = error "GmSilent MUST not be used for log messages" -gmLogLevelDoc GmPanic = text "PANIC" -gmLogLevelDoc GmException = text "EXCEPTION" -gmLogLevelDoc GmError = text "ERROR" -gmLogLevelDoc GmWarning = text "Warning" -gmLogLevelDoc GmInfo = text "info" -gmLogLevelDoc GmDebug = text "DEBUG" -gmLogLevelDoc GmVomit = text "VOMIT" - -infixl 6 <+>: -(<+>:) :: Doc -> Doc -> Doc -a <+>: b = (a <> colon) <+> b - -fnDoc :: FilePath -> Doc -fnDoc = doubleQuotes . text - -showDoc :: Show a => a -> Doc -showDoc = strLnDoc . show - -warnDoc :: Doc -> Doc -warnDoc d = text "Warning" <+>: d - -strLnDoc :: String -> Doc -strLnDoc str = doc (dropWhileEnd isSpace str) - where - doc = lines >>> map text >>> foldr ($+$) empty - -strDoc :: String -> Doc -strDoc str = doc (dropWhileEnd isSpace str) - where - doc :: String -> Doc - doc = lines - >>> map (words >>> map text >>> fsep) - >>> \l -> case l of (x:xs) -> hang x 4 (vcat xs); [] -> empty diff --git a/Language/Haskell/GhcMod/Read.hs b/Language/Haskell/GhcMod/Read.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Read.hs +++ /dev/null @@ -1,106 +0,0 @@ -module Language.Haskell.GhcMod.Read where - -import Text.Read (readPrec_to_S, readPrec, minPrec) -import qualified Text.ParserCombinators.ReadP as P -import Text.ParserCombinators.ReadPrec (lift) - --- This library (libraries/base) is derived from code from several --- sources: - --- * Code from the GHC project which is largely (c) The University of --- Glasgow, and distributable under a BSD-style license (see below), - --- * Code from the Haskell 98 Report which is (c) Simon Peyton Jones --- and freely redistributable (but see the full license for --- restrictions). - --- * Code from the Haskell Foreign Function Interface specification, --- which is (c) Manuel M. T. Chakravarty and freely redistributable --- (but see the full license for restrictions). - --- The full text of these licenses is reproduced below. All of the --- licenses are BSD-style or compatible. - --- ----------------------------------------------------------------------------- - --- The Glasgow Haskell Compiler License - --- Copyright 2004, The University Court of the University of Glasgow. --- All rights reserved. - --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: - --- - Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. - --- - Redistributions in binary form must reproduce the above copyright notice, --- this list of conditions and the following disclaimer in the documentation --- and/or other materials provided with the distribution. - --- - Neither name of the University nor the names of its contributors may be --- used to endorse or promote products derived from this software without --- specific prior written permission. - --- THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF --- GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, --- INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND --- FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE --- UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT --- LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY --- OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH --- DAMAGE. - --- ----------------------------------------------------------------------------- - --- Code derived from the document "Report on the Programming Language --- Haskell 98", is distributed under the following license: - --- Copyright (c) 2002 Simon Peyton Jones - --- The authors intend this Report to belong to the entire Haskell --- community, and so we grant permission to copy and distribute it for --- any purpose, provided that it is reproduced in its entirety, --- including this Notice. Modified versions of this Report may also be --- copied and distributed for any purpose, provided that the modified --- version is clearly presented as such, and that it does not claim to --- be a definition of the Haskell 98 Language. - --- ----------------------------------------------------------------------------- - --- Code derived from the document "The Haskell 98 Foreign Function --- Interface, An Addendum to the Haskell 98 Report" is distributed under --- the following license: - --- Copyright (c) 2002 Manuel M. T. Chakravarty - --- The authors intend this Report to belong to the entire Haskell --- community, and so we grant permission to copy and distribute it for --- any purpose, provided that it is reproduced in its entirety, --- including this Notice. Modified versions of this Report may also be --- copied and distributed for any purpose, provided that the modified --- version is clearly presented as such, and that it does not claim to --- be a definition of the Haskell 98 Foreign Function Interface. - --- ----------------------------------------------------------------------------- - -readEither :: Read a => String -> Either String a -readEither s = - case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of - [x] -> Right x - [] -> Left "Prelude.read: no parse" - _ -> Left "Prelude.read: ambiguous parse" - where - read' = - do x <- readPrec - lift P.skipSpaces - return x - -readMaybe :: Read a => String -> Maybe a -readMaybe s = case readEither s of - Left _ -> Nothing - Right a -> Just a diff --git a/Language/Haskell/GhcMod/SrcUtils.hs b/Language/Haskell/GhcMod/SrcUtils.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/SrcUtils.hs +++ /dev/null @@ -1,88 +0,0 @@ -{-# LANGUAGE TupleSections, FlexibleInstances, Rank2Types #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Language.Haskell.GhcMod.SrcUtils where - -import Control.Applicative -import CoreUtils (exprType) -import Data.Generics -import Data.Maybe (fromMaybe) -import Data.Ord as O -import GHC (LHsExpr, LPat, Id, DynFlags, SrcSpan, Type, Located, ParsedSource, RenamedSource, TypecheckedSource, GenLocated(L)) -import qualified GHC as G -import GHC.SYB.Utils (Stage(..), everythingStaged) -import GhcMonad -import qualified Language.Haskell.Exts.Annotated as HE -import Language.Haskell.GhcMod.Doc -import Language.Haskell.GhcMod.Gap -import qualified Language.Haskell.GhcMod.Gap as Gap -import OccName (OccName) -import Outputable (PprStyle) -import TcHsSyn (hsPatType) -import Prelude - ----------------------------------------------------------------- - -instance HasType (LHsExpr Id) where - getType tcm e = do - hs_env <- G.getSession - mbe <- liftIO $ Gap.deSugar tcm e hs_env - return $ (G.getLoc e, ) <$> CoreUtils.exprType <$> mbe - -instance HasType (LPat Id) where - getType _ (G.L spn pat) = return $ Just (spn, hsPatType pat) - ----------------------------------------------------------------- - -listifySpans :: Typeable a => TypecheckedSource -> (Int, Int) -> [Located a] -listifySpans tcs lc = listifyStaged TypeChecker p tcs - where - p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc - -listifyParsedSpans :: Typeable a => ParsedSource -> (Int, Int) -> [Located a] -listifyParsedSpans pcs lc = listifyStaged Parser p pcs - where - p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc - -listifyRenamedSpans :: Typeable a => RenamedSource -> (Int, Int) -> [Located a] -listifyRenamedSpans pcs lc = listifyStaged Renamer p pcs - where - p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc - -listifyStaged :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r] -listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x])) - -cmp :: SrcSpan -> SrcSpan -> Ordering -cmp a b - | a `G.isSubspanOf` b = O.LT - | b `G.isSubspanOf` a = O.GT - | otherwise = O.EQ - -toTup :: DynFlags -> PprStyle -> (SrcSpan, Type) -> ((Int,Int,Int,Int),String) -toTup dflag style (spn, typ) = (fourInts spn, pretty dflag style typ) - -fourInts :: SrcSpan -> (Int,Int,Int,Int) -fourInts = fromMaybe (0,0,0,0) . Gap.getSrcSpan - -fourIntsHE :: HE.SrcSpan -> (Int,Int,Int,Int) -fourIntsHE loc = ( HE.srcSpanStartLine loc, HE.srcSpanStartColumn loc - , HE.srcSpanEndLine loc, HE.srcSpanEndColumn loc) - --- Check whether (line,col) is inside a given SrcSpanInfo -typeSigInRangeHE :: Int -> Int -> HE.Decl HE.SrcSpanInfo -> Bool -typeSigInRangeHE lineNo colNo (HE.TypeSig (HE.SrcSpanInfo s _) _ _) = - HE.srcSpanStart s <= (lineNo, colNo) && HE.srcSpanEnd s >= (lineNo, colNo) -typeSigInRangeHE lineNo colNo (HE.TypeFamDecl (HE.SrcSpanInfo s _) _ _) = - HE.srcSpanStart s <= (lineNo, colNo) && HE.srcSpanEnd s >= (lineNo, colNo) -typeSigInRangeHE lineNo colNo (HE.DataFamDecl (HE.SrcSpanInfo s _) _ _ _) = - HE.srcSpanStart s <= (lineNo, colNo) && HE.srcSpanEnd s >= (lineNo, colNo) -typeSigInRangeHE _ _ _= False - -pretty :: DynFlags -> PprStyle -> Type -> String -pretty dflag style = showOneLine dflag style . Gap.typeForUser - -showName :: DynFlags -> PprStyle -> G.Name -> String -showName dflag style name = showOneLine dflag style $ Gap.nameForUser name - -showOccName :: DynFlags -> PprStyle -> OccName -> String -showOccName dflag style name = showOneLine dflag style $ Gap.occNameForUser name diff --git a/Language/Haskell/GhcMod/Stack.hs b/Language/Haskell/GhcMod/Stack.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Stack.hs +++ /dev/null @@ -1,95 +0,0 @@ --- ghc-mod: Making Haskell development *more* fun --- Copyright (C) 2015 Daniel Gröber --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU Affero General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU Affero General Public License for more details. --- --- You should have received a copy of the GNU Affero General Public License --- along with this program. If not, see . - -module Language.Haskell.GhcMod.Stack where - -import Safe -import Control.Applicative -import Control.Exception as E -import Control.Monad -import Control.Monad.Trans.Maybe -import Control.Monad.Trans.Class -import Data.List -import Data.List.Split -import Data.Maybe -import System.Directory -import System.FilePath -import System.Info.Extra -import Exception - -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Monad.Types -import Language.Haskell.GhcMod.Output -import Language.Haskell.GhcMod.Logging -import Language.Haskell.GhcMod.Error -import qualified Language.Haskell.GhcMod.Utils as U -import Prelude - -patchStackPrograms :: (IOish m, GmOut m) => Cradle -> Programs -> m Programs -patchStackPrograms Cradle { cradleProject = (StackProject senv) } progs = do - Just ghc <- getStackGhcPath senv - Just ghcPkg <- getStackGhcPkgPath senv - return $ progs { - ghcProgram = ghc - , ghcPkgProgram = ghcPkg - } -patchStackPrograms _crdl progs = return progs - -getStackEnv :: (IOish m, GmOut m, GmLog m) => FilePath -> m (Maybe StackEnv) -getStackEnv projdir = U.withDirectory_ projdir $ runMaybeT $ do - env <- map (liToTup . splitOn ": ") . lines <$> readStack ["path"] - let look k = fromJustNote "getStackEnv" $ lookup k env - return StackEnv { - seDistDir = look "dist-dir" - , seBinPath = splitSearchPath $ look "bin-path" - , seSnapshotPkgDb = look "snapshot-pkg-db" - , seLocalPkgDb = look "local-pkg-db" - } - where - liToTup [k,v] = (k,v) - liToTup [k] = (k, error "getStackEnv: missing key '"++k++"'") - liToTup _ = error "getStackEnv" - -getStackGhcPath :: IOish m => StackEnv -> m (Maybe FilePath) -getStackGhcPath = findExecutablesInStackBinPath "ghc" - -getStackGhcPkgPath :: IOish m => StackEnv -> m (Maybe FilePath) -getStackGhcPkgPath = findExecutablesInStackBinPath "ghc-pkg" - -findExecutablesInStackBinPath :: IOish m => String -> StackEnv -> m (Maybe FilePath) -findExecutablesInStackBinPath exe StackEnv {..} = - liftIO $ listToMaybe <$> findExecutablesInDirectories' seBinPath exe - -findExecutablesInDirectories' :: [FilePath] -> String -> IO [FilePath] -findExecutablesInDirectories' path binary = - U.findFilesWith' isExecutable path (binary <.> exeExtension) - where isExecutable file = do - perms <- getPermissions file - return $ executable perms - - exeExtension = if isWindows then "exe" else "" - -readStack :: (IOish m, GmOut m, GmLog m) => [String] -> MaybeT m String -readStack args = do - stack <- MaybeT $ liftIO $ findExecutable "stack" - readProc <- lift gmReadProcess - flip gcatch handler $ do - liftIO $ evaluate =<< readProc stack args "" - where - handler (e :: IOError) = do - gmLog GmWarning "readStack" $ gmeDoc $ exToErr e - mzero - exToErr = GMEStackBootstrap . GMEString . show diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ /dev/null @@ -1,492 +0,0 @@ --- ghc-mod: Making Haskell development *more* fun --- Copyright (C) 2015 Daniel Gröber --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU Affero General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU Affero General Public License for more details. --- --- You should have received a copy of the GNU Affero General Public License --- along with this program. If not, see . - -{-# LANGUAGE CPP, ViewPatterns, NamedFieldPuns, RankNTypes #-} -module Language.Haskell.GhcMod.Target where - -import Control.Arrow -import Control.Applicative -import Control.Category ((.)) -import GHC -import GHC.Paths (libdir) -import SysTools -import DynFlags - -import Language.Haskell.GhcMod.DynFlags -import Language.Haskell.GhcMod.Monad.Types -import Language.Haskell.GhcMod.CabalHelper -import Language.Haskell.GhcMod.HomeModuleGraph -import Language.Haskell.GhcMod.PathsAndFiles -import Language.Haskell.GhcMod.GhcPkg -import Language.Haskell.GhcMod.Error -import Language.Haskell.GhcMod.Logging -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Utils as U -import Language.Haskell.GhcMod.FileMapping -import Language.Haskell.GhcMod.LightGhc -import Language.Haskell.GhcMod.CustomPackageDb -import Language.Haskell.GhcMod.Output - -import Safe -import Data.Maybe -import Data.Monoid as Monoid -import Data.Either -import Data.Foldable as Foldable (foldrM) -import qualified Data.Foldable as Foldable -import Data.Traversable hiding (mapM, forM) -import Data.IORef -import Data.List -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Function (on) -import Distribution.Helper -import Prelude hiding ((.)) - -import System.Directory -import System.FilePath - -runGmPkgGhc :: (IOish m, Gm m) => LightGhc a -> m a -runGmPkgGhc action = do - pkgOpts <- packageGhcOptions - withLightHscEnv pkgOpts $ \env -> liftIO $ runLightGhc env action - -initSession :: IOish m - => [GHCOption] -> (DynFlags -> Ghc 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 - - 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 - let setDf df = setTmpDir cradleTempDir <$> (mdf =<< addCmdOpts opts df) - _ <- setSessionDynFlags =<< setDf =<< getSessionDynFlags - getSession - --- | Drop the currently active GHC session, the next that requires a GHC session --- will initialize a new one. -dropSession :: IOish m => GhcModT m () -dropSession = do - s <- gmsGet - case gmGhcSession s of - Just (GmGhcSession _opts ref) -> do - -- TODO: This is still not enough, there seem to still be references to - -- GHC's state around afterwards. - liftIO $ writeIORef ref (error "HscEnv: session was dropped") - -- Not available on ghc<7.8; didn't really help anyways - -- liftIO $ setUnsafeGlobalDynFlags (error "DynFlags: session was dropped") - gmsPut s { gmGhcSession = Nothing } - - Nothing -> return () - --- | Run a GmlT action (i.e. a function in the GhcMonad) in the context --- of certain files or modules -runGmlT :: IOish m => [Either FilePath ModuleName] -> GmlT m a -> GhcModT m a -runGmlT fns action = runGmlT' fns return action - --- | Run a GmlT action (i.e. a function in the GhcMonad) in the context --- of certain files or modules, with updated GHC flags -runGmlT' :: IOish m - => [Either FilePath ModuleName] - -> (DynFlags -> Ghc DynFlags) - -> GmlT m a - -> GhcModT m a -runGmlT' fns mdf action = runGmlTWith fns mdf id action - --- | Run a GmlT action (i.e. a function in the GhcMonad) in the context --- of certain files or modules, with updated GHC flags and a final --- transformation -runGmlTWith :: IOish m - => [Either FilePath ModuleName] - -> (DynFlags -> Ghc DynFlags) - -> (GmlT m a -> GmlT m b) - -> GmlT m a - -> GhcModT m b -runGmlTWith efnmns' mdf wrapper action = do - crdl <- cradle - Options { optGhcUserOptions } <- options - - let (fns, mns) = partitionEithers efnmns' - ccfns = map (cradleCurrentDir crdl ) fns - cfns <- mapM getCanonicalFileNameSafe ccfns - let serfnmn = Set.fromList $ map Right mns ++ map Left cfns - opts <- targetGhcOptions crdl serfnmn - let opts' = opts ++ ["-O0"] ++ optGhcUserOptions - - gmVomit - "session-ghc-options" - (text "Initializing GHC session with following options") - (intercalate " " $ map (("\""++) . (++"\"")) opts') - - GhcModLog { gmLogLevel = Just level } <- gmlHistory - putErr <- gmErrStrIO - let setLogger | level >= GmDebug = setDebugLogger putErr - | otherwise = setEmptyLogger - - initSession opts' $ - setHscNothing >>> setLogger >>> mdf - - mappedStrs <- getMMappedFilePaths - let targetStrs = mappedStrs ++ map moduleNameString mns ++ cfns - - unGmlT $ wrapper $ do - loadTargets opts targetStrs - action - -targetGhcOptions :: forall m. IOish m - => Cradle - -> Set (Either FilePath ModuleName) - -> GhcModT m [GHCOption] -targetGhcOptions crdl sefnmn = do - when (Set.null sefnmn) $ error "targetGhcOptions: no targets given" - - case cradleProject crdl of - proj - | isCabalHelperProject proj -> cabalOpts crdl - | otherwise -> sandboxOpts crdl - where - zipMap f l = l `zip` (f `map` l) - - cabalOpts :: Cradle -> GhcModT m [String] - cabalOpts Cradle{..} = do - mcs <- cabalResolvedComponents - - let mdlcs = moduleComponents mcs `zipMap` Set.toList sefnmn - candidates = findCandidates $ map snd mdlcs - - let noCandidates = Set.null candidates - noModuleHasAnyAssignment = all (Set.null . snd) mdlcs - - if noCandidates && noModuleHasAnyAssignment - then do - -- First component should be ChLibName, if no lib will take lexically first exe. - let cns = filter (/= ChSetupHsName) $ Map.keys mcs - - gmLog GmDebug "" $ strDoc $ "Could not find a component assignment, falling back to picking library component in cabal file." - return $ gmcGhcOpts $ fromJustNote "targetGhcOptions, no-assignment" $ Map.lookup (head cns) mcs - else do - when noCandidates $ - throwError $ GMECabalCompAssignment mdlcs - - let cn = pickComponent candidates - return $ gmcGhcOpts $ fromJustNote "targetGhcOptions" $ Map.lookup cn mcs - -resolvedComponentsCache :: IOish m => FilePath -> - Cached (GhcModT m) GhcModState - [GmComponent 'GMCRaw (Set.Set ModulePath)] - (Map.Map ChComponentName (GmComponent 'GMCResolved (Set.Set ModulePath))) -resolvedComponentsCache distdir = Cached { - cacheLens = Just (lGmcResolvedComponents . lGmCaches), - cacheFile = resolvedComponentsCacheFile distdir, - cachedAction = \tcfs comps ma -> do - Cradle {..} <- cradle - let iifs = invalidatingInputFiles tcfs - - setupChanged = - (cradleRootDir setupConfigPath distdir) `elem` iifs - - mums :: Maybe [Either FilePath ModuleName] - mums = - let - filterOutSetupCfg = - filter (/= cradleRootDir setupConfigPath distdir) - changedFiles = filterOutSetupCfg iifs - in if null changedFiles || setupChanged - then Nothing - else Just $ map Left changedFiles - - let mdesc (Left f) = "file:" ++ f - mdesc (Right mn) = "module:" ++ moduleNameString mn - - changed = map (text . mdesc) $ Foldable.concat mums - changedDoc | [] <- changed = text "none" - | otherwise = sep changed - - gmLog GmDebug "resolvedComponentsCache" $ - text "files changed" <+>: changedDoc - - mcs <- resolveGmComponents ((,) <$> mums <*> ma) comps - - return (setupConfigPath distdir : flatten mcs , mcs) - } - - where - flatten :: Map.Map ChComponentName (GmComponent t (Set.Set ModulePath)) - -> [FilePath] - flatten = Map.elems - >>> map (gmcHomeModuleGraph >>> gmgGraph - >>> (Map.keysSet &&& Map.elems) - >>> uncurry insert - >>> map (Set.map mpPath) - >>> Set.unions - ) - >>> Set.unions - >>> Set.toList - -moduleComponents :: Map ChComponentName (GmComponent t (Set ModulePath)) - -> Either FilePath ModuleName - -> Set ChComponentName -moduleComponents m efnmn = - foldr' Set.empty m $ \c s -> - let - memb = - case efnmn of - Left fn -> fn `Set.member` Set.map mpPath (smp c) - Right mn -> mn `Set.member` Set.map mpModule (smp c) - in if memb - then Set.insert (gmcName c) s - else s - where - smp c = Map.keysSet $ gmgGraph $ gmcHomeModuleGraph c - - foldr' b as f = Map.foldr f b as - - -findCandidates :: [Set ChComponentName] -> Set ChComponentName -findCandidates [] = Set.empty -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 = do - crdl <- cradle - case cradleProject crdl of - proj - | isCabalHelperProject proj -> getGhcMergedPkgOptions - | otherwise -> sandboxOpts crdl - --- also works for plain projects! -sandboxOpts :: (IOish m, GmEnv m) => Cradle -> m [String] -sandboxOpts crdl = do - mCusPkgDb <- getCustomPkgDbStack - pkgDbStack <- liftIO $ getSandboxPackageDbStack - let pkgOpts = ghcDbStackOpts $ fromMaybe pkgDbStack mCusPkgDb - return $ ["-i" ++ d | d <- [wdir,rdir]] ++ pkgOpts ++ ["-Wall"] - where - (wdir, rdir) = (cradleCurrentDir crdl, cradleRootDir crdl) - - getSandboxPackageDbStack :: IO [GhcPkgDb] - getSandboxPackageDbStack = - ([GlobalDb] ++) . maybe [UserDb] return <$> getSandboxDb crdl - -resolveGmComponent :: (IOish m, Gm m) - => Maybe [CompilationUnit] -- ^ Updated modules - -> GmComponent 'GMCRaw (Set ModulePath) - -> m (GmComponent 'GMCResolved (Set ModulePath)) -resolveGmComponent mums c@GmComponent {..} = do - distDir <- cradleDistDir <$> cradle - gmLog GmDebug "resolveGmComponent" $ text $ show $ ghcOpts distDir - withLightHscEnv (ghcOpts distDir) $ \env -> do - let srcDirs = if null gmcSourceDirs then [""] else gmcSourceDirs - let mg = gmcHomeModuleGraph - let simp = gmcEntrypoints - sump <- case mums of - Nothing -> return simp - Just ums -> - Set.fromList . catMaybes <$> - mapM (resolveModule env srcDirs) ums - - mg' <- canonicalizeModuleGraph =<< updateHomeModuleGraph env mg simp sump - - return $ c { gmcEntrypoints = simp, gmcHomeModuleGraph = mg' } - - where ghcOpts distDir = concat [ - gmcGhcSrcOpts, - gmcGhcLangOpts, - [ "-optP-include", "-optP" ++ distDir macrosHeaderPath ] - ] - -resolveEntrypoint :: (IOish m, Gm m) - => Cradle - -> GmComponent 'GMCRaw ChEntrypoint - -> m (GmComponent 'GMCRaw (Set ModulePath)) -resolveEntrypoint Cradle {..} c@GmComponent {..} = do - gmLog GmDebug "resolveEntrypoint" $ text $ show $ gmcGhcSrcOpts - withLightHscEnv gmcGhcSrcOpts $ \env -> do - let srcDirs = if null gmcSourceDirs then [""] else gmcSourceDirs - eps <- liftIO $ resolveChEntrypoints cradleRootDir gmcEntrypoints - rms <- resolveModule env srcDirs `mapM` eps - return c { gmcEntrypoints = Set.fromList $ catMaybes rms } - --- TODO: remember that the file from `main-is:` is always module `Main` and let --- ghc do the warning about it. Right now we run that module through --- resolveModule like any other -resolveChEntrypoints :: FilePath -> ChEntrypoint -> IO [CompilationUnit] -resolveChEntrypoints _ (ChLibEntrypoint em om) = - return $ map (Right . chModToMod) (em ++ om) - -resolveChEntrypoints _ (ChExeEntrypoint main om) = - return $ [Left main] ++ map (Right . chModToMod) om - -resolveChEntrypoints srcDir ChSetupEntrypoint = do - shs <- doesFileExist (srcDir "Setup.hs") - slhs <- doesFileExist (srcDir "Setup.lhs") - return $ case (shs, slhs) of - (True, _) -> [Left "Setup.hs"] - (_, True) -> [Left "Setup.lhs"] - (False, False) -> [] - -chModToMod :: ChModuleName -> ModuleName -chModToMod (ChModuleName mn) = mkModuleName mn - - -resolveModule :: (IOish m, Gm m) => - HscEnv -> [FilePath] -> CompilationUnit -> m (Maybe ModulePath) -resolveModule env _srcDirs (Right mn) = - liftIO $ traverse canonicalizeModulePath =<< findModulePath env mn -resolveModule env srcDirs (Left fn') = do - mfn <- liftIO $ findFile' srcDirs fn' - case mfn of - Nothing -> return Nothing - Just fn'' -> do - fn <- liftIO $ canonicalizePath fn'' - emn <- fileModuleName env fn - case emn of - Left errs -> do - gmLog GmWarning ("resolveModule " ++ show fn) $ - Monoid.mempty $+$ (vcat $ map text errs) - return Nothing -- TODO: should expose these errors otherwise - -- modules with preprocessor/parse errors are - -- going to be missing - Right mmn -> return $ Just $ - case mmn of - Nothing -> mkMainModulePath fn - Just mn -> ModulePath mn fn - where - -- needed for ghc 7.4 - findFile' dirs file = - getFirst . mconcat <$> mapM (fmap First . mightExist . (file)) dirs - - -- fileModuleName fn (dir:dirs) - -- | makeRelative dir fn /= fn - -type CompilationUnit = Either FilePath ModuleName -type Components = - [GmComponent 'GMCRaw (Set ModulePath)] -type ResolvedComponentsMap = - Map ChComponentName (GmComponent 'GMCResolved (Set ModulePath)) - -resolveGmComponents :: (IOish m, Gm m) - => Maybe ([CompilationUnit], ResolvedComponentsMap) - -- ^ Updated modules - -> Components -> m ResolvedComponentsMap -resolveGmComponents mcache cs = do - let rcm = fromMaybe Map.empty $ snd <$> mcache - - m' <- foldrM' rcm cs $ \c m -> do - case Map.lookup (gmcName c) m of - Nothing -> insertUpdated m c - Just c' -> if same gmcRawEntrypoints c c' && same gmcGhcSrcOpts c c' - then return m - else insertUpdated m c - return m' - - where - foldrM' b fa f = foldrM f b fa - insertUpdated m c = do - rc <- resolveGmComponent (fst <$> mcache) c - return $ Map.insert (gmcName rc) rc m - - same :: Eq b - => (forall t a. GmComponent t a -> b) - -> GmComponent u c -> GmComponent v d -> Bool - same f a b = (f a) == (f b) - --- | Set the files as targets and load them. -loadTargets :: IOish m => [GHCOption] -> [FilePath] -> GmlT m () -loadTargets opts targetStrs = do - targets' <- - withLightHscEnv opts $ \env -> - liftM (nubBy ((==) `on` targetId)) - (mapM ((`guessTarget` Nothing) >=> mapFile env) targetStrs) - >>= mapM relativize - - let targets = map (\t -> t { targetAllowObjCode = False }) targets' - - gmLog GmDebug "loadTargets" $ - text "Loading" <+>: fsep (map (text . showTargetId) targets) - - setTargets targets - - mg <- depanal [] False - - let interp = needsHscInterpreted mg - target <- hscTarget <$> getSessionDynFlags - when (interp && target /= HscInterpreted) $ do - resetTargets targets - _ <- setSessionDynFlags . setHscInterpreted =<< getSessionDynFlags - gmLog GmInfo "loadTargets" $ text "Target needs interpeter, switching to LinkInMemory/HscInterpreted. Perfectly normal if anything is using TemplateHaskell, QuasiQuotes or PatternSynonyms." - - target' <- hscTarget <$> getSessionDynFlags - - case target' of - HscNothing -> do - void $ load LoadAllTargets - mapM_ (parseModule >=> typecheckModule >=> desugarModule) mg - HscInterpreted -> do - void $ load LoadAllTargets - _ -> error ("loadTargets: unsupported hscTarget") - - gmLog GmDebug "loadTargets" $ text "Loading done" - - where - relativize (Target (TargetFile filePath phase) taoc src) = do - crdl <- cradle - let tid = TargetFile relativeFilePath phase - relativeFilePath = makeRelative (cradleRootDir crdl) filePath - return $ Target tid taoc src - relativize tgt = return tgt - - resetTargets targets' = do - setTargets [] - void $ load LoadAllTargets - setTargets targets' - - showTargetId (Target (TargetModule s) _ _) = moduleNameString s - showTargetId (Target (TargetFile s _) _ _) = s - -needsHscInterpreted :: ModuleGraph -> Bool -needsHscInterpreted = any $ \ms -> - let df = ms_hspp_opts ms in - Opt_TemplateHaskell `xopt` df - || Opt_QuasiQuotes `xopt` df -#if __GLASGOW_HASKELL__ >= 708 - || (Opt_PatternSynonyms `xopt` df) -#endif - -cabalResolvedComponents :: (IOish m) => - GhcModT m (Map ChComponentName (GmComponent 'GMCResolved (Set ModulePath))) -cabalResolvedComponents = do - crdl@(Cradle{..}) <- cradle - comps <- mapM (resolveEntrypoint crdl) =<< getComponents - withAutogen $ - cached cradleRootDir (resolvedComponentsCache cradleDistDir) comps diff --git a/Language/Haskell/GhcMod/Test.hs b/Language/Haskell/GhcMod/Test.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Test.hs +++ /dev/null @@ -1,45 +0,0 @@ -module Language.Haskell.GhcMod.Test where - -import Control.Applicative -import Data.List -import System.FilePath -import System.Directory -import Prelude - -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Monad -import Language.Haskell.GhcMod.DynFlags - -import GHC -import GHC.Exception -import OccName - -test :: IOish m - => FilePath -> GhcModT m String -test f = runGmlT' [Left f] (fmap setHscInterpreted . deferErrors) $ do - mg <- getModuleGraph - root <- cradleRootDir <$> cradle - f' <- makeRelative root <$> liftIO (canonicalizePath f) - let Just ms = find ((==Just f') . ml_hs_file . ms_location) mg - mdl = ms_mod ms - mn = moduleName mdl - - Just mi <- getModuleInfo mdl - let exs = map (occNameString . getOccName) $ modInfoExports mi - cqs = filter ("prop_" `isPrefixOf`) exs - - setContext [ IIDecl $ simpleImportDecl mn - , IIDecl $ simpleImportDecl $ mkModuleName "Test.QuickCheck" - ] - - _res <- mapM runTest cqs - - return "" - -runTest :: GhcMonad m => String -> m (Maybe SomeException) -runTest fn = do - res <- runStmt ("quickCheck " ++ fn) RunToCompletion - return $ case res of - RunOk [] -> Nothing - RunException se -> Just se - _ -> error "runTest" diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ /dev/null @@ -1,401 +0,0 @@ -{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, RankNTypes, - StandaloneDeriving, DefaultSignatures, FlexibleInstances, TemplateHaskell, - GeneralizedNewtypeDeriving #-} -{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-} -module Language.Haskell.GhcMod.Types ( - module Language.Haskell.GhcMod.Types - , ModuleName - , mkModuleName - , moduleNameString - ) where - -import Control.Monad.Trans.Control (MonadBaseControl) -import Control.Monad.Error (Error(..)) -import qualified Control.Monad.IO.Class as MTL -import Control.Exception (Exception) -import Control.Applicative -import Control.Concurrent -import Control.Monad -import Control.DeepSeq -import Data.Binary -import Data.Binary.Generic -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Monoid -import Data.Maybe -import Data.Typeable (Typeable) -import Data.IORef -import Data.Label.Derive -import Distribution.Helper hiding (Programs(..)) -import qualified Distribution.Helper as CabalHelper -import Exception (ExceptionMonad) -#if __GLASGOW_HASKELL__ < 708 -import qualified MonadUtils as GHC (MonadIO(..)) -#endif -import GHC (ModuleName, moduleNameString, mkModuleName) -import HscTypes (HscEnv) -import GHC.Generics -import Text.PrettyPrint (Doc) -import Prelude - -import Language.Haskell.GhcMod.Caching.Types - --- | A constraint alias (-XConstraintKinds) to make functions dealing with --- 'GhcModT' somewhat cleaner. --- --- Basicially an @IOish m => m@ is a 'Monad' supporting arbitrary 'IO' and --- exception handling. Usually this will simply be 'IO' but we parametrise it in --- the exported API so users have the option to use a custom inner monad. -type IOish m = (Functor m, MonadIO m, MonadBaseControl IO m, ExceptionMonad m) - - --- MonadUtils of GHC 7.6 or earlier defines its own MonadIO. --- MonadUtils of GHC 7.8 or later imports MonadIO in Monad.Control.IO.Class. -#if __GLASGOW_HASKELL__ < 708 -type MonadIOC m = (GHC.MonadIO m, MTL.MonadIO m) -#else -type MonadIOC m = (MTL.MonadIO m) -#endif - -class MonadIOC m => MonadIO m where - liftIO :: IO a -> m a - --- | Output style. -data OutputStyle = LispStyle -- ^ S expression style. - | PlainStyle -- ^ Plain textstyle. - deriving (Show) - --- | The type for line separator. Historically, a Null string is used. -newtype LineSeparator = LineSeparator String deriving (Show) - -data FileMapping = FileMapping {fmPath :: FilePath, fmTemp :: Bool} - deriving Show - -type FileMappingMap = Map FilePath FileMapping - -data ProgramSource = ProgramSourceUser | ProgramSourceStack - -data Programs = Programs { - -- | @ghc@ program name. - ghcProgram :: FilePath - -- | @ghc-pkg@ program name. - , ghcPkgProgram :: FilePath - -- | @cabal@ program name. - , cabalProgram :: FilePath - -- | @stack@ program name. - , stackProgram :: FilePath - } deriving (Show) - -data OutputOpts = OutputOpts { - -- | Verbosity - ooptLogLevel :: GmLogLevel - , ooptStyle :: OutputStyle - -- | Line separator string. - , ooptLineSeparator :: LineSeparator - -- | Stdout/err line multiplexing using prefix encoding. @fst@ is stdout, - -- @snd@ is stderr prefix. - , ooptLinePrefix :: Maybe (String, String) - } deriving (Show) - -data Options = Options { - optOutput :: OutputOpts - , optPrograms :: Programs - -- | GHC command line options set on the @ghc-mod@ command line - , optGhcUserOptions :: [GHCOption] - , optFileMappings :: [(FilePath, Maybe FilePath)] - } deriving (Show) - --- | A default 'Options'. -defaultOptions :: Options -defaultOptions = Options { - optOutput = OutputOpts { - ooptLogLevel = GmWarning - , ooptStyle = PlainStyle - , ooptLineSeparator = LineSeparator "\0" - , ooptLinePrefix = Nothing - } - , optPrograms = Programs { - ghcProgram = "ghc" - , ghcPkgProgram = "ghc-pkg" - , cabalProgram = "cabal" - , stackProgram = "stack" - } - , optGhcUserOptions = [] - , optFileMappings = [] - } - ----------------------------------------------------------------- - -data Project = CabalProject - | SandboxProject - | PlainProject - | StackProject StackEnv - deriving (Eq, Show) - -isCabalHelperProject :: Project -> Bool -isCabalHelperProject StackProject {} = True -isCabalHelperProject CabalProject {} = True -isCabalHelperProject _ = False - -data StackEnv = StackEnv { - seDistDir :: FilePath - , seBinPath :: [FilePath] - , seSnapshotPkgDb :: FilePath - , seLocalPkgDb :: FilePath - } deriving (Eq, Show) - --- | The environment where this library is used. -data Cradle = Cradle { - cradleProject :: Project - -- | The directory where this library is executed. - , cradleCurrentDir :: FilePath - -- | The project root directory. - , cradleRootDir :: FilePath - -- | Per-Project temporary directory - , cradleTempDir :: FilePath - -- | The file name of the found cabal file. - , cradleCabalFile :: Maybe FilePath - -- | The build info directory. - , cradleDistDir :: FilePath - } deriving (Eq, Show) - -data GmStream = GmOutStream | GmErrStream - deriving (Show) - -data GhcModEnv = GhcModEnv { - gmOptions :: Options - , gmCradle :: Cradle - } - -data GhcModOut = GhcModOut { - gmoOptions :: OutputOpts - , gmoChan :: Chan (Either (MVar ()) (GmStream, String)) - } - -data GhcModLog = GhcModLog { - gmLogLevel :: Maybe GmLogLevel, - gmLogVomitDump :: Last Bool, - gmLogMessages :: [(GmLogLevel, String, Doc)] - } deriving (Show) - -instance Monoid GhcModLog where - mempty = GhcModLog (Just GmPanic) (Last Nothing) mempty - GhcModLog ml vd ls `mappend` GhcModLog ml' vd' ls' = - GhcModLog (ml' `mplus` ml) (vd `mappend` vd') (ls `mappend` ls') - -data GmGhcSession = GmGhcSession { - gmgsOptions :: ![GHCOption], - gmgsSession :: !(IORef HscEnv) - } - -data GhcModCaches = GhcModCaches { - gmcPackageDbStack :: CacheContents ChCacheData [GhcPkgDb] - , gmcMergedPkgOptions :: CacheContents ChCacheData [GHCOption] - , gmcComponents :: CacheContents ChCacheData [GmComponent 'GMCRaw ChEntrypoint] - , gmcResolvedComponents :: CacheContents - [GmComponent 'GMCRaw (Set.Set ModulePath)] - (Map.Map ChComponentName (GmComponent 'GMCResolved (Set.Set ModulePath))) - } - -data GhcModState = GhcModState { - gmGhcSession :: !(Maybe GmGhcSession) - , gmCaches :: !GhcModCaches - , gmMMappedFiles :: !FileMappingMap - } - -defaultGhcModState :: GhcModState -defaultGhcModState = - GhcModState n (GhcModCaches n n n n) Map.empty - where n = Nothing - ----------------------------------------------------------------- - --- | GHC package database flags. -data GhcPkgDb = GlobalDb - | UserDb - | PackageDb String - deriving (Eq, Show, Generic) - -instance Binary GhcPkgDb where - put = ggput . from - get = to `fmap` ggget - --- | A single GHC command line option. -type GHCOption = String - --- | An include directory for modules. -type IncludeDir = FilePath - --- | Haskell expression. -newtype Expression = Expression { getExpression :: String } - deriving (Show, Eq, Ord) - --- | Module name. -newtype ModuleString = ModuleString { getModuleString :: String } - deriving (Show, Eq, Ord, Binary, NFData) - -data GmLogLevel = - GmSilent - | GmPanic - | GmException - | GmError - | GmWarning - | GmInfo - | GmDebug - | GmVomit - deriving (Eq, Ord, Enum, Bounded, Show, Read) - -data GmModuleGraph = GmModuleGraph { - gmgGraph :: Map ModulePath (Set ModulePath) - } deriving (Eq, Ord, Show, Read, Generic, Typeable) - -instance Binary GmModuleGraph where - put GmModuleGraph {..} = put (mpim, graph) - where - mpim :: Map ModulePath Integer - mpim = Map.fromList $ Map.keys gmgGraph `zip` [0..] - graph :: Map Integer (Set Integer) - graph = Map.map (Set.map mpToInt) $ Map.mapKeys mpToInt gmgGraph - mpToInt :: ModulePath -> Integer - mpToInt mp = fromJust $ Map.lookup mp mpim - - get = do - (mpim :: Map ModulePath Integer, graph :: Map Integer (Set Integer)) <- get - let impm = swapMap mpim - intToMp i = fromJust $ Map.lookup i impm - mpGraph :: Map ModulePath (Set ModulePath) - 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 = Map.fromList . map (\(x, y) -> (y, x)) . Map.toList - -instance Monoid GmModuleGraph where - mempty = GmModuleGraph mempty - mappend (GmModuleGraph a) (GmModuleGraph a') = - GmModuleGraph (Map.unionWith Set.union a a') - -data GmComponentType = GMCRaw - | GMCResolved -data GmComponent (t :: GmComponentType) eps = GmComponent { - gmcHomeModuleGraph :: GmModuleGraph - , gmcName :: ChComponentName - , gmcGhcOpts :: [GHCOption] - , gmcGhcPkgOpts :: [GHCOption] - , gmcGhcSrcOpts :: [GHCOption] - , gmcGhcLangOpts :: [GHCOption] - , gmcRawEntrypoints :: ChEntrypoint - , gmcEntrypoints :: eps - , gmcSourceDirs :: [FilePath] - } deriving (Eq, Ord, Show, Read, Generic, Functor) - -instance Binary eps => Binary (GmComponent t eps) where - put = ggput . from - get = to `fmap` ggget - -data ModulePath = ModulePath { mpModule :: ModuleName, mpPath :: FilePath } - deriving (Eq, Ord, Show, Read, Generic, Typeable) -instance Binary ModulePath where - put = ggput . from - get = to `fmap` ggget - -instance Binary ModuleName where - get = mkModuleName <$> get - put mn = put (moduleNameString mn) - -instance Show ModuleName where - show mn = "ModuleName " ++ show (moduleNameString mn) - -instance Read ModuleName where - readsPrec d = - readParen - (d > app_prec) - (\r' -> [ (mkModuleName m, t) - | ("ModuleName", s) <- lex r' - , (m, t) <- readsPrec (app_prec + 1) s - ]) - where - app_prec = 10 - -data GhcModError - = GMENoMsg - -- ^ Unknown error - - | GMEString String - -- ^ Some Error with a message. These are produced mostly by - -- 'fail' calls on GhcModT. - - | GMECabalConfigure GhcModError - -- ^ Configuring a cabal project failed. - - | GMEStackConfigure GhcModError - -- ^ Configuring a stack project failed. - - | GMEStackBootstrap GhcModError - -- ^ Bootstrapping @stack@ environment failed (process exited with failure) - - | GMECabalCompAssignment [(Either FilePath ModuleName, Set ChComponentName)] - -- ^ Could not find a consistent component assignment for modules - - | GMEProcess String String [String] (Either Int GhcModError) - -- ^ Launching an operating system process failed. Fields in - -- order: function, command, arguments, (stdout, stderr, exitcode) - - | GMENoCabalFile - -- ^ No cabal file found. - - | GMETooManyCabalFiles [FilePath] - -- ^ Too many cabal files found. - - deriving (Eq,Show,Typeable) - -instance Error GhcModError where - noMsg = GMENoMsg - strMsg = GMEString - -instance Exception GhcModError - -instance Binary CabalHelper.Programs where - put = ggput . from - get = to `fmap` ggget -instance Binary ChModuleName where - put = ggput . from - get = to `fmap` ggget -instance Binary ChComponentName where - put = ggput . from - get = to `fmap` ggget -instance Binary ChEntrypoint where - put = ggput . from - get = to `fmap` ggget - --- | Options for "lintWith" function -data LintOpts = LintOpts { - optLintHlintOpts :: [String] - -- ^ options that will be passed to hlint executable - } deriving (Show) - --- | Default "LintOpts" instance -defaultLintOpts :: LintOpts -defaultLintOpts = LintOpts [] - --- | Options for "browseWith" function -data BrowseOpts = BrowseOpts { - optBrowseOperators :: Bool - -- ^ If 'True', "browseWith" also returns operators. - , optBrowseDetailed :: Bool - -- ^ If 'True', "browseWith" also returns types. - , optBrowseQualified :: Bool - -- ^ If 'True', "browseWith" will return fully qualified name - } deriving (Show) - --- | Default "BrowseOpts" instance -defaultBrowseOpts :: BrowseOpts -defaultBrowseOpts = BrowseOpts False False False - -mkLabel ''GhcModCaches -mkLabel ''GhcModState -mkLabel ''Options -mkLabel ''OutputOpts -mkLabel ''Programs diff --git a/Language/Haskell/GhcMod/Utils.hs b/Language/Haskell/GhcMod/Utils.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Utils.hs +++ /dev/null @@ -1,220 +0,0 @@ --- ghc-mod: Making Haskell development *more* fun --- Copyright (C) 2015 Daniel Gröber --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU Affero General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU Affero General Public License for more details. --- --- You should have received a copy of the GNU Affero General Public License --- along with this program. If not, see . - -{-# LANGUAGE CPP #-} -{-# LANGUAGE DoAndIfThenElse #-} - -module Language.Haskell.GhcMod.Utils ( - module Language.Haskell.GhcMod.Utils - , module Utils - , readProcess - ) where - -import Control.Applicative -import Data.Char -import qualified Data.Map as M -import Data.Maybe (fromMaybe) -import Data.Either (rights) -import Data.List (inits) -import Exception -import Language.Haskell.GhcMod.Error -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Monad.Types -import System.Directory -import System.Environment -import System.FilePath -import System.IO.Temp (createTempDirectory) -import System.Process (readProcess) -import Text.Printf - -import Paths_ghc_mod (getLibexecDir) -import Utils -import Prelude - --- dropWhileEnd is not provided prior to base 4.5.0.0. -dropWhileEnd :: (a -> Bool) -> [a] -> [a] -dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) [] - -withDirectory_ :: (MonadIO m, ExceptionMonad m) => FilePath -> m a -> m a -withDirectory_ dir action = - gbracket - (liftIO getCurrentDirectory) - (liftIO . setCurrentDirectory) - (\_ -> liftIO (setCurrentDirectory dir) >> action) - -uniqTempDirName :: FilePath -> FilePath -uniqTempDirName dir = - "ghc-mod" ++ map escapeDriveChar drive ++ map escapePathChar path - where - (drive, path) = splitDrive dir - escapeDriveChar :: Char -> Char - escapeDriveChar c - | isAlphaNum c = c - | otherwise = '-' - escapePathChar :: Char -> Char - escapePathChar c - | c `elem` pathSeparators = '-' - | otherwise = c - -newTempDir :: FilePath -> IO FilePath -newTempDir _dir = - flip createTempDirectory "ghc-mod" =<< getTemporaryDirectory - -whenM :: Monad m => m Bool -> m () -> m () -whenM mb ma = mb >>= flip when ma - --- | Returns the path to the currently running ghc-mod executable. With ghc<7.6 --- this is a guess but >=7.6 uses 'getExecutablePath'. -ghcModExecutable :: IO FilePath -#ifndef SPEC -ghcModExecutable = do - dir <- takeDirectory <$> getExecutablePath' - return $ (if dir == "." then "" else dir) "ghc-mod" -#else -ghcModExecutable = fmap ( "dist/build/ghc-mod/ghc-mod") getCurrentDirectory -#endif - -findLibexecExe :: String -> IO FilePath -findLibexecExe "cabal-helper-wrapper" = do - libexecdir <- getLibexecDir - let exeName = "cabal-helper-wrapper" - exe = libexecdir exeName - - exists <- doesFileExist exe - - if exists - then return exe - else do - mdir <- tryFindGhcModTreeDataDir - case mdir of - Nothing -> - error $ libexecNotExitsError exeName libexecdir - Just dir -> - return $ dir "dist" "build" exeName exeName -findLibexecExe exe = error $ "findLibexecExe: Unknown executable: " ++ exe - -libexecNotExitsError :: String -> FilePath -> String -libexecNotExitsError exe dir = printf - ( "Could not find $libexecdir/%s\n" - ++"\n" - ++"If you are a developer set the environment variable `ghc_mod_libexecdir'\n" - ++"to override $libexecdir[1] the following will work in the ghc-mod tree:\n" - ++"\n" - ++" $ export ghc_mod_libexecdir=$PWD/dist/build/%s\n" - ++"\n" - ++"[1]: %s\n" - ++"\n" - ++"If you don't know what I'm talking about something went wrong with your\n" - ++"installation. Please report this problem here:\n" - ++"\n" - ++" https://github.com/kazu-yamamoto/ghc-mod/issues") exe exe dir - -tryFindGhcModTreeLibexecDir :: IO (Maybe FilePath) -tryFindGhcModTreeLibexecDir = do - exe <- getExecutablePath' - dir <- case takeFileName exe of - "ghc" -> getCurrentDirectory -- we're probably in ghci; try CWD - _ -> return $ (!!4) $ iterate takeDirectory exe - exists <- doesFileExist $ dir "ghc-mod.cabal" - return $ if exists - then Just dir - else Nothing - -tryFindGhcModTreeDataDir :: IO (Maybe FilePath) -tryFindGhcModTreeDataDir = do - dir <- (!!4) . iterate takeDirectory <$> getExecutablePath' - exists <- doesFileExist $ dir "ghc-mod.cabal" - return $ if exists - then Just dir - else Nothing - -readLibExecProcess' :: (MonadIO m, ExceptionMonad m) - => String -> [String] -> m String -readLibExecProcess' cmd args = do - exe <- liftIO $ findLibexecExe cmd - liftIO $ readProcess exe args "" - -getExecutablePath' :: IO FilePath -#if __GLASGOW_HASKELL__ >= 706 -getExecutablePath' = getExecutablePath -#else -getExecutablePath' = getProgName -#endif - -canonFilePath :: FilePath -> IO FilePath -canonFilePath f = do - p <- canonicalizePath f - e <- doesFileExist p - when (not e) $ error $ "canonFilePath: not a file: " ++ p - return p - -withMappedFile :: (IOish m, GmState m, GmEnv m) => - forall a. FilePath -> (FilePath -> m a) -> m a -withMappedFile file action = getCanonicalFileNameSafe file >>= lookupMMappedFile >>= runWithFile - where - runWithFile (Just to) = action $ fmPath to - runWithFile _ = action file - -getCanonicalFileNameSafe :: (IOish m, GmEnv m) => FilePath -> m FilePath -getCanonicalFileNameSafe fn = do - let fn' = normalise fn - pl <- liftIO $ rights <$> (mapM ((try :: IO FilePath -> IO (Either SomeException FilePath)) . canonicalizePath . joinPath) $ reverse $ inits $ splitPath' fn') - return $ - if (length pl > 0) - then joinPath $ (head pl):(drop (length pl - 1) (splitPath fn')) - else error "Current dir doesn't seem to exist?" - where -#if __GLASGOW_HASKELL__ < 710 - splitPath' = (".":) . splitPath -#else - splitPath' = splitPath -#endif - -mkRevRedirMapFunc :: (Functor m, GmState m, GmEnv m) => m (FilePath -> FilePath) -mkRevRedirMapFunc = do - rm <- M.fromList <$> map (uncurry mf) <$> M.toList <$> getMMappedFiles - crdl <- cradle - return $ \key -> - fromMaybe key - $ makeRelative (cradleRootDir crdl) - <$> M.lookup key rm - where - mf :: FilePath -> FileMapping -> (FilePath, FilePath) - mf from to = (fmPath to, from) - -findFilesWith' :: (FilePath -> IO Bool) -> [FilePath] -> String -> IO [FilePath] -findFilesWith' _ [] _ = return [] -findFilesWith' f (d:ds) fileName = do - let file = d fileName - exist <- doesFileExist file - b <- if exist then f file else return False - if b then do - files <- findFilesWith' f ds fileName - return $ file : files - else findFilesWith' f ds fileName - - --- Copyright : (c) The University of Glasgow 2001 --- | Make a path absolute by prepending the current directory (if it isn't --- already absolute) and applying 'normalise' to the result. --- --- If the path is already absolute, the operation never fails. Otherwise, the --- operation may fail with the same exceptions as 'getCurrentDirectory'. -makeAbsolute' :: FilePath -> IO FilePath -makeAbsolute' = (normalise <$>) . absolutize - where absolutize path -- avoid the call to `getCurrentDirectory` if we can - | isRelative path = ( path) <$> getCurrentDirectory - | otherwise = return path diff --git a/Language/Haskell/GhcMod/World.hs b/Language/Haskell/GhcMod/World.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/World.hs +++ /dev/null @@ -1,55 +0,0 @@ -module Language.Haskell.GhcMod.World where - -import Language.Haskell.GhcMod.GhcPkg -import Language.Haskell.GhcMod.PathsAndFiles -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Monad.Types -import Language.Haskell.GhcMod.Utils - -import Control.Applicative -import Data.Maybe -import Data.Traversable hiding (mapM) -import System.FilePath (()) - -import GHC.Paths (libdir) -import Prelude - -data World = World { - worldPackageCaches :: [TimedFile] - , worldCabalFile :: Maybe TimedFile - , worldCabalConfig :: Maybe TimedFile - , worldCabalSandboxConfig :: Maybe TimedFile - , worldSymbolCache :: Maybe TimedFile - } deriving (Eq) - -timedPackageCaches :: IOish m => GhcModT m [TimedFile] -timedPackageCaches = do - fs <- mapM (liftIO . mightExist) . map ( packageCache) - =<< getPackageCachePaths libdir - (liftIO . timeFile) `mapM` catMaybes fs - -getCurrentWorld :: IOish m => GhcModT m World -getCurrentWorld = do - crdl <- cradle - pkgCaches <- timedPackageCaches - mCabalFile <- liftIO $ timeFile `traverse` cradleCabalFile crdl - mCabalConfig <- liftIO $ timeMaybe (setupConfigFile crdl) - mCabalSandboxConfig <- liftIO $ timeMaybe (sandboxConfigFile crdl) - mSymbolCache <- liftIO $ timeMaybe (symbolCache crdl) - - return World { - worldPackageCaches = pkgCaches - , worldCabalFile = mCabalFile - , worldCabalConfig = mCabalConfig - , worldCabalSandboxConfig = mCabalSandboxConfig - , worldSymbolCache = mSymbolCache - } - -didWorldChange :: IOish m => World -> GhcModT m Bool -didWorldChange world = do - (world /=) <$> getCurrentWorld - -isYoungerThanSetupConfig :: FilePath -> World -> IO Bool -isYoungerThanSetupConfig file World {..} = do - tfile <- timeFile file - return $ worldCabalConfig < Just tfile diff --git a/NotCPP/COPYING b/NotCPP/COPYING deleted file mode 100644 --- a/NotCPP/COPYING +++ /dev/null @@ -1,30 +0,0 @@ -Copyright Ben Millwood 2012 - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Ben Millwood nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/NotCPP/Declarations.hs b/NotCPP/Declarations.hs deleted file mode 100644 --- a/NotCPP/Declarations.hs +++ /dev/null @@ -1,164 +0,0 @@ --- ghc-mod: Making Haskell development *more* fun --- Copyright (C) 2015 Daniel Gröber --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU Affero General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU Affero General Public License for more details. --- --- You should have received a copy of the GNU Affero General Public License --- along with this program. If not, see . - -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -{-# LANGUAGE CPP #-} --- Using CPP so you don't have to :) -module NotCPP.Declarations where - -import Control.Arrow -import Control.Applicative -import Data.Maybe -import Language.Haskell.TH.Syntax - -import NotCPP.LookupValueName - -nT :: Monad m => String -> m Type -cT :: Monad m => String -> m Type -nE :: Monad m => String -> m Exp -nP :: Monad m => String -> m Pat - -nT str = return $ VarT (mkName str) -cT str = return $ ConT (mkName str) -nE str = return $ VarE (mkName str) -nP str = return $ VarP (mkName str) -recUpdE' :: Q Exp -> Name -> Exp -> Q Exp -recUpdE' ex name assign = do - RecUpdE <$> ex <*> pure [(name, assign)] - -lookupName' :: (NameSpace, String) -> Q (Maybe Name) -lookupName' (VarName, n) = lookupValueName n -lookupName' (DataName, n) = lookupValueName n -lookupName' (TcClsName, n) = lookupTypeName n - --- Does this even make sense? -ifelseD :: Q [Dec] -> Q [Dec] -> Q [Dec] -ifelseD if_decls' else_decls = do - if_decls <- if_decls' - alreadyDefined <- definedNames (boundNames `concatMap` if_decls) - case alreadyDefined of - [] -> if_decls' - _ -> else_decls - -ifdefelseD, ifelsedefD :: String -> Q [Dec] -> Q [Dec] -> Q [Dec] -ifelsedefD = ifdefelseD -ifdefelseD ident if_decls else_decls = do - exists <- isJust <$> lookupValueName ident - if exists - then if_decls - else else_decls - -ifdefD :: String -> Q [Dec] -> Q [Dec] -ifdefD ident decls = ifdefelseD ident decls (return []) - -ifndefD :: String -> Q [Dec] -> Q [Dec] -ifndefD ident decls = ifdefelseD ident (return []) decls - --- | Each of the given declarations is only spliced if the identifier it defines --- is not defined yet. --- --- For example: --- --- @$(ifD [[d| someFunctionThatShouldExist x = x+1 |]]@ --- --- If @someFunctionThatShouldExist@ doesn't actually exist the definition given --- in the splice will be the result of the splice otherwise nothing will be --- spliced. --- --- Currently this only works for function declarations but it can be easily --- extended to other kinds of declarations. -ifD :: Q [Dec] -> Q [Dec] -ifD decls' = do - decls <- decls' - concat <$> flip mapM decls (\decl -> do - alreadyDefined <- definedNames (boundNames decl) - case alreadyDefined of - [] -> return [decl] - _ -> return []) - -definedNames :: [(NameSpace, Name)] -> Q [Name] -definedNames ns = catMaybes <$> (lookupName' . second nameBase) `mapM` ns - -boundNames :: Dec -> [(NameSpace, Name)] -boundNames decl = - case decl of - SigD n _ -> [(VarName, n)] - FunD n _cls -> [(VarName, n)] -#if __GLASGOW_HASKELL__ >= 706 - InfixD _ n -> [(VarName, n)] -#endif - ValD p _ _ -> map ((,) VarName) $ patNames p - - TySynD n _ _ -> [(TcClsName, n)] - ClassD _ n _ _ _ -> [(TcClsName, n)] - FamilyD _ n _ _ -> [(TcClsName, n)] - - DataD _ n _ ctors _ -> - [(TcClsName, n)] ++ map ((,) TcClsName) (conNames `concatMap` ctors) - - NewtypeD _ n _ ctor _ -> - [(TcClsName, n)] ++ map ((,) TcClsName) (conNames ctor) - - DataInstD _ _n _ ctors _ -> - map ((,) TcClsName) (conNames `concatMap` ctors) - - NewtypeInstD _ _n _ ctor _ -> - map ((,) TcClsName) (conNames ctor) - - InstanceD _ _ty _ -> - error "notcpp: Instance declarations are not supported yet" - ForeignD _ -> - error "notcpp: Foreign declarations are not supported yet" - PragmaD _pragma -> error "notcpp: pragmas are not supported yet" - -#if __GLASGOW_HASKELL__ >= 708 - TySynInstD _n _ -> error "notcpp: TySynInstD not supported yet" -#else - TySynInstD _n _ _ -> error "notcpp: TySynInstD not supported yet" -#endif - -#if __GLASGOW_HASKELL__ >= 708 - ClosedTypeFamilyD n _ _ _ -> [(TcClsName, n)] - RoleAnnotD _n _ -> error "notcpp: RoleAnnotD not supported yet" -#endif - -conNames :: Con -> [Name] -conNames con = - case con of - NormalC n _ -> [n] - RecC n _ -> [n] - InfixC _ n _ -> [n] - ForallC _ _ c -> conNames c - -patNames :: Pat -> [Name] -patNames p'' = - case p'' of - LitP _ -> [] - VarP n -> [n] - TupP ps -> patNames `concatMap` ps - UnboxedTupP ps -> patNames `concatMap` ps - ConP _ ps -> patNames `concatMap` ps - InfixP p _ p' -> patNames `concatMap` [p,p'] - UInfixP p _ p' -> patNames `concatMap` [p,p'] - ParensP p -> patNames p - TildeP p -> patNames p - BangP p -> patNames p - AsP n p -> n:(patNames p) - WildP -> [] - RecP _ fps -> patNames `concatMap` map snd fps - ListP ps -> patNames `concatMap` ps - SigP p _ -> patNames p - ViewP _ p -> patNames p diff --git a/NotCPP/LookupValueName.hs b/NotCPP/LookupValueName.hs deleted file mode 100644 --- a/NotCPP/LookupValueName.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} --- | This module uses scope lookup techniques to either export --- 'lookupValueName' from @Language.Haskell.TH@, or define --- its own 'lookupValueName', which attempts to do the --- same job with just 'reify'. This will sometimes fail, but if it --- succeeds it will give the answer that the real function would have --- given. --- --- The idea is that if you use lookupValueName from this module, --- your client code will automatically use the best available name --- lookup mechanism. This means that e.g. 'scopeLookup' can work --- very well on recent GHCs and less well but still somewhat --- usefully on older GHCs. -module NotCPP.LookupValueName ( - lookupValueName - ) where - -import Language.Haskell.TH - -import NotCPP.Utils - -bestValueGuess :: String -> Q (Maybe Name) -bestValueGuess s = do - mi <- maybeReify (mkName s) - case mi of - Nothing -> no - Just i -> case i of - VarI n _ _ _ -> yes n - DataConI n _ _ _ -> yes n - _ -> err ["unexpected info:", show i] - where - no = return Nothing - yes = return . Just - err = fail . showString "NotCPP.bestValueGuess: " . unwords - -$(recover [d| lookupValueName = bestValueGuess |] $ do - VarI _ _ _ _ <- reify (mkName "lookupValueName") - return []) diff --git a/NotCPP/OrphanEvasion.hs b/NotCPP/OrphanEvasion.hs deleted file mode 100644 --- a/NotCPP/OrphanEvasion.hs +++ /dev/null @@ -1,114 +0,0 @@ -{-# LANGUAGE EmptyDataDecls, TemplateHaskell #-} --- | --- The orphan instance problem is well-known in Haskell. This module --- by no means purports to solve the problem, but provides a workaround --- that may be significantly less awful than the status quo in some --- cases. --- --- Say I think that the 'Name' type should have an 'IsString' instance. --- But I don't control either the class or the type, so if I define the --- instance, and then the template-haskell package defines one, my code --- is going to break. --- --- 'safeInstance' can help me to solve this problem: --- --- > safeInstance ''IsString [t| Name |] [d| --- > fromString = mkName |] --- --- This will declare an instance only if one doesn't already exist. --- Now anyone importing your module is guaranteed to get an instance --- one way or the other. --- --- This module is still highly experimental. The example given above --- does work, but anything involving type variables or complex method --- bodies may be less fortunate. The names of the methods are mangled --- a bit, so using recursion to define them may not work. Define the --- method outside the code and then use a simple binding as above. --- --- If you use this code (successfully or unsuccessfully!), go fetch --- the maintainer address from the cabal file and let me know! -module NotCPP.OrphanEvasion ( - MultiParams, - safeInstance, - safeInstance', - ) where - -import Control.Applicative - -import Language.Haskell.TH -import Language.Haskell.TH.Syntax - -import NotCPP.ScopeLookup - --- | An empty type used only to signify a multiparameter typeclass in --- 'safeInstance'. -data MultiParams a - --- | Given @(forall ts. Cxt => t)@, return @(Cxt, [t])@. --- Given @(forall ts. Cxt => 'MultiParams' (t1, t2, t3))@, return --- @(Cxt, [t1, t2, t3])@. --- --- This is used in 'safeInstance' to allow types to be specified more --- easily with TH typequotes. -fromTuple :: Type -> (Cxt, [Type]) -fromTuple ty = unTuple <$> case ty of - ForallT _ cxt ty' -> (cxt, ty') - _ -> ([], ty) - where - unTuple :: Type -> [Type] - unTuple (AppT (ConT n) ta) - | n == ''MultiParams = case unrollAppT ta of - (TupleT{}, ts) -> ts - _ -> [ty] - unTuple t = [t] - --- | A helper function to unwind type application. --- Given @TyCon t1 t2 t3@, returns @(TyCon, [t1,t2,t3])@ -unrollAppT :: Type -> (Type, [Type]) -unrollAppT = go [] - where - go acc (AppT tc ta) = go (ta : acc) tc - go acc ty = (ty, reverse acc) - --- | Left inverse to unrollAppT, equal to @'foldl' 'AppT'@ -rollAppT :: Type -> [Type] -> Type -rollAppT = foldl AppT - --- | @'safeInstance'' className cxt types methods@ produces an instance --- of the given class if and only if one doesn't already exist. --- --- See 'safeInstance' for a simple way to construct the 'Cxt' and --- @['Type']@ parameters. -safeInstance' :: Name -> Cxt -> [Type] -> Q [Dec] -> Q [Dec] -safeInstance' cl cxt tys inst = do - b <- $(scopeLookups ["isInstance", "isClassInstance"]) cl tys - if b - then return [] - else do - ds <- map fixInst <$> inst - return [InstanceD cxt (rollAppT (ConT cl) tys) ds] - where - fixInst (FunD n cls) = FunD (fixName n) cls - fixInst (ValD (VarP n) rhs wh) = ValD (VarP (fixName n)) rhs wh - fixInst d = d - fixName (Name n _) = Name n NameS - --- | 'safeInstance' is a more convenient version of 'safeInstance'' --- that takes the context and type from a @'Q' 'Type'@ with the intention --- that it be supplied using a type-quote. --- --- To define an instance @Show a => Show (Wrapper a)@, you'd use: --- --- > safeInstance ''Show [t| Show a => Wrapper a |] --- > [d| show _ = "stuff" |] --- --- To define an instance of a multi-param type class, use the --- 'MultiParams' type constructor with a tuple: --- --- > safeInstance ''MonadState --- > [t| MonadState s m => MultiParams (s, MaybeT m) |] --- > [d| put = ... |] -safeInstance :: Name -> Q Type -> Q [Dec] -> Q [Dec] -safeInstance n qty inst = do - (cxt, tys) <- fromTuple <$> qty - safeInstance' n cxt tys inst diff --git a/NotCPP/ScopeLookup.hs b/NotCPP/ScopeLookup.hs deleted file mode 100644 --- a/NotCPP/ScopeLookup.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} --- | --- This module exports 'scopeLookup', which will find a variable or --- value constructor for you and present it for your use. E.g. at some --- point in the history of the acid-state package, 'openAcidState' was --- renamed 'openLocalState'; for compatibility with both, you could --- use: --- --- > openState :: IO (AcidState st) --- > openState = case $(scopeLookup "openLocalState") of --- > Just open -> open defaultState --- > Nothing -> case $(scopeLookup "openAcidState") of --- > Just open -> open defaultState --- > Nothing -> error --- > "openState: runtime name resolution has its drawbacks :/" --- --- Or, for this specific case, you can use 'scopeLookups': --- --- > openState :: IO (AcidState st) --- > openState = open defaultState --- > where --- > open = $(scopeLookups ["openLocalState","openAcidState"]) --- --- Now if neither of the names are found then TH will throw a --- compile-time error. -module NotCPP.ScopeLookup ( - scopeLookup, - scopeLookups, - scopeLookup', - liftMaybe, - recoverMaybe, - maybeReify, - infoToExp, - ) where - -import Control.Applicative ((<$>)) - -import Language.Haskell.TH (Q, Exp, recover, reify) - -import NotCPP.LookupValueName -import NotCPP.Utils - --- | Produces a spliceable expression which expands to @'Just' val@ if --- the given string refers to a value @val@ in scope, or 'Nothing' --- otherwise. --- --- @scopeLookup = 'fmap' 'liftMaybe' . 'scopeLookup''@ -scopeLookup :: String -> Q Exp -scopeLookup = fmap liftMaybe . scopeLookup' - --- | Finds the first string in the list that names a value, and produces --- a spliceable expression of that value, or reports a compile error if --- it fails. -scopeLookups :: [String] -> Q Exp -scopeLookups xs = foldr - (\s r -> maybe r return =<< scopeLookup' s) - (fail ("scopeLookups: none found: " ++ show xs)) - xs - --- | Produces @'Just' x@ if the given string names the value @x@, --- or 'Nothing' otherwise. -scopeLookup' :: String -> Q (Maybe Exp) -scopeLookup' s = recover (return Nothing) $ do - Just n <- lookupValueName s - infoToExp <$> reify n diff --git a/NotCPP/Utils.hs b/NotCPP/Utils.hs deleted file mode 100644 --- a/NotCPP/Utils.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module NotCPP.Utils where - -import Control.Applicative ((<$>)) -import Language.Haskell.TH - --- | Turns 'Nothing' into an expression representing 'Nothing', and --- @'Just' x@ into an expression representing 'Just' applied to the --- expression in @x@. -liftMaybe :: Maybe Exp -> Exp -liftMaybe = maybe (ConE 'Nothing) (AppE (ConE 'Just)) - --- | A useful variant of 'reify' that returns 'Nothing' instead of --- halting compilation when an error occurs (e.g. because the given --- name was not in scope). -maybeReify :: Name -> Q (Maybe Info) -maybeReify = recoverMaybe . reify - --- | Turns a possibly-failing 'Q' action into one returning a 'Maybe' --- value. -recoverMaybe :: Q a -> Q (Maybe a) -recoverMaybe q = recover (return Nothing) (Just <$> q) - --- | Returns @'Just' ('VarE' n)@ if the info relates to a value called --- @n@, or 'Nothing' if it relates to a different sort of thing. -infoToExp :: Info -> Maybe Exp -infoToExp (VarI n _ _ _) = Just (VarE n) -infoToExp (DataConI n _ _ _) = Just (ConE n) -infoToExp _ = Nothing diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,99 @@ +# ghc-mod: Happy Haskell Hacking +[![build status](https://gitlab.com/dxld/ghc-mod/badges/master/build.svg)](https://gitlab.com/dxld/ghc-mod/commits/master) + +ghc-mod provides editors/IDEs with support for Haskell compiler features, it +supports both Cabal and Stack based projects and integrations exist for Emacs, +Vim, Atom, IntelliJ and VSCode. + +- for [all Haskell developers (Using ghc-mod in your development environment)](#using-ghc-mod-in-your-development-environment) +- for [people developing Haskell IDEs (Using ghc-mod as an IDE backend program)](#using-ghc-mod-as-an-ide-backend-program) +- for [developing Haskell tooling (Using ghc-mod as a library)](#using-ghc-mod-as-a-library) + +## Overview + +### Using ghc-mod in your Development Environment + +To use `ghc-mod` in your development environment of choice you need two things: + + - The `ghc-mod` program included in the package of the same name, see [Installing](https://github.com/DanielG/ghc-mod/wiki/Installing) + - A ghc-mod frontend to integrate it into your development environment, see [Frontend](https://github.com/DanielG/ghc-mod/wiki/Frontend) + +### Using ghc-mod as an IDE Backend Program + +We provide two modes of operation for frontends: interactive and single shot +mode. The former is accessed by calling `$ ghc-mod legacy-interactive` this will +sit and wait for you to type a command and exit when an empty line is +entered. Interactive mode is pretty much always faster than single shot mode +since it gives ghc-mod the ability to cache the compiler session between +commands on the other hand it needs more memory because it keeps these things +cached. + +Single shot mode is pretty much only there for (backwards) compatibility with +Vim since it only recently got the ability to talk to background processes +without installing some external plugin. You can use single-shot mode by simply +calling the sub-comamnds of the `ghc-mod` program. Since re-compiling large +projects can be really, really slow you really shouldn't use this and use +interactive mode instead. + +As a rule of thumb all commands available in single shot mode are available in +interactive mode, a list of the former can be obtained by running +`$ ghc-mod --help`. + +If you're developing a new ghc-mod fronted we'd love to hear from you! Please +open an issue or e-mail the maintainer. Also we invite you to add installation +and configuration instructions to +[Frontend](https://github.com/DanielG/ghc-mod/wiki/Frontend). + +### Using ghc-mod as a Library + +Internally ghc-mod uses the Glasgow Haskell Compilers's API to implement most of +it's functionality. + +In order to provide a hassle free experience to users ghc-mod tries hard to +automatically, and correctly, detect and if needed tweak the environment GHC +needs. It also handles some of the more cumbersome parts of getting a working +compiler session up and running. + +This functionality can be very useful to all kinds of Haskell development tools +therefore want to expose all the useful abstractions ghc-mod provides. + +Right now the ghc-mod API is pretty messy; a result of major internal rewrites +and reorganization coupled with too little time for cleanups over the course of +almost 100 releases! We would like to make a cut during v6.0 or so and +completely re-do the API but we need more input from downstream tool writers to +do that properly, see [Library API Redesign](Library-API-Redesign.md). + +For example [The Haskell Refactorer (HaRe)](https://github.com/alanz/HaRe) uses +the build environment abstraction ghc-mod provides so it can concentrate on it's +core functionality instead of worrying about build environments and compiler +session setup. + +Recently the +[`haskell-ide-engine`](https://github.com/haskell/haskell-ide-engine) project +has sprung up and if you're planning to write any kind of tool that needs editor +integration eventually you should definetly look into that. `haskell-ide-engine` +uses `ghc-mod` at it's core so you'll want to be familliar with it either way. + +API "documentation" is here: +[Hackage docs](https://hackage.haskell.org/package/ghc-mod#modules). + +## Reporting Bugs + +Please report bugs on the GitHub issue tracker for ghc-mod: +https://github.com/DanielG/ghc-mod/issues + +Including general environment information like the operating system +(distribution, version) you're using and the output of `$ ghc-mod debug` run in +your project directory is probably a good idea. + +## IRC + +If you have any problems, suggestions, comments swing by +[\#ghc-mod (web client)](https://kiwiirc.com/client/irc.freenode.org/ghc-mod) on +Freenode. If you're reporting a bug please also create an issue +[here (GitHub issue tracker)](https://github.com/DanielG/ghc-mod/issues) so we +have a way to contact you if you don't have time to stay. + +Do hang around for a while if no one answers and repeat your question if you +still haven't gotten any answer after a day or so (the maintainer was probably +asleep). You're most likely to get an answer during the day in GMT+1. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,13 +1,19 @@ #!/usr/bin/env runhaskell -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} import Distribution.Simple +import Distribution.Simple.Utils import Distribution.Simple.Setup import Distribution.Simple.Install +import Distribution.Simple.Program import Distribution.Simple.Register -import Distribution.Simple.InstallDirs as ID +import Distribution.Simple.BuildPaths +import qualified Distribution.Simple.InstallDirs as ID import Distribution.Simple.LocalBuildInfo import Distribution.PackageDescription +import qualified Data.Map as M +import Data.Map (Map) + import Control.Arrow import Control.Applicative import Control.Monad @@ -18,46 +24,23 @@ import System.Process import System.Exit import System.FilePath -import Text.ParserCombinators.ReadP - -import SetupCompat +import System.Directory (renameFile) main :: IO () main = defaultMainWithHooks $ simpleUserHooks { - confHook = \(gpd, hbi) cf -> - xBuildDependsLike <$> (confHook simpleUserHooks) (gpd, hbi) cf - - , instHook = inst - , copyHook = copy - --- , postConf = sanityCheckCabalVersions + instHook = inst, + copyHook = copy, + buildHook = \pd lbi hooks flags -> (buildHook simpleUserHooks) pd (patchLibexecdir lbi) hooks flags, + hookedPrograms = [ simpleProgram "shelltest" ] } -xBuildDependsLike :: LocalBuildInfo -> LocalBuildInfo -xBuildDependsLike lbi = - let - cc = componentsConfigs lbi - pd = localPkgDescr lbi - deps = dependsMap lbi - in setComponentsConfigs lbi - [ (cn, updateClbi deps comp clbi, cdeps) - | (cn, clbi, cdeps) <- cc - , let comp = getComponent pd cn - ] - - where - updateClbi deps comp clbi = setUnionDeps (otherDeps deps comp) clbi - - dependsMap :: - LocalBuildInfo -> [(ComponentName, Deps)] - dependsMap lbi = - second getDeps <$> allComponentsInBuildOrder lbi - - otherDeps :: [(ComponentName, Deps)] -> Component -> Deps - otherDeps deps comp = fromMaybe noDeps $ - flip lookup deps =<< read <$> lookup "x-build-depends-like" fields - where - fields = customFieldsBI (componentBuildInfo comp) +patchLibexecdir :: LocalBuildInfo -> LocalBuildInfo +patchLibexecdir lbi = let + idirtpl = installDirTemplates lbi + libexecdir' = toPathTemplate $ fromPathTemplate (libexecdir idirtpl) "$abi/$pkgid" + lbi' = lbi { installDirTemplates = idirtpl { libexecdir = libexecdir' } } + in + lbi' -- mostly copypasta from 'defaultInstallHook' inst :: @@ -68,7 +51,7 @@ copyDest = toFlag NoCopyDest, copyVerbosity = installVerbosity ifl } - xInstallTarget pd lbi (\pd' lbi' -> install pd' lbi' copyFlags) + xInstallTarget pd lbi copyFlags (\pd' lbi' -> install pd' lbi' copyFlags) let registerFlags = defaultRegisterFlags { regDistPref = installDistPref ifl, regInPlace = installInPlace ifl, @@ -79,124 +62,46 @@ copy :: PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO () copy pd lbi _uh cf = - xInstallTarget pd lbi (\pd' lbi' -> install pd' lbi' cf) + xInstallTarget pd lbi cf (\pd' lbi' -> install pd' lbi' cf) xInstallTarget :: PackageDescription -> LocalBuildInfo + -> CopyFlags -> (PackageDescription -> LocalBuildInfo -> IO ()) -> IO () -xInstallTarget pd lbi fn = do - let (extended, regular) = partition (isJust . installTarget) (executables pd) +xInstallTarget pd lbi cf fn = do + let (extended, regular) = partition isInternal (executables pd) let pd_regular = pd { executables = regular } _ <- flip mapM extended $ \exe -> do - putStrLn $ "extended " ++ show (exeName exe) + let pd_extended = onlyExePackageDesc [exe] pd + fn pd_extended lbi - let - idirtpl = installDirTemplates lbi - env = installDirsTemplateEnv idirtpl - libexecdir' = fromPathTemplate (libexecdir idirtpl) + let lbi' = patchLibexecdir lbi + copydest = fromFlag (copyDest cf) + verbosity = fromFlag (copyVerbosity cf) + InstallDirs { bindir, libexecdir } = absoluteInstallDirs pd lbi' copydest + progprefix = substPathTemplate (packageId pd) lbi (progPrefix lbi) + progsuffix = substPathTemplate (packageId pd) lbi (progSuffix lbi) + fixedExeBaseName = progprefix ++ exeName exe ++ progsuffix - pd_extended = onlyExePackageDesc [exe] pd - install_target = fromJustNote "xInstallTarget" $ installTarget exe - install_target' = ID.substPathTemplate env install_target - -- $libexec isn't a real thing :/ so we have to simulate it - install_target'' = substLibExec' libexecdir' install_target' + fixedExeFileName = bindir fixedExeBaseName <.> exeExtension + newExeFileName = libexecdir fixedExeBaseName <.> exeExtension - let lbi' = lbi { - installDirTemplates = - (installDirTemplates lbi) { - bindir = install_target'' - } - } - fn pd_extended lbi' + when (exeName exe == "ghc-mod-real") $ do + createDirectoryIfMissingVerbose verbosity True libexecdir + renameFile fixedExeFileName newExeFileName fn pd_regular lbi where - installTarget :: Executable -> Maybe PathTemplate - installTarget exe = - toPathTemplate <$> lookup "x-install-target" (customFieldsBI $ buildInfo exe) - - substLibExec libexecdir "$libexecdir" = libexecdir - substLibExec _ comp = comp - - substLibExec' dir = - withPT $ - withSP $ map (substLibExec dir . dropTrailingPathSeparator) - - - withPT f pt = toPathTemplate $ f (fromPathTemplate pt) - withSP f p = joinPath $ f (splitPath p) + isInternal :: Executable -> Bool + isInternal exe = + fromMaybe False $ (=="True") <$> lookup "x-internal" (customFieldsBI $ buildInfo exe) onlyExePackageDesc :: [Executable] -> PackageDescription -> PackageDescription onlyExePackageDesc exes pd = emptyPackageDescription { package = package pd , executables = exes } - -parseVer str = - case filter ((=="") . snd) $ readP_to_S parseVersion str of - [(ver, _)] -> ver - _ -> error $ "No parse (Ver) :(\n" ++ str ++ "\n" - -fromJustNote :: String -> Maybe a -> a -fromJustNote _ (Just x) = x -fromJustNote note Nothing = error $ "fromJustNote ("++note++"): " - --- sanityCheckCabalVersions args cf desc lbi = do --- (cabalInstallVer, cabalVer) <- getCabalExecVer - --- let --- ghcVer = compilerVersion (compiler lbi) --- -- ghc >= 7.10? --- minGhc710 = ghcVer `withinRange` orLaterVersion (parseVer "7.10") - --- when minGhc710 $ do --- let cabalHelperCabalVer = compCabalVer (CExeName "cabal-helper") - --- when (not $ cabalVer `sameMajorVersionAs` cabalHelperCabalVer) $ --- failCabalVersionDifferent cabalVer cabalHelperCabalVer - --- -- carry on as usual --- (postConf simpleUserHooks) args cf desc lbi - --- where --- earlierVersionThan ver ver' = --- ver `withinRange` earlierVersion ver' --- sameMajorVersionAs ver ver' = --- ver `withinRange` withinVersion (Version (take 2 $ versionBranch ver') []) - --- compCabalVer comp = let --- clbi = getComponentLocalBuildInfo lbi comp - --- [cabalVer] = --- [ ver | (_, PackageIdentifier pkg ver) <- componentPackageDeps clbi --- , pkg == PackageName "Cabal" ] --- in cabalVer - --- getCabalExecVer = do --- ["cabal-install", "version", cabalInstallVer, "using", "version", cabalVer, "of", "the", "Cabal", "library"] <- words <$> readProcess "cabal" ["--version"] "" --- return (parseVer cabalInstallVer, parseVer cabalVer) - --- failCabalVersionDifferent cabalVer libCabalVer = --- putStrLn rerr >> exitFailure --- where --- replace :: String -> String -> String -> String --- replace _ _ [] = [] --- replace n r h@(h':hs) --- | map snd (n `zip` h ) == n = r ++ replace n r (drop (length n) h) --- | otherwise = h':replace n r hs - --- rerr = replace "X.XX.X.X" (showVersion libCabalVer) $ --- replace "Y.YY.Y.Y" (showVersion cabalVer) err --- err = "\ --- \Error: Cabal seems to have decided ghc-mod should be built using Cabal\n\ --- \X.XX.X.X while the `cabal' executable in your PATH was built with Cabal\n\ --- \Y.YY.Y.Y. This will lead to conflicts when running ghc-mod in any project\n\ --- \where you use this `cabal' executable. Please compile ghc-mod using the same\n\ --- \Cabal version as your `cabal' executable or recompile cabal-install using\n\ --- \this version of the Cabal library.\n\ --- \\n\ --- \See: https://github.com/kazu-yamamoto/ghc-mod/wiki/InconsistentCabalVersions\n" diff --git a/SetupCompat.hs b/SetupCompat.hs deleted file mode 100644 --- a/SetupCompat.hs +++ /dev/null @@ -1,198 +0,0 @@ -{-# LANGUAGE TemplateHaskell, RecordWildCards, StandaloneDeriving #-} -module SetupCompat where - -import Control.Arrow -import Control.Monad.Trans.State -import Data.List -import Data.Maybe -import Data.Functor -import Data.Function -import Distribution.Simple.LocalBuildInfo -import Distribution.PackageDescription - -import Distribution.Simple -import Distribution.Simple.Setup -import Distribution.Simple.Install - -import qualified Data.Map as M -import Data.Map (Map) - - -import NotCPP.Declarations -import Language.Haskell.TH - --- $(ifdefD "componentsConfigs" [d| deriving instance (Ord ComponentName) |] ) - -$(ifD [d| - - showComponentName :: ComponentName -> String - showComponentName CLibName = "library" - showComponentName (CExeName name) = "executable '" ++ name ++ "'" - showComponentName (CTestName name) = "test suite '" ++ name ++ "'" - showComponentName (CBenchName name) = "benchmark '" ++ name ++ "'" - - |]) - -$(ifelsedefD "componentsConfigs" [d| - - setComponentsConfigs - :: LocalBuildInfo - -> [(ComponentName, ComponentLocalBuildInfo, [ComponentName])] - -> LocalBuildInfo - setComponentsConfigs lbi cs = $(recUpdE' (nE "lbi") (mkName "componentsConfigs") (VarE $ mkName "cs")) - - |] [d| - - setComponentsConfigs - :: LocalBuildInfo - -> [(ComponentName, ComponentLocalBuildInfo, a)] - -> LocalBuildInfo - setComponentsConfigs lbi cs = flip execState lbi $ mapM setClbis gcs - where - gcs = groupBy (sameKind `on` fst3) $ sortBy (compare `on` showComponentName . fst3) cs - - fst3 (x,_,_) = x - - sameKind CLibName CLibName = True - sameKind CLibName _ = False - sameKind (CExeName _) (CExeName _) = True - sameKind (CExeName _) _ = False - sameKind (CTestName _) (CTestName _) = True - sameKind (CTestName _) _ = False - sameKind (CBenchName _) (CBenchName _) = True - sameKind (CBenchName _) _ = False - - setClbis [(CLibName, clbi, _)] = - get >>= \lbi -> - put $ $(recUpdE' (nE "lbi") (mkName "libraryConfig") (AppE (ConE (mkName "Just")) (VarE (mkName "clbi")))) - - setClbis cs@((CExeName _, _, _):_) = - let cfg = (\((CExeName n), clbi, _) -> (n, clbi)) <$> cs in - get >>= \lbi -> - put $ $(recUpdE' (nE "lbi") (mkName "executableConfigs") (VarE $ mkName "cfg")) - - setClbis cs@((CTestName _, _, _):_) = - let cfg = (\((CTestName n), clbi, _) -> (n, clbi)) <$> cs in - get >>= \lbi -> - put $ $(recUpdE' (nE "lbi") (mkName "testSuiteConfigs") (VarE $ mkName "cfg")) - - setClbis cs@((CBenchName _, _, _):_) = - let cfg = (\((CBenchName n), clbi, _) -> (n, clbi)) <$> cs in - get >>= \lbi -> - put $ $(recUpdE' (nE "lbi") (mkName "benchmarkConfigs") (VarE $ mkName "cfg")) - - |]) - - -$(ifD [d| - - componentsConfigs :: - LocalBuildInfo -> [(ComponentName, ComponentLocalBuildInfo, [ComponentName])] - componentsConfigs LocalBuildInfo {..} = - (maybe [] (\c -> [(CLibName, c, [])]) $(nE "libraryConfig")) - ++ ((\(n, clbi) -> (CExeName n, clbi, [])) <$> $(nE "executableConfigs")) - ++ ((\(n, clbi) -> (CTestName n, clbi, [])) <$> $(nE "testSuiteConfigs")) - ++ ((\(n, clbi) -> (CBenchName n, clbi, [])) <$> $(nE "benchmarkConfigs")) - - getComponent :: PackageDescription -> ComponentName -> Component - getComponent pkg cname = - case lookupComponent pkg cname of - Just cpnt -> cpnt - Nothing -> missingComponent - where - missingComponent = - error $ "internal error: the package description contains no " - ++ "component corresponding to " ++ show cname - - lookupComponent :: PackageDescription -> ComponentName -> Maybe Component - lookupComponent pkg CLibName = - fmap CLib $ library pkg - lookupComponent pkg (CExeName name) = - fmap CExe $ find ((name ==) . exeName) (executables pkg) - lookupComponent pkg (CTestName name) = - fmap CTest $ find ((name ==) . testName) (testSuites pkg) - lookupComponent pkg (CBenchName name) = - fmap CBench $ find ((name ==) . benchmarkName) (benchmarks pkg) - --- We're lying here can't be bothered to order these - allComponentsInBuildOrder :: LocalBuildInfo - -> [(ComponentName, ComponentLocalBuildInfo)] - allComponentsInBuildOrder lbi = - [ (cname, clbi) | (cname, clbi, _) <- componentsConfigs lbi ] - - getComponentLocalBuildInfo :: LocalBuildInfo -> ComponentName -> ComponentLocalBuildInfo - getComponentLocalBuildInfo lbi cname = - case [ clbi - | (cname', clbi, _) <- componentsConfigs lbi - , cname == cname' ] of - [clbi] -> clbi - _ -> missingComponent - where - missingComponent = - error $ "internal error: there is no configuration data " - ++ "for component " ++ show cname - - componentBuildInfo :: Component -> BuildInfo - componentBuildInfo = - foldComponent libBuildInfo buildInfo testBuildInfo benchmarkBuildInfo - - |]) - - -$(ifelsedefD "componentPackageRenaming" [d| - -- M.Map PackageName - newtype Deps = Deps { unDeps :: ([(InstalledPackageId, PackageId)], Map PackageName $(cT "ModuleRenaming")) } --- $(return $ TySynD $(mkName "Deps") [] [t| |] ) - - noDeps = Deps ([], M.empty) - - getDeps :: ComponentLocalBuildInfo -> Deps - getDeps = componentPackageDeps &&& $(nE "componentPackageRenaming") >>> Deps - - setUnionDeps :: Deps -> ComponentLocalBuildInfo -> ComponentLocalBuildInfo - setUnionDeps (Deps (deps, rns)) clbi = let - clbi' = setComponentPackageRenaming clbi rns - cpdeps = componentPackageDeps clbi - in - clbi' { - componentPackageDeps = cpdeps `union` deps - } - - setComponentPackageRenaming clbi cprn = - -- [| clbi { componentPackageRenaming = componentPackageRenaming clbi `M.union` cprn } |] - $(recUpdE' - (nE "clbi") - (mkName "componentPackageRenaming") - (InfixE - (Just - (AppE - (VarE - (mkName "componentPackageRenaming")) - (VarE (mkName "clbi")) - )) - (VarE (mkName "M.union")) - (Just (VarE (mkName "cprn"))) - ) - ) - - |] [d| - - newtype Deps = Deps { unDeps :: [(InstalledPackageId, PackageId)] } - - noDeps = Deps [] - - getDeps :: ComponentLocalBuildInfo -> Deps - getDeps lbi = Deps $ componentPackageDeps lbi - - setUnionDeps :: Deps -> ComponentLocalBuildInfo -> ComponentLocalBuildInfo - setUnionDeps (Deps deps) clbi = let - cpdeps = componentPackageDeps clbi - in - clbi { - componentPackageDeps = cpdeps `union` deps - } - - --- setComponentPackageRenaming clbi _cprn = clbi - - |]) diff --git a/System/Directory/ModTime.hs b/System/Directory/ModTime.hs deleted file mode 100644 --- a/System/Directory/ModTime.hs +++ /dev/null @@ -1,63 +0,0 @@ --- ghc-mod: Making Haskell development *more* fun --- Copyright (C) 2015 Daniel Gröber --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU Affero General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU Affero General Public License for more details. --- --- You should have received a copy of the GNU Affero General Public License --- along with this program. If not, see . -{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} -module System.Directory.ModTime where - -import Control.Applicative -import Control.DeepSeq -import Data.Binary -#if MIN_VERSION_directory(1,2,0) -import Data.Time (UTCTime(..), Day(..), getCurrentTime) -#else -import System.Time (ClockTime(..), getClockTime) -#endif -import System.Directory -import Prelude - -#if MIN_VERSION_directory(1,2,0) - -newtype ModTime = ModTime UTCTime - deriving (Eq, Ord, NFData) -getCurrentModTime = ModTime <$> getCurrentTime - -instance Binary ModTime where - put (ModTime (UTCTime (ModifiedJulianDay day) difftime)) = - put day >> put (toRational difftime) - get = - ModTime <$> (UTCTime <$> (ModifiedJulianDay <$> get) <*> (fromRational <$> get)) - -#else - -newtype ModTime = ModTime ClockTime - deriving (Eq, Ord) -getCurrentModTime = ModTime <$> getClockTime - -instance Binary ModTime where - put (ModTime (TOD s ps)) = - put s >> put ps - get = - ModTime <$> (TOD <$> get <*> get) - -instance NFData ModTime where - rnf (ModTime (TOD s ps)) = - s `seq` ps `seq` (ModTime $! TOD s ps) `seq` () - -#endif - -getCurrentModTime :: IO ModTime - -getModTime :: FilePath -> IO ModTime -getModTime f = ModTime <$> getModificationTime f diff --git a/Utils.hs b/Utils.hs deleted file mode 100644 --- a/Utils.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE CPP #-} -module Utils where - -import Control.Applicative -import Data.Traversable -import System.Directory -import System.Directory.ModTime - -import Prelude - -data TimedFile = TimedFile { tfPath :: FilePath, tfTime :: ModTime } - deriving (Eq) - -instance Ord TimedFile where - compare (TimedFile _ a) (TimedFile _ b) = compare a b - -timeFile :: FilePath -> IO TimedFile -timeFile f = TimedFile <$> pure f <*> getModTime f - -mightExist :: FilePath -> IO (Maybe FilePath) -mightExist f = do - exists <- doesFileExist f - return $ if exists then (Just f) else (Nothing) - -timeMaybe :: FilePath -> IO (Maybe TimedFile) -timeMaybe f = traverse timeFile =<< mightExist f diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -0,0 +1,30 @@ +import Criterion.Main +import GhcMod.Target +import GhcMod.Monad +import GhcMod.Types +import Dir +import System.IO.Temp +import System.Process hiding (env) +import Control.Monad + +main = defaultMain [ + env setup $ \dir -> bgroup "simple-cabal" [ + bench "nop" $ whnfIO (simpleCabalNop dir 1) + , bench "nop10" $ whnfIO (simpleCabalNop dir 10) + ] + ] + +setup = do + tdir <- createTempDirectory "/tmp" "ghc-mod-bench" + system $ "cp -rv \"bench/data/simple-cabal/\" \""++ tdir ++"\"" + + simpleCabalNop tdir 1 -- warmup dist/ + + return tdir + +simpleCabalNop :: FilePath -> Int -> IO () +simpleCabalNop dir n = withDirectory_ (dir "simple-cabal") $ do + _ <- runGhcModT defaultOptions $ + forM_ [1..n] $ \_ -> do + runGmlT [Left "Main.hs"] (return ()) + return () diff --git a/bench/data/simple-cabal/Main.hs b/bench/data/simple-cabal/Main.hs new file mode 100644 --- /dev/null +++ b/bench/data/simple-cabal/Main.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = putStrLn "Hello, Haskell!" diff --git a/bench/data/simple-cabal/Setup.hs b/bench/data/simple-cabal/Setup.hs new file mode 100644 --- /dev/null +++ b/bench/data/simple-cabal/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bench/data/simple-cabal/simple-cabal.cabal b/bench/data/simple-cabal/simple-cabal.cabal new file mode 100644 --- /dev/null +++ b/bench/data/simple-cabal/simple-cabal.cabal @@ -0,0 +1,13 @@ +name: simple-cabal +version: 0.1.0.0 +license: BSD3 +license-file: LICENSE +author: Daniel Gröber +maintainer: dxld@darkboxed.org +build-type: Simple +cabal-version: >=1.10 + +executable simple-cabal + main-is: Main.hs + build-depends: base + default-language: Haskell2010 diff --git a/core/Data/Binary/Generic.hs b/core/Data/Binary/Generic.hs new file mode 100644 --- /dev/null +++ b/core/Data/Binary/Generic.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE BangPatterns, CPP, FlexibleInstances, KindSignatures, + ScopedTypeVariables, TypeOperators, TypeSynonymInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Binary.Generic +-- Copyright : Bryan O'Sullivan +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Bryan O'Sullivan +-- Stability : unstable +-- Portability : Only works with GHC 7.2 and newer +-- +-- Instances for supporting GHC generics. +-- +----------------------------------------------------------------------------- +module Data.Binary.Generic where + +import Control.Applicative +import Data.Binary +import Data.Bits +import GHC.Generics +import Prelude + +class GGBinary f where + ggput :: f t -> Put + ggget :: Get (f t) + +-- Type without constructors +instance GGBinary V1 where + ggput _ = return () + ggget = return undefined + +-- Constructor without arguments +instance GGBinary U1 where + ggput U1 = return () + ggget = return U1 + +-- Product: constructor with parameters +instance (GGBinary a, GGBinary b) => GGBinary (a :*: b) where + ggput (x :*: y) = ggput x >> ggput y + ggget = (:*:) <$> ggget <*> ggget + +-- Metadata (constructor name, etc) +instance GGBinary a => GGBinary (M1 i c a) where + ggput = ggput . unM1 + ggget = M1 <$> ggget + +-- Constants, additional parameters, and rank-1 recursion +instance Binary a => GGBinary (K1 i a) where + ggput = put . unK1 + ggget = K1 <$> get + +-- Borrowed from the cereal package. + +-- The following GGBinary instance for sums has support for serializing +-- types with up to 2^64-1 constructors. It will use the minimal +-- number of bytes needed to encode the constructor. For example when +-- a type has 2^8 constructors or less it will use a single byte to +-- encode the constructor. If it has 2^16 constructors or less it will +-- use two bytes, and so on till 2^64-1. + +#define GUARD(WORD) (size - 1) <= fromIntegral (maxBound :: WORD) +#define PUTSUM(WORD) GUARD(WORD) = putSum (0 :: WORD) (fromIntegral size) +#define GETSUM(WORD) GUARD(WORD) = (get :: Get WORD) >>= checkGetSum (fromIntegral size) + +instance ( GSum a, GSum b + , SumSize a, SumSize b) => GGBinary (a :+: b) where + ggput | PUTSUM(Word8) | PUTSUM(Word16) | PUTSUM(Word32) | PUTSUM(Word64) + | otherwise = sizeError "encode" size + where + size = unTagged (sumSize :: Tagged (a :+: b) Word64) + {-# INLINE ggput #-} + + ggget | GETSUM(Word8) | GETSUM(Word16) | GETSUM(Word32) | GETSUM(Word64) + | otherwise = sizeError "decode" size + where + size = unTagged (sumSize :: Tagged (a :+: b) Word64) + {-# INLINE ggget #-} + +sizeError :: Show size => String -> size -> error +sizeError s size = + error $ "Can't " ++ s ++ " a type with " ++ show size ++ " constructors" + +------------------------------------------------------------------------ + +checkGetSum :: (Ord word, Num word, Bits word, GSum f) + => word -> word -> Get (f a) +checkGetSum size code | code < size = getSum code size + | otherwise = fail "Unknown encoding for constructor" +{-# INLINE checkGetSum #-} + +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) => GSum (a :+: b) where + getSum !code !size | code < sizeL = L1 <$> getSum code sizeL + | otherwise = R1 <$> getSum (code - sizeL) sizeR + where + sizeL = size `shiftR` 1 + sizeR = size - sizeL + {-# INLINE getSum #-} + + putSum !code !size s = case s of + L1 x -> putSum code sizeL x + R1 x -> putSum (code + sizeL) sizeR x + where + sizeL = size `shiftR` 1 + sizeR = size - sizeL + {-# INLINE putSum #-} + +instance GGBinary a => GSum (C1 c a) where + getSum _ _ = ggget + {-# INLINE getSum #-} + + putSum !code _ x = put code *> ggput x + {-# INLINE putSum #-} + +------------------------------------------------------------------------ + +class SumSize f where + sumSize :: Tagged f Word64 + +newtype Tagged (s :: * -> *) b = Tagged {unTagged :: b} + +instance (SumSize a, SumSize b) => SumSize (a :+: b) where + sumSize = Tagged $ unTagged (sumSize :: Tagged a Word64) + + unTagged (sumSize :: Tagged b Word64) + +instance SumSize (C1 c a) where + sumSize = Tagged 1 diff --git a/core/GhcMod/CabalHelper.hs b/core/GhcMod/CabalHelper.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/CabalHelper.hs @@ -0,0 +1,309 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +{-# LANGUAGE CPP #-} +module GhcMod.CabalHelper + ( getComponents + , getGhcMergedPkgOptions + , getCabalPackageDbStack + , prepareCabalHelper + , withAutogen + , withCabal + ) where + +import Control.Applicative +import Control.Monad +import Control.Category ((.)) +import Data.Maybe +import Data.Monoid +import Data.Version +import Data.Binary (Binary) +import Data.Traversable +import Distribution.Helper hiding (Programs(..)) +import qualified Distribution.Helper as CH +import qualified GhcMod.Types as T +import GhcMod.Types +import GhcMod.Monad.Types +import GhcMod.Utils +import GhcMod.PathsAndFiles +import GhcMod.Logging +import GhcMod.Output +import GhcMod.CustomPackageDb +import GhcMod.Stack +import System.FilePath +import System.Process +import System.Exit +import Prelude hiding ((.)) + +import Paths_ghc_mod as GhcMod + +-- | Only package related GHC options, sufficient for things that don't need to +-- access home modules +getGhcMergedPkgOptions :: (Applicative m, IOish m, Gm m) + => m [GHCOption] +getGhcMergedPkgOptions = chCached $ \distdir -> Cached { + cacheLens = Just (lGmcMergedPkgOptions . lGmCaches), + cacheFile = mergedPkgOptsCacheFile distdir, + cachedAction = \_tcf (_progs, _projdir, _ver) _ma -> do + opts <- runCHQuery ghcMergedPkgOptions + return ([setupConfigPath distdir], opts) + } + +getCabalPackageDbStack :: (IOish m, Gm m) => m [GhcPkgDb] +getCabalPackageDbStack = chCached $ \distdir -> Cached { + cacheLens = Just (lGmcPackageDbStack . lGmCaches), + cacheFile = pkgDbStackCacheFile distdir, + cachedAction = \_tcf (_progs, _projdir, _ver) _ma -> do + crdl <- cradle + dbs <- map chPkgToGhcPkg <$> + runCHQuery packageDbStack + return ([setupConfigFile crdl, sandboxConfigFile crdl], dbs) + } + +chPkgToGhcPkg :: ChPkgDb -> GhcPkgDb +chPkgToGhcPkg ChPkgGlobal = GlobalDb +chPkgToGhcPkg ChPkgUser = UserDb +chPkgToGhcPkg (ChPkgSpecific f) = PackageDb f + +-- | Primary interface to cabal-helper and intended single entrypoint to +-- constructing 'GmComponent's +-- +-- The Component\'s 'gmcHomeModuleGraph' will be empty and has to be resolved by +-- 'resolveGmComponents'. +getComponents :: (Applicative m, IOish m, Gm m) + => m [GmComponent 'GMCRaw ChEntrypoint] +getComponents = chCached $ \distdir -> Cached { + cacheLens = Just (lGmcComponents . lGmCaches), + cacheFile = cabalHelperCacheFile distdir, + cachedAction = \ _tcf (_progs, _projdir, _ver) _ma -> do + runCHQuery $ do + q <- join7 + <$> ghcOptions + <*> ghcPkgOptions + <*> ghcSrcOptions + <*> ghcLangOptions + <*> entrypoints + <*> entrypoints + <*> sourceDirs + let cs = flip map q $ curry8 (GmComponent mempty) + return ([setupConfigPath distdir], cs) + } + where + curry8 fn (a, (b, (c, (d, (e, (f, (g, h))))))) = fn a b c d e f g h + + join7 a b c d e f = join' a . join' b . join' c . join' d . join' e . join' f + join' :: Eq a => [(a,b)] -> [(a,c)] -> [(a,(b,c))] + join' lb lc = [ (a, (b, c)) + | (a, b) <- lb + , (a', c) <- lc + , a == a' + ] + +getQueryEnv :: (IOish m, GmOut m, GmEnv m) => m QueryEnv +getQueryEnv = do + crdl <- cradle + progs <- patchStackPrograms crdl =<< (optPrograms <$> options) + readProc <- gmReadProcess + let projdir = cradleRootDir crdl + distdir = projdir cradleDistDir crdl + return (defaultQueryEnv projdir distdir) { + qeReadProcess = readProc + , qePrograms = helperProgs progs + } + +runCHQuery :: (IOish m, GmOut m, GmEnv m) => Query m b -> m b +runCHQuery a = do + qe <- getQueryEnv + runQuery qe a + + +prepareCabalHelper :: (IOish m, GmEnv m, GmOut m, GmLog m) => m () +prepareCabalHelper = do + crdl <- cradle + when (isCabalHelperProject $ cradleProject crdl) $ + withCabal $ prepare' =<< getQueryEnv + +withAutogen :: (IOish m, GmEnv m, GmOut m, GmLog m) => m a -> m a +withAutogen action = do + gmLog GmDebug "" $ strDoc $ "making sure autogen files exist" + crdl <- cradle + let projdir = cradleRootDir crdl + distdir = projdir cradleDistDir crdl + + (pkgName', _) <- runCHQuery packageId + + mCabalFile <- liftIO $ timeFile `traverse` cradleCabalFile crdl + mCabalMacroHeader <- liftIO $ timeMaybe (distdir macrosHeaderPath) + mCabalPathsModule <- liftIO $ timeMaybe (distdir autogenModulePath pkgName') + + when (mCabalMacroHeader < mCabalFile || mCabalPathsModule < mCabalFile) $ do + gmLog GmDebug "" $ strDoc $ "autogen files out of sync" + writeAutogen + + action + + where + writeAutogen = do + gmLog GmDebug "" $ strDoc $ "writing Cabal autogen files" + writeAutogenFiles' =<< getQueryEnv + + +withCabal :: (IOish m, GmEnv m, GmOut m, GmLog m) => m a -> m a +withCabal action = do + crdl <- cradle + mCabalFile <- liftIO $ timeFile `traverse` cradleCabalFile crdl + mCabalConfig <- liftIO $ timeMaybe (setupConfigFile crdl) + mCabalSandboxConfig <- liftIO $ timeMaybe (sandboxConfigFile crdl) + + let haveSetupConfig = isJust mCabalConfig + + cusPkgDb <- getCustomPkgDbStack + (flgs, pkgDbStackOutOfSync) <- do + if haveSetupConfig + then runCHQuery $ do + flgs <- nonDefaultConfigFlags + pkgDb <- map chPkgToGhcPkg <$> packageDbStack + return (flgs, fromMaybe False $ (pkgDb /=) <$> cusPkgDb) + else return ([], False) + + when (isSetupConfigOutOfDate mCabalFile mCabalConfig) $ + gmLog GmDebug "" $ strDoc $ "setup configuration is out of date" + + when (isSetupConfigOutOfDate mCabalSandboxConfig mCabalConfig) $ + gmLog GmDebug "" $ strDoc $ "sandbox configuration is out of date" + + when pkgDbStackOutOfSync $ + gmLog GmDebug "" $ strDoc $ "package-db stack out of sync with ghc-mod.package-db-stack" + + when ( isSetupConfigOutOfDate mCabalFile mCabalConfig + || pkgDbStackOutOfSync + || isSetupConfigOutOfDate mCabalSandboxConfig mCabalConfig) $ do + proj <- cradleProject <$> cradle + opts <- options + case proj of + CabalProject -> do + gmLog GmDebug "" $ strDoc "reconfiguring Cabal project" + cabalReconfigure (optPrograms opts) crdl flgs + StackProject {} -> do + gmLog GmDebug "" $ strDoc "reconfiguring Stack project" + -- TODO: we could support flags for stack too, but it seems + -- you're supposed to put those in stack.yaml so detecting which + -- flags to pass down would be more difficult + + -- "--flag PACKAGE:[-]FLAG Override flags set in stack.yaml + -- (applies to local packages and extra-deps)" + + stackReconfigure (optStackBuildDeps opts) crdl (optPrograms opts) + _ -> + error $ "withCabal: unsupported project type: " ++ show proj + + action + + where + cabalReconfigure progs crdl flgs = do + readProc <- gmReadProcess + withDirectory_ (cradleRootDir crdl) $ do + cusPkgStack <- maybe [] ((PackageDb "clear"):) <$> getCustomPkgDbStack + let progOpts = + [ "--with-ghc=" ++ T.ghcProgram progs ] + -- Only pass ghc-pkg if it was actually set otherwise we + -- might break cabal's guessing logic + ++ if T.ghcPkgProgram progs /= T.ghcPkgProgram (optPrograms defaultOptions) + then [ "--with-ghc-pkg=" ++ T.ghcPkgProgram progs ] + else [] + ++ map pkgDbArg cusPkgStack + ++ flagOpt + + toFlag (f, True) = f + toFlag (f, False) = '-':f + flagOpt = ["--flags", unwords $ map toFlag flgs] + + liftIO $ void $ readProc (T.cabalProgram progs) ("configure":progOpts) "" + stackReconfigure deps crdl progs = do + withDirectory_ (cradleRootDir crdl) $ do + supported <- haveStackSupport + if supported + then do + when deps $ + spawn [T.stackProgram progs, "build", "--only-dependencies", "."] + spawn [T.stackProgram progs, "build", "--only-configure", "."] + else + gmLog GmWarning "" $ strDoc $ "Stack project configuration is out of date, please reconfigure manually using 'stack build' as your stack version is too old (need at least 0.1.4.0)" + + spawn [] = return () + spawn (exe:args) = do + readProc <- gmReadProcess + liftIO $ void $ readProc exe args "" + + haveStackSupport = do + (rv, _, _) <- + liftIO $ readProcessWithExitCode "stack" ["--numeric-version"] "" + case rv of + ExitSuccess -> return True + ExitFailure _ -> return False + + + +pkgDbArg :: GhcPkgDb -> String +pkgDbArg GlobalDb = "--package-db=global" +pkgDbArg UserDb = "--package-db=user" +pkgDbArg (PackageDb p) = "--package-db=" ++ p + +-- * Neither file exists -> should return False: +-- @Nothing < Nothing = False@ +-- (since we don't need to @cabal configure@ when no cabal file exists.) +-- +-- * Cabal file doesn't exist (impossible since cabal-helper is only used with +-- cabal projects) -> should return False +-- @Just cc < Nothing = False@ +-- +-- * dist/setup-config doesn't exist yet -> should return True: +-- @Nothing < Just cf = True@ +-- +-- * Both files exist +-- @Just cc < Just cf = cc < cf = cc `olderThan` cf@ +isSetupConfigOutOfDate :: Maybe TimedFile -> Maybe TimedFile -> Bool +isSetupConfigOutOfDate worldCabalFile worldCabalConfig = do + worldCabalConfig < worldCabalFile + +helperProgs :: Programs -> CH.Programs +helperProgs progs = CH.Programs { + cabalProgram = T.cabalProgram progs, + ghcProgram = T.ghcProgram progs, + ghcPkgProgram = T.ghcPkgProgram progs + } + +chCached :: (Applicative m, IOish m, Gm m, Binary a) + => (FilePath -> Cached m GhcModState ChCacheData a) -> m a +chCached c = do + projdir <- cradleRootDir <$> cradle + distdir <- (projdir ) . cradleDistDir <$> cradle + d <- cacheInputData projdir + withCabal $ cached projdir (c distdir) d + where + -- we don't need to include the distdir in the cache input because when it + -- changes the cache files will be gone anyways ;) + cacheInputData projdir = do + opts <- options + crdl <- cradle + progs' <- patchStackPrograms crdl (optPrograms opts) + return $ ( helperProgs progs' + , projdir + , (showVersion gmVer, chVer) + ) + + gmVer = GhcMod.version + chVer = VERSION_cabal_helper diff --git a/core/GhcMod/Caching.hs b/core/GhcMod/Caching.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Caching.hs @@ -0,0 +1,141 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . +{-# LANGUAGE CPP, OverloadedStrings #-} +module GhcMod.Caching ( + module GhcMod.Caching + , module GhcMod.Caching.Types + ) where + +import Control.Arrow (first) +import Control.Monad +import Control.Monad.Trans.Maybe +#if !MIN_VERSION_binary(0,7,0) +import Control.Exception +#endif +import Data.Maybe +import Data.Binary hiding (get) +import Data.Version +import Data.Label +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import System.FilePath +import System.Directory.ModTime +import Utils (TimedFile(..), timeMaybe, mightExist) +import Paths_ghc_mod (version) +import Prelude + +import GhcMod.Monad.Types +import GhcMod.Caching.Types +import GhcMod.Logging + +-- | Cache a MonadIO action with proper invalidation. +cached :: forall m a d. (Gm m, MonadIO m, Binary a, Eq d, Binary d, Show d) + => FilePath -- ^ Directory to prepend to 'cacheFile' + -> Cached m GhcModState d a -- ^ Cache descriptor + -> d + -> m a +cached dir cd d = do + mcc <- readCache + case mcc of + Nothing -> do + t <- liftIO $ getCurrentModTime + writeCache (TimedCacheFiles t []) Nothing "cache missing or unreadable" + Just (t, ifs, d', a) | d /= d' -> do + tcfs <- timeCacheInput dir ifs + writeCache (TimedCacheFiles t tcfs) (Just a) $ "input data changed" -- ++ " was: " ++ show d ++ " is: " ++ show d' + Just (t, ifs, _, a) -> do + tcfs <- timeCacheInput dir ifs + case invalidatingInputFiles $ TimedCacheFiles t tcfs of + [] -> return a + _ -> writeCache (TimedCacheFiles t tcfs) (Just a) "input files changed" + + where + cacheHeader = BS8.pack $ "Written by ghc-mod " ++ showVersion version ++ "\n" + + lbsToStrict = BS.concat . LBS.toChunks + lbsFromStrict bs = LBS.fromChunks [bs] + + writeCache tcfs ma cause = do + (ifs', a) <- (cachedAction cd) tcfs d ma + t <- liftIO $ getCurrentModTime + gmLog GmDebug "" $ (text "regenerating cache") <+>: text (cacheFile cd) + <+> parens (text cause) + case cacheLens cd of + Nothing -> return () + Just label -> do + gmLog GmDebug "" $ (text "writing memory cache") <+>: text (cacheFile cd) + setLabel label $ Just (t, ifs', d, a) + + let c = BS.append cacheHeader $ lbsToStrict $ encode (t, ifs', d, a) + + liftIO $ BS.writeFile (dir cacheFile cd) c + + return a + + setLabel l x = do + s <- gmsGet + gmsPut $ set l x s + + readCache :: m (Maybe (ModTime, [FilePath], d, a)) + readCache = runMaybeT $ do + case cacheLens cd of + Just label -> do + c <- MaybeT (get label `liftM` gmsGet) `mplus` readCacheFromFile + setLabel label $ Just c + return c + Nothing -> + readCacheFromFile + + readCacheFromFile :: MaybeT m (ModTime, [FilePath], d, a) + readCacheFromFile = do + f <- MaybeT $ liftIO $ mightExist $ cacheFile cd + readCacheFromFile' f + + readCacheFromFile' :: FilePath -> MaybeT m (ModTime, [FilePath], d, a) + readCacheFromFile' f = MaybeT $ do + gmLog GmDebug "" $ (text "reading cache") <+>: text (cacheFile cd) + cc <- liftIO $ BS.readFile f + case first BS8.words $ BS8.span (/='\n') cc of + (["Written", "by", "ghc-mod", ver], rest) + | BS8.unpack ver == showVersion version -> + either (const Nothing) Just + `liftM` decodeE (lbsFromStrict $ BS.drop 1 rest) + _ -> return Nothing + + decodeE b = do +#if MIN_VERSION_binary(0,7,0) + return $ case decodeOrFail b of + Left (_rest, _offset, errmsg) -> Left errmsg + Right (_reset, _offset, a) -> Right a +#else + ea <- liftIO $ try $ evaluate $ decode b + return $ case ea of + Left (ErrorCall errmsg) -> Left errmsg + Right a -> Right a + +#endif + +timeCacheInput :: MonadIO m => FilePath -> [FilePath] -> m [TimedFile] +timeCacheInput dir ifs = liftIO $ do + ins <- (timeMaybe . (dir )) `mapM` ifs + return $ catMaybes ins + +invalidatingInputFiles :: TimedCacheFiles -> [FilePath] +invalidatingInputFiles (TimedCacheFiles tcreated tcfs) = + map tfPath $ + -- get input files older than tcfile + filter ((TimedFile "" tcreated)<) tcfs diff --git a/core/GhcMod/Caching/Types.hs b/core/GhcMod/Caching/Types.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Caching/Types.hs @@ -0,0 +1,67 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . +module GhcMod.Caching.Types where + +import Utils +import Data.Label +import System.Directory.ModTime +import Distribution.Helper + +type CacheContents d a = Maybe (ModTime, [FilePath], d, a) +type CacheLens s d a = s :-> CacheContents d a + +data Cached m s d a = Cached { + cacheFile :: FilePath, + cacheLens :: Maybe (CacheLens s d a), + cachedAction :: TimedCacheFiles + -> d + -> Maybe a + -> m ([FilePath], a) + + -- ^ @cachedAction tcf data ma@ + -- + -- * @tcf@: Input file timestamps. Not technically necessary, just an + -- optimizazion when knowing which input files changed can make updating the + -- cache faster + -- + -- * @data@: Arbitrary static input data to cache action. Can be used to + -- invalidate the cache using something other than file timestamps + -- i.e. environment tool version numbers + -- + -- * @ma@: Cached data if it existed + -- + -- Returns: + -- + -- * @fst@: Input files used in generating the cache + -- + -- * @snd@: Cache data, will be stored alongside the static input data in the + -- 'cacheFile' + -- + -- The cached action, will only run if one of the following is true: + -- + -- * 'cacheFile' doesn\'t exist yet + -- * 'cacheFile' exists and 'inputData' changed + -- * any files returned by the cached action changed + } + +data TimedCacheFiles = TimedCacheFiles { + tcCreated :: ModTime, + -- ^ 'cacheFile' timestamp + tcFiles :: [TimedFile] + -- ^ Timestamped files returned by the cached action + } deriving (Eq, Ord) + +type ChCacheData = (Programs, FilePath, (String, String)) diff --git a/core/GhcMod/Convert.hs b/core/GhcMod/Convert.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Convert.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE CPP, FlexibleInstances, FlexibleContexts #-} + +module GhcMod.Convert (convert, convert', emptyResult, whenFound, whenFound') where + +import GhcMod.Monad.Types +import GhcMod.Types + +import Control.Applicative +import Prelude + +type Builder = String -> String + +-- | +-- +-- >>> replace '"' "\\\"" "foo\"bar" "" +-- "foo\\\"bar" +replace :: Char -> String -> String -> Builder +replace _ _ [] = id +replace c cs (x:xs) + | x == c = (cs ++) . replace c cs xs + | otherwise = (x :) . replace c cs xs + +inter :: Char -> [Builder] -> Builder +inter _ [] = id +inter c bs = foldr1 (\x y -> x . (c:) . y) bs + +convert' :: (ToString a, IOish m, GmEnv m) => a -> m String +convert' x = flip convert x . optOutput <$> options + +convert :: ToString a => OutputOpts -> a -> String +convert opt@OutputOpts { ooptStyle = LispStyle } x = toLisp opt x "\n" +convert opt@OutputOpts { ooptStyle = PlainStyle } x + | str == "\n" = "" + | otherwise = str + where + str = toPlain opt x "\n" + +class ToString a where + toLisp :: OutputOpts -> a -> Builder + toPlain :: OutputOpts -> a -> Builder + +lineSep :: OutputOpts -> String +lineSep oopts = interpret lsep + where + interpret s = read $ "\"" ++ s ++ "\"" + LineSeparator lsep = ooptLineSeparator oopts + +-- | +-- +-- >>> toLisp (optOutput defaultOptions) "fo\"o" "" +-- "\"fo\\\"o\"" +-- >>> toPlain (optOutput defaultOptions) "foo" "" +-- "foo" +instance ToString String where + toLisp oopts = quote oopts + toPlain oopts = replace '\n' (lineSep oopts) + +-- | +-- +-- >>> toLisp (optOutput defaultOptions) ["foo", "bar", "ba\"z"] "" +-- "(\"foo\" \"bar\" \"ba\\\"z\")" +-- >>> toPlain (optOutput defaultOptions) ["foo", "bar", "baz"] "" +-- "foo\nbar\nbaz" +instance ToString [String] where + toLisp oopts = toSexp1 oopts + toPlain oopts = inter '\n' . map (toPlain oopts) + +instance ToString [ModuleString] where + toLisp oopts = toLisp oopts . map getModuleString + toPlain oopts = toPlain oopts . map getModuleString + +-- | +-- +-- >>> let inp = [((1,2,3,4),"foo"),((5,6,7,8),"bar")] :: [((Int,Int,Int,Int),String)] +-- >>> toLisp (optOutput defaultOptions) inp "" +-- "((1 2 3 4 \"foo\") (5 6 7 8 \"bar\"))" +-- >>> toPlain (optOutput defaultOptions) inp "" +-- "1 2 3 4 \"foo\"\n5 6 7 8 \"bar\"" +instance ToString [((Int,Int,Int,Int),String)] where + toLisp oopts = toSexp2 . map toS + where + toS x = ('(' :) . tupToString oopts x . (')' :) + toPlain oopts = inter '\n' . map (tupToString oopts) + +instance ToString ((Int,Int,Int,Int),String) where + toLisp oopts x = ('(' :) . tupToString oopts x . (')' :) + toPlain oopts x = tupToString oopts x + +instance ToString ((Int,Int,Int,Int),[String]) where + toLisp oopts (x,s) = ('(' :) . fourIntsToString x . + (' ' :) . toLisp oopts s . (')' :) + toPlain oopts (x,s) = fourIntsToString x . ('\n' :) . toPlain oopts s + +instance ToString (String, (Int,Int,Int,Int),[String]) where + toLisp oopts (s,x,y) = toSexp2 [toLisp oopts s, ('(' :) . fourIntsToString x . (')' :), toLisp oopts y] + toPlain oopts (s,x,y) = inter '\n' [toPlain oopts s, fourIntsToString x, toPlain oopts y] + +toSexp1 :: OutputOpts -> [String] -> Builder +toSexp1 oopts ss = ('(' :) . inter ' ' (map (quote oopts) ss) . (')' :) + +toSexp2 :: [Builder] -> Builder +toSexp2 ss = ('(' :) . inter ' ' ss . (')' :) + +fourIntsToString :: (Int,Int,Int,Int) -> Builder +fourIntsToString (a,b,c,d) = (show a ++) . (' ' :) + . (show b ++) . (' ' :) + . (show c ++) . (' ' :) + . (show d ++) + +tupToString :: OutputOpts -> ((Int,Int,Int,Int),String) -> Builder +tupToString oopts ((a,b,c,d),s) = (show a ++) . (' ' :) + . (show b ++) . (' ' :) + . (show c ++) . (' ' :) + . (show d ++) . (' ' :) + . quote oopts s -- fixme: quote is not necessary + +quote :: OutputOpts -> String -> Builder +quote oopts str = ("\"" ++) . (quote' str ++) . ("\"" ++) + where + lsep = lineSep oopts + quote' [] = [] + quote' (x:xs) + | x == '\n' = lsep ++ quote' xs + | x == '\\' = "\\\\" ++ quote' xs + | x == '"' = "\\\"" ++ quote' xs + | otherwise = x : quote' xs + +---------------------------------------------------------------- + +-- Empty result to be returned when no info can be gathered +emptyResult :: Monad m => OutputOpts -> m String +emptyResult oopts = return $ convert oopts ([] :: [String]) + +-- Return an emptyResult when Nothing +whenFound :: (Monad m, ToString b) => OutputOpts -> m (Maybe a) -> (a -> b) -> m String +whenFound oopts from f = maybe (emptyResult oopts) (return . convert oopts . f) =<< from + +-- Return an emptyResult when Nothing, inside a monad +whenFound' :: (Monad m, ToString b) => OutputOpts -> m (Maybe a) -> (a -> m b) -> m String +whenFound' oopts from f = maybe (emptyResult oopts) (\x -> do y <- f x ; return (convert oopts y)) =<< from diff --git a/core/GhcMod/Cradle.hs b/core/GhcMod/Cradle.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Cradle.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE CPP #-} +module GhcMod.Cradle + ( findCradle + , findCradle' + , findCradleNoLog + , findSpecCradle + , cleanupCradle + + -- * for @spec@ + , plainCradle + ) where + +import GhcMod.PathsAndFiles +import GhcMod.Monad.Types +import GhcMod.Types +import GhcMod.Utils +import GhcMod.Stack +import GhcMod.Logging +import GhcMod.Error + +import Safe +import Control.Applicative +import Control.Monad.Trans.Maybe +import Data.Maybe +import System.Directory +import System.FilePath +import System.Environment +import Prelude +import Control.Monad.Trans.Journal (runJournalT) + +---------------------------------------------------------------- + +-- | Finding 'Cradle'. +-- 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) => Programs -> m Cradle +findCradle progs = findCradle' progs =<< liftIO getCurrentDirectory + +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) => 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) => 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 + [] -> fromJust <$> runMaybeT (plainCradle dir) + c:_ -> return c + where + isNotGmCradle crdl = + liftIO $ not <$> doesFileExist (cradleRootDir crdl "ghc-mod.cabal") + +cleanupCradle :: Cradle -> IO () +cleanupCradle crdl = removeDirectoryRecursive $ cradleTempDir crdl + +fillTempDir :: IOish m => Cradle -> m Cradle +fillTempDir crdl = do + tmpDir <- liftIO $ newTempDir (cradleRootDir crdl) + return crdl { cradleTempDir = tmpDir } + +cabalCradle :: + (IOish m, GmLog m, GmOut m) => FilePath -> FilePath -> MaybeT m Cradle +cabalCradle cabalProg wdir = do + cabalFile <- MaybeT $ liftIO $ findCabalFile wdir + let cabalDir = takeDirectory cabalFile + + gmLog GmInfo "" $ text "Found Cabal project at" <+>: text cabalDir + + -- If cabal doesn't exist the user probably wants to use something else + whenM ((==Nothing) <$> liftIO (findExecutable cabalProg)) $ do + gmLog GmInfo "" $ text "'cabal' executable wasn't found, trying next project type" + mzero + + gmLog GmInfo "" $ text "Using Cabal project at" <+>: text cabalDir + return Cradle { + cradleProject = CabalProject + , cradleCurrentDir = wdir + , cradleRootDir = cabalDir + , cradleTempDir = error "tmpDir" + , cradleCabalFile = Just cabalFile + , cradleDistDir = "dist" + } + +stackCradle :: + (IOish m, GmLog m, GmOut m) => FilePath -> FilePath -> MaybeT m Cradle +stackCradle stackProg wdir = do +#if __GLASGOW_HASKELL__ < 708 + -- GHC < 7.8 is not supported by stack + mzero +#endif + + cabalFile <- MaybeT $ liftIO $ findCabalFile wdir + let cabalDir = takeDirectory cabalFile + _stackConfigFile <- MaybeT $ liftIO $ findStackConfigFile cabalDir + + gmLog GmInfo "" $ text "Found Stack project at" <+>: text cabalDir + + stackExeSet <- liftIO $ isJust <$> lookupEnv "STACK_EXE" + stackExeExists <- liftIO $ isJust <$> findExecutable stackProg + setupCfgExists <- liftIO $ doesFileExist $ cabalDir setupConfigPath "dist" + + case (stackExeExists, stackExeSet) of + (False, True) -> do + gmLog GmWarning "" $ text "'stack' executable wasn't found but STACK_EXE is set, trying next project type" + mzero + + (False, False) -> do + gmLog GmInfo "" $ text "'stack' executable wasn't found, trying next project type" + mzero + + (True, True) -> do + gmLog GmInfo "" $ text "STACK_EXE set, preferring Stack project" + + (True, False) | setupCfgExists -> do + gmLog GmWarning "" $ text "'dist/setup-config' exists, ignoring Stack project" + mzero + + (True, False) -> return () + + senv <- MaybeT $ getStackEnv cabalDir stackProg + + gmLog GmInfo "" $ text "Using Stack project at" <+>: text cabalDir + return Cradle { + cradleProject = StackProject senv + , cradleCurrentDir = wdir + , cradleRootDir = cabalDir + , cradleTempDir = error "tmpDir" + , cradleCabalFile = Just cabalFile + , cradleDistDir = seDistDir senv + } + +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 + when b mzero + return crdl + _ -> error "stackCradleSpec" + where + isGmDistDir dir = + liftIO $ not <$> doesFileExist (dir ".." "ghc-mod.cabal") + +sandboxCradle :: (IOish m, GmLog m, GmOut m) => FilePath -> MaybeT m Cradle +sandboxCradle wdir = do + sbDir <- MaybeT $ liftIO $ findCabalSandboxDir wdir + gmLog GmInfo "" $ text "Using sandbox project at" <+>: text sbDir + return Cradle { + cradleProject = SandboxProject + , cradleCurrentDir = wdir + , cradleRootDir = sbDir + , cradleTempDir = error "tmpDir" + , cradleCabalFile = Nothing + , cradleDistDir = "dist" + } + +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 + , cradleRootDir = wdir + , cradleTempDir = error "tmpDir" + , cradleCabalFile = Nothing + , cradleDistDir = "dist" + } diff --git a/core/GhcMod/CustomPackageDb.hs b/core/GhcMod/CustomPackageDb.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/CustomPackageDb.hs @@ -0,0 +1,38 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . +module GhcMod.CustomPackageDb where + +import Control.Applicative +import Control.Monad +import Control.Category ((.)) +import Data.Maybe +import Data.Traversable +import GhcMod.Types +import GhcMod.Monad.Types +import GhcMod.PathsAndFiles +import Prelude hiding ((.)) + +parseCustomPackageDb :: String -> [GhcPkgDb] +parseCustomPackageDb src = map parsePkgDb $ filter (not . null) $ lines src + where + parsePkgDb "global" = GlobalDb + parsePkgDb "user" = UserDb + parsePkgDb s = PackageDb s + +getCustomPkgDbStack :: (MonadIO m, GmEnv m) => m (Maybe [GhcPkgDb]) +getCustomPkgDbStack = do + mCusPkgDbFile <- liftIO . (traverse readFile <=< findCustomPackageDbFile) . cradleRootDir =<< cradle + return $ parseCustomPackageDb <$> mCusPkgDbFile diff --git a/core/GhcMod/DebugLogger.hs b/core/GhcMod/DebugLogger.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/DebugLogger.hs @@ -0,0 +1,138 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . +{-# LANGUAGE CPP, RankNTypes #-} +module GhcMod.DebugLogger where + +-- (c) The University of Glasgow 2005 +-- +-- The Glasgow Haskell Compiler License +-- +-- Copyright 2002, The University Court of the University of Glasgow. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- - Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright notice, +-- this list of conditions and the following disclaimer in the documentation +-- and/or other materials provided with the distribution. +-- +-- - Neither name of the University nor the names of its contributors may be +-- used to endorse or promote products derived from this software without +-- specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF +-- GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +-- INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +-- FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +-- UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +-- LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +-- OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +-- DAMAGE. + +import GHC +import FastString +import Pretty +import Outputable (SDoc, PprStyle, runSDoc, initSDocContext, blankLine) +import qualified Outputable +import ErrUtils + +import GhcMod.Error +import GhcMod.Gap +import Prelude + +debugLogAction :: (String -> IO ()) -> GmLogAction +debugLogAction putErr _reason dflags severity srcSpan style' msg + = case severity of + SevOutput -> printSDoc putErr msg style' + +#if __GLASGOW_HASKELL__ >= 706 + SevDump -> printSDoc putErr (msg Outputable.$$ blankLine) style' +#endif + +#if __GLASGOW_HASKELL__ >= 708 + SevInteractive -> let + putStrSDoc = debugLogActionHPutStrDoc dflags putErr + in + putStrSDoc msg style' +#endif + SevInfo -> printErrs putErr msg style' + SevFatal -> printErrs putErr msg style' + _ -> do putErr "\n" +#if __GLASGOW_HASKELL__ >= 706 + printErrs putErr (mkLocMessage severity srcSpan msg) style' +#else + printErrs putErr (mkLocMessage srcSpan msg) style' +#endif + -- careful (#2302): printErrs prints in UTF-8, + -- whereas converting to string first and using + -- hPutStr would just emit the low 8 bits of + -- each unicode char. + where +#if __GLASGOW_HASKELL__ >= 706 + printSDoc put = debugLogActionHPrintDoc dflags put + printErrs put = debugLogActionHPrintDoc dflags put +#endif + + +#if __GLASGOW_HASKELL__ >= 706 + +debugLogActionHPrintDoc :: DynFlags -> (String -> IO ()) -> SDoc -> PprStyle -> IO () +debugLogActionHPrintDoc dflags put d sty + = debugLogActionHPutStrDoc dflags put (d Outputable.$$ Outputable.text "") sty + -- Adds a newline + +debugLogActionHPutStrDoc :: DynFlags -> (String -> IO ()) -> SDoc -> PprStyle -> IO () +debugLogActionHPutStrDoc dflags put d sty + = gmPrintDoc_ Pretty.PageMode (pprCols dflags) put doc + where -- Don't add a newline at the end, so that successive + -- calls to this log-action can output all on the same line + doc = runSDoc d (initSDocContext dflags sty) + +#else + +printSDoc = printErrs + +printErrs :: (String -> IO ()) -> SDoc -> PprStyle -> IO () +printErrs put doc sty = do + gmPrintDoc PageMode 100 put (runSDoc doc (initSDocContext sty)) + +#endif + +gmPrintDoc :: Mode -> Int -> (String -> IO ()) -> Doc -> IO () +-- printDoc adds a newline to the end +gmPrintDoc mode cols put doc = gmPrintDoc_ mode cols put (doc $$ text "") + +gmPrintDoc_ :: Mode -> Int -> (String -> IO ()) -> Doc -> IO () +gmPrintDoc_ mode pprCols putS doc + = fullRender mode pprCols 1.5 put done doc + where + put (Chr c) next = putS [c] >> next + put (Str s) next = putS s >> next + put (PStr s) next = putS (unpackFS s) >> next +#if __GLASGOW_HASKELL__ >= 708 + put (ZStr s) next = putS (zString s) >> next +#endif + put (LStr s _l) next = putS (unpackLitString s) >> next + + done = return () -- hPutChar hdl '\n' diff --git a/core/GhcMod/Doc.hs b/core/GhcMod/Doc.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Doc.hs @@ -0,0 +1,20 @@ +module GhcMod.Doc where + +import GHC +import GhcMod.Gap (withStyle, showDocWith) +import Outputable +import Pretty (Mode(..)) + +showPage :: DynFlags -> PprStyle -> SDoc -> String +showPage dflag style = showDocWith dflag PageMode . withStyle dflag style + +showOneLine :: DynFlags -> PprStyle -> SDoc -> String +showOneLine dflag style = showDocWith dflag OneLineMode . withStyle dflag style + +getStyle :: GhcMonad m => m PprStyle +getStyle = do + unqual <- getPrintUnqual + return $ mkUserStyle unqual AllTheWay + +styleUnqualified :: PprStyle +styleUnqualified = mkUserStyle neverQualify AllTheWay diff --git a/core/GhcMod/DynFlags.hs b/core/GhcMod/DynFlags.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/DynFlags.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE TemplateHaskell #-} + +module GhcMod.DynFlags where + +import Control.Applicative +import Control.Monad +import GHC +import qualified GHC as G +import GHC.Paths (libdir) +import qualified GhcMod.Gap as Gap +import GhcMod.Types +import GhcMod.DebugLogger +import GhcMod.DynFlagsTH +import System.IO.Unsafe (unsafePerformIO) +import Prelude + +setEmptyLogger :: DynFlags -> DynFlags +setEmptyLogger df = + Gap.setLogAction df $ \_ _ _ _ _ _ -> return () + +setDebugLogger :: (String -> IO ()) -> DynFlags -> DynFlags +setDebugLogger put df = do + Gap.setLogAction df (debugLogAction put) + +-- * Fast +-- * Friendly to foreign export +-- * Not friendly to -XTemplateHaskell and -XPatternSynonyms +-- * Uses little memory +setHscNothing :: DynFlags -> DynFlags +setHscNothing df = df { + ghcMode = CompManager + , ghcLink = NoLink + , hscTarget = HscNothing + , optLevel = 0 + } + +-- * Slow +-- * Not friendly to foreign export +-- * Friendly to -XTemplateHaskell and -XPatternSynonyms +-- * Uses lots of memory +setHscInterpreted :: DynFlags -> DynFlags +setHscInterpreted df = df { + ghcMode = CompManager + , ghcLink = LinkInMemory + , hscTarget = HscInterpreted + , optLevel = 0 + } + +-- | Parse command line ghc options and add them to the 'DynFlags' passed +addCmdOpts :: GhcMonad m => [GHCOption] -> DynFlags -> m DynFlags +addCmdOpts cmdOpts df = + fst3 <$> G.parseDynamicFlags df (map G.noLoc cmdOpts) + where + fst3 (a,_,_) = a + +---------------------------------------------------------------- + +withDynFlags :: GhcMonad m + => (DynFlags -> DynFlags) + -> m a + -> m a +withDynFlags setFlags body = G.gbracket setup teardown (\_ -> body) + where + setup = do + dflags <- G.getSessionDynFlags + void $ G.setSessionDynFlags (setFlags dflags) + return dflags + teardown = void . G.setSessionDynFlags + +withCmdFlags :: GhcMonad m => [GHCOption] -> m a -> m a +withCmdFlags flags body = G.gbracket setup teardown (\_ -> body) + where + setup = do + dflags <- G.getSessionDynFlags + void $ G.setSessionDynFlags =<< addCmdOpts flags dflags + return dflags + teardown = void . G.setSessionDynFlags + +---------------------------------------------------------------- + +-- | Set 'DynFlags' equivalent to "-w:". +setNoWarningFlags :: DynFlags -> DynFlags +setNoWarningFlags df = df { warningFlags = Gap.emptyWarnFlags} + +-- | Set 'DynFlags' equivalent to "-Wall". +setAllWarningFlags :: DynFlags -> DynFlags +setAllWarningFlags df = df { warningFlags = allWarningFlags } + +allWarningFlags :: Gap.WarnFlags +allWarningFlags = unsafePerformIO $ + G.runGhc (Just libdir) $ do + df <- G.getSessionDynFlags + df' <- addCmdOpts ["-Wall"] df + return $ G.warningFlags df' + +---------------------------------------------------------------- + +deferErrors :: Monad m => DynFlags -> m DynFlags +deferErrors df = return $ + Gap.setWarnTypedHoles $ Gap.setDeferTypedHoles $ + Gap.setDeferTypeErrors $ setNoWarningFlags df + +---------------------------------------------------------------- + +deriveEqDynFlags [d| + eqDynFlags :: DynFlags -> DynFlags -> Bool + eqDynFlags = undefined + |] diff --git a/core/GhcMod/DynFlagsTH.hs b/core/GhcMod/DynFlagsTH.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/DynFlagsTH.hs @@ -0,0 +1,144 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +{-# LANGUAGE CPP, TemplateHaskell #-} +module GhcMod.DynFlagsTH where + +import Language.Haskell.TH +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 (fun@(Name (OccName fon) _), _, ft) + | not (isUneqable || isIgnored) = Just expr + | otherwise = Nothing + where + isUneqable = everything (||) (mkQ False hasUnEqable) ft + + hasUnEqable (AppT (ConT (Name (OccName on) _)) _) + | any (==on) ignoredConstructorNames = True + hasUnEqable (ConT (Name (OccName on) _)) + | any (==on) ignoredTypeNames = True + | any (==on) ignoredTypeOccNames = True + hasUnEqable _ = False + + isIgnored = fon `elem` ignoredNames + + ignoredConstructorNames = [ "IORef" ] + + 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 fun) (VarE a) + fb = AppE (VarE fun) (VarE b) + expr = + case fon of + "rtsOptsEnabled" -> do + let eqfn = [| let fn RtsOptsNone RtsOptsNone = True + fn RtsOptsSafeOnly RtsOptsSafeOnly = True + fn RtsOptsAll RtsOptsAll = True + fn _ _ = False + in fn + |] + [e| $(eqfn) $(return fa) $(return fb) |] + + "extraPkgConfs" -> do + let eqfn = [| let fn a' b' = and (zipWith eqpr (a' []) (b' [])) + && length (a' []) == length (b' []) + eqpr GlobalPkgConf GlobalPkgConf = True + eqpr UserPkgConf UserPkgConf = True + eqpr (PkgConfFile pa) (PkgConfFile pb) = pa == pb + eqpr _ _ = False + in fn + |] + [e| $(eqfn) $(return fa) $(return fb) |] + +#if __GLASGOW_HASKELL__ >= 710 && __GLASGOW_HASKELL__ < 800 + "sigOf" -> do + let eqfn = [| let fn NotSigOf NotSigOf = True + fn (SigOf a') (SigOf b') = a' == b' + fn (SigOfMap a') (SigOfMap b') = a' == b' + fn _ _ = False + in fn + |] + [e| $(eqfn) $(return fa) $(return fb) |] +#endif + +#if __GLASGOW_HASKELL <= 706 + "profAuto" -> do + let eqfn = [| let fn NoProfAuto NoProfAuto = True + fn ProfAutoAll ProfAutoAll = True + fn ProfAutoTop ProfAutoTop = True + fn ProfAutoExports ProfAutoExports = True + fn ProfAutoCalls ProfAutoCalls = True + fn _ _ = False + in fn + |] + [e| $(eqfn) $(return fa) $(return fb) |] +#endif + +#if __GLASGOW_HASKELL__ >= 706 + "language" -> do + let eqfn = [| let fn (Just Haskell98) (Just Haskell98) = True + fn (Just Haskell2010) (Just Haskell2010) = True + fn Nothing Nothing = True + fn _ _ = False + in fn + |] + [e| $(eqfn) $(return fa) $(return fb) |] +#endif + + _ -> + [e| $(return fa) == $(return fb) |] + +-- expr' = [e| trace (if $(expr) == True then "" else show ($(litE $ StringL fon), $(expr))) $(expr) |] diff --git a/core/GhcMod/Error.hs b/core/GhcMod/Error.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Error.hs @@ -0,0 +1,160 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +{-# LANGUAGE ExistentialQuantification #-} +module GhcMod.Error ( + GhcModError(..) + , GmError + , gmeDoc + , ghcExceptionDoc + , liftMaybe + , overrideError + , modifyError + , modifyError' + , modifyGmError + , tryFix + , GHandler(..) + , gcatches + , module Control.Monad.Error + , module Control.Exception + ) where + +import Control.Arrow hiding ((<+>)) +import Control.Exception +import Control.Monad.Error hiding (MonadIO, liftIO) +import qualified Data.Set as Set +import Data.List +import Data.Version +import System.Process (showCommandForUser) +import Text.Printf + +import Exception +import Panic +import Pretty +import Config (cProjectVersion, cHostPlatformString) +import Paths_ghc_mod (version) + +import GhcMod.Types +import GhcMod.Pretty + +type GmError m = MonadError GhcModError m + +gmeDoc :: GhcModError -> Doc +gmeDoc e = case e of + GMENoMsg -> + text "Unknown error" + GMEString msg -> + text msg + GMECabalConfigure msg -> + text "Configuring cabal project failed" <+>: gmeDoc msg + GMEStackConfigure msg -> + text "Configuring stack project failed" <+>: gmeDoc msg + GMEStackBootstrap msg -> + text "Bootstrapping stack project environment failed" <+>: gmeDoc msg + GMECabalCompAssignment ctx -> + text "Could not find a consistent component assignment for modules:" $$ + (nest 4 $ foldr ($+$) empty $ map ctxDoc ctx) $$ + text "" $$ + (if all (Set.null . snd) ctx + then noComponentSuggestions + else empty) $$ + text "- To find out which components ghc-mod knows about try:" $$ + nest 4 (backticks $ text "ghc-mod debug") + + where + noComponentSuggestions = + text "- Are some of these modules part of a test and or benchmark?\ + \ Try enabling them:" $$ + nest 4 (backticks $ text "cabal configure --enable-tests [--enable-benchmarks]") + + backticks d = char '`' <> d <> char '`' + ctxDoc = moduleDoc *** compsDoc + >>> first (<> colon) >>> uncurry (flip hang 4) + + moduleDoc (Left fn) = + text "File " <> quotes (text fn) + moduleDoc (Right mdl) = + text "Module " <> quotes (text $ moduleNameString mdl) + + compsDoc sc | Set.null sc = text "has no known components" + compsDoc sc = fsep $ punctuate comma $ + map gmComponentNameDoc $ Set.toList sc + GMEProcess _fn cmd args emsg -> let c = showCommandForUser cmd args in + case emsg of + Right err -> + text (printf "Launching system command `%s` failed: " c) + <> gmeDoc err + Left rv -> text $ + printf "Launching system command `%s` failed (exited with %d)" c rv + GMENoCabalFile -> + text "No cabal file found." + GMETooManyCabalFiles cfs -> + text $ "Multiple cabal files found. Possible cabal files: \"" + ++ intercalate "\", \"" cfs ++"\"." + +ghcExceptionDoc :: GhcException -> Doc +ghcExceptionDoc e@(CmdLineError _) = + text $ ": " ++ showGhcException e "" +ghcExceptionDoc (UsageError str) = strDoc str +ghcExceptionDoc (Panic msg) = vcat $ map text $ lines $ printf "\ +\GHC panic! (the 'impossible' happened)\n\ +\ ghc-mod version %s\n\ +\ GHC library version %s for %s:\n\ +\ %s\n\ +\\n\ +\Please report this as a bug: %s\n" + gmVer ghcVer platform msg url + where + gmVer = showVersion version + ghcVer = cProjectVersion + platform = cHostPlatformString + url = "https://github.com/kazu-yamamoto/ghc-mod/issues" :: String + +ghcExceptionDoc e = text $ showGhcException e "" + +liftMaybe :: MonadError e m => e -> m (Maybe a) -> m a +liftMaybe e action = maybe (throwError e) return =<< action + +overrideError :: MonadError e m => e -> m a -> m a +overrideError e action = modifyError (const e) action + +modifyError :: MonadError e m => (e -> e) -> m a -> m a +modifyError f action = action `catchError` \e -> throwError $ f e + +infixr 0 `modifyError'` +modifyError' :: MonadError e m => m a -> (e -> e) -> m a +modifyError' = flip modifyError + +modifyGmError :: (MonadIO m, ExceptionMonad m) + => (GhcModError -> GhcModError) -> m a -> m a +modifyGmError f a = gcatch a $ \(ex :: GhcModError) -> liftIO $ throwIO (f ex) + +tryFix :: MonadError e m => m a -> (e -> m ()) -> m a +tryFix action f = do + action `catchError` \e -> f e >> action + +data GHandler m a = forall e . Exception e => GHandler (e -> m a) + +gcatches :: (MonadIO m, ExceptionMonad m) => m a -> [GHandler m a] -> m a +gcatches io handlers = io `gcatch` gcatchesHandler handlers + +gcatchesHandler :: (MonadIO m, ExceptionMonad m) + => [GHandler m a] -> SomeException -> m a +gcatchesHandler handlers e = foldr tryHandler (liftIO $ throw e) handlers + where tryHandler (GHandler handler) res + = case fromException e of + Just e' -> handler e' + Nothing -> res diff --git a/core/GhcMod/FileMapping.hs b/core/GhcMod/FileMapping.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/FileMapping.hs @@ -0,0 +1,104 @@ +module GhcMod.FileMapping + ( loadMappedFile + , loadMappedFileSource + , unloadMappedFile + , mapFile + , fileModSummaryWithMapping + ) where + +import GhcMod.Types +import GhcMod.Monad.Types +import GhcMod.Gap +import GhcMod.HomeModuleGraph +import GhcMod.Utils + +import System.IO +import System.FilePath +import System.Directory + +import Control.Monad.Trans.Maybe +import GHC +import Control.Monad + +{- | maps 'FilePath', given as first argument to take source from +'FilePath' given as second argument. Works exactly the same as +first form of `--map-file` CLI option. + +\'from\' can be either full path, or path relative to project root. +\'to\' has to be either relative to project root, or full path (preferred) +-} +loadMappedFile :: IOish m + => FilePath -- ^ \'from\', file that will be mapped + -> FilePath -- ^ \'to\', file to take source from + -> GhcModT m () +loadMappedFile from to = loadMappedFile' from to False + +{- | +maps 'FilePath', given as first argument to have source as given +by second argument. + +\'from\' may or may not exist, and should be either full path, +or relative to project root. +-} +loadMappedFileSource :: IOish m + => FilePath -- ^ \'from\', file that will be mapped + -> String -- ^ \'src\', source + -> 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 + loadMappedFile' from to True + +loadMappedFile' :: IOish m => FilePath -> FilePath -> Bool -> GhcModT m () +loadMappedFile' from to isTemp = do + cfn <- getCanonicalFileNameSafe from + unloadMappedFile' cfn + crdl <- cradle + let to' = makeRelative (cradleRootDir crdl) to + addMMappedFile cfn (FileMapping to' isTemp) + +mapFile :: (IOish m, GmState m) => HscEnv -> Target -> m Target +mapFile _ (Target tid@(TargetFile filePath _) taoc _) = do + mapping <- lookupMMappedFile filePath + 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) + return $ mkMappedTarget fp tid taoc mapping + +mkMappedTarget :: Maybe FilePath -> TargetId -> Bool -> Maybe FileMapping -> Target +mkMappedTarget _ _ taoc (Just to) = + 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, +and removes any temporary files created when file was +mapped. + +\'file\' should be either full path, or relative to project root. +-} +unloadMappedFile :: IOish m + => FilePath -- ^ \'file\', file to unmap + -> GhcModT m () +unloadMappedFile = getCanonicalFileNameSafe >=> unloadMappedFile' + +unloadMappedFile' :: IOish m => FilePath -> GhcModT m () +unloadMappedFile' cfn = void $ runMaybeT $ do + fm <- MaybeT $ lookupMMappedFile cfn + liftIO $ when (fmTemp fm) $ removeFile (fmPath fm) + delMMappedFile cfn + +fileModSummaryWithMapping :: (IOish m, GmState m, GhcMonad m, GmEnv m) => + FilePath -> m ModSummary +fileModSummaryWithMapping fn = + withMappedFile fn $ \fn' -> fileModSummary fn' diff --git a/core/GhcMod/Gap.hs b/core/GhcMod/Gap.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Gap.hs @@ -0,0 +1,723 @@ +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, CPP, ScopedTypeVariables, RankNTypes #-} + +module GhcMod.Gap ( + GhcMod.Gap.ClsInst + , mkTarget + , withStyle + , GmLogAction + , setLogAction + , getSrcSpan + , getSrcFile + , withInteractiveContext + , ghcCmdOptions + , toStringBuffer + , showSeverityCaption + , setCabalPkg + , setHideAllPackages + , setDeferTypeErrors + , setDeferTypedHoles + , setWarnTypedHoles + , setDumpSplices + , setNoMaxRelevantBindings + , isDumpSplices + , filterOutChildren + , infoThing + , pprInfo + , HasType(..) + , errorMsgSpan + , setErrorMsgSpan + , typeForUser + , nameForUser + , occNameForUser + , deSugar + , showDocWith + , renderGm + , GapThing(..) + , fromTyThing + , fileModSummary + , WarnFlags + , emptyWarnFlags + , GLMatch + , GLMatchI + , getClass + , occName + , listVisibleModuleNames + , listVisibleModules + , lookupModulePackageInAllPackages + , GhcMod.Gap.isSynTyCon + , parseModuleHeader + , mkErrStyle' + , everythingStagedWithContext + , withCleanupSession + ) where + +import Control.Applicative hiding (empty) +import Control.Monad (filterM) +import CoreSyn (CoreExpr) +import Data.List (intersperse) +import Data.Maybe (catMaybes) +import Data.Time.Clock (UTCTime) +import Data.Traversable hiding (mapM) +import DataCon (dataConUserType) +import Desugar (deSugarExpr) +import DynFlags +import ErrUtils +import Exception +import FastString +import GhcMonad +import HscTypes +import NameSet +import OccName +import Outputable +import PprTyThing +import StringBuffer +import TcType +import Var (varType) +import System.Directory +import SysTools +#if __GLASGOW_HASKELL__ >= 800 +import GHCi (stopIServ) +#endif + +import qualified Name +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 +#else +import TcRnTypes +#endif + +-- GHC 7.8 doesn't define this macro, nor does GHC 7.10.0 +-- It IS defined from 7.10.1 and up though. +-- So we can only test for 7.10.1.0 and up with it. +#if __GLASGOW_HASKELL__ < 710 +#ifndef MIN_VERSION_GLASGOW_HASKELL +#define MIN_VERSION_GLASGOW_HASKELL(a,b,c,d) FALSE +#endif +#endif + +#if MIN_VERSION_GLASGOW_HASKELL(8,0,1,20161117) +import GHC hiding (ClsInst, withCleanupSession) +import qualified GHC (withCleanupSession) +#elif __GLASGOW_HASKELL__ >= 706 +import GHC hiding (ClsInst) +#else +import GHC hiding (Instance) +import Control.Arrow hiding ((<+>)) +import Data.Convertible +import RdrName (rdrNameOcc) +#endif + +#if __GLASGOW_HASKELL__ < 710 +import UniqFM (eltsUFM) +import Module +#endif + +#if __GLASGOW_HASKELL__ >= 704 +import qualified Data.IntSet as I (IntSet, empty) +#endif + +#if __GLASGOW_HASKELL__ < 706 +import Control.DeepSeq (NFData(rnf)) +import Data.ByteString.Lazy.Internal (ByteString(..)) +#endif + +import Bag +import Lexer as L +import Parser +import SrcLoc +import Packages +import Data.Generics (GenericQ, extQ, gmapQ) +import GHC.SYB.Utils (Stage(..)) + +import GhcMod.Types (Expression(..)) +import Prelude + +---------------------------------------------------------------- +---------------------------------------------------------------- +-- +#if __GLASGOW_HASKELL__ >= 706 +type ClsInst = InstEnv.ClsInst +#else +type ClsInst = InstEnv.Instance +#endif + +mkTarget :: TargetId -> Bool -> Maybe (SB.StringBuffer, UTCTime) -> Target +#if __GLASGOW_HASKELL__ >= 706 +mkTarget = Target +#else +mkTarget tid allowObjCode = Target tid allowObjCode . (fmap . second) convert +#endif + +---------------------------------------------------------------- +---------------------------------------------------------------- + +withStyle :: DynFlags -> PprStyle -> SDoc -> Pretty.Doc +#if __GLASGOW_HASKELL__ >= 706 +withStyle = withPprStyleDoc +#else +withStyle _ = withPprStyleDoc +#endif + +#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 = forall a. a -> DynFlags -> LogAction +#endif + +-- DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO () + +setLogAction :: DynFlags -> GmLogAction -> DynFlags +setLogAction df 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 (error "setLogAction") df } +#endif + +showDocWith :: DynFlags -> Pretty.Mode -> Pretty.Doc -> String +#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) +#else +showDocWith _ = Pretty.showDocWith +#endif + +renderGm :: Pretty.Doc -> String +#if __GLASGOW_HASKELL__ >= 800 +renderGm = Pretty.fullRender Pretty.PageMode 80 1.2 string_txt "" +#else +renderGm = Pretty.fullRender Pretty.PageMode 80 1.2 string_txt "" +#endif + where + string_txt :: Pretty.TextDetails -> String -> String + string_txt (Pretty.Chr c) s = c:s + string_txt (Pretty.Str s1) s2 = s1 ++ s2 + string_txt (Pretty.PStr s1) s2 = unpackFS s1 ++ s2 + string_txt (Pretty.LStr s1 _) s2 = unpackLitString s1 ++ s2 +#if __GLASGOW_HASKELL__ >= 708 + string_txt (Pretty.ZStr s1) s2 = zString s1 ++ s2 +#endif + + +---------------------------------------------------------------- +---------------------------------------------------------------- + +getSrcSpan :: SrcSpan -> Maybe (Int,Int,Int,Int) +#if __GLASGOW_HASKELL__ >= 702 +getSrcSpan (RealSrcSpan spn) +#else +getSrcSpan spn | isGoodSrcSpan spn +#endif + = Just (srcSpanStartLine spn + , srcSpanStartCol spn + , srcSpanEndLine spn + , srcSpanEndCol spn) +getSrcSpan _ = Nothing + +getSrcFile :: SrcSpan -> Maybe String +#if __GLASGOW_HASKELL__ >= 702 +getSrcFile (RealSrcSpan spn) = Just . unpackFS . srcSpanFile $ spn +#else +getSrcFile spn | isGoodSrcSpan spn = Just . unpackFS . srcSpanFile $ spn +#endif +getSrcFile _ = Nothing + +---------------------------------------------------------------- + +toStringBuffer :: GhcMonad m => [String] -> m StringBuffer +#if __GLASGOW_HASKELL__ >= 702 +toStringBuffer = return . stringToStringBuffer . unlines +#else +toStringBuffer = liftIO . stringToStringBuffer . unlines +#endif + +---------------------------------------------------------------- + +ghcCmdOptions :: [String] +#if __GLASGOW_HASKELL__ >= 710 +-- 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 + where opts = + [option | (option,_,_,_) <- fFlags] + ++ [option | (option,_,_,_) <- fWarningFlags] + ++ [option | (option,_,_,_) <- fLangFlags] +# endif +#endif + +---------------------------------------------------------------- +---------------------------------------------------------------- + +fileModSummary :: GhcMonad m => FilePath -> m ModSummary +fileModSummary file' = do + mss <- getModuleGraph + file <- liftIO $ canonicalizePath file' + [ms] <- liftIO $ flip filterM mss $ \m -> + (Just file==) <$> canonicalizePath `traverse` ml_hs_file (ms_location m) + return ms + +withInteractiveContext :: GhcMonad m => m a -> m a +withInteractiveContext action = gbracket setup teardown body + where + setup = getContext + teardown = setCtx + body _ = do + topImports >>= setCtx + action + topImports = do + ms <- filterM moduleIsInterpreted =<< map ms_mod <$> getModuleGraph + let iis = map (IIModule . modName) ms +#if __GLASGOW_HASKELL__ >= 704 + return iis +#else + return (iis,[]) +#endif +#if __GLASGOW_HASKELL__ >= 706 + modName = moduleName + setCtx = setContext +#elif __GLASGOW_HASKELL__ >= 704 + modName = id + setCtx = setContext +#else + modName = ms_mod + setCtx = uncurry setContext +#endif + +showSeverityCaption :: Severity -> String +#if __GLASGOW_HASKELL__ >= 706 +showSeverityCaption SevWarning = "Warning: " +showSeverityCaption _ = "" +#else +showSeverityCaption = const "" +#endif + +---------------------------------------------------------------- +---------------------------------------------------------------- + +setCabalPkg :: DynFlags -> DynFlags +#if __GLASGOW_HASKELL__ >= 708 +setCabalPkg dflag = gopt_set dflag Opt_BuildingCabalPackage +#else +setCabalPkg dflag = dopt_set dflag Opt_BuildingCabalPackage +#endif + +---------------------------------------------------------------- + +setHideAllPackages :: DynFlags -> DynFlags +#if __GLASGOW_HASKELL__ >= 708 +setHideAllPackages df = gopt_set df Opt_HideAllPackages +#else +setHideAllPackages df = dopt_set df Opt_HideAllPackages +#endif + +---------------------------------------------------------------- + +setDumpSplices :: DynFlags -> DynFlags +setDumpSplices dflag = dopt_set dflag Opt_D_dump_splices + +isDumpSplices :: DynFlags -> Bool +isDumpSplices dflag = dopt Opt_D_dump_splices dflag + +---------------------------------------------------------------- + + +setDeferTypeErrors :: DynFlags -> DynFlags +#if __GLASGOW_HASKELL__ >= 708 +setDeferTypeErrors dflag = gopt_set dflag Opt_DeferTypeErrors +#elif __GLASGOW_HASKELL__ >= 706 +setDeferTypeErrors dflag = dopt_set dflag Opt_DeferTypeErrors +#else +setDeferTypeErrors = id +#endif + +setDeferTypedHoles :: DynFlags -> DynFlags +#if __GLASGOW_HASKELL__ >= 710 +setDeferTypedHoles dflag = gopt_set dflag Opt_DeferTypedHoles +#else +setDeferTypedHoles = id +#endif + +setWarnTypedHoles :: DynFlags -> DynFlags +#if __GLASGOW_HASKELL__ >= 708 +setWarnTypedHoles dflag = wopt_set dflag Opt_WarnTypedHoles +#else +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 + +---------------------------------------------------------------- +---------------------------------------------------------------- + +class HasType a where + getType :: GhcMonad m => TypecheckedModule -> a -> m (Maybe (SrcSpan, Type)) + + +instance HasType (LHsBind Id) where +#if __GLASGOW_HASKELL__ >= 708 + getType _ (L spn FunBind{fun_matches = m}) = return $ Just (spn, typ) + where in_tys = mg_arg_tys m + out_typ = mg_res_ty m + typ = mkFunTys in_tys out_typ +#else + getType _ (L spn FunBind{fun_matches = MatchGroup _ typ}) = return $ Just (spn, typ) +#endif + getType _ _ = return Nothing + +---------------------------------------------------------------- +---------------------------------------------------------------- +-- from ghc/InteractiveUI.hs + +filterOutChildren :: (a -> TyThing) -> [a] -> [a] +filterOutChildren get_thing xs + = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)] + where + implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)] + +infoThing :: GhcMonad m => (FilePath -> FilePath) -> Expression -> m SDoc +infoThing m (Expression str) = do + names <- parseName str +#if __GLASGOW_HASKELL__ >= 708 + mb_stuffs <- mapM (getInfo False) names + let filtered = filterOutChildren (\(t,_f,_i,_fam) -> t) (catMaybes mb_stuffs) +#else + mb_stuffs <- mapM getInfo names + let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs) +#endif + return $ vcat (intersperse (text "") $ map (pprInfo m False) filtered) + +#if __GLASGOW_HASKELL__ >= 708 +pprInfo :: (FilePath -> FilePath) -> Bool -> (TyThing, GHC.Fixity, [ClsInst], [FamInst]) -> SDoc +pprInfo m _ (thing, fixity, insts, famInsts) + = pprTyThingInContextLoc' thing + $$ show_fixity fixity + $$ 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) +#endif + where + show_fixity fx + | fx == defaultFixity = Outputable.empty + | otherwise = ppr fx <+> ppr (getName thing) +#if __GLASGOW_HASKELL__ >= 708 + 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 + 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) + UnhelpfulLoc s + | Name.isInternalName name || Name.isSystemName name + -> ptext (sLit "at") <+> ftext s + | otherwise + -> ptext (sLit "in") <+> quotes (ppr (nameModule name)) + where subst s = mkRealSrcLoc (realFP s) (srcLocLine s) (srcLocCol s) + realFP = mkFastString . m . unpackFS . srcLocFile + +---------------------------------------------------------------- +---------------------------------------------------------------- + +errorMsgSpan :: ErrMsg -> SrcSpan +#if __GLASGOW_HASKELL__ >= 708 +errorMsgSpan = errMsgSpan +#else +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 +#else +typeForUser = pprTypeForUser False +#endif + +nameForUser :: Name -> SDoc +nameForUser = pprOccName . getOccName + +occNameForUser :: OccName -> SDoc +occNameForUser = pprOccName + +deSugar :: TypecheckedModule -> LHsExpr Id -> HscEnv + -> IO (Maybe CoreExpr) +#if __GLASGOW_HASKELL__ >= 708 +deSugar _ e hs_env = snd <$> deSugarExpr hs_env e +#else +deSugar tcm e hs_env = snd <$> deSugarExpr hs_env modu rn_env ty_env e + where + modu = ms_mod $ pm_mod_summary $ tm_parsed_module tcm + tcgEnv = fst $ tm_internals_ tcm + rn_env = tcg_rdr_env tcgEnv + ty_env = tcg_type_env tcgEnv +#endif + +---------------------------------------------------------------- +---------------------------------------------------------------- + +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 $ dataConUserType 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 $ dataConUserType d +#endif +fromTyThing (ATyCon t) = GtT t +fromTyThing _ = GtN + +---------------------------------------------------------------- +---------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ >= 704 +type WarnFlags = I.IntSet +emptyWarnFlags :: WarnFlags +emptyWarnFlags = I.empty +#else +type WarnFlags = [WarningFlag] +emptyWarnFlags :: WarnFlags +emptyWarnFlags = [] +#endif + +---------------------------------------------------------------- +---------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ >= 708 +type GLMatch = LMatch RdrName (LHsExpr RdrName) +type GLMatchI = LMatch Id (LHsExpr Id) +#else +type GLMatch = LMatch RdrName +type GLMatchI = LMatch Id +#endif + +getClass :: [LInstDecl Name] -> Maybe (Name, SrcSpan) +#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) +getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsAppTy (L _ (HsTyVar className)) _))}))] = Just (className, loc) +#elif __GLASGOW_HASKELL__ >= 708 +-- 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) +getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsAppTy (L _ (HsTyVar className)) _))}))] = Just (className, loc) +#elif __GLASGOW_HASKELL__ >= 706 +getClass [L loc (ClsInstD (L _ (HsForAllTy _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _)))) _ _ _)] = Just (className, loc) +getClass[L loc (ClsInstD (L _ (HsAppTy (L _ (HsTyVar className)) _)) _ _ _)] = Just (className, loc) +#else +getClass [L loc (InstDecl (L _ (HsForAllTy _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _)))) _ _ _)] = Just (className, loc) +getClass [L loc (InstDecl (L _ (HsAppTy (L _ (HsTyVar className)) _)) _ _ _)] = Just (className, loc) +#endif +getClass _ = Nothing + +#if __GLASGOW_HASKELL__ < 706 +occName :: RdrName -> OccName +occName = rdrNameOcc +#endif + +---------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ < 710 +-- Copied from ghc/InteractiveUI.hs +allExposedPackageConfigs :: DynFlags -> [PackageConfig] +allExposedPackageConfigs df = filter exposed $ eltsUFM $ pkgIdMap $ pkgState df + +allExposedModules :: DynFlags -> [ModuleName] +allExposedModules df = concat $ map exposedModules $ allExposedPackageConfigs df + +listVisibleModuleNames :: DynFlags -> [ModuleName] +listVisibleModuleNames = allExposedModules +#endif + +lookupModulePackageInAllPackages :: + DynFlags -> ModuleName -> [String] +lookupModulePackageInAllPackages df mn = +#if __GLASGOW_HASKELL__ >= 710 + unpackSPId . sourcePackageId . snd <$> lookupModuleInAllPackages df mn + where + unpackSPId (SourcePackageId fs) = unpackFS fs +#else + unpackPId . sourcePackageId . fst <$> lookupModuleInAllPackages df mn + where + unpackPId pid = packageIdString $ mkPackageId pid +-- n ++ "-" ++ showVersion v +#endif + +listVisibleModules :: DynFlags -> [GHC.Module] +listVisibleModules df = let +#if __GLASGOW_HASKELL__ >= 710 + modNames = listVisibleModuleNames df + mods = [ m | mn <- modNames, (m, _) <- lookupModuleInAllPackages df mn ] +#else + pkgCfgs = allExposedPackageConfigs df + mods = [ mkModule pid modname | p <- pkgCfgs + , let pid = packageConfigId p + , modname <- exposedModules p ] +#endif + in mods + +isSynTyCon :: TyCon -> Bool +#if __GLASGOW_HASKELL__ >= 710 +isSynTyCon = GHC.isTypeSynonymTyCon +#else +isSynTyCon = GHC.isSynTyCon +#endif + + +parseModuleHeader + :: String -- ^ Haskell module source text (full Unicode is supported) + -> DynFlags + -> FilePath -- ^ the filename (for source locations) + -> Either ErrorMessages (WarningMessages, Located (HsModule RdrName)) +parseModuleHeader str dflags filename = + let + loc = mkRealSrcLoc (mkFastString filename) 1 1 + buf = stringToStringBuffer str + in + case L.unP Parser.parseHeader (mkPState dflags buf loc) of + + PFailed sp err -> +#if __GLASGOW_HASKELL__ >= 706 + Left (unitBag (mkPlainErrMsg dflags sp err)) +#else + Left (unitBag (mkPlainErrMsg sp err)) +#endif + + POk pst rdr_module -> + let (warns,_) = getMessages pst in + Right (warns, rdr_module) + +mkErrStyle' :: DynFlags -> PrintUnqualified -> PprStyle +#if __GLASGOW_HASKELL__ >= 706 +mkErrStyle' = Outputable.mkErrStyle +#else +mkErrStyle' _ = Outputable.mkErrStyle +#endif + +#if __GLASGOW_HASKELL__ < 706 +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 Bool +#endif + fixity = const (stage Bool + (r, s') = q x s0 + +withCleanupSession :: GhcMonad m => m a -> m a +#if __GLASGOW_HASKELL__ >= 800 +#if MIN_VERSION_GLASGOW_HASKELL(8,0,1,20161117) +withCleanupSession = GHC.withCleanupSession +#else +withCleanupSession ghc = ghc `gfinally` cleanup + where + cleanup = do + hsc_env <- getSession + let dflags = hsc_dflags hsc_env + liftIO $ do + cleanTempFiles dflags + cleanTempDirs dflags + stopIServ hsc_env +#endif +#else +withCleanupSession action = do + df <- getSessionDynFlags + GHC.defaultCleanupHandler df action +#endif diff --git a/core/GhcMod/GhcPkg.hs b/core/GhcMod/GhcPkg.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/GhcPkg.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE BangPatterns, ScopedTypeVariables, TupleSections #-} +module GhcMod.GhcPkg ( + ghcPkgDbOpt + , ghcPkgDbStackOpts + , ghcDbStackOpts + , ghcDbOpt + , getPackageDbStack + , getPackageCachePaths + , getGhcPkgProgram + ) where + +import Config (cProjectVersion, cTargetPlatformString, cProjectVersionInt) +import Control.Applicative +import Data.List.Split (splitOn) +import Data.Maybe +import Exception (handleIO) +import System.Directory (doesDirectoryExist, getAppUserDataDirectory) +import System.FilePath (()) +import Prelude + +import GhcMod.Types +import GhcMod.Monad.Types +import GhcMod.CabalHelper +import GhcMod.PathsAndFiles +import GhcMod.CustomPackageDb +import GhcMod.Stack + +ghcVersion :: Int +ghcVersion = read cProjectVersionInt + +---------------------------------------------------------------- + +-- | Get options needed to add a list of package dbs to ghc-pkg's db stack +ghcPkgDbStackOpts :: [GhcPkgDb] -- ^ Package db stack + -> [String] +ghcPkgDbStackOpts dbs = ghcPkgDbOpt `concatMap` dbs + +-- | Get options needed to add a list of package dbs to ghc's db stack +ghcDbStackOpts :: [GhcPkgDb] -- ^ Package db stack + -> [String] +ghcDbStackOpts dbs = ghcDbOpt `concatMap` dbs + +---------------------------------------------------------------- + +ghcPkgDbOpt :: GhcPkgDb -> [String] +ghcPkgDbOpt GlobalDb = ["--global"] +ghcPkgDbOpt UserDb = ["--user"] +ghcPkgDbOpt (PackageDb pkgDb) + | ghcVersion < 706 = ["--no-user-package-conf", "--package-conf=" ++ pkgDb] + | otherwise = ["--no-user-package-db", "--package-db=" ++ pkgDb] + +ghcDbOpt :: GhcPkgDb -> [String] +ghcDbOpt GlobalDb + | ghcVersion < 706 = ["-global-package-conf"] + | otherwise = ["-global-package-db"] +ghcDbOpt UserDb + | ghcVersion < 706 = ["-user-package-conf"] + | otherwise = ["-user-package-db"] +ghcDbOpt (PackageDb pkgDb) + | ghcVersion < 706 = ["-no-user-package-conf", "-package-conf", pkgDb] + | otherwise = ["-no-user-package-db", "-package-db", pkgDb] + +---------------------------------------------------------------- + +getGhcPkgProgram :: IOish m => GhcModT m FilePath +getGhcPkgProgram = do + crdl <- cradle + progs <- optPrograms <$> options + case cradleProject crdl of + (StackProject senv) -> do + Just ghcPkg <- getStackGhcPkgPath senv + return ghcPkg + _ -> + return $ ghcPkgProgram progs + +getPackageDbStack :: IOish m => GhcModT m [GhcPkgDb] +getPackageDbStack = do + crdl <- cradle + mCusPkgStack <- getCustomPkgDbStack + stack <- case cradleProject crdl of + PlainProject -> + return [GlobalDb, UserDb] + SandboxProject -> do + Just db <- liftIO $ getSandboxDb crdl + return $ [GlobalDb, db] + CabalProject -> + getCabalPackageDbStack + (StackProject StackEnv {..}) -> + return $ [GlobalDb, PackageDb seSnapshotPkgDb, PackageDb seLocalPkgDb] + return $ fromMaybe stack mCusPkgStack + +getPackageCachePaths :: IOish m => FilePath -> GhcModT m [FilePath] +getPackageCachePaths sysPkgCfg = do + pkgDbStack <- getPackageDbStack + catMaybes <$> (liftIO . resolvePackageConfig sysPkgCfg) `mapM` pkgDbStack + +-- TODO: use PkgConfRef +--- Copied from ghc module `Packages' unfortunately it's not exported :/ +resolvePackageConfig :: FilePath -> GhcPkgDb -> IO (Maybe FilePath) +resolvePackageConfig sysPkgCfg GlobalDb = return $ Just sysPkgCfg +resolvePackageConfig _ UserDb = handleIO (\_ -> return Nothing) $ do + appdir <- getAppUserDataDirectory "ghc" + let dir = appdir (target_arch ++ '-':target_os ++ '-':cProjectVersion) + pkgconf = dir "package.conf.d" + exist <- doesDirectoryExist pkgconf + return $ if exist then Just pkgconf else Nothing + where + [target_arch,_,target_os] = splitOn "-" cTargetPlatformString +resolvePackageConfig _ (PackageDb name) = return $ Just name diff --git a/core/GhcMod/HomeModuleGraph.hs b/core/GhcMod/HomeModuleGraph.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/HomeModuleGraph.hs @@ -0,0 +1,271 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +{-# LANGUAGE ScopedTypeVariables, RecordWildCards #-} +module GhcMod.HomeModuleGraph ( + GmModuleGraph(..) + , ModulePath(..) + , mkFileMap + , mkModuleMap + , mkMainModulePath + , findModulePath + , findModulePathSet + , fileModuleName + , canonicalizeModulePath + , homeModuleGraph + , updateHomeModuleGraph + , canonicalizeModuleGraph + , reachable + , moduleGraphToDot + ) where + +import DriverPipeline +import DynFlags +import ErrUtils +import Exception +import Finder +import GHC +import HscTypes +import Pretty + +import Control.Arrow ((&&&)) +import Control.Applicative +import Control.Monad +import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) +import Control.Monad.State.Strict (execStateT) +import Control.Monad.State.Class +import Data.Maybe +import Data.Monoid as Monoid +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set +import System.FilePath +import System.Directory +import System.IO +import Prelude + +import GhcMod.Logging +import GhcMod.Logger +import GhcMod.Monad.Types +import GhcMod.Types +import GhcMod.Utils (withMappedFile) +import GhcMod.Gap (parseModuleHeader) + +-- | Turn module graph into a graphviz dot file +-- +-- @dot -Tpng -o modules.png modules.dot@ +moduleGraphToDot :: GmModuleGraph -> String +moduleGraphToDot GmModuleGraph { gmgGraph } = + "digraph {\n" ++ concatMap edges (Map.toList graph) ++ "}\n" + where + graph = Map.map (Set.mapMonotonic mpPath) + $ Map.mapKeysMonotonic mpPath gmgGraph + edges :: (FilePath, (Set FilePath)) -> String + edges (f, sf) = + concatMap (\f' -> " \""++ f ++"\" -> \""++ f' ++"\"\n") (Set.toList sf) + +data S = S { + sErrors :: [(ModulePath, ErrorMessages)], + sWarnings :: [(ModulePath, WarningMessages)], + sGraph :: GmModuleGraph +} + +defaultS :: S +defaultS = S [] [] mempty + +putErr :: MonadState S m + => (ModulePath, ErrorMessages) -> m () +putErr e = do + s <- get + put s { sErrors = e:sErrors s} + +putWarn :: MonadState S m + => (ModulePath, ErrorMessages) -> m () +putWarn w = do + s <- get + put s { sWarnings = w:sWarnings s} + +gmgLookupMP :: MonadState S m => ModulePath -> m (Maybe (Set ModulePath)) +gmgLookupMP k = (Map.lookup k . gmgGraph . sGraph) `liftM` get + +graphUnion :: MonadState S m => GmModuleGraph -> m () +graphUnion gmg = do + s <- get + put s { sGraph = sGraph s `mappend` gmg } + +reachable :: Set ModulePath -> GmModuleGraph -> Set ModulePath +reachable smp0 GmModuleGraph {..} = go smp0 + where + go smp = let + δsmp = Set.unions $ + collapseMaybeSet . flip Map.lookup gmgGraph <$> Set.toList smp + smp' = smp `Set.union` δsmp + in if smp == smp' then smp' else go smp' + +pruneUnreachable :: Set ModulePath -> GmModuleGraph -> GmModuleGraph +pruneUnreachable smp0 gmg@GmModuleGraph {..} = let + r = reachable smp0 gmg + in + GmModuleGraph { + gmgGraph = Map.filterWithKey (\k _ -> k `Set.member` r) gmgGraph + } + +collapseMaybeSet :: Maybe (Set a) -> Set a +collapseMaybeSet = maybe Set.empty id + +homeModuleGraph :: (IOish m, Gm m) + => HscEnv -> Set ModulePath -> m GmModuleGraph +homeModuleGraph env smp = updateHomeModuleGraph env mempty smp smp + +mkMainModulePath :: FilePath -> ModulePath +mkMainModulePath = ModulePath (mkModuleName "Main") + +findModulePath :: HscEnv -> ModuleName -> IO (Maybe ModulePath) +findModulePath env mn = do + fmap (ModulePath mn) <$> find env mn + +findModulePathSet :: HscEnv -> [ModuleName] -> IO (Set ModulePath) +findModulePathSet env mns = do + Set.fromList . catMaybes <$> findModulePath env `mapM` mns + +find :: MonadIO m => HscEnv -> ModuleName -> m (Maybe FilePath) +find env mn = liftIO $ do + res <- findHomeModule env mn + case res of + -- TODO: handle SOURCE imports (hs-boot stuff): addBootSuffixLocn loc + Found loc@ModLocation { ml_hs_file = Just _ } _mod -> + return $ normalise <$> ml_hs_file loc + _ -> return Nothing + + +canonicalizeModulePath :: ModulePath -> IO ModulePath +canonicalizeModulePath (ModulePath mn fp) = ModulePath mn <$> canonicalizePath fp + +canonicalizeModuleGraph :: MonadIO m => GmModuleGraph -> m GmModuleGraph +canonicalizeModuleGraph GmModuleGraph {..} = liftIO $ do + GmModuleGraph . Map.fromList <$> mapM fmg (Map.toList gmgGraph) + where + fmg (mp, smp) = liftM2 (,) (canonicalizeModulePath mp) (Set.fromList <$> mapM canonicalizeModulePath (Set.toList smp)) + + +updateHomeModuleGraph :: (IOish m, Gm m) + => HscEnv + -> GmModuleGraph + -> Set ModulePath -- ^ Initial set of modules + -> Set ModulePath -- ^ Updated set of modules + -> m GmModuleGraph +updateHomeModuleGraph env GmModuleGraph {..} smp sump = do + -- TODO: It would be good if we could retain information about modules that + -- stop to compile after we've already successfully parsed them at some + -- point. Figure out a way to delete the modules about to be updated only + -- after we're sure they won't fail to parse .. or something. Should probably + -- push this whole prune logic deep into updateHomeModuleGraph' + (pruneUnreachable smp . sGraph) `liftM` runS (updateHomeModuleGraph' env sump) + where + runS = flip execStateT defaultS { sGraph = graph' } + graph' = GmModuleGraph { + gmgGraph = Set.foldr Map.delete gmgGraph sump + } + +mkFileMap :: Set ModulePath -> Map FilePath ModulePath +mkFileMap smp = Map.fromList $ map (mpPath &&& id) $ Set.toList smp + +mkModuleMap :: Set ModulePath -> Map ModuleName ModulePath +mkModuleMap smp = Map.fromList $ map (mpModule &&& id) $ Set.toList smp + +updateHomeModuleGraph' + :: forall m. (MonadState S m, IOish m, Gm m) + => HscEnv + -> Set ModulePath -- ^ Initial set of modules + -> m () +updateHomeModuleGraph' env smp0 = do + go `mapM_` Set.toList smp0 + where + go :: ModulePath -> m () + go mp = do + msmp <- gmgLookupMP mp + case msmp of + Just _ -> return () + Nothing -> do + smp <- collapseMaybeSet `liftM` step mp + + graphUnion GmModuleGraph { + gmgGraph = Map.singleton mp smp + } + + mapM_ go (Set.toList smp) + + step :: ModulePath -> m (Maybe (Set ModulePath)) + step mp = runMaybeT $ do + (dflags, ppsrc_fn) <- MaybeT preprocess' + src <- liftIO $ readFile ppsrc_fn + imports mp src dflags + where + preprocess' :: m (Maybe (DynFlags, FilePath)) + preprocess' = do + let fn = mpPath mp + ep <- preprocessFile env fn + case ep of + Right (_, x) -> return $ Just x + Left errs -> do + -- TODO: Remember these and present them as proper errors if this is + -- the file the user is looking at. + gmLog GmWarning ("preprocess " ++ show fn) $ Pretty.empty $+$ (vcat $ map text errs) + return Nothing + + + imports :: ModulePath -> String -> DynFlags -> MaybeT m (Set ModulePath) + imports mp@ModulePath {..} src dflags = + case parseModuleHeader src dflags mpPath of + Left err -> do + putErr (mp, err) + mzero + + Right (ws, lmdl) -> do + putWarn (mp, ws) + let HsModule {..} = unLoc lmdl + 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) => + HscEnv -> FilePath -> m (Either [String] ([String], (DynFlags, FilePath))) +preprocessFile env file = + withLogger' env $ \setDf -> do + withMappedFile file $ \fn -> do + let env' = env { hsc_dflags = setDf (hsc_dflags env) } + liftIO $ preprocess env' (fn, Nothing) + +fileModuleName :: (IOish m, GmEnv m, GmState m) => + HscEnv -> FilePath -> m (Either [String] (Maybe ModuleName)) +fileModuleName env fn = do + let handler = liftIO . handle (\(_ :: SomeException) -> return $ Right Nothing) + ep <- preprocessFile env fn + case ep of + Left errs -> do + return $ Left errs + Right (_warns, (dflags, procdFile)) -> leftM (errBagToStrList env) =<< handler (do + src <- readFile procdFile + case parseModuleHeader src dflags procdFile of + Left errs -> return $ Left errs + Right (_, lmdl) -> do + let HsModule {..} = unLoc lmdl + return $ Right $ unLoc <$> hsmodName) + where + leftM f = either (return . Left <=< f) (return . Right) diff --git a/core/GhcMod/LightGhc.hs b/core/GhcMod/LightGhc.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/LightGhc.hs @@ -0,0 +1,60 @@ +module GhcMod.LightGhc where + +import Control.Monad +import Control.Monad.Reader (runReaderT) +import Data.IORef + +import GHC +import GHC.Paths (libdir) +import StaticFlags +import SysTools +import DynFlags +import HscMain +import HscTypes + +import GhcMod.Types +import GhcMod.Monad.Types +import GhcMod.DynFlags +import qualified GhcMod.Gap as Gap + +-- We have to be more careful about tearing down 'HscEnv's since GHC 8 added an +-- out of process GHCI server which has to be shutdown. +newLightEnv :: IOish m => (DynFlags -> LightGhc DynFlags) -> m HscEnv +newLightEnv mdf = do + df <- liftIO $ do + initStaticOpts + settings <- initSysTools (Just libdir) + initDynFlags $ defaultDynFlags settings + + hsc_env <- liftIO $ newHscEnv df + df' <- runLightGhc hsc_env $ mdf df + return $ hsc_env { + hsc_dflags = df', + hsc_IC = (hsc_IC hsc_env) { ic_dflags = df' } + } + +teardownLightEnv :: MonadIO m => HscEnv -> m () +teardownLightEnv env = runLightGhc env $ do + Gap.withCleanupSession $ return () + +withLightHscEnv' + :: IOish m => (DynFlags -> LightGhc DynFlags) -> (HscEnv -> m a) -> m a +withLightHscEnv' mdf action = gbracket (newLightEnv mdf) teardownLightEnv action + +withLightHscEnv :: IOish m => [GHCOption] -> (HscEnv -> m a) -> m a +withLightHscEnv opts = withLightHscEnv' (f <=< liftIO . newHscEnv) + where + f env = runLightGhc env $ do + -- HomeModuleGraph and probably all other clients get into all sorts of + -- trouble if the package state isn't initialized here + _ <- setSessionDynFlags =<< addCmdOpts opts =<< getSessionDynFlags + getSessionDynFlags + +runLightGhc :: MonadIO m => HscEnv -> LightGhc a -> m a +runLightGhc env action = liftIO $ do + renv <- newIORef env + flip runReaderT renv $ unLightGhc action + +runLightGhc' :: MonadIO m => IORef HscEnv -> LightGhc a -> m a +runLightGhc' renv action = liftIO $ do + flip runReaderT renv $ unLightGhc action diff --git a/core/GhcMod/Logger.hs b/core/GhcMod/Logger.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Logger.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE CPP, RankNTypes #-} + +module GhcMod.Logger ( + withLogger + , withLogger' + , checkErrorPrefix + , errsToStr + , errBagToStrList + ) where + +import Control.Arrow +import Control.Applicative +import Data.Ord +import Data.List +import Data.Maybe +import Data.Function +import Control.Monad.Reader (Reader, ask, runReader) +import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef) +import System.FilePath (normalise) + +import ErrUtils +import GHC +import HscTypes +import Outputable +import qualified GHC as G +import Bag +import SrcLoc +import FastString + +import GhcMod.Convert +import GhcMod.Doc (showPage) +import GhcMod.DynFlags (withDynFlags) +import GhcMod.Monad.Types +import GhcMod.Error +import GhcMod.Pretty +import GhcMod.Utils (mkRevRedirMapFunc) +import qualified GhcMod.Gap as Gap +import Prelude + +type Builder = [String] -> [String] + +data Log = Log [String] Builder + +newtype LogRef = LogRef (IORef Log) + +data GmPprEnv = GmPprEnv { gpeDynFlags :: DynFlags + , gpeMapFile :: FilePath -> FilePath + } + +type GmPprEnvM a = Reader GmPprEnv a + +emptyLog :: Log +emptyLog = Log [] id + +newLogRef :: IO LogRef +newLogRef = LogRef <$> newIORef emptyLog + +readAndClearLogRef :: LogRef -> IO [String] +readAndClearLogRef (LogRef ref) = do + Log _ b <- readIORef ref + writeIORef ref emptyLog + return $ b [] + +appendLogRef :: (FilePath -> FilePath) -> DynFlags -> LogRef -> Gap.GmLogAction +appendLogRef map_file df (LogRef ref) _reason _df sev src st msg = do + modifyIORef ref update + where + -- 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 + | otherwise = Log (l:ls) (b . (l:)) + +---------------------------------------------------------------- + +-- | Logged messages are returned as 'String'. +-- Right is success and Left is failure. +withLogger :: (GmGhc m, GmEnv m, GmOut m, GmState m) + => (DynFlags -> DynFlags) + -> m a + -> m (Either String (String, a)) +withLogger f action = do + env <- G.getSession + oopts <- outputOpts + let conv = convert oopts + eres <- withLogger' env $ \setDf -> + withDynFlags (f . setDf) action + return $ either (Left . conv) (Right . first conv) eres + +withLogger' :: (IOish m, GmState m, GmEnv m) + => HscEnv -> ((DynFlags -> DynFlags) -> m a) -> m (Either [String] ([String], a)) +withLogger' env action = do + logref <- liftIO $ newLogRef + + rfm <- mkRevRedirMapFunc + + let setLogger df = Gap.setLogAction df $ appendLogRef rfm df logref + handlers = [ + GHandler $ \ex -> return $ Left $ runReader (sourceError ex) gpe, + GHandler $ \ex -> return $ Left [renderGm $ ghcExceptionDoc ex] + ] + gpe = GmPprEnv { + gpeDynFlags = hsc_dflags env + , gpeMapFile = rfm + } + + a <- gcatches (Right <$> action setLogger) handlers + ls <- liftIO $ readAndClearLogRef logref + + return ((,) ls <$> a) + +errBagToStrList :: (IOish m, GmState m, GmEnv m) => HscEnv -> Bag ErrMsg -> m [String] +errBagToStrList env errs = do + rfm <- mkRevRedirMapFunc + return $ runReader + (errsToStr (sortMsgBag errs)) + GmPprEnv{ gpeDynFlags = hsc_dflags env, gpeMapFile = rfm } + +---------------------------------------------------------------- + +-- | Converting 'SourceError' to 'String'. +sourceError :: SourceError -> GmPprEnvM [String] +sourceError = errsToStr . sortMsgBag . srcErrorMessages + +errsToStr :: [ErrMsg] -> GmPprEnvM [String] +errsToStr = mapM ppErrMsg + +sortMsgBag :: Bag ErrMsg -> [ErrMsg] +sortMsgBag bag = sortBy (compare `on` Gap.errorMsgSpan) $ bagToList bag + +---------------------------------------------------------------- + +ppErrMsg :: ErrMsg -> GmPprEnvM String +ppErrMsg err = do + GmPprEnv {..} <- ask + let unqual = errMsgContext err + st = Gap.mkErrStyle' gpeDynFlags unqual + err' = Gap.setErrorMsgSpan err $ mapSrcSpanFile gpeMapFile (Gap.errorMsgSpan err) + return $ showPage gpeDynFlags st $ pprLocErrMsg err' + +mapSrcSpanFile :: (FilePath -> FilePath) -> SrcSpan -> SrcSpan +mapSrcSpanFile map_file (RealSrcSpan s) = + RealSrcSpan $ mapRealSrcSpanFile map_file s +mapSrcSpanFile _ (UnhelpfulSpan s) = + UnhelpfulSpan s + +mapRealSrcSpanFile :: (FilePath -> FilePath) -> RealSrcSpan -> RealSrcSpan +mapRealSrcSpanFile map_file s = let + start = mapRealSrcLocFile map_file $ realSrcSpanStart s + end = mapRealSrcLocFile map_file $ realSrcSpanEnd s + in + mkRealSrcSpan start end + +mapRealSrcLocFile :: (FilePath -> FilePath) -> RealSrcLoc -> RealSrcLoc +mapRealSrcLocFile map_file l = let + file = mkFastString $ map_file $ unpackFS $ srcLocFile l + line = srcLocLine l + col = srcLocCol l + in + mkRealSrcLoc file line col + +ppMsg :: (FilePath -> FilePath) -> DynFlags -> PprStyle -> SrcSpan -> Severity -> SDoc -> String +ppMsg map_file df st spn sev msg = let + cts = showPage df st msg + in + ppMsgPrefix map_file df spn sev cts ++ cts + +ppMsgPrefix :: (FilePath -> FilePath) -> DynFlags -> SrcSpan -> Severity -> String -> String +ppMsgPrefix map_file df spn sev cts = + let + defaultPrefix = if Gap.isDumpSplices df then "" else checkErrorPrefix + in + fromMaybe defaultPrefix $ do + (line,col,_,_) <- Gap.getSrcSpan spn + file <- map_file <$> normalise <$> Gap.getSrcFile spn + return $ file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ + if or (map (\x -> x `isPrefixOf` cts) warningAsErrorPrefixes) + then "" + else Gap.showSeverityCaption sev + +checkErrorPrefix :: String +checkErrorPrefix = "Dummy:0:0:Error:" + +warningAsErrorPrefixes :: [String] +warningAsErrorPrefixes = [ "Couldn't match expected type" + , "Couldn't match type" + , "No instance for"] diff --git a/core/GhcMod/Logging.hs b/core/GhcMod/Logging.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Logging.hs @@ -0,0 +1,115 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module GhcMod.Logging ( + module GhcMod.Logging + , module GhcMod.Pretty + , GmLogLevel(..) + , module Data.Monoid + , module Pretty + ) where + +import Control.Applicative hiding (empty) +import Control.Monad +import Control.Monad.Trans.Class +import Data.List +import Data.Char +import Data.Monoid +import Data.Maybe +import System.IO +import System.FilePath +import Prelude + +import Pretty hiding (style, (<>)) + +import GhcMod.Monad.Types +import GhcMod.Types +import GhcMod.Pretty +import GhcMod.Output + +gmSetLogLevel :: GmLog m => GmLogLevel -> m () +gmSetLogLevel level = + gmlJournal $ GhcModLog (Just level) (Last Nothing) [] + +gmGetLogLevel :: forall m. GmLog m => m GmLogLevel +gmGetLogLevel = do + GhcModLog { gmLogLevel = Just level } <- gmlHistory + return level + +gmSetDumpLevel :: GmLog m => Bool -> m () +gmSetDumpLevel level = + gmlJournal $ GhcModLog Nothing (Last (Just level)) [] + + +increaseLogLevel :: GmLogLevel -> GmLogLevel +increaseLogLevel l | l == maxBound = l +increaseLogLevel l = succ l + +decreaseLogLevel :: GmLogLevel -> GmLogLevel +decreaseLogLevel l | l == minBound = l +decreaseLogLevel l = pred l + +-- | +-- >>> Just GmDebug <= Nothing +-- False +-- >>> Just GmException <= Just GmDebug +-- True +-- >>> Just GmDebug <= Just GmException +-- False +gmLog :: (MonadIO m, GmLog m, GmOut m) => GmLogLevel -> String -> Doc -> m () +gmLog level loc' doc = do + GhcModLog { gmLogLevel = Just level' } <- gmlHistory + + let loc | loc' == "" = empty + | otherwise = text loc' <+>: empty + msgDoc = sep [loc, doc] + msg = dropWhileEnd isSpace $ renderGm $ gmLogLevelDoc level <+>: msgDoc + + when (level <= level') $ gmErrStrLn msg + gmLogQuiet level loc' doc + +gmLogQuiet :: GmLog m => GmLogLevel -> String -> Doc -> m () +gmLogQuiet level loc doc = + gmlJournal (GhcModLog Nothing (Last Nothing) [(level, loc, doc)]) + +gmAppendLogQuiet :: GmLog m => GhcModLog -> m () +gmAppendLogQuiet GhcModLog { gmLogMessages } = + forM_ gmLogMessages $ \(level, loc, doc) -> gmLogQuiet level loc doc + +gmVomit :: (MonadIO m, GmLog m, GmOut m, GmEnv m) => String -> Doc -> String -> m () +gmVomit filename doc content = do + gmLog GmVomit "" $ doc <+>: text content + + GhcModLog { gmLogVomitDump = Last mdump } + <- gmlHistory + + dir <- cradleTempDir `liftM` cradle + when (fromMaybe False mdump) $ + liftIO $ writeFile (dir filename) content + + +newtype LogDiscardT m a = LogDiscardT { runLogDiscard :: m a } + deriving (Functor, Applicative, Monad) + +instance MonadTrans LogDiscardT where + lift = LogDiscardT + +instance Monad m => GmLog (LogDiscardT m) where + gmlJournal = const $ return () + gmlHistory = return mempty + gmlClear = return () diff --git a/core/GhcMod/Monad.hs b/core/GhcMod/Monad.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Monad.hs @@ -0,0 +1,148 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +{-# LANGUAGE CPP #-} +module GhcMod.Monad ( + runGmOutT + , runGmOutT' + , runGhcModT + , runGhcModT' + , hoistGhcModT + , runGmlT + , runGmlT' + , runGmlTWith + , runGmPkgGhc + , withGhcModEnv + , withGhcModEnv' + , module GhcMod.Monad.Types + ) where + +import GhcMod.Types +import GhcMod.Monad.Types +import GhcMod.Error +import GhcMod.Logging +import GhcMod.Cradle +import GhcMod.Target +import GhcMod.Output + +import Control.Arrow (first) +import Control.Applicative + +import Control.Concurrent + +import Control.Monad.Reader (runReaderT) +import Control.Monad.State.Strict (runStateT) +import Control.Monad.Trans.Journal (runJournalT) + +import Exception + +import System.Directory +import System.IO.Unsafe +import Prelude + +withGhcModEnv :: (IOish m, GmOut m) => FilePath -> Options -> ((GhcModEnv, GhcModLog) -> m a) -> m a +withGhcModEnv dir opts f = withGhcModEnv' withCradle dir opts f + where + withCradle dir' = + gbracket + (runJournalT $ do + gmSetLogLevel $ ooptLogLevel $ optOutput opts + findCradle' (optPrograms opts) dir') + (liftIO . cleanupCradle . fst) + + + +cwdLock :: MVar ThreadId +cwdLock = unsafePerformIO $ newEmptyMVar +{-# NOINLINE cwdLock #-} + +withGhcModEnv' :: (IOish m, GmOut m) => (FilePath -> ((Cradle, GhcModLog) -> m a) -> m a) -> FilePath -> Options -> ((GhcModEnv, GhcModLog) -> m a) -> m a +withGhcModEnv' withCradle dir opts f = + withCradle dir $ \(crdl,lg) -> + withCradleRootDir crdl $ + f (GhcModEnv opts crdl, lg) + where + swapCurrentDirectory ndir = do + odir <- canonicalizePath =<< getCurrentDirectory + setCurrentDirectory ndir + return odir + + withCradleRootDir (cradleRootDir -> projdir) a = do + success <- liftIO $ tryPutMVar cwdLock =<< myThreadId + if not success + then error "withGhcModEnv': using ghc-mod from multiple threads is not supported!" + else gbracket setup teardown (const a) + where + setup = liftIO $ swapCurrentDirectory projdir + + teardown odir = liftIO $ do + setCurrentDirectory odir + void $ takeMVar cwdLock + +runGmOutT :: IOish m => Options -> GmOutT m a -> m a +runGmOutT opts ma = do + gmo@GhcModOut{..} <- GhcModOut (optOutput opts) <$> liftIO newChan + let action = runGmOutT' gmo ma + case ooptLinePrefix $ optOutput opts of + Nothing -> action + Just pfxs -> + gbracket_ (liftIO $ forkIO $ stdoutGateway pfxs gmoChan) + (const $ liftIO $ flushStdoutGateway gmoChan) + action + +runGmOutT' :: GhcModOut -> GmOutT m a -> m a +runGmOutT' gmo ma = flip runReaderT gmo $ unGmOutT ma + +-- | Run a @GhcModT m@ computation. +runGhcModT :: IOish m + => Options + -> GhcModT m a + -> m (Either GhcModError a, GhcModLog) +runGhcModT opt action = liftIO (getCurrentDirectory >>= canonicalizePath) >>= \dir' -> do + runGmOutT opt $ + withGhcModEnv dir' opt $ \(env,lg) -> + first (fst <$>) <$> runGhcModT' env defaultGhcModState (do + gmSetLogLevel (ooptLogLevel $ optOutput opt) + gmAppendLogQuiet lg + action) + +-- | @hoistGhcModT result@. Embed a GhcModT computation's result into a GhcModT +-- computation. Note that if the computation that returned @result@ modified the +-- state part of GhcModT this cannot be restored. +hoistGhcModT :: IOish m + => (Either GhcModError a, GhcModLog) + -> GhcModT m a +hoistGhcModT (r,l) = do + gmlJournal l >> case r of + Left e -> throwError e + Right a -> return a + + +-- | Run a computation inside @GhcModT@ providing the RWST environment and +-- initial state. This is a low level function, use it only if you know what to +-- do with 'GhcModEnv' and 'GhcModState'. +-- +-- You should probably look at 'runGhcModT' instead. +runGhcModT' :: IOish m + => GhcModEnv + -> GhcModState + -> GhcModT m a + -> GmOutT m (Either GhcModError (a, GhcModState), GhcModLog) +runGhcModT' r s a = do + flip runReaderT r $ runJournalT $ runErrorT $ runStateT (unGmT a) s + +gbracket_ :: ExceptionMonad m => m a -> (a -> m b) -> m c -> m c +gbracket_ ma mb mc = gbracket ma mb (const mc) diff --git a/core/GhcMod/Monad/Compat.hs_h b/core/GhcMod/Monad/Compat.hs_h new file mode 100644 --- /dev/null +++ b/core/GhcMod/Monad/Compat.hs_h @@ -0,0 +1,28 @@ +-- ghc-mod: Making Haskell development *more* fun +-- Copyright (C) 2015,2016 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +-- MonadUtils of GHC 7.6 or earlier defines its own MonadIO. +-- RWST does not automatically become an instance of MonadIO. +-- MonadUtils of GHC 7.8 or later imports MonadIO in Monad.Control.IO.Class. +-- So, RWST automatically becomes an instance of +#if __GLASGOW_HASKELL__ < 708 +-- 'CoreMonad.MonadIO' and 'Control.Monad.IO.Class.MonadIO' are different +-- classes before ghc 7.8 +#define DIFFERENT_MONADIO 1 + +-- RWST doen't have a MonadIO instance before ghc 7.8 +#define MONADIO_INSTANCES 1 +#endif diff --git a/core/GhcMod/Monad/Env.hs b/core/GhcMod/Monad/Env.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Monad/Env.hs @@ -0,0 +1,68 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015,2016 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-} +{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} + +module GhcMod.Monad.Env where + +import GhcMod.Types +import GhcMod.Monad.Newtypes + +import Control.Monad +import Control.Monad.Trans.Journal (JournalT) +import Control.Monad.State.Strict (StateT(..)) +import Control.Monad.Error (ErrorT(..)) +import Control.Monad.Reader.Class +import Control.Monad.Trans.Class (MonadTrans(..)) +import Prelude + +class Monad m => GmEnv m where + gmeAsk :: m GhcModEnv + gmeAsk = gmeReader id + + gmeReader :: (GhcModEnv -> a) -> m a + gmeReader f = f `liftM` gmeAsk + + gmeLocal :: (GhcModEnv -> GhcModEnv) -> m a -> m a + {-# MINIMAL (gmeAsk | gmeReader), gmeLocal #-} + +instance Monad m => GmEnv (GmT m) where + gmeAsk = GmT ask + gmeReader = GmT . reader + gmeLocal f a = GmT $ local f (unGmT a) + +instance GmEnv m => GmEnv (GmOutT m) where + gmeAsk = lift gmeAsk + gmeReader = lift . gmeReader + gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma)) + +instance GmEnv m => GmEnv (StateT s m) where + gmeAsk = lift gmeAsk + gmeReader = lift . gmeReader + gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma)) + +instance GmEnv m => GmEnv (JournalT GhcModLog m) where + gmeAsk = lift gmeAsk + gmeReader = lift . gmeReader + gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma)) + +instance GmEnv m => GmEnv (ErrorT GhcModError m) where + gmeAsk = lift gmeAsk + gmeReader = lift . gmeReader + gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma)) + +deriving instance (Monad m, GmEnv (GhcModT m)) => GmEnv (GmlT m) diff --git a/core/GhcMod/Monad/Log.hs b/core/GhcMod/Monad/Log.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Monad/Log.hs @@ -0,0 +1,71 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015,2016 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-} +{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} + +module GhcMod.Monad.Log where + +import GhcMod.Types +import GhcMod.Monad.Newtypes + +import Control.Monad +import Control.Monad.Trans.Journal (JournalT) +import Control.Monad.Reader (ReaderT(..)) +import Control.Monad.State.Strict (StateT(..)) +import Control.Monad.Error (Error, ErrorT(..)) +import Control.Monad.Trans.Maybe (MaybeT(..)) +import Control.Monad.Journal.Class (MonadJournal(..)) +import Control.Monad.Trans.Class (MonadTrans(..)) +import Prelude + +class Monad m => GmLog m where + gmlJournal :: GhcModLog -> m () + gmlHistory :: m GhcModLog + gmlClear :: m () + +instance Monad m => GmLog (JournalT GhcModLog m) where + gmlJournal = journal + gmlHistory = history + gmlClear = clear + +instance Monad m => GmLog (GmT m) where + gmlJournal = GmT . lift . lift . journal + gmlHistory = GmT $ lift $ lift history + gmlClear = GmT $ lift $ lift clear + +instance (Monad m, GmLog m) => GmLog (ReaderT r m) where + gmlJournal = lift . gmlJournal + gmlHistory = lift gmlHistory + gmlClear = lift gmlClear + +instance (Monad m, GmLog m) => GmLog (StateT s m) where + gmlJournal = lift . gmlJournal + gmlHistory = lift gmlHistory + gmlClear = lift gmlClear + +instance (Monad m, GmLog m, Error e) => GmLog (ErrorT e m) where + gmlJournal = lift . gmlJournal + gmlHistory = lift gmlHistory + gmlClear = lift gmlClear + +instance (Monad m, GmLog m) => GmLog (MaybeT m) where + gmlJournal = lift . gmlJournal + gmlHistory = lift gmlHistory + gmlClear = lift gmlClear + +deriving instance GmLog m => GmLog (GmOutT m) +deriving instance (Monad m, GmLog (GhcModT m)) => GmLog (GmlT m) diff --git a/core/GhcMod/Monad/Newtypes.hs b/core/GhcMod/Monad/Newtypes.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Monad/Newtypes.hs @@ -0,0 +1,176 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015,2016 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, DeriveFunctor #-} +{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, UndecidableInstances #-} +{-# LANGUAGE RankNTypes, FlexibleInstances #-} + +module GhcMod.Monad.Newtypes where + +#include "Compat.hs_h" + +import GhcMod.Types + +import GHC + +import Control.Applicative +import Control.Monad + +import Control.Monad.Reader (ReaderT(..)) +import Control.Monad.Error (ErrorT(..), MonadError(..)) +import Control.Monad.State.Strict (StateT(..)) +import Control.Monad.Trans.Journal (JournalT) +import Control.Monad.Reader.Class +import Control.Monad.State.Class (MonadState(..)) +import Control.Monad.Journal.Class (MonadJournal(..)) +import Control.Monad.Trans.Class (MonadTrans(..)) +import Control.Monad.Trans.Control +import Control.Monad.Base (MonadBase(..), liftBase) + +import Data.IORef +import Prelude + +type GhcModT m = GmT (GmOutT m) + +newtype GmOutT m a = GmOutT { + unGmOutT :: ReaderT GhcModOut m a + } deriving ( Functor + , Applicative + , Alternative + , Monad + , MonadPlus + , MonadTrans + ) + +newtype GmT m a = GmT { + unGmT :: StateT GhcModState + (ErrorT GhcModError + (JournalT GhcModLog + (ReaderT GhcModEnv m) ) ) a + } deriving ( Functor + , Applicative + , Alternative + , Monad + , MonadPlus + , MonadError GhcModError + ) + +newtype GmlT m a = GmlT { unGmlT :: GhcModT m a } + deriving ( Functor + , Applicative + , Alternative + , Monad + , MonadPlus + , MonadError GhcModError + ) + +newtype LightGhc a = LightGhc { unLightGhc :: ReaderT (IORef HscEnv) IO a } + deriving ( Functor + , Applicative + , Monad + ) + +-- GmOutT ---------------------------------------- +instance (MonadBaseControl IO m) => MonadBase IO (GmOutT m) where + liftBase = GmOutT . liftBase + +instance (MonadBaseControl IO m) => MonadBaseControl IO (GmOutT m) where + type StM (GmOutT m) a = StM (ReaderT GhcModEnv m) a + liftBaseWith = defaultLiftBaseWith + restoreM = defaultRestoreM + {-# INLINE liftBaseWith #-} + {-# INLINE restoreM #-} + +instance MonadTransControl GmOutT where + type StT GmOutT a = StT (ReaderT GhcModEnv) a + liftWith = defaultLiftWith GmOutT unGmOutT + restoreT = defaultRestoreT GmOutT + + +-- GmlT ------------------------------------------ +instance (MonadBaseControl IO m) => MonadBase IO (GmlT m) where + liftBase = GmlT . liftBase + +instance (MonadBaseControl IO m) => MonadBaseControl IO (GmlT m) where + type StM (GmlT m) a = StM (GmT m) a + liftBaseWith = defaultLiftBaseWith + restoreM = defaultRestoreM + {-# INLINE liftBaseWith #-} + {-# INLINE restoreM #-} + +instance MonadTransControl GmlT where + type StT GmlT a = StT GmT a + liftWith f = GmlT $ + liftWith $ \runGm -> + liftWith $ \runEnv -> + f $ \ma -> runEnv $ runGm $ unGmlT ma + restoreT = GmlT . restoreT . restoreT + +instance MonadTrans GmlT where + lift = GmlT . lift . lift + +-- GmT ------------------------------------------ + +instance MonadReader r m => MonadReader r (GmT m) where + local f ma = gmLiftWithInner (\run -> local f (run ma)) + ask = gmLiftInner ask + +instance MonadState s m => MonadState s (GmT m) where + get = GmT $ lift $ lift $ lift get + put = GmT . lift . lift . lift . put + state = GmT . lift . lift . lift . state + +instance Monad m => MonadJournal GhcModLog (GmT m) where + journal w = GmT $ lift $ lift $ (journal w) + history = GmT $ lift $ lift $ history + clear = GmT $ lift $ lift $ clear + +instance (MonadBaseControl IO m) => MonadBase IO (GmT m) where + liftBase = GmT . liftBase + +instance (MonadBaseControl IO m) => MonadBaseControl IO (GmT m) where + type StM (GmT m) a = + StM (StateT GhcModState + (ErrorT GhcModError + (JournalT GhcModLog + (ReaderT GhcModEnv m) ) ) ) a + liftBaseWith f = GmT (liftBaseWith $ \runInBase -> + f $ runInBase . unGmT) + restoreM = GmT . restoreM + {-# INLINE liftBaseWith #-} + {-# INLINE restoreM #-} + +instance MonadTransControl GmT where + type StT GmT a = (Either GhcModError (a, GhcModState), GhcModLog) + liftWith f = GmT $ + liftWith $ \runS -> + liftWith $ \runE -> + liftWith $ \runJ -> + liftWith $ \runR -> + f $ \ma -> runR $ runJ $ runE $ runS $ unGmT ma + restoreT = GmT . restoreT . restoreT . restoreT . restoreT + {-# INLINE liftWith #-} + {-# INLINE restoreT #-} + +instance MonadTrans GmT where + lift = GmT . lift . lift . lift . lift + +gmLiftInner :: Monad m => m a -> GmT m a +gmLiftInner = GmT . lift . lift . lift . lift + +gmLiftWithInner :: (MonadTransControl t, Monad m, Monad (t m)) + => (Run t -> m (StT t a)) -> t m a +gmLiftWithInner f = liftWith f >>= restoreT . return diff --git a/core/GhcMod/Monad/Orphans.hs b/core/GhcMod/Monad/Orphans.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Monad/Orphans.hs @@ -0,0 +1,83 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015,2016 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +{-# LANGUAGE CPP, UndecidableInstances, StandaloneDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} +module GhcMod.Monad.Orphans where + +#include "Compat.hs_h" + +import GhcMod.Types +import GhcMod.Monad.Newtypes + +#if DIFFERENT_MONADIO +import qualified MonadUtils as GHC (MonadIO(..)) +#endif +import qualified Control.Monad.IO.Class as MTL + +import Control.Monad.Reader (ReaderT(..)) +import Control.Monad.State.Strict (StateT(..)) +import Control.Monad.Trans.Journal (JournalT) +import Control.Monad.Trans.Maybe (MaybeT(..)) +import Control.Monad.Error (Error(..), ErrorT(..)) + +-------------------------------------------------- +-- Miscellaneous instances + +#if DIFFERENT_MONADIO +instance MTL.MonadIO m => GHC.MonadIO (ReaderT x m) where + liftIO = MTL.liftIO +instance MTL.MonadIO m => GHC.MonadIO (StateT x m) where + liftIO = MTL.liftIO +instance (Error e, MTL.MonadIO m) => GHC.MonadIO (ErrorT e m) where + liftIO = MTL.liftIO +instance MTL.MonadIO m => GHC.MonadIO (JournalT x m) where + liftIO = MTL.liftIO +instance MTL.MonadIO m => GHC.MonadIO (MaybeT m) where + liftIO = MTL.liftIO +deriving instance MTL.MonadIO m => GHC.MonadIO (GmOutT m) +deriving instance MTL.MonadIO m => GHC.MonadIO (GmT m) +deriving instance MTL.MonadIO m => GHC.MonadIO (GmlT m) +deriving instance GHC.MonadIO LightGhc +#endif + +deriving instance MTL.MonadIO m => MTL.MonadIO (GmOutT m) +deriving instance MTL.MonadIO m => MTL.MonadIO (GmT m) +deriving instance MTL.MonadIO m => MTL.MonadIO (GmlT m) +deriving instance MTL.MonadIO LightGhc + +instance MonadIO IO where + liftIO = id +instance MonadIO m => MonadIO (ReaderT x m) where + liftIO = MTL.liftIO +instance MonadIO m => MonadIO (StateT x m) where + liftIO = MTL.liftIO +instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where + liftIO = MTL.liftIO +instance MonadIO m => MonadIO (JournalT x m) where + liftIO = MTL.liftIO +instance MonadIO m => MonadIO (MaybeT m) where + liftIO = MTL.liftIO +instance MonadIOC m => MonadIO (GmOutT m) where + liftIO = MTL.liftIO +instance MonadIOC m => MonadIO (GmT m) where + liftIO = MTL.liftIO +instance MonadIOC m => MonadIO (GmlT m) where + liftIO = MTL.liftIO +instance MonadIO LightGhc where + liftIO = MTL.liftIO diff --git a/core/GhcMod/Monad/Out.hs b/core/GhcMod/Monad/Out.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Monad/Out.hs @@ -0,0 +1,52 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015,2016 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-} +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-} + +module GhcMod.Monad.Out where + +import GhcMod.Types +import GhcMod.Monad.Newtypes + +import Control.Monad +import Control.Monad.State.Strict (StateT(..)) +import Control.Monad.Trans.Journal (JournalT) +import Control.Monad.Trans.Maybe (MaybeT(..)) +import Control.Monad.Reader.Class +import Control.Monad.Trans.Class (MonadTrans(..)) +import Prelude + +class Monad m => GmOut m where + gmoAsk :: m GhcModOut + +instance Monad m => GmOut (GmOutT m) where + gmoAsk = GmOutT ask + +instance Monad m => GmOut (GmlT m) where + gmoAsk = GmlT $ lift $ GmOutT ask + +instance GmOut m => GmOut (GmT m) where + gmoAsk = lift gmoAsk + +instance GmOut m => GmOut (StateT s m) where + gmoAsk = lift gmoAsk + +instance GmOut m => GmOut (JournalT w m) where + gmoAsk = lift gmoAsk + +instance GmOut m => GmOut (MaybeT m) where + gmoAsk = lift gmoAsk diff --git a/core/GhcMod/Monad/State.hs b/core/GhcMod/Monad/State.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Monad/State.hs @@ -0,0 +1,67 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015,2016 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-} +{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} + +module GhcMod.Monad.State where + +import GhcMod.Types +import GhcMod.Monad.Newtypes + +import Control.Monad +import Control.Monad.State.Strict (StateT(..)) +import Control.Monad.Trans.Maybe (MaybeT(..)) +import Control.Monad.State.Class (MonadState(..)) +import Control.Monad.Trans.Class (MonadTrans(..)) +import Prelude + +class Monad m => GmState m where + gmsGet :: m GhcModState + gmsGet = gmsState (\s -> (s, s)) + + gmsPut :: GhcModState -> m () + gmsPut s = gmsState (\_ -> ((), s)) + + gmsState :: (GhcModState -> (a, GhcModState)) -> m a + gmsState f = do + s <- gmsGet + let ~(a, s') = f s + gmsPut s' + return a + {-# MINIMAL gmsState | gmsGet, gmsPut #-} + +instance GmState m => GmState (StateT s m) where + gmsGet = lift gmsGet + gmsPut = lift . gmsPut + gmsState = lift . gmsState + +instance Monad m => GmState (StateT GhcModState m) where + gmsGet = get + gmsPut = put + gmsState = state + +instance Monad m => GmState (GmT m) where + gmsGet = GmT get + gmsPut = GmT . put + gmsState = GmT . state + +instance GmState m => GmState (MaybeT m) where + gmsGet = MaybeT $ Just `liftM` gmsGet + gmsPut = MaybeT . (Just `liftM`) . gmsPut + gmsState = MaybeT . (Just `liftM`) . gmsState + +deriving instance (Monad m, GmState (GhcModT m)) => GmState (GmlT m) diff --git a/core/GhcMod/Monad/Types.hs b/core/GhcMod/Monad/Types.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Monad/Types.hs @@ -0,0 +1,239 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, RankNTypes #-} +{-# LANGUAGE TypeFamilies, UndecidableInstances, BangPatterns #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module GhcMod.Monad.Types ( + -- * Monad Types + GhcModT + , GmOutT(..) + , GmT(..) + , GmlT(..) + , LightGhc(..) + , GmGhc + , IOish + -- * Environment, state and logging + , GhcModEnv(..) + , GhcModState(..) + , GhcModCaches(..) + , defaultGhcModState + , GmGhcSession(..) + , GmComponent(..) + -- * Accessing 'GhcModEnv', 'GhcModState' and 'GhcModLog' + , GmLogLevel(..) + , GhcModLog(..) + , GhcModError(..) + , Gm + , GmEnv(..) + , GmState(..) + , GmLog(..) + , GmOut(..) + , cradle + , options + , outputOpts + , withOptions + , getMMappedFiles + , setMMappedFiles + , addMMappedFile + , delMMappedFile + , lookupMMappedFile + , getMMappedFilePaths + -- * Re-exporting convenient stuff + , MonadIO + , liftIO + , gmlGetSession + , gmlSetSession + ) where + +#include "Compat.hs_h" + +import GhcMod.Types + +import GhcMod.Monad.Env +import GhcMod.Monad.State +import GhcMod.Monad.Log +import GhcMod.Monad.Out +import GhcMod.Monad.Newtypes +import GhcMod.Monad.Orphans () + +import Safe + +import GHC +import DynFlags +import Exception +import HscTypes + +import Control.Applicative +import Control.Monad + +import Control.Monad.Reader (ReaderT(..)) +import Control.Monad.State.Strict (StateT(..)) +import Control.Monad.Trans.Journal (JournalT) +import Control.Monad.Trans.Maybe (MaybeT) + +import Control.Monad.Trans.Control + +import Control.Monad.Reader.Class + +import qualified Data.Map as M +import Data.Maybe +import Data.Monoid +import Data.IORef +import Prelude + +type Gm m = (GmEnv m, GmState m, GmLog m, GmOut m) + +-------------------------------------------------- +-- GHC API instances ----------------------------- + +-- GHC cannot prove the following instances to be decidable automatically using +-- the FlexibleContexts extension as they violate the second Paterson Condition, +-- namely that: The assertion has fewer constructors and variables (taken +-- together and counting repetitions) than the head. Specifically the +-- @MonadBaseControl IO m@ constraint in 'IOish' is causing this violation. + +type GmGhc m = (IOish m, GhcMonad m) + +instance (MonadIO m, MonadBaseControl IO m) => GhcMonad (GmlT m) where + getSession = gmlGetSession + setSession = gmlSetSession + +-- | Get the underlying GHC session +gmlGetSession :: (MonadIO m, MonadBaseControl IO m) => GmlT m HscEnv +gmlGetSession = do + ref <- gmgsSession . fromJustNote "gmlGetSession" . gmGhcSession <$> gmsGet + liftIO $ readIORef ref + +-- | Set the underlying GHC session +gmlSetSession :: (MonadIO m, MonadBaseControl IO m) => HscEnv -> GmlT m () +gmlSetSession a = do + ref <- gmgsSession . fromJustNote "gmlSetSession" . gmGhcSession <$> gmsGet + liftIO $ flip writeIORef a ref + +instance GhcMonad LightGhc where + getSession = (liftIO . readIORef) =<< LightGhc ask + setSession a = (liftIO . flip writeIORef a) =<< LightGhc ask + +#if __GLASGOW_HASKELL__ >= 706 +instance (MonadIO m, MonadBaseControl IO m) => HasDynFlags (GmlT m) where + getDynFlags = hsc_dflags <$> getSession + +instance HasDynFlags LightGhc where + getDynFlags = hsc_dflags <$> getSession +#endif + +instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (GmOutT m) where + gcatch act handler = control $ \run -> + run act `gcatch` (run . handler) + + gmask = liftBaseOp gmask . liftRestore + where liftRestore f r = f $ liftBaseOp_ r + +instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (GmT m) where + gcatch act handler = control $ \run -> + run act `gcatch` (run . handler) + + gmask = liftBaseOp gmask . liftRestore + where liftRestore f r = f $ liftBaseOp_ r + +instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (GmlT m) where + gcatch act handler = control $ \run -> + run act `gcatch` (run . handler) + + gmask = liftBaseOp gmask . liftRestore + where liftRestore f r = f $ liftBaseOp_ r + +instance ExceptionMonad LightGhc where + gcatch act handl = + LightGhc $ unLightGhc act `gcatch` \e -> unLightGhc (handl e) + gmask f = + LightGhc $ gmask $ \io_restore ->let + g_restore (LightGhc m) = LightGhc $ io_restore m + in + unLightGhc (f g_restore) + + +instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (StateT s m) where + gcatch act handler = control $ \run -> + run act `gcatch` (run . handler) + + gmask = liftBaseOp gmask . liftRestore + where liftRestore f r = f $ liftBaseOp_ r + +instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (ReaderT s m) where + gcatch act handler = control $ \run -> + run act `gcatch` (run . handler) + + gmask = liftBaseOp gmask . liftRestore + where liftRestore f r = f $ liftBaseOp_ r + +instance (Monoid w, MonadIO m, MonadBaseControl IO m) => ExceptionMonad (JournalT w m) where + gcatch act handler = control $ \run -> + run act `gcatch` (run . handler) + + gmask = liftBaseOp gmask . liftRestore + where liftRestore f r = f $ liftBaseOp_ r + +instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (MaybeT m) where + gcatch act handler = control $ \run -> + run act `gcatch` (run . handler) + + gmask = liftBaseOp gmask . liftRestore + where liftRestore f r = f $ liftBaseOp_ r + + +---------------------------------------------------------------- + +options :: GmEnv m => m Options +options = gmOptions `liftM` gmeAsk + +outputOpts :: GmOut m => m OutputOpts +outputOpts = gmoOptions `liftM` gmoAsk + +cradle :: GmEnv m => m Cradle +cradle = gmCradle `liftM` gmeAsk + +getMMappedFiles :: GmState m => m FileMappingMap +getMMappedFiles = gmMMappedFiles `liftM` gmsGet + +setMMappedFiles :: GmState m => FileMappingMap -> m () +setMMappedFiles mf = (\s -> gmsPut s { gmMMappedFiles = mf } ) =<< gmsGet + +addMMappedFile :: GmState m => FilePath -> FileMapping -> m () +addMMappedFile t fm = + getMMappedFiles >>= setMMappedFiles . M.insert t fm + +delMMappedFile :: GmState m => FilePath -> m () +delMMappedFile t = + getMMappedFiles >>= setMMappedFiles . M.delete t + +lookupMMappedFile :: GmState m => FilePath -> m (Maybe FileMapping) +lookupMMappedFile t = + M.lookup t `liftM` getMMappedFiles + +getMMappedFilePaths :: GmState m => m [FilePath] +getMMappedFilePaths = M.keys `liftM` getMMappedFiles + +withOptions :: GmEnv m => (Options -> Options) -> m a -> m a +withOptions changeOpt action = gmeLocal changeEnv action + where + changeEnv e = e { gmOptions = changeOpt opt } + where + opt = gmOptions e diff --git a/core/GhcMod/Options/DocUtils.hs b/core/GhcMod/Options/DocUtils.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Options/DocUtils.hs @@ -0,0 +1,48 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Nikolay Yakimov +-- +-- 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 . + +module GhcMod.Options.DocUtils ( + ($$), + ($$$), + (<=>), + (<$$>), + (<||>) +) where + +import Options.Applicative +import Data.Monoid +import Prelude + +infixl 6 <||> +infixr 7 <$$> +infixr 7 $$ +infixr 8 <=> +infixr 9 $$$ + +($$) :: (a -> b) -> a -> b +($$) = ($) + +($$$) :: (a -> b) -> a -> b +($$$) = ($) + +(<||>) :: Alternative a => a b -> a b -> a b +(<||>) = (<|>) + +(<=>) :: Monoid m => m -> m -> m +(<=>) = (<>) + +(<$$>) :: Functor f => (a -> b) -> f a -> f b +(<$$>) = (<$>) diff --git a/core/GhcMod/Options/Help.hs b/core/GhcMod/Options/Help.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Options/Help.hs @@ -0,0 +1,79 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Nikolay Yakimov +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . +{-# LANGUAGE OverloadedStrings, FlexibleInstances, GeneralizedNewtypeDeriving #-} + +module GhcMod.Options.Help where + +import Options.Applicative +import Options.Applicative.Help.Pretty (Doc) +import qualified Options.Applicative.Help.Pretty as PP +import Control.Monad.State +import GHC.Exts( IsString(..) ) +import Data.Maybe +import Data.Monoid +import Prelude + +newtype MyDocM s a = MyDoc {unwrapState :: State s a} + deriving (Monad, Functor, Applicative, MonadState s) +type MyDoc = MyDocM (Maybe Doc) () + +instance IsString (MyDocM (Maybe Doc) a) where + fromString = append . para + +instance Monoid (MyDocM (Maybe Doc) ()) where + mappend a b = append $ doc a <> doc b + mempty = append PP.empty + +para :: String -> Doc +para = PP.fillSep . map PP.text . words + +append :: Doc -> MyDocM (Maybe Doc) a +append s = modify m >> return undefined + where + m :: Maybe Doc -> Maybe Doc + m Nothing = Just s + m (Just old) = Just $ old PP..$. s + +infixr 7 \\ +(\\) :: MyDoc -> MyDoc -> MyDoc +(\\) a b = append $ doc a PP.<+> doc b + +doc :: MyDoc -> Doc +doc = fromMaybe PP.empty . flip execState Nothing . unwrapState + +help' :: MyDoc -> Mod f a +help' = helpDoc . Just . doc + +desc :: MyDoc -> InfoMod a +desc = footerDoc . Just . doc . indent 2 + +code :: MyDoc -> MyDoc +code x = do + _ <- " " + indent 4 x + " " + +progDesc' :: MyDoc -> InfoMod a +progDesc' = progDescDoc . Just . doc + +indent :: Int -> MyDoc -> MyDoc +indent n = append . PP.indent n . doc + +int' :: Int -> MyDoc +int' = append . PP.int + +para' :: String -> MyDoc +para' = append . para diff --git a/core/GhcMod/Options/Options.hs b/core/GhcMod/Options/Options.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Options/Options.hs @@ -0,0 +1,177 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Nikolay Yakimov +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} + +module GhcMod.Options.Options ( + globalArgSpec + , parseCmdLineOptions +) where + +import Options.Applicative +import Options.Applicative.Types +import GhcMod.Types +import Control.Arrow +import Data.Char (toUpper, toLower) +import Data.List (intercalate) +import GhcMod.Read +import GhcMod.Options.DocUtils +import 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" + <*> switch + $$ long "stack-build-deps" + <=> showDefault + <=> help "Build dependencies if needed when using stack" + 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) diff --git a/core/GhcMod/Output.hs b/core/GhcMod/Output.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Output.hs @@ -0,0 +1,243 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +-- Derived from process:System.Process +-- Copyright (c) The University of Glasgow 2004-2008 + +{-# LANGUAGE FlexibleInstances #-} +module GhcMod.Output ( + gmPutStr + , gmErrStr + , gmPutStrLn + , gmErrStrLn + + , gmPutStrIO + , gmErrStrIO + + , gmReadProcess + , gmReadProcess' + + , stdoutGateway + , flushStdoutGateway + ) where + +import Data.List +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as BS +import qualified Data.Label as L +import qualified Data.Label.Base as LB +import System.IO +import System.Exit +import System.Process +import Control.Monad +import Control.Monad.State.Strict +import Control.DeepSeq +import Control.Exception +import Control.Concurrent (forkIO, killThread) +import Control.Concurrent.MVar +import Control.Concurrent.Chan +import Pipes +import Pipes.Lift +import Prelude + +import GhcMod.Types hiding (LineSeparator, MonadIO(..)) +import GhcMod.Monad.Types hiding (MonadIO(..)) +import GhcMod.Gap () + +class ProcessOutput a where + hGetContents' :: Handle -> IO a + +instance ProcessOutput String where + hGetContents' = hGetContents + +instance ProcessOutput ByteString where + hGetContents' = BS.hGetContents + +outputFns :: (GmOut m, MonadIO m') + => m (String -> m' (), String -> m' ()) +outputFns = + outputFns' `liftM` gmoAsk + +outputFns' :: + MonadIO m => GhcModOut -> (String -> m (), String -> m ()) +outputFns' (GhcModOut oopts c) = let + OutputOpts {..} = oopts + in + case ooptLinePrefix of + Nothing -> stdioOutputFns + Just _ -> chanOutputFns c + +stdioOutputFns :: MonadIO m => (String -> m (), String -> m ()) +stdioOutputFns = + ( liftIO . putStr + , liftIO . hPutStr stderr + ) + +chanOutputFns :: MonadIO m + => Chan (Either (MVar ()) (GmStream, String)) + -> (String -> m (), String -> m ()) +chanOutputFns c = (write GmOutStream, write GmErrStream) + where + write stream s = liftIO $ writeChan c $ Right $ (stream,s) + +gmPutStr, gmPutStrLn, gmErrStr, gmErrStrLn + :: (MonadIO m, GmOut m) => String -> m () + +gmPutStr str = do + putOut <- gmPutStrIO + putOut str + +gmErrStr str = do + putErr <- gmErrStrIO + putErr str + +gmPutStrLn = gmPutStr . (++"\n") +gmErrStrLn = gmErrStr . (++"\n") + +gmPutStrIO, gmErrStrIO :: (GmOut m, MonadIO mi) => m (String -> mi ()) + +gmPutStrIO = fst `liftM` outputFns +gmErrStrIO = snd `liftM` outputFns + + +gmReadProcess :: GmOut m => m (FilePath -> [String] -> String -> IO String) +gmReadProcess = do + GhcModOut {..} <- gmoAsk + case ooptLinePrefix gmoOptions of + Just _ -> + readProcessStderrChan + Nothing -> + return $ readProcess + +gmReadProcess' :: GmOut m => m (FilePath -> [String] -> String -> IO ByteString) +gmReadProcess' = readProcessStderrChan + +flushStdoutGateway :: Chan (Either (MVar ()) (GmStream, String)) -> IO () +flushStdoutGateway c = do + mv <- newEmptyMVar + writeChan c $ Left mv + takeMVar mv + +type Line = String + +stdoutGateway :: (String, String) -> Chan (Either (MVar ()) (GmStream, String)) -> IO () +stdoutGateway (outPf, errPf) chan = do + runEffect $ commandProc >-> evalStateP ("","") seperateStreams + where + commandProc :: Producer (Either (MVar ()) (GmStream, String)) IO () + commandProc = do + cmd <- liftIO $ readChan chan + case cmd of + Left mv -> do + yield $ Left mv + Right input -> do + yield $ Right input + commandProc + + seperateStreams :: Consumer (Either (MVar ()) (GmStream, String)) (StateT (String, String) IO) () + seperateStreams = do + ecmd <- await + case ecmd of + Left mv -> do + -- flush buffers + (\s -> lift $ zoom (streamLens s) $ sGetLine Nothing) + `mapM_` [GmOutStream, GmErrStream] + + liftIO $ putMVar mv () + Right (stream, str) -> do + ls <- lift $ zoom (streamLens stream) $ sGetLine (Just str) + case ls of + [] -> return () + _ -> liftIO $ putStr $ unlines $ map (streamPf stream++) ls + + liftIO $ hFlush stdout + seperateStreams + + sGetLine :: (Maybe String) -> StateT String IO [Line] + sGetLine mstr' = do + buf <- get + let mstr = (buf++) `liftM` mstr' + case mstr of + Nothing -> put "" >> return [buf] + Just "" -> return [] + Just s | last s == '\n' -> put "" >> return (lines s) + | otherwise -> do + let (p:ls') = reverse $ lines s + put p + return $ reverse $ ls' + + streamLens GmOutStream = LB.fst + streamLens GmErrStream = LB.snd + + streamPf GmOutStream = outPf + streamPf GmErrStream = errPf + +zoom :: Monad m => (f L.:-> o) -> StateT o m a -> StateT f m a +zoom l (StateT a) = + StateT $ \f -> do + (a', s') <- a $ L.get l f + return (a', L.set l s' f) + +readProcessStderrChan :: + (GmOut m, ProcessOutput a, NFData a) => m (FilePath -> [String] -> String -> IO a) +readProcessStderrChan = do + (_, e :: String -> IO ()) <- outputFns + return $ readProcessStderrChan' e + +readProcessStderrChan' :: (ProcessOutput a, NFData a) => + (String -> IO ()) -> FilePath -> [String] -> String -> IO a +readProcessStderrChan' putErr exe args input = do + let cp = (proc exe args) { + std_out = CreatePipe + , std_err = CreatePipe + , std_in = CreatePipe + } + (Just i, Just o, Just e, h) <- createProcess cp + + _ <- forkIO $ reader e + + output <- hGetContents' o + withForkWait (evaluate $ rnf output) $ \waitOut -> do + + -- now write any input + unless (null input) $ + ignoreSEx $ hPutStr i input + -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE + ignoreSEx $ hClose i + + -- wait on the output + waitOut + hClose o + + res <- waitForProcess h + case res of + ExitFailure rv -> + throw $ GMEProcess "readProcessStderrChan" exe args $ Left rv + ExitSuccess -> + return output + where + ignoreSEx = handle (\(SomeException _) -> return ()) + reader h = ignoreSEx $ do + putErr . (++"\n") =<< hGetLine h + reader h + +withForkWait :: IO () -> (IO () -> IO a) -> IO a +withForkWait async body = do + waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ())) + mask $ \restore -> do + tid <- forkIO $ try (restore async) >>= putMVar waitVar + let wait = takeMVar waitVar >>= either throwIO return + restore (body wait) `onException` killThread tid diff --git a/core/GhcMod/PathsAndFiles.hs b/core/GhcMod/PathsAndFiles.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/PathsAndFiles.hs @@ -0,0 +1,242 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +module GhcMod.PathsAndFiles ( + module GhcMod.PathsAndFiles + , module GhcMod.Caching + ) where + +import Config (cProjectVersion) +import Control.Arrow (second) +import Control.Applicative +import Control.Exception as E +import Control.Monad +import Control.Monad.Trans.Maybe +import Data.List +import Data.Char +import Data.Maybe +import Data.Traversable hiding (mapM) +import Distribution.Helper (buildPlatform) +import System.Directory +import System.FilePath +import System.Process + +import GhcMod.Types +import GhcMod.Caching +import qualified GhcMod.Utils as U +import Utils (mightExist) +import Prelude + +-- | Guaranteed to be a path to a directory with no trailing slash. +type DirPath = FilePath + +-- | Guaranteed to be the name of a file only (no slashes). +type FileName = String + +-- | @findCabalFiles dir@. Searches for a @.cabal@ files in @dir@'s parent +-- directories. The first parent directory containing more than one cabal file +-- is assumed to be the project directory. If only one cabal file exists in this +-- directory it is returned otherwise @findCabalFiles@ throws 'GMENoCabalFile' +-- or 'GMETooManyCabalFiles' +findCabalFile :: FilePath -> IO (Maybe FilePath) +findCabalFile dir = findFileInParentsP isCabalFile pick dir + where + pick [] = Nothing + pick [cf] = Just cf + pick cfs = throw $ GMETooManyCabalFiles cfs + +findStackConfigFile :: FilePath -> IO (Maybe FilePath) +findStackConfigFile dir = + findFileInParentsP (=="stack.yaml") pick dir + where + pick [] = Nothing + pick (sf:_) = Just sf + +findCabalSandboxDir :: FilePath -> IO (Maybe FilePath) +findCabalSandboxDir dir = + fmap takeDirectory <$> findFileInParentsP isSandboxConfig pick dir + where + isSandboxConfig = (==sandboxConfigFileName) + pick [] = Nothing + pick (sc:_) = Just sc + +findCustomPackageDbFile :: FilePath -> IO (Maybe FilePath) +findCustomPackageDbFile dir = + mightExist $ dir "ghc-mod.package-db-stack" + +-- | Get path to sandbox config file +getSandboxDb :: Cradle -> IO (Maybe GhcPkgDb) +getSandboxDb crdl = do + mConf <- traverse readFile =<< mightExist (sandboxConfigFile crdl) + bp <- buildPlatform readProcess + return $ PackageDb . fixPkgDbVer bp <$> (extractSandboxDbDir =<< mConf) + + where + fixPkgDbVer bp dir = + case takeFileName dir == ghcSandboxPkgDbDir bp of + True -> dir + False -> takeDirectory dir ghcSandboxPkgDbDir bp + +-- | Extract the sandbox package db directory from the cabal.sandbox.config +-- file. Exception is thrown if the sandbox config file is broken. +extractSandboxDbDir :: String -> Maybe FilePath +extractSandboxDbDir conf = extractValue <$> parse conf + where + key = "package-db:" + keyLen = length key + + parse = listToMaybe . filter (key `isPrefixOf`) . lines + extractValue = U.dropWhileEnd isSpace . dropWhile isSpace . drop keyLen + + +-- | +-- >>> isCabalFile "/home/user/.cabal" +-- False +isCabalFile :: FilePath -> Bool +isCabalFile f = takeExtension' f == ".cabal" + +-- | +-- >>> takeExtension' "/some/dir/bla.cabal" +-- ".cabal" +-- +-- >>> takeExtension' "some/reldir/bla.cabal" +-- ".cabal" +-- +-- >>> takeExtension' "bla.cabal" +-- ".cabal" +-- +-- >>> takeExtension' ".cabal" +-- "" +takeExtension' :: FilePath -> String +takeExtension' p = + if takeFileName p == takeExtension p + then "" -- just ".cabal" is not a valid cabal file + else takeExtension p + +-- | @findFileInParentsP p r dir@ Look for files satisfying @p@ in @dir@ and all +-- it's parent directories. Files found to satisfy @p@ in a given directory are +-- passed to @r@ and if this yields a 'Just' value the search finishes early +-- without examinig any more directories and this value is returned. +findFileInParentsP :: (FilePath -> Bool) + -> ([FilePath] -> Maybe a) + -> FilePath + -> IO (Maybe a) +findFileInParentsP p r dir = runMaybeT $ + join $ msum <$> map (MaybeT . fmap r) <$> liftIO (findFilesInParentsP p dir) + +-- | @findFilesInParentsP p dir@ Look for files satisfying @p@ in @dir@ and all +-- it's parent directories. +findFilesInParentsP :: (FilePath -> Bool) -> FilePath + -> IO [IO [FilePath]] +findFilesInParentsP p dir' = U.makeAbsolute' dir' >>= \dir -> return $ + map (\d -> (map (d )) <$> getFilesP p d) $ parents dir + +-- | @getFilesP p dir@. Find all __files__ satisfying @p@ in @.cabal@ in @dir@. +getFilesP :: (FilePath -> Bool) -> DirPath -> IO [FileName] +getFilesP p dir = filterM p' =<< getDirectoryContentsSafe + where + p' fn = do + (p fn && ) <$> doesFileExist (dir fn) + getDirectoryContentsSafe = do + rdable <- readable <$> getPermissions dir + if rdable + then getDirectoryContents dir + else return [] + +-- | @parents dir@. Returns all parent directories of @dir@ including @dir@. +-- +-- Examples +-- +-- >>> parents "foo" +-- ["foo"] +-- +-- >>> parents "/foo" +-- ["/foo","/"] +-- +-- >>> parents "/foo/bar" +-- ["/foo/bar","/foo","/"] +-- +-- >>> parents "foo/bar" +-- ["foo/bar","foo"] +parents :: FilePath -> [FilePath] +parents "" = [] +parents dir' = + let (drive, dir) = splitDrive $ normalise $ dropTrailingPathSeparator dir' + in map (joinDrive drive) $ parents' $ filter (/=".") $ splitDirectories dir + where + parents' :: [String] -> [FilePath] + parents' [] | isAbsolute dir' = "":[] + parents' [] = [] + parents' dir = [joinPath dir] ++ parents' (init dir) + +---------------------------------------------------------------- + +setupConfigFile :: Cradle -> FilePath +setupConfigFile crdl = + cradleRootDir crdl setupConfigPath (cradleDistDir crdl) + +sandboxConfigFile :: Cradle -> FilePath +sandboxConfigFile crdl = cradleRootDir crdl sandboxConfigFileName + +sandboxConfigFileName :: String +sandboxConfigFileName = "cabal.sandbox.config" + +-- | Path to 'LocalBuildInfo' file, usually @dist/setup-config@ +setupConfigPath :: FilePath -> FilePath +setupConfigPath dist = dist "setup-config" + -- localBuildInfoFile defaultDistPref + +macrosHeaderPath :: FilePath +macrosHeaderPath = autogenModulesDir "cabal_macros.h" + +autogenModulePath :: String -> String +autogenModulePath pkg_name = + autogenModulesDir ("Paths_" ++ map fixchar pkg_name) <.> ".hs" + where fixchar '-' = '_' + fixchar c = c + +autogenModulesDir :: FilePath +autogenModulesDir = "build" "autogen" + +ghcSandboxPkgDbDir :: String -> String +ghcSandboxPkgDbDir buildPlatf = do + buildPlatf ++ "-ghc-" ++ cProjectVersion ++ "-packages.conf.d" + +packageCache :: String +packageCache = "package.cache" + +-- | Filename of the symbol table cache file. +symbolCache :: Cradle -> FilePath +symbolCache crdl = cradleRootDir crdl cradleDistDir crdl symbolCacheFile + +symbolCacheFile :: String +symbolCacheFile = "ghc-mod.symbol-cache" + +resolvedComponentsCacheFile :: FilePath -> FilePath +resolvedComponentsCacheFile dist = + setupConfigPath dist <.> "ghc-mod.resolved-components" + +cabalHelperCacheFile :: FilePath -> FilePath +cabalHelperCacheFile dist = + setupConfigPath dist <.> "ghc-mod.cabal-components" + +mergedPkgOptsCacheFile :: FilePath -> FilePath +mergedPkgOptsCacheFile dist = + setupConfigPath dist <.> "ghc-mod.package-options" + +pkgDbStackCacheFile :: FilePath -> FilePath +pkgDbStackCacheFile dist = + setupConfigPath dist <.> "ghc-mod.package-db-stack" diff --git a/core/GhcMod/Pretty.hs b/core/GhcMod/Pretty.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Pretty.hs @@ -0,0 +1,90 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +module GhcMod.Pretty + ( renderGm + , renderSDoc + , gmComponentNameDoc + , gmLogLevelDoc + , (<+>:) + , fnDoc + , showToDoc + , warnDoc + , strLnDoc + , strDoc + ) where + +import Control.Arrow hiding ((<+>)) +import Data.Char +import Data.List +import Distribution.Helper +import Pretty +import GHC +import Outputable (SDoc, withPprStyleDoc) + +import GhcMod.Types +import GhcMod.Doc +import GhcMod.Gap (renderGm) + +renderSDoc :: GhcMonad m => SDoc -> m Doc +renderSDoc sdoc = do + df <- getSessionDynFlags + ppsty <- getStyle + return $ withPprStyleDoc df ppsty sdoc + +gmComponentNameDoc :: ChComponentName -> Doc +gmComponentNameDoc ChSetupHsName = text $ "Setup.hs" +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 + +gmLogLevelDoc :: GmLogLevel -> Doc +gmLogLevelDoc GmSilent = error "GmSilent MUST not be used for log messages" +gmLogLevelDoc GmPanic = text "PANIC" +gmLogLevelDoc GmException = text "EXCEPTION" +gmLogLevelDoc GmError = text "ERROR" +gmLogLevelDoc GmWarning = text "Warning" +gmLogLevelDoc GmInfo = text "info" +gmLogLevelDoc GmDebug = text "DEBUG" +gmLogLevelDoc GmVomit = text "VOMIT" + +infixl 6 <+>: +(<+>:) :: Doc -> Doc -> Doc +a <+>: b = (a <> colon) <+> b + +fnDoc :: FilePath -> Doc +fnDoc = doubleQuotes . text + +showToDoc :: Show a => a -> Doc +showToDoc = strLnDoc . show + +warnDoc :: Doc -> Doc +warnDoc d = text "Warning" <+>: d + +strLnDoc :: String -> Doc +strLnDoc str = doc (dropWhileEnd isSpace str) + where + doc = lines >>> map text >>> foldr ($+$) empty + +strDoc :: String -> Doc +strDoc str = doc (dropWhileEnd isSpace str) + where + doc :: String -> Doc + doc = lines + >>> map (words >>> map text >>> fsep) + >>> \l -> case l of (x:xs) -> hang x 4 (vcat xs); [] -> empty diff --git a/core/GhcMod/Read.hs b/core/GhcMod/Read.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Read.hs @@ -0,0 +1,106 @@ +module GhcMod.Read where + +import Text.Read (readPrec_to_S, readPrec, minPrec) +import qualified Text.ParserCombinators.ReadP as P +import Text.ParserCombinators.ReadPrec (lift) + +-- This library (libraries/base) is derived from code from several +-- sources: + +-- * Code from the GHC project which is largely (c) The University of +-- Glasgow, and distributable under a BSD-style license (see below), + +-- * Code from the Haskell 98 Report which is (c) Simon Peyton Jones +-- and freely redistributable (but see the full license for +-- restrictions). + +-- * Code from the Haskell Foreign Function Interface specification, +-- which is (c) Manuel M. T. Chakravarty and freely redistributable +-- (but see the full license for restrictions). + +-- The full text of these licenses is reproduced below. All of the +-- licenses are BSD-style or compatible. + +-- ----------------------------------------------------------------------------- + +-- The Glasgow Haskell Compiler License + +-- Copyright 2004, The University Court of the University of Glasgow. +-- All rights reserved. + +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: + +-- - Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. + +-- - Redistributions in binary form must reproduce the above copyright notice, +-- this list of conditions and the following disclaimer in the documentation +-- and/or other materials provided with the distribution. + +-- - Neither name of the University nor the names of its contributors may be +-- used to endorse or promote products derived from this software without +-- specific prior written permission. + +-- THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF +-- GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +-- INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +-- FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +-- UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +-- LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +-- OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +-- DAMAGE. + +-- ----------------------------------------------------------------------------- + +-- Code derived from the document "Report on the Programming Language +-- Haskell 98", is distributed under the following license: + +-- Copyright (c) 2002 Simon Peyton Jones + +-- The authors intend this Report to belong to the entire Haskell +-- community, and so we grant permission to copy and distribute it for +-- any purpose, provided that it is reproduced in its entirety, +-- including this Notice. Modified versions of this Report may also be +-- copied and distributed for any purpose, provided that the modified +-- version is clearly presented as such, and that it does not claim to +-- be a definition of the Haskell 98 Language. + +-- ----------------------------------------------------------------------------- + +-- Code derived from the document "The Haskell 98 Foreign Function +-- Interface, An Addendum to the Haskell 98 Report" is distributed under +-- the following license: + +-- Copyright (c) 2002 Manuel M. T. Chakravarty + +-- The authors intend this Report to belong to the entire Haskell +-- community, and so we grant permission to copy and distribute it for +-- any purpose, provided that it is reproduced in its entirety, +-- including this Notice. Modified versions of this Report may also be +-- copied and distributed for any purpose, provided that the modified +-- version is clearly presented as such, and that it does not claim to +-- be a definition of the Haskell 98 Foreign Function Interface. + +-- ----------------------------------------------------------------------------- + +readEither :: Read a => String -> Either String a +readEither s = + case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of + [x] -> Right x + [] -> Left "Prelude.read: no parse" + _ -> Left "Prelude.read: ambiguous parse" + where + read' = + do x <- readPrec + lift P.skipSpaces + return x + +readMaybe :: Read a => String -> Maybe a +readMaybe s = case readEither s of + Left _ -> Nothing + Right a -> Just a diff --git a/core/GhcMod/SrcUtils.hs b/core/GhcMod/SrcUtils.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/SrcUtils.hs @@ -0,0 +1,191 @@ +-- TODO: remove CPP once Gap(ed) +{-# LANGUAGE CPP, TupleSections, FlexibleInstances, Rank2Types #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module GhcMod.SrcUtils where + +import Control.Applicative +import CoreUtils (exprType) +import Data.Generics +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 qualified Var as G +import qualified Type as G +import GHC.SYB.Utils +import GhcMonad +import qualified Language.Haskell.Exts as HE +import GhcMod.Doc +import GhcMod.Gap +import qualified GhcMod.Gap as Gap +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 + +---------------------------------------------------------------- + +instance HasType (LHsExpr Id) where + getType tcm e = do + hs_env <- G.getSession + mbe <- liftIO $ Gap.deSugar tcm e hs_env + return $ (G.getLoc e, ) <$> CoreUtils.exprType <$> mbe + +instance HasType (LPat Id) where + getType _ (G.L spn pat) = return $ Just (spn, hsPatType pat) + +---------------------------------------------------------------- + +-- | 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 + p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc + +listifyParsedSpans :: Typeable a => ParsedSource -> (Int, Int) -> [Located a] +listifyParsedSpans pcs lc = listifyStaged Parser p pcs + where + p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc + +listifyRenamedSpans :: Typeable a => RenamedSource -> (Int, Int) -> [Located a] +listifyRenamedSpans pcs lc = listifyStaged Renamer p pcs + where + p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc + +listifyStaged :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r] +listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x])) + +cmp :: SrcSpan -> SrcSpan -> Ordering +cmp a b + | a `G.isSubspanOf` b = O.LT + | b `G.isSubspanOf` a = O.GT + | otherwise = O.EQ + +toTup :: DynFlags -> PprStyle -> (SrcSpan, Type) -> ((Int,Int,Int,Int),String) +toTup dflag style (spn, typ) = (fourInts spn, pretty dflag style typ) + +fourInts :: SrcSpan -> (Int,Int,Int,Int) +fourInts = fromMaybe (0,0,0,0) . Gap.getSrcSpan + +fourIntsHE :: HE.SrcSpan -> (Int,Int,Int,Int) +fourIntsHE loc = ( HE.srcSpanStartLine loc, HE.srcSpanStartColumn loc + , HE.srcSpanEndLine loc, HE.srcSpanEndColumn loc) + +-- Check whether (line,col) is inside a given SrcSpanInfo +typeSigInRangeHE :: Int -> Int -> HE.Decl HE.SrcSpanInfo -> Bool +typeSigInRangeHE lineNo colNo (HE.TypeSig (HE.SrcSpanInfo s _) _ _) = + HE.srcSpanStart s <= (lineNo, colNo) && HE.srcSpanEnd s >= (lineNo, colNo) +typeSigInRangeHE lineNo colNo (HE.TypeFamDecl (HE.SrcSpanInfo s _) _ _ _) = + HE.srcSpanStart s <= (lineNo, colNo) && HE.srcSpanEnd s >= (lineNo, colNo) +typeSigInRangeHE lineNo colNo (HE.DataFamDecl (HE.SrcSpanInfo s _) _ _ _) = + HE.srcSpanStart s <= (lineNo, colNo) && HE.srcSpanEnd s >= (lineNo, colNo) +typeSigInRangeHE _ _ _= False + +pretty :: DynFlags -> PprStyle -> Type -> String +pretty dflag style = showOneLine dflag style . Gap.typeForUser + +showName :: DynFlags -> PprStyle -> G.Name -> String +showName dflag style name = showOneLine dflag style $ Gap.nameForUser name + +showOccName :: DynFlags -> PprStyle -> OccName -> String +showOccName dflag style name = showOneLine dflag style $ Gap.occNameForUser name diff --git a/core/GhcMod/Stack.hs b/core/GhcMod/Stack.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Stack.hs @@ -0,0 +1,97 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +module GhcMod.Stack where + +import Safe +import Control.Applicative +import Control.Exception as E +import Control.Monad +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Class +import Data.List +import Data.List.Split +import Data.Maybe +import System.Directory +import System.FilePath +import System.Info.Extra +import Exception + +import GhcMod.Types +import GhcMod.Monad.Types +import GhcMod.Output +import GhcMod.Logging +import GhcMod.Error +import qualified GhcMod.Utils as U +import Prelude + +patchStackPrograms :: (IOish m, GmOut m) => Cradle -> Programs -> m Programs +patchStackPrograms Cradle { cradleProject = (StackProject senv) } progs = do + Just ghc <- getStackGhcPath senv + Just ghcPkg <- getStackGhcPkgPath senv + return $ progs { + ghcProgram = ghc + , ghcPkgProgram = ghcPkg + } +patchStackPrograms _crdl progs = return progs + +getStackEnv :: (IOish m, GmOut m, GmLog m) + => FilePath -> FilePath -> m (Maybe StackEnv) +getStackEnv projdir stackProg = U.withDirectory_ projdir $ runMaybeT $ do + env <- map (liToTup . splitOn ": ") . lines <$> readStack stackProg ["path"] + let look k = fromJustNote "getStackEnv" $ lookup k env + return StackEnv { + seDistDir = look "dist-dir" + , seBinPath = splitSearchPath $ look "bin-path" + , seSnapshotPkgDb = look "snapshot-pkg-db" + , seLocalPkgDb = look "local-pkg-db" + } + where + liToTup [k,v] = (k,v) + liToTup [k] = (k, error "getStackEnv: missing key '"++k++"'") + liToTup _ = error "getStackEnv" + +getStackGhcPath :: IOish m => StackEnv -> m (Maybe FilePath) +getStackGhcPath = findExecutablesInStackBinPath "ghc" + +getStackGhcPkgPath :: IOish m => StackEnv -> m (Maybe FilePath) +getStackGhcPkgPath = findExecutablesInStackBinPath "ghc-pkg" + +findExecutablesInStackBinPath :: IOish m => String -> StackEnv -> m (Maybe FilePath) +findExecutablesInStackBinPath exe StackEnv {..} = + liftIO $ listToMaybe <$> findExecutablesInDirectories' seBinPath exe + +findExecutablesInDirectories' :: [FilePath] -> String -> IO [FilePath] +findExecutablesInDirectories' path binary = + U.findFilesWith' isExecutable path (binary <.> exeExtension') + where isExecutable file = do + perms <- getPermissions file + return $ executable perms + + exeExtension' = if isWindows then "exe" else "" + +readStack :: (IOish m, GmOut m, GmLog m) + => FilePath -> [String] -> MaybeT m String +readStack exe args = do + stack <- MaybeT $ liftIO $ findExecutable exe + readProc <- lift gmReadProcess + flip gcatch handler $ do + liftIO $ evaluate =<< readProc stack args "" + where + handler (e :: IOError) = do + gmLog GmWarning "readStack" $ gmeDoc $ exToErr e + mzero + exToErr = GMEStackBootstrap . GMEString . show diff --git a/core/GhcMod/Target.hs b/core/GhcMod/Target.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Target.hs @@ -0,0 +1,515 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +{-# LANGUAGE CPP, ViewPatterns, NamedFieldPuns, RankNTypes #-} +module GhcMod.Target where + +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 +import HscTypes +import Pretty + +import GhcMod.DynFlags +import GhcMod.Monad.Types +import GhcMod.CabalHelper +import GhcMod.HomeModuleGraph +import GhcMod.PathsAndFiles +import GhcMod.GhcPkg +import GhcMod.Error +import GhcMod.Logging +import GhcMod.Types +import GhcMod.Utils as U +import GhcMod.FileMapping +import GhcMod.LightGhc +import GhcMod.CustomPackageDb +import GhcMod.Output + +import Safe +import Data.Maybe +import Data.Monoid as Monoid +import Data.Either +import Data.Foldable as Foldable (foldrM) +import qualified Data.Foldable as Foldable +import Data.Traversable hiding (mapM, forM) +import Data.IORef +import Data.List +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Function (on) +import Distribution.Helper +import Prelude hiding ((.)) + +import System.Directory +import System.FilePath + +runGmPkgGhc :: (IOish m, Gm m) => LightGhc a -> m a +runGmPkgGhc action = do + pkgOpts <- packageGhcOptions + withLightHscEnv pkgOpts $ \env -> liftIO $ runLightGhc env action + +initSession :: IOish m + => [GHCOption] + -> (forall gm. GhcMonad gm => DynFlags -> gm DynFlags) + -> GhcModT m () +initSession opts mdf = do + s <- gmsGet + case gmGhcSession s of + Nothing -> do + gmLog GmDebug "initSession" $ text "Session not initialized, creating new one" + putNewSession s + Just (GmGhcSession hsc_env_ref) -> do + crdl <- cradle + + df <- liftIO $ hsc_dflags <$> readIORef hsc_env_ref + changed <- + withLightHscEnv' (initDF crdl) $ \hsc_env -> + return $ not $ hsc_dflags hsc_env `eqDynFlags` df + + if changed + then do + gmLog GmDebug "initSession" $ text "Flags changed, creating new session" + teardownSession hsc_env_ref + putNewSession s + else + gmLog GmDebug "initSession" $ text "Session already initialized" + where + initDF Cradle { cradleTempDir } df = + setTmpDir cradleTempDir <$> (mdf =<< addCmdOpts opts df) + + teardownSession hsc_env_ref = do + hsc_env <- liftIO $ readIORef hsc_env_ref + teardownLightEnv hsc_env + + putNewSession :: IOish m => GhcModState -> GhcModT m () + putNewSession s = do + crdl <- cradle + nhsc_env_ref <- liftIO . newIORef =<< newLightEnv (initDF crdl) + runLightGhc' nhsc_env_ref $ setSessionDynFlags =<< getSessionDynFlags + gmsPut s { gmGhcSession = Just $ GmGhcSession nhsc_env_ref } + + +-- | Drop the currently active GHC session, the next that requires a GHC session +-- will initialize a new one. +dropSession :: IOish m => GhcModT m () +dropSession = do + s <- gmsGet + case gmGhcSession s of + Just (GmGhcSession ref) -> do + -- TODO: This is still not enough, there seem to still be references to + -- GHC's state around afterwards. + liftIO $ writeIORef ref (error "HscEnv: session was dropped") + -- Not available on ghc<7.8; didn't really help anyways + -- liftIO $ setUnsafeGlobalDynFlags (error "DynFlags: session was dropped") + gmsPut s { gmGhcSession = Nothing } + + Nothing -> return () + +-- | Run a GmlT action (i.e. a function in the GhcMonad) in the context +-- of certain files or modules +runGmlT :: IOish m => [Either FilePath ModuleName] -> GmlT m a -> GhcModT m a +runGmlT fns action = runGmlT' fns return action + +-- | Run a GmlT action (i.e. a function in the GhcMonad) in the context +-- of certain files or modules, with updated GHC flags +runGmlT' :: IOish m + => [Either FilePath ModuleName] + -> (forall gm. GhcMonad gm => DynFlags -> gm DynFlags) + -> GmlT m a + -> GhcModT m a +runGmlT' fns mdf action = runGmlTWith fns mdf id action + +-- | Run a GmlT action (i.e. a function in the GhcMonad) in the context +-- of certain files or modules, with updated GHC flags and a final +-- transformation +runGmlTWith :: IOish m + => [Either FilePath ModuleName] + -> (forall gm. GhcMonad gm => DynFlags -> gm DynFlags) + -> (GmlT m a -> GmlT m b) + -> GmlT m a + -> GhcModT m b +runGmlTWith efnmns' mdf wrapper action = do + crdl <- cradle + Options { optGhcUserOptions } <- options + + let (fns, mns) = partitionEithers efnmns' + ccfns = map (cradleCurrentDir crdl ) fns + cfns <- mapM getCanonicalFileNameSafe ccfns + let serfnmn = Set.fromList $ map Right mns ++ map Left cfns + opts <- targetGhcOptions crdl serfnmn + let opts' = opts ++ ["-O0"] ++ optGhcUserOptions + + gmVomit + "session-ghc-options" + (text "Initializing GHC session with following options") + (intercalate " " $ map (("\""++) . (++"\"")) opts') + + GhcModLog { gmLogLevel = Just level } <- gmlHistory + putErr <- gmErrStrIO + let setLogger | level >= GmDebug = setDebugLogger putErr + | otherwise = setEmptyLogger + + initSession opts' $ + setHscNothing >>> setLogger >>> mdf + + mappedStrs <- getMMappedFilePaths + let targetStrs = mappedStrs ++ map moduleNameString mns ++ cfns + + unGmlT $ wrapper $ do + loadTargets opts targetStrs + action + +targetGhcOptions :: forall m. IOish m + => Cradle + -> Set (Either FilePath ModuleName) + -> GhcModT m [GHCOption] +targetGhcOptions crdl sefnmn = do + when (Set.null sefnmn) $ error "targetGhcOptions: no targets given" + + case cradleProject crdl of + proj + | isCabalHelperProject proj -> cabalOpts crdl + | otherwise -> sandboxOpts crdl + where + zipMap f l = l `zip` (f `map` l) + + cabalOpts :: Cradle -> GhcModT m [String] + cabalOpts Cradle{..} = do + mcs <- cabalResolvedComponents + + let mdlcs = moduleComponents mcs `zipMap` Set.toList sefnmn + candidates = findCandidates $ map snd mdlcs + + let noCandidates = Set.null candidates + noModuleHasAnyAssignment = all (Set.null . snd) mdlcs + + if noCandidates && noModuleHasAnyAssignment + then do + -- First component should be ChLibName, if no lib will take lexically first exe. + let cns = filter (/= ChSetupHsName) $ Map.keys mcs + + gmLog GmDebug "" $ strDoc $ "Could not find a component assignment, falling back to picking library component in cabal file." + return $ gmcGhcOpts $ fromJustNote "targetGhcOptions, no-assignment" $ Map.lookup (head cns) mcs + else do + when noCandidates $ + throwError $ GMECabalCompAssignment mdlcs + + let cn = pickComponent candidates + return $ gmcGhcOpts $ fromJustNote "targetGhcOptions" $ Map.lookup cn mcs + +resolvedComponentsCache :: IOish m => FilePath -> + Cached (GhcModT m) GhcModState + [GmComponent 'GMCRaw (Set.Set ModulePath)] + (Map.Map ChComponentName (GmComponent 'GMCResolved (Set.Set ModulePath))) +resolvedComponentsCache distdir = Cached { + cacheLens = Just (lGmcResolvedComponents . lGmCaches), + cacheFile = resolvedComponentsCacheFile distdir, + cachedAction = \tcfs comps ma -> do + Cradle {..} <- cradle + let iifs = invalidatingInputFiles tcfs + + setupChanged = + (cradleRootDir setupConfigPath distdir) `elem` iifs + + mums :: Maybe [Either FilePath ModuleName] + mums = + let + filterOutSetupCfg = + filter (/= cradleRootDir setupConfigPath distdir) + changedFiles = filterOutSetupCfg iifs + in if null changedFiles || setupChanged + then Nothing + else Just $ map Left changedFiles + + let mdesc (Left f) = "file:" ++ f + mdesc (Right mn) = "module:" ++ moduleNameString mn + + changed = map (text . mdesc) $ Foldable.concat mums + changedDoc | [] <- changed = text "none" + | otherwise = sep changed + + gmLog GmDebug "resolvedComponentsCache" $ + text "files changed" <+>: changedDoc + + mcs <- resolveGmComponents ((,) <$> mums <*> ma) comps + + return (setupConfigPath distdir : flatten mcs , mcs) + } + + where + flatten :: Map.Map ChComponentName (GmComponent t (Set.Set ModulePath)) + -> [FilePath] + flatten = Map.elems + >>> map (gmcHomeModuleGraph >>> gmgGraph + >>> (Map.keysSet &&& Map.elems) + >>> uncurry insert + >>> map (Set.map mpPath) + >>> Set.unions + ) + >>> Set.unions + >>> Set.toList + +moduleComponents :: Map ChComponentName (GmComponent t (Set ModulePath)) + -> Either FilePath ModuleName + -> Set ChComponentName +moduleComponents m efnmn = + foldr' Set.empty m $ \c s -> + let + memb = + case efnmn of + Left fn -> fn `Set.member` Set.map mpPath (smp c) + Right mn -> mn `Set.member` Set.map mpModule (smp c) + in if memb + then Set.insert (gmcName c) s + else s + where + smp c = Map.keysSet $ gmgGraph $ gmcHomeModuleGraph c + + foldr' b as f = Map.foldr f b as + + +findCandidates :: [Set ChComponentName] -> Set ChComponentName +findCandidates [] = Set.empty +findCandidates scns = foldl1 Set.intersection scns + +pickComponent :: Set ChComponentName -> ChComponentName +pickComponent scn = Set.findMin scn + +packageGhcOptions :: (IOish m, Applicative m, Gm m) => m [GHCOption] +packageGhcOptions = do + crdl <- cradle + case cradleProject crdl of + proj + | isCabalHelperProject proj -> getGhcMergedPkgOptions + | otherwise -> sandboxOpts crdl + +-- also works for plain projects! +sandboxOpts :: (IOish m, GmEnv m) => Cradle -> m [String] +sandboxOpts crdl = do + mCusPkgDb <- getCustomPkgDbStack + pkgDbStack <- liftIO $ getSandboxPackageDbStack + let pkgOpts = ghcDbStackOpts $ fromMaybe pkgDbStack mCusPkgDb + return $ ["-i" ++ d | d <- [wdir,rdir]] ++ pkgOpts ++ ["-Wall"] + where + (wdir, rdir) = (cradleCurrentDir crdl, cradleRootDir crdl) + + getSandboxPackageDbStack :: IO [GhcPkgDb] + getSandboxPackageDbStack = + ([GlobalDb] ++) . maybe [UserDb] return <$> getSandboxDb crdl + +resolveGmComponent :: (IOish m, Gm m) + => Maybe [CompilationUnit] -- ^ Updated modules + -> GmComponent 'GMCRaw (Set ModulePath) + -> m (GmComponent 'GMCResolved (Set ModulePath)) +resolveGmComponent mums c@GmComponent {..} = do + distDir <- cradleDistDir <$> cradle + gmLog GmDebug "resolveGmComponent" $ text $ show $ ghcOpts distDir + withLightHscEnv (ghcOpts distDir) $ \env -> do + let srcDirs = if null gmcSourceDirs then [""] else gmcSourceDirs + let mg = gmcHomeModuleGraph + let simp = gmcEntrypoints + sump <- case mums of + Nothing -> return simp + Just ums -> + Set.fromList . catMaybes <$> + mapM (resolveModule env srcDirs) ums + + mg' <- canonicalizeModuleGraph =<< updateHomeModuleGraph env mg simp sump + + return $ c { gmcEntrypoints = simp, gmcHomeModuleGraph = mg' } + + where ghcOpts distDir = concat [ + gmcGhcSrcOpts, + gmcGhcLangOpts, + [ "-optP-include", "-optP" ++ distDir macrosHeaderPath ] + ] + +resolveEntrypoint :: (IOish m, Gm m) + => Cradle + -> GmComponent 'GMCRaw ChEntrypoint + -> m (GmComponent 'GMCRaw (Set ModulePath)) +resolveEntrypoint Cradle {..} c@GmComponent {..} = do + gmLog GmDebug "resolveEntrypoint" $ text $ show $ gmcGhcSrcOpts + withLightHscEnv gmcGhcSrcOpts $ \env -> do + let srcDirs = if null gmcSourceDirs then [""] else gmcSourceDirs + eps <- liftIO $ resolveChEntrypoints cradleRootDir gmcEntrypoints + rms <- resolveModule env srcDirs `mapM` eps + return c { gmcEntrypoints = Set.fromList $ catMaybes rms } + +-- TODO: remember that the file from `main-is:` is always module `Main` and let +-- ghc do the warning about it. Right now we run that module through +-- resolveModule like any other +resolveChEntrypoints :: FilePath -> ChEntrypoint -> IO [CompilationUnit] +resolveChEntrypoints _ (ChLibEntrypoint em om) = + return $ map (Right . chModToMod) (em ++ om) + +resolveChEntrypoints _ (ChExeEntrypoint main om) = + return $ [Left main] ++ map (Right . chModToMod) om + +resolveChEntrypoints srcDir ChSetupEntrypoint = do + shs <- doesFileExist (srcDir "Setup.hs") + slhs <- doesFileExist (srcDir "Setup.lhs") + return $ case (shs, slhs) of + (True, _) -> [Left "Setup.hs"] + (_, True) -> [Left "Setup.lhs"] + (False, False) -> [] + +chModToMod :: ChModuleName -> ModuleName +chModToMod (ChModuleName mn) = mkModuleName mn + + +resolveModule :: (IOish m, Gm m) => + HscEnv -> [FilePath] -> CompilationUnit -> m (Maybe ModulePath) +resolveModule env _srcDirs (Right mn) = + liftIO $ traverse canonicalizeModulePath =<< findModulePath env mn +resolveModule env srcDirs (Left fn') = do + mfn <- liftIO $ findFile' srcDirs fn' + case mfn of + Nothing -> return Nothing + Just fn'' -> do + fn <- liftIO $ canonicalizePath fn'' + emn <- fileModuleName env fn + case emn of + Left errs -> do + gmLog GmWarning ("resolveModule " ++ show fn) $ + Pretty.empty $+$ (vcat $ map text errs) + return Nothing -- TODO: should expose these errors otherwise + -- modules with preprocessor/parse errors are + -- going to be missing + Right mmn -> return $ Just $ + case mmn of + Nothing -> mkMainModulePath fn + Just mn -> ModulePath mn fn + where + -- needed for ghc 7.4 + findFile' dirs file = + getFirst . mconcat <$> mapM (fmap First . mightExist . (file)) dirs + + -- fileModuleName fn (dir:dirs) + -- | makeRelative dir fn /= fn + +type CompilationUnit = Either FilePath ModuleName +type Components = + [GmComponent 'GMCRaw (Set ModulePath)] +type ResolvedComponentsMap = + Map ChComponentName (GmComponent 'GMCResolved (Set ModulePath)) + +resolveGmComponents :: (IOish m, Gm m) + => Maybe ([CompilationUnit], ResolvedComponentsMap) + -- ^ Updated modules + -> Components -> m ResolvedComponentsMap +resolveGmComponents mcache cs = do + let rcm = fromMaybe Map.empty $ snd <$> mcache + + m' <- foldrM' rcm cs $ \c m -> do + case Map.lookup (gmcName c) m of + Nothing -> insertUpdated m c + Just c' -> if same gmcRawEntrypoints c c' && same gmcGhcSrcOpts c c' + then return m + else insertUpdated m c + return m' + + where + foldrM' b fa f = foldrM f b fa + insertUpdated m c = do + rc <- resolveGmComponent (fst <$> mcache) c + return $ Map.insert (gmcName rc) rc m + + same :: Eq b + => (forall t a. GmComponent t a -> b) + -> GmComponent u c -> GmComponent v d -> Bool + same f a b = (f a) == (f b) + +-- | Set the files as targets and load them. +loadTargets :: IOish m => [GHCOption] -> [FilePath] -> GmlT m () +loadTargets opts targetStrs = do + targets' <- + withLightHscEnv opts $ \env -> + liftM (nubBy ((==) `on` targetId)) + (mapM ((`guessTarget` Nothing) >=> mapFile env) targetStrs) + >>= mapM relativize + + let targets = map (\t -> t { targetAllowObjCode = False }) targets' + + gmLog GmDebug "loadTargets" $ + text "Loading" <+>: fsep (map (text . showTargetId) targets) + + setTargets targets + + mg <- depanal [] False + + let interp = needsHscInterpreted mg + target <- hscTarget <$> getSessionDynFlags + when (interp && target /= HscInterpreted) $ do + _ <- setSessionDynFlags . setHscInterpreted =<< getSessionDynFlags + gmLog GmInfo "loadTargets" $ text "Target needs interpeter, switching to LinkInMemory/HscInterpreted. Perfectly normal if anything is using TemplateHaskell, QuasiQuotes or PatternSynonyms." + + target' <- hscTarget <$> getSessionDynFlags + + case target' of + HscNothing -> do + void $ load LoadAllTargets + forM_ mg $ + handleSourceError (gmLog GmDebug "loadTargets" . text . show) + . void . (parseModule >=> typecheckModule >=> desugarModule) + HscInterpreted -> do + void $ load LoadAllTargets + _ -> error ("loadTargets: unsupported hscTarget") + + gmLog GmDebug "loadTargets" $ text "Loading done" + + where + relativize (Target (TargetFile filePath phase) taoc src) = do + crdl <- cradle + let tid = TargetFile relativeFilePath phase + relativeFilePath = makeRelative (cradleRootDir crdl) filePath + return $ Target tid taoc src + relativize tgt = return tgt + + showTargetId (Target (TargetModule s) _ _) = moduleNameString s + showTargetId (Target (TargetFile s _) _ _) = s + +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))) +cabalResolvedComponents = do + crdl@(Cradle{..}) <- cradle + comps <- mapM (resolveEntrypoint crdl) =<< getComponents + withAutogen $ + cached cradleRootDir (resolvedComponentsCache cradleDistDir) comps diff --git a/core/GhcMod/Types.hs b/core/GhcMod/Types.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Types.hs @@ -0,0 +1,406 @@ +{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, RankNTypes, + StandaloneDeriving, DefaultSignatures, FlexibleInstances, TemplateHaskell, + GeneralizedNewtypeDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-} +module GhcMod.Types ( + module GhcMod.Types + , ModuleName + , mkModuleName + , moduleNameString + ) where + +import Control.Monad.Trans.Control (MonadBaseControl) +import Control.Monad.Error (Error(..)) +import qualified Control.Monad.IO.Class as MTL +import Control.Exception (Exception) +import Control.Applicative +import Control.Concurrent +import Control.Monad +import Control.DeepSeq +import Data.Binary +import Data.Binary.Generic +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Monoid +import Data.Maybe +import Data.Typeable (Typeable) +import Data.IORef +import Data.Label.Derive +import Distribution.Helper hiding (Programs(..)) +import qualified Distribution.Helper as CabalHelper +import Exception (ExceptionMonad) +#if __GLASGOW_HASKELL__ < 708 +import qualified MonadUtils as GHC (MonadIO(..)) +#endif +import GHC (ModuleName, moduleNameString, mkModuleName) +import HscTypes (HscEnv) +import GHC.Generics +import Pretty (Doc) +import Prelude + +import GhcMod.Caching.Types + +-- | A constraint alias (-XConstraintKinds) to make functions dealing with +-- 'GhcModT' somewhat cleaner. +-- +-- Basicially an @IOish m => m@ is a 'Monad' supporting arbitrary 'IO' and +-- exception handling. Usually this will simply be 'IO' but we parametrise it in +-- the exported API so users have the option to use a custom inner monad. +type IOish m = (Functor m, MonadIO m, MonadBaseControl IO m, ExceptionMonad m) + + +-- MonadUtils of GHC 7.6 or earlier defines its own MonadIO. +-- MonadUtils of GHC 7.8 or later imports MonadIO in Monad.Control.IO.Class. +#if __GLASGOW_HASKELL__ < 708 +type MonadIOC m = (GHC.MonadIO m, MTL.MonadIO m) +#else +type MonadIOC m = (MTL.MonadIO m) +#endif + +class MonadIOC m => MonadIO m where + liftIO :: IO a -> m a + +-- | Output style. +data OutputStyle = LispStyle -- ^ S expression style. + | PlainStyle -- ^ Plain textstyle. + deriving (Show) + +-- | The type for line separator. Historically, a Null string is used. +newtype LineSeparator = LineSeparator String deriving (Show) + +data FileMapping = FileMapping {fmPath :: FilePath, fmTemp :: Bool} + deriving (Eq, Show) + +type FileMappingMap = Map FilePath FileMapping + +data ProgramSource = ProgramSourceUser | ProgramSourceStack + +data Programs = Programs { + -- | @ghc@ program name. + ghcProgram :: FilePath + -- | @ghc-pkg@ program name. + , ghcPkgProgram :: FilePath + -- | @cabal@ program name. + , cabalProgram :: FilePath + -- | @stack@ program name. + , stackProgram :: FilePath + } deriving (Show) + +data OutputOpts = OutputOpts { + -- | Verbosity + ooptLogLevel :: GmLogLevel + , ooptStyle :: OutputStyle + -- | Line separator string. + , ooptLineSeparator :: LineSeparator + -- | Stdout/err line multiplexing using prefix encoding. @fst@ is stdout, + -- @snd@ is stderr prefix. + , ooptLinePrefix :: Maybe (String, String) + } deriving (Show) + +data Options = Options { + optOutput :: OutputOpts + , optPrograms :: Programs + -- | GHC command line options set on the @ghc-mod@ command line + , optGhcUserOptions :: [GHCOption] + , optFileMappings :: [(FilePath, Maybe FilePath)] + , optEncoding :: String + , optStackBuildDeps :: Bool + } deriving (Show) + +-- | A default 'Options'. +defaultOptions :: Options +defaultOptions = Options { + optOutput = OutputOpts { + ooptLogLevel = GmWarning + , ooptStyle = PlainStyle + , ooptLineSeparator = LineSeparator "\0" + , ooptLinePrefix = Nothing + } + , optPrograms = Programs { + ghcProgram = "ghc" + , ghcPkgProgram = "ghc-pkg" + , cabalProgram = "cabal" + , stackProgram = "stack" + } + , optGhcUserOptions = [] + , optFileMappings = [] + , optEncoding = "UTF-8" + , optStackBuildDeps = False + } + +---------------------------------------------------------------- + +data Project = CabalProject + | SandboxProject + | PlainProject + | StackProject StackEnv + deriving (Eq, Show, Ord) + +isCabalHelperProject :: Project -> Bool +isCabalHelperProject StackProject {} = True +isCabalHelperProject CabalProject {} = True +isCabalHelperProject _ = False + +data StackEnv = StackEnv { + seDistDir :: FilePath + , seBinPath :: [FilePath] + , seSnapshotPkgDb :: FilePath + , seLocalPkgDb :: FilePath + } deriving (Eq, Show, Ord) + +-- | The environment where this library is used. +data Cradle = Cradle { + cradleProject :: Project + -- | The directory where this library is executed. + , cradleCurrentDir :: FilePath + -- | The project root directory. + , cradleRootDir :: FilePath + -- | Per-Project temporary directory + , cradleTempDir :: FilePath + -- | The file name of the found cabal file. + , cradleCabalFile :: Maybe FilePath + -- | The build info directory. + , cradleDistDir :: FilePath + } deriving (Eq, Show, Ord) + +data GmStream = GmOutStream | GmErrStream + deriving (Show) + +data GhcModEnv = GhcModEnv { + gmOptions :: Options + , gmCradle :: Cradle + } + +data GhcModOut = GhcModOut { + gmoOptions :: OutputOpts + , gmoChan :: Chan (Either (MVar ()) (GmStream, String)) + } + +data GhcModLog = GhcModLog { + gmLogLevel :: Maybe GmLogLevel, + gmLogVomitDump :: Last Bool, + gmLogMessages :: [(GmLogLevel, String, Doc)] + } deriving (Show) + +instance Monoid GhcModLog where + mempty = GhcModLog (Just GmPanic) (Last Nothing) mempty + GhcModLog ml vd ls `mappend` GhcModLog ml' vd' ls' = + GhcModLog (ml' `mplus` ml) (vd `mappend` vd') (ls `mappend` ls') + +data GmGhcSession = GmGhcSession { + gmgsSession :: !(IORef HscEnv) + } + +data GhcModCaches = GhcModCaches { + gmcPackageDbStack :: CacheContents ChCacheData [GhcPkgDb] + , gmcMergedPkgOptions :: CacheContents ChCacheData [GHCOption] + , gmcComponents :: CacheContents ChCacheData [GmComponent 'GMCRaw ChEntrypoint] + , gmcResolvedComponents :: CacheContents + [GmComponent 'GMCRaw (Set.Set ModulePath)] + (Map.Map ChComponentName (GmComponent 'GMCResolved (Set.Set ModulePath))) + } + +data GhcModState = GhcModState { + gmGhcSession :: !(Maybe GmGhcSession) + , gmCaches :: !GhcModCaches + , gmMMappedFiles :: !FileMappingMap + } + +defaultGhcModState :: GhcModState +defaultGhcModState = + GhcModState n (GhcModCaches n n n n) Map.empty + where n = Nothing + +---------------------------------------------------------------- + +-- | GHC package database flags. +data GhcPkgDb = GlobalDb + | UserDb + | PackageDb String + deriving (Eq, Show, Generic) + +instance Binary GhcPkgDb where + put = ggput . from + get = to `fmap` ggget + +-- | A single GHC command line option. +type GHCOption = String + +-- | An include directory for modules. +type IncludeDir = FilePath + +-- | Haskell expression. +newtype Expression = Expression { getExpression :: String } + deriving (Show, Eq, Ord) + +-- | Module name. +newtype ModuleString = ModuleString { getModuleString :: String } + deriving (Show, Eq, Ord, Binary, NFData) + +data GmLogLevel = + GmSilent + | GmPanic + | GmException + | GmError + | GmWarning + | GmInfo + | GmDebug + | GmVomit + deriving (Eq, Ord, Enum, Bounded, Show, Read) + +data GmModuleGraph = GmModuleGraph { + gmgGraph :: Map ModulePath (Set ModulePath) + } deriving (Eq, Ord, Show, Read, Generic, Typeable) + +instance Binary GmModuleGraph where + put GmModuleGraph {..} = put (mpim, graph) + where + mpim :: Map ModulePath Integer + mpim = Map.fromList $ Map.keys gmgGraph `zip` [0..] + graph :: Map Integer (Set Integer) + graph = Map.map (Set.map mpToInt) $ Map.mapKeys mpToInt gmgGraph + mpToInt :: ModulePath -> Integer + mpToInt mp = fromJust $ Map.lookup mp mpim + + get = do + (mpim :: Map ModulePath Integer, graph :: Map Integer (Set Integer)) <- get + let impm = swapMap mpim + intToMp i = fromJust $ Map.lookup i impm + mpGraph :: Map ModulePath (Set ModulePath) + mpGraph = Map.map (Set.map intToMp) $ Map.mapKeys intToMp graph + return $ GmModuleGraph mpGraph + where + swapMap :: Ord v => Map k v -> Map v k + swapMap = Map.fromList . map (\(x, y) -> (y, x)) . Map.toList + +instance Monoid GmModuleGraph where + mempty = GmModuleGraph mempty + mappend (GmModuleGraph a) (GmModuleGraph a') = + GmModuleGraph (Map.unionWith Set.union a a') + +data GmComponentType = GMCRaw + | GMCResolved +data GmComponent (t :: GmComponentType) eps = GmComponent { + gmcHomeModuleGraph :: GmModuleGraph + , gmcName :: ChComponentName + , gmcGhcOpts :: [GHCOption] + , gmcGhcPkgOpts :: [GHCOption] + , gmcGhcSrcOpts :: [GHCOption] + , gmcGhcLangOpts :: [GHCOption] + , gmcRawEntrypoints :: ChEntrypoint + , gmcEntrypoints :: eps + , gmcSourceDirs :: [FilePath] + } deriving (Eq, Ord, Show, Read, Generic, Functor) + +instance Binary eps => Binary (GmComponent t eps) where + put = ggput . from + get = to `fmap` ggget + +data ModulePath = ModulePath { mpModule :: ModuleName, mpPath :: FilePath } + deriving (Eq, Ord, Show, Read, Generic, Typeable) +instance Binary ModulePath where + put = ggput . from + get = to `fmap` ggget + +instance Binary ModuleName where + get = mkModuleName <$> get + put mn = put (moduleNameString mn) + +instance Show ModuleName where + show mn = "ModuleName " ++ show (moduleNameString mn) + +instance Read ModuleName where + readsPrec d = + readParen + (d > app_prec) + (\r' -> [ (mkModuleName m, t) + | ("ModuleName", s) <- lex r' + , (m, t) <- readsPrec (app_prec + 1) s + ]) + where + app_prec = 10 + +data GhcModError + = GMENoMsg + -- ^ Unknown error + + | GMEString String + -- ^ Some Error with a message. These are produced mostly by + -- 'fail' calls on GhcModT. + + | GMECabalConfigure GhcModError + -- ^ Configuring a cabal project failed. + + | GMEStackConfigure GhcModError + -- ^ Configuring a stack project failed. + + | GMEStackBootstrap GhcModError + -- ^ Bootstrapping @stack@ environment failed (process exited with failure) + + | GMECabalCompAssignment [(Either FilePath ModuleName, Set ChComponentName)] + -- ^ Could not find a consistent component assignment for modules + + | GMEProcess String String [String] (Either Int GhcModError) + -- ^ Launching an operating system process failed. Fields in + -- order: function, command, arguments, (stdout, stderr, exitcode) + + | GMENoCabalFile + -- ^ No cabal file found. + + | GMETooManyCabalFiles [FilePath] + -- ^ Too many cabal files found. + + deriving (Eq,Show,Typeable) + +instance Error GhcModError where + noMsg = GMENoMsg + strMsg = GMEString + +instance Exception GhcModError + +instance Binary CabalHelper.Programs where + put = ggput . from + get = to `fmap` ggget +instance Binary ChModuleName where + put = ggput . from + get = to `fmap` ggget +instance Binary ChComponentName where + put = ggput . from + get = to `fmap` ggget +instance Binary ChEntrypoint where + put = ggput . from + get = to `fmap` ggget + +-- | Options for "lintWith" function +data LintOpts = LintOpts { + optLintHlintOpts :: [String] + -- ^ options that will be passed to hlint executable + } deriving (Show) + +-- | Default "LintOpts" instance +defaultLintOpts :: LintOpts +defaultLintOpts = LintOpts [] + +-- | Options for "browseWith" function +data BrowseOpts = BrowseOpts { + optBrowseOperators :: Bool + -- ^ 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 False + +mkLabel ''GhcModCaches +mkLabel ''GhcModState +mkLabel ''Options +mkLabel ''OutputOpts +mkLabel ''Programs diff --git a/core/GhcMod/Utils.hs b/core/GhcMod/Utils.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Utils.hs @@ -0,0 +1,165 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DoAndIfThenElse #-} + +module GhcMod.Utils ( + module GhcMod.Utils + , module Utils + , readProcess + ) where + +import Control.Applicative +import Data.Char +import qualified Data.Map as M +import Data.Maybe (fromMaybe) +import Data.Either (rights) +import Data.List (inits) +import Exception +import GhcMod.Error +import GhcMod.Types +import GhcMod.Monad.Types +import System.Directory +import System.Environment +import System.FilePath +import System.IO.Temp (createTempDirectory) +import System.Process (readProcess) +import Text.Printf + +import Paths_ghc_mod (getLibexecDir, getBinDir) +import Utils +import Prelude + +-- dropWhileEnd is not provided prior to base 4.5.0.0. +dropWhileEnd :: (a -> Bool) -> [a] -> [a] +dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) [] + +withDirectory_ :: (MonadIO m, ExceptionMonad m) => FilePath -> m a -> m a +withDirectory_ dir action = + gbracket + (liftIO getCurrentDirectory) + (liftIO . setCurrentDirectory) + (\_ -> liftIO (setCurrentDirectory dir) >> action) + +uniqTempDirName :: FilePath -> FilePath +uniqTempDirName dir = + "ghc-mod" ++ map escapeDriveChar drive ++ map escapePathChar path + where + (drive, path) = splitDrive dir + escapeDriveChar :: Char -> Char + escapeDriveChar c + | isAlphaNum c = c + | otherwise = '-' + escapePathChar :: Char -> Char + escapePathChar c + | c `elem` pathSeparators = '-' + | otherwise = c + +newTempDir :: FilePath -> IO FilePath +newTempDir _dir = + flip createTempDirectory "ghc-mod" =<< getTemporaryDirectory + +whenM :: Monad m => m Bool -> m () -> m () +whenM mb ma = mb >>= flip when ma + +-- | Returns the path to the currently running ghc-mod executable. With ghc<7.6 +-- this is a guess but >=7.6 uses 'getExecutablePath'. +ghcModExecutable :: IO FilePath +ghcModExecutable = do + exe <- getExecutablePath' + stack <- lookupEnv "STACK_EXE" + case takeBaseName exe of + "spec" | Just _ <- stack -> + ( "ghc-mod") <$> getBinDir + "spec" -> + ( "dist/build/ghc-mod/ghc-mod") <$> getCurrentDirectory + "ghc-mod" -> + return exe + _ -> + return $ takeDirectory exe "ghc-mod" + +getExecutablePath' :: IO FilePath +#if __GLASGOW_HASKELL__ >= 706 +getExecutablePath' = getExecutablePath +#else +getExecutablePath' = getProgName +#endif + +canonFilePath :: FilePath -> IO FilePath +canonFilePath f = do + p <- canonicalizePath f + e <- doesFileExist p + when (not e) $ error $ "canonFilePath: not a file: " ++ p + return p + +withMappedFile :: (IOish m, GmState m, GmEnv m) => + forall a. FilePath -> (FilePath -> m a) -> m a +withMappedFile file action = getCanonicalFileNameSafe file >>= lookupMMappedFile >>= runWithFile + where + runWithFile (Just to) = action $ fmPath to + runWithFile _ = action file + +getCanonicalFileNameSafe :: (IOish m, GmEnv m) => FilePath -> m FilePath +getCanonicalFileNameSafe fn = do + let fn' = normalise fn + pl <- liftIO $ rights <$> (mapM ((try :: IO FilePath -> IO (Either SomeException FilePath)) . canonicalizePath . joinPath) $ reverse $ inits $ splitPath' fn') + return $ + if (length pl > 0) + then joinPath $ (head pl):(drop (length pl - 1) (splitPath fn')) + else error "Current dir doesn't seem to exist?" + where +#if __GLASGOW_HASKELL__ < 710 + splitPath' = (".":) . splitPath +#else + splitPath' = splitPath +#endif + +mkRevRedirMapFunc :: (Functor m, GmState m, GmEnv m) => m (FilePath -> FilePath) +mkRevRedirMapFunc = do + rm <- M.fromList <$> map (uncurry mf) <$> M.toList <$> getMMappedFiles + crdl <- cradle + return $ \key -> + fromMaybe key + $ makeRelative (cradleRootDir crdl) + <$> M.lookup key rm + where + mf :: FilePath -> FileMapping -> (FilePath, FilePath) + mf from to = (fmPath to, from) + +findFilesWith' :: (FilePath -> IO Bool) -> [FilePath] -> String -> IO [FilePath] +findFilesWith' _ [] _ = return [] +findFilesWith' f (d:ds) fileName = do + let file = d fileName + exist <- doesFileExist file + b <- if exist then f file else return False + if b then do + files <- findFilesWith' f ds fileName + return $ file : files + else findFilesWith' f ds fileName + + +-- Copyright : (c) The University of Glasgow 2001 +-- | Make a path absolute by prepending the current directory (if it isn't +-- already absolute) and applying 'normalise' to the result. +-- +-- If the path is already absolute, the operation never fails. Otherwise, the +-- operation may fail with the same exceptions as 'getCurrentDirectory'. +makeAbsolute' :: FilePath -> IO FilePath +makeAbsolute' = (normalise <$>) . absolutize + where absolutize path -- avoid the call to `getCurrentDirectory` if we can + | isRelative path = ( path) <$> getCurrentDirectory + | otherwise = return path diff --git a/core/GhcMod/World.hs b/core/GhcMod/World.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/World.hs @@ -0,0 +1,55 @@ +module GhcMod.World where + +import GhcMod.GhcPkg +import GhcMod.PathsAndFiles +import GhcMod.Types +import GhcMod.Monad.Types +import GhcMod.Utils + +import Control.Applicative +import Data.Maybe +import Data.Traversable hiding (mapM) +import System.FilePath (()) + +import GHC.Paths (libdir) +import Prelude + +data World = World { + worldPackageCaches :: [TimedFile] + , worldCabalFile :: Maybe TimedFile + , worldCabalConfig :: Maybe TimedFile + , worldCabalSandboxConfig :: Maybe TimedFile + , worldMappedFiles :: FileMappingMap + } deriving (Eq) + +timedPackageCaches :: IOish m => GhcModT m [TimedFile] +timedPackageCaches = do + fs <- mapM (liftIO . mightExist) . map ( packageCache) + =<< getPackageCachePaths libdir + (liftIO . timeFile) `mapM` catMaybes fs + +getCurrentWorld :: IOish m => GhcModT m World +getCurrentWorld = do + crdl <- cradle + pkgCaches <- timedPackageCaches + mCabalFile <- liftIO $ timeFile `traverse` cradleCabalFile crdl + mCabalConfig <- liftIO $ timeMaybe (setupConfigFile crdl) + mCabalSandboxConfig <- liftIO $ timeMaybe (sandboxConfigFile crdl) + mFileMap <- getMMappedFiles + + return World { + worldPackageCaches = pkgCaches + , worldCabalFile = mCabalFile + , worldCabalConfig = mCabalConfig + , worldCabalSandboxConfig = mCabalSandboxConfig + , worldMappedFiles = mFileMap + } + +didWorldChange :: IOish m => World -> GhcModT m Bool +didWorldChange world = do + (world /=) <$> getCurrentWorld + +isYoungerThanSetupConfig :: FilePath -> World -> IO Bool +isYoungerThanSetupConfig file World {..} = do + tfile <- timeFile file + return $ worldCabalConfig < Just tfile diff --git a/elisp/ghc-func.el b/elisp/ghc-func.el --- a/elisp/ghc-func.el +++ b/elisp/ghc-func.el @@ -211,7 +211,7 @@ default-directory))) ;; ghc-mod root (with-temp-buffer (let ((default-directory cdir)) - (apply 'ghc-call-process target nil t nil + (apply 'ghc-call-process target nil '(t nil) nil (append (ghc-make-ghc-options) cmds)) (buffer-substring (point-min) (1- (point-max))))))))) diff --git a/elisp/ghc-process.el b/elisp/ghc-process.el --- a/elisp/ghc-process.el +++ b/elisp/ghc-process.el @@ -55,7 +55,7 @@ (let ((pro (ghc-get-process cpro name buf root)) (map-cmd (format "map-file %s\n" file))) ; (unmap-cmd (format "unmap-file %s\n" file))) - (when (buffer-modified-p (current-buffer)) + (when (buffer-modified-p cbuf) (setq ghc-process-file-mapping t) (setq ghc-process-async-after-callback nil) (erase-buffer) diff --git a/elisp/ghc.el b/elisp/ghc.el --- a/elisp/ghc.el +++ b/elisp/ghc.el @@ -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.8.0.0") (defgroup ghc-mod '() "ghc-mod customization") diff --git a/ghc-mod.cabal b/ghc-mod.cabal --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -1,5 +1,5 @@ Name: ghc-mod -Version: 5.5.0.0 +Version: 5.8.0.0 Author: Kazu Yamamoto , Daniel Gröber , Alejandro Serrano , @@ -8,8 +8,8 @@ License: AGPL-3 License-File: LICENSE License-Files: COPYING.BSD3 COPYING.AGPL3 -Homepage: http://www.mew.org/~kazu/proj/ghc-mod/ -Synopsis: Happy Haskell Programming +Homepage: https://github.com/DanielG/ghc-mod +Synopsis: Happy Haskell Hacking Description: ghc-mod is a backend program to enrich Haskell programming in editors. It strives to offer most of the features one has come to expect from modern IDEs @@ -22,38 +22,30 @@ significantly extend ghc-mod you should submit these changes upstream instead of implementing them on top of the library. - For more information, please see its home page. Category: GHC, Development -Cabal-Version: >= 1.14 +Cabal-Version: >= 1.18 Build-Type: Custom Data-Files: elisp/Makefile elisp/*.el -Data-Files: LICENSE COPYING.BSD3 COPYING.AGPL3 Extra-Source-Files: ChangeLog - SetupCompat.hs - NotCPP/*.hs - NotCPP/COPYING - Language/Haskell/GhcMod/Monad/Compat.hs_h + README.md + core/GhcMod/Monad/Compat.hs_h test/data/annotations/*.hs test/data/broken-cabal/*.cabal - test/data/broken-cabal/cabal.sandbox.config.in test/data/broken-sandbox/cabal.sandbox.config test/data/broken-sandbox/dummy.cabal test/data/cabal-flags/cabal-flags.cabal test/data/cabal-project/*.cabal test/data/cabal-project/*.hs test/data/cabal-project/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf - test/data/cabal-project/cabal.sandbox.config.in test/data/cabal-project/subdir1/subdir2/dummy test/data/case-split/*.hs - test/data/check-packageid/cabal.sandbox.config.in test/data/check-packageid/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-2.8.0.0-32d4f24abdbb6bf41272b183b2e23e9c.conf test/data/check-test-subdir/*.cabal test/data/check-test-subdir/src/Check/Test/*.hs test/data/check-test-subdir/test/*.hs test/data/check-test-subdir/test/Bar/*.hs - test/data/duplicate-pkgver/cabal.sandbox.config.in test/data/duplicate-pkgver/duplicate-pkgver.cabal test/data/duplicate-pkgver/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-1.0-7c59d13f32294d1ef6dc6233c24df961.conf test/data/duplicate-pkgver/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-2.8.0.0-14e543bdae2da4d2aeff5386892c9112.conf @@ -88,158 +80,193 @@ test/data/file-mapping/preprocessor/*.hs test/data/file-mapping/lhs/*.lhs test/data/nice-qualification/*.hs - test/data/stack-project/stack.yaml + test/data/stack-project/stack.yaml.in test/data/stack-project/new-template.cabal test/data/stack-project/*.hs test/data/stack-project/app/*.hs test/data/stack-project/src/*.hs test/data/stack-project/test/*.hs + bench/data/simple-cabal/simple-cabal.cabal + bench/data/simple-cabal/*.hs + +Custom-Setup + Setup-Depends: base + , Cabal >= 1.18 && < 1.25 + , containers + , filepath + , directory + , process + , template-haskell + , transformers + + Library Default-Language: Haskell2010 GHC-Options: -Wall -fno-warn-deprecations Default-Extensions: ScopedTypeVariables, RecordWildCards, NamedFieldPuns, ConstraintKinds, FlexibleContexts, DataKinds, KindSignatures, TypeOperators, ViewPatterns - Exposed-Modules: Language.Haskell.GhcMod - Language.Haskell.GhcMod.Internal - Language.Haskell.GhcMod.Boot - Language.Haskell.GhcMod.Browse - Language.Haskell.GhcMod.CabalHelper - Language.Haskell.GhcMod.Caching - Language.Haskell.GhcMod.Caching.Types - Language.Haskell.GhcMod.CaseSplit - Language.Haskell.GhcMod.Check - Language.Haskell.GhcMod.Convert - Language.Haskell.GhcMod.Cradle - Language.Haskell.GhcMod.CustomPackageDb - Language.Haskell.GhcMod.Debug - Language.Haskell.GhcMod.DebugLogger - Language.Haskell.GhcMod.Doc - Language.Haskell.GhcMod.DynFlags - Language.Haskell.GhcMod.Error - Language.Haskell.GhcMod.FileMapping - Language.Haskell.GhcMod.FillSig - Language.Haskell.GhcMod.Find - Language.Haskell.GhcMod.Flag - Language.Haskell.GhcMod.Gap - Language.Haskell.GhcMod.GhcPkg - Language.Haskell.GhcMod.HomeModuleGraph - Language.Haskell.GhcMod.Info - Language.Haskell.GhcMod.Lang - Language.Haskell.GhcMod.Lint - Language.Haskell.GhcMod.LightGhc - Language.Haskell.GhcMod.Logger - Language.Haskell.GhcMod.Logging - Language.Haskell.GhcMod.Modules - Language.Haskell.GhcMod.Monad - Language.Haskell.GhcMod.Monad.Env - Language.Haskell.GhcMod.Monad.Log - Language.Haskell.GhcMod.Monad.Newtypes - Language.Haskell.GhcMod.Monad.Orphans - Language.Haskell.GhcMod.Monad.Out - Language.Haskell.GhcMod.Monad.State - Language.Haskell.GhcMod.Monad.Types - Language.Haskell.GhcMod.Output - Language.Haskell.GhcMod.PathsAndFiles - Language.Haskell.GhcMod.PkgDoc - Language.Haskell.GhcMod.Pretty - Language.Haskell.GhcMod.Read - Language.Haskell.GhcMod.SrcUtils - Language.Haskell.GhcMod.Stack - Language.Haskell.GhcMod.Target - Language.Haskell.GhcMod.Test - Language.Haskell.GhcMod.Types - Language.Haskell.GhcMod.Utils - Language.Haskell.GhcMod.World + HS-Source-Dirs: ., core, shared + Exposed-Modules: + GhcMod + GhcMod.Exe.Boot + GhcMod.Exe.Browse + GhcMod.Exe.CaseSplit + GhcMod.Exe.Check + GhcMod.Exe.Debug + GhcMod.Exe.FillSig + GhcMod.Exe.Find + GhcMod.Exe.Flag + GhcMod.Exe.Info + GhcMod.Exe.Internal + GhcMod.Exe.Lang + GhcMod.Exe.Lint + GhcMod.Exe.Modules + GhcMod.Exe.PkgDoc + GhcMod.Exe.Test + GhcMod.CabalHelper + GhcMod.Caching + GhcMod.Caching.Types + GhcMod.Convert + GhcMod.Cradle + GhcMod.CustomPackageDb + GhcMod.DebugLogger + GhcMod.Doc + GhcMod.DynFlags + GhcMod.DynFlagsTH + GhcMod.Error + GhcMod.FileMapping + GhcMod.Gap + GhcMod.GhcPkg + GhcMod.HomeModuleGraph + GhcMod.LightGhc + GhcMod.Logger + GhcMod.Logging + GhcMod.Monad + GhcMod.Monad.Env + GhcMod.Monad.Log + GhcMod.Monad.Newtypes + GhcMod.Monad.Orphans + GhcMod.Monad.Out + GhcMod.Monad.State + GhcMod.Monad.Types + GhcMod.Options.DocUtils + GhcMod.Options.Help + GhcMod.Options.Options + GhcMod.Output + GhcMod.PathsAndFiles + GhcMod.Pretty + GhcMod.Read + GhcMod.SrcUtils + GhcMod.Stack + GhcMod.Target + GhcMod.Types + GhcMod.Utils + GhcMod.World 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 - , containers < 0.6 - , cabal-helper < 0.7 && >= 0.6.3.0 - , deepseq < 1.5 - , directory < 1.3 - , filepath < 1.5 - , ghc < 7.11 - , ghc-paths < 0.2 - , ghc-syb-utils < 0.3 - , hlint < 1.10 && >= 1.8.61 - , monad-journal < 0.8 && >= 0.4 - , old-time < 1.2 - , pretty < 1.2 - , process < 1.3 - , syb < 0.7 - , temporary < 1.3 - , time < 1.6 - , transformers < 0.5 - , transformers-base < 0.5 - , mtl < 2.3 && >= 2.0 - , monad-control < 1.1 && >= 1 - , split < 0.3 - , haskell-src-exts < 1.18 - , text < 1.3 - , djinn-ghc < 0.1 && >= 0.0.2.2 - , fclabels == 2.0.* - , extra == 1.4.* - , pipes == 4.1.* - , safe < 0.4 && >= 0.3.9 + Build-Depends: + -- See Note [GHC Boot libraries] + binary + , bytestring + , containers + , deepseq + , directory + , filepath + , mtl + , old-time + , process + , template-haskell + , time + , transformers + + , base < 4.10 && >= 4.6.0.1 + , djinn-ghc < 0.1 && >= 0.0.2.2 + , extra < 1.6 && >= 1.4 + , fclabels < 2.1 && >= 2.0 + , ghc-paths < 0.2 && >= 0.1.0.9 + , ghc-syb-utils < 0.3 && >= 0.2.3 + , haskell-src-exts < 1.20 && >= 1.18 + , hlint < 2.1 && >= 2.0.8 + , monad-control < 1.1 && >= 1 + , monad-journal < 0.8 && >= 0.4 + , optparse-applicative < 0.14 && >= 0.13.0.0 + , pipes < 4.4 && >= 4.1 + , safe < 0.4 && >= 0.3.9 + , semigroups < 0.19 && >= 0.10.0 + , split < 0.3 && >= 0.2.2 + , syb < 0.7 && >= 0.5.1 + , temporary < 1.3 && >= 1.2.0.3 + , text < 1.3 && >= 1.2.1.3 + , transformers-base < 0.5 && >= 0.4.4 + + , cabal-helper < 0.8 && >= 0.7.3.0 + , ghc < 8.2 && >= 7.6 + + if impl(ghc >= 8.0) + Build-Depends: ghc-boot 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 + Build-Depends: convertible < 1.2 && >= 1.1.0.0 Executable ghc-mod Default-Language: Haskell2010 - Main-Is: GHCMod.hs + Main-Is: GhcModMain.hs Other-Modules: Paths_ghc_mod - , GHCMod.Options - , GHCMod.Options.Commands - , GHCMod.Version - , GHCMod.Options.DocUtils - , GHCMod.Options.ShellParse - , GHCMod.Options.Help + , GhcMod.Exe.Options + , GhcMod.Exe.Options.Commands + , GhcMod.Exe.Version + , GhcMod.Exe.Options.ShellParse GHC-Options: -Wall -fno-warn-deprecations -threaded Default-Extensions: ConstraintKinds, FlexibleContexts - HS-Source-Dirs: src - Build-Depends: base < 5 && >= 4.0 - , directory < 1.3 - , filepath < 1.5 - , pretty < 1.2 - , process < 1.3 - , split < 0.3 - , mtl < 2.3 && >= 2.0 - , ghc < 7.11 - , monad-control ==1.0.* - , fclabels ==2.0.* - , optparse-applicative >=0.11.0 && <0.13.0 + HS-Source-Dirs: src, shared + X-Internal: True + Build-Depends: + -- See Note [GHC Boot libraries] + directory + , filepath + , mtl + , process + + , base < 4.10 && >= 4.6.0.1 + , fclabels < 2.1 && >= 2.0 + , monad-control < 1.1 && >= 1 + , optparse-applicative < 0.14 && >= 0.13.0.0 + , semigroups < 0.19 && >= 0.10.0 + , split < 0.3 && >= 0.2.2 + + , ghc < 8.2 && >= 7.6 , ghc-mod + Executable ghc-modi Default-Language: Haskell2010 - Main-Is: GHCModi.hs + Main-Is: GhcModi.hs Other-Modules: Paths_ghc_mod Utils + System.Directory.ModTime GHC-Options: -Wall -threaded -fno-warn-deprecations if os(windows) Cpp-Options: -DWINDOWS Default-Extensions: ConstraintKinds, FlexibleContexts - HS-Source-Dirs: src, . - Build-Depends: base < 5 && >= 4.0 - , binary < 0.8 && >= 0.5.1.0 - , deepseq < 1.5 - , directory < 1.3 - , filepath < 1.5 - , process < 1.3 - , old-time < 1.2 - , time < 1.6 + HS-Source-Dirs: ., src, shared + Build-Depends: + -- See Note [GHC Boot libraries] + binary + , deepseq + , directory + , filepath + , old-time + , process + , time + + , base < 4.10 && >= 4.6.0.1 + , ghc-mod + Test-Suite doctest Type: exitcode-stdio-1.0 Default-Language: Haskell2010 @@ -247,46 +274,116 @@ 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 + Build-Depends: base < 4.10 && >= 4.6.0.1 + , doctest < 0.12 && >= 0.9.3 + Test-Suite spec Default-Language: Haskell2010 Default-Extensions: ScopedTypeVariables, RecordWildCards, NamedFieldPuns, ConstraintKinds, FlexibleContexts, DataKinds, KindSignatures, TypeOperators, ViewPatterns Main-Is: Main.hs - Hs-Source-Dirs: test, ., src + Hs-Source-Dirs: test, src Ghc-Options: -Wall -fno-warn-deprecations -threaded - CPP-Options: -DSPEC=1 Type: exitcode-stdio-1.0 Other-Modules: Paths_ghc_mod Dir - Spec TestUtils + +-- $ ls test/*Spec.hs | sed 's_^.*/\(.*\)\.hs$_\1_' | sort BrowseSpec - CustomPackageDbSpec + CabalHelperSpec + CaseSplitSpec CheckSpec + CradleSpec + CustomPackageDbSpec + FileMappingSpec + FindSpec FlagSpec + GhcPkgSpec + HomeModuleGraphSpec InfoSpec LangSpec LintSpec ListSpec MonadSpec PathsAndFilesSpec - HomeModuleGraphSpec - FileMappingSpec ShellParseSpec + TargetSpec - Build-Depends: hspec >= 2.0.0 - if impl(ghc == 7.4.*) - Build-Depends: executable-path - X-Build-Depends-Like: CLibName + Build-Depends: + -- See Note [GHC Boot libraries] + containers + , directory + , filepath + , mtl + , process + , transformers + , base < 4.10 && >= 4.6.0.1 + , fclabels < 2.1 && >= 2.0 + , hspec < 2.4 && >= 2.0.0 + , monad-journal < 0.8 && >= 0.4 + , split < 0.3 && >= 0.2.2 + , temporary < 1.3 && >= 1.2.0.3 + if impl(ghc < 7.8) + Build-Depends: convertible < 1.2 && >= 1.1.0.0 + if impl(ghc >= 8.0) + Build-Depends: ghc-boot + + Build-Depends: + cabal-helper < 0.8 && >= 0.7.1.0 + , ghc < 8.2 && >= 7.6 + , ghc-mod + + +Test-Suite shelltest + Default-Language: Haskell2010 + Main-Is: ShellTest.hs + Hs-Source-Dirs: shelltest + Type: exitcode-stdio-1.0 + Build-Tools: shelltest + Build-Depends: base < 4.10 && >= 4.6.0.1 + , process < 1.5 + -- , shelltestrunner >= 1.3.5 + if !flag(shelltest) + Buildable: False + + +Benchmark criterion + Type: exitcode-stdio-1.0 + Default-Language: Haskell2010 + Default-Extensions: ScopedTypeVariables, RecordWildCards, NamedFieldPuns, + ConstraintKinds, FlexibleContexts, + DataKinds, KindSignatures, TypeOperators, ViewPatterns + HS-Source-Dirs: bench, test + Main-Is: Bench.hs + Build-Depends: + -- See Note [GHC Boot libraries] + directory + , filepath + + , base < 4.10 && >= 4.6.0.1 + , criterion < 1.2 && >= 1.1.1.0 + , temporary < 1.3 && >= 1.2.0.3 + + , ghc-mod + + +Flag shelltest + Description: Enable/disable shelltest test-suite + Default: False + Manual: True + + Source-Repository head Type: git - Location: https://github.com/kazu-yamamoto/ghc-mod.git + Location: https://github.com/DanielG/ghc-mod.git + +-- Note [GHC Boot libraries] +-- +-- We don't give bounds to GHC boot libraries as our dependency on 'ghc' already +-- constrains these packages to the version that shipped with GHC. diff --git a/shared/System/Directory/ModTime.hs b/shared/System/Directory/ModTime.hs new file mode 100644 --- /dev/null +++ b/shared/System/Directory/ModTime.hs @@ -0,0 +1,63 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} +module System.Directory.ModTime where + +import Control.Applicative +import Control.DeepSeq +import Data.Binary +#if MIN_VERSION_directory(1,2,0) +import Data.Time (UTCTime(..), Day(..), getCurrentTime) +#else +import System.Time (ClockTime(..), getClockTime) +#endif +import System.Directory +import Prelude + +#if MIN_VERSION_directory(1,2,0) + +newtype ModTime = ModTime UTCTime + deriving (Eq, Ord, NFData) +getCurrentModTime = ModTime <$> getCurrentTime + +instance Binary ModTime where + put (ModTime (UTCTime (ModifiedJulianDay day) difftime)) = + put day >> put (toRational difftime) + get = + ModTime <$> (UTCTime <$> (ModifiedJulianDay <$> get) <*> (fromRational <$> get)) + +#else + +newtype ModTime = ModTime ClockTime + deriving (Eq, Ord) +getCurrentModTime = ModTime <$> getClockTime + +instance Binary ModTime where + put (ModTime (TOD s ps)) = + put s >> put ps + get = + ModTime <$> (TOD <$> get <*> get) + +instance NFData ModTime where + rnf (ModTime (TOD s ps)) = + s `seq` ps `seq` (ModTime $! TOD s ps) `seq` () + +#endif + +getCurrentModTime :: IO ModTime + +getModTime :: FilePath -> IO ModTime +getModTime f = ModTime <$> getModificationTime f diff --git a/shared/Utils.hs b/shared/Utils.hs new file mode 100644 --- /dev/null +++ b/shared/Utils.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE CPP #-} +module Utils where + +import Control.Applicative +import Data.Traversable +import System.Directory +import System.Directory.ModTime + +import Prelude + +data TimedFile = TimedFile { tfPath :: FilePath, tfTime :: ModTime } + deriving (Eq) + +instance Ord TimedFile where + compare (TimedFile _ a) (TimedFile _ b) = compare a b + +timeFile :: FilePath -> IO TimedFile +timeFile f = TimedFile <$> pure f <*> getModTime f + +mightExist :: FilePath -> IO (Maybe FilePath) +mightExist f = do + exists <- doesFileExist f + return $ if exists then (Just f) else (Nothing) + +timeMaybe :: FilePath -> IO (Maybe TimedFile) +timeMaybe f = traverse timeFile =<< mightExist f diff --git a/shelltest/ShellTest.hs b/shelltest/ShellTest.hs new file mode 100644 --- /dev/null +++ b/shelltest/ShellTest.hs @@ -0,0 +1,23 @@ +#!/usr/bin/env runhaskell +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2017 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +module Main where + +import System.Exit +import System.Process + +main = exitWith =<< rawSystem "shelltest" [ "--execdir", "shelltest/" ] diff --git a/src/GHCMod.hs b/src/GHCMod.hs deleted file mode 100644 --- a/src/GHCMod.hs +++ /dev/null @@ -1,186 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-} - -module Main where - -import Control.Applicative -import Control.Monad -import Data.Typeable (Typeable) -import Data.List -import Data.List.Split -import Exception -import Language.Haskell.GhcMod -import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO) -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Monad -import Language.Haskell.GhcMod.Find (AsyncSymbolDb, newAsyncSymbolDb, getAsyncSymbolDb) -import System.FilePath (()) -import System.Directory (setCurrentDirectory, getAppUserDataDirectory, - removeDirectoryRecursive) -import System.IO -import System.Exit -import Text.PrettyPrint hiding ((<>)) -import GHCMod.Options -import Prelude - -ghcModStyle :: Style -ghcModStyle = style { lineLength = 80, ribbonsPerLine = 1.2 } - ----------------------------------------------------------------- - -handler :: IOish m => GhcModT m a -> GhcModT m a -handler = flip gcatches - [ GHandler $ \(e :: ExitCode) -> throw e - , GHandler $ \(SomeException e) -> exitError $ "ghc-mod: " ++ show e - ] - -main :: IO () -main = do - hSetEncoding stdout utf8 - parseArgs >>= \res@(globalOptions, _) -> - catches (progMain res) [ - Handler $ \(e :: GhcModError) -> - runGmOutT globalOptions $ exitError $ renderStyle ghcModStyle (gmeDoc e) - ] - -progMain :: (Options, GhcModCommands) -> IO () -progMain (globalOptions, commands) = runGmOutT globalOptions $ - wrapGhcCommands globalOptions commands - --- ghc-modi -legacyInteractive :: IOish m => GhcModT m () -legacyInteractive = do - prepareCabalHelper - asyncSymbolDb <- newAsyncSymbolDb - world <- getCurrentWorld - legacyInteractiveLoop asyncSymbolDb world - -legacyInteractiveLoop :: IOish m => AsyncSymbolDb -> World -> GhcModT m () -legacyInteractiveLoop asyncSymbolDb world = do - liftIO . setCurrentDirectory =<< cradleRootDir <$> cradle - - -- blocking - cmdArg <- liftIO getLine - - -- after blocking, we need to see if the world has changed. - - changed <- didWorldChange world - - world' <- if changed - then getCurrentWorld -- TODO: gah, we're hitting the fs twice - else return world - - when changed dropSession - - res <- flip gcatches interactiveHandlers $ do - pargs <- either (throw . InvalidCommandLine . Right) return - $ parseArgsInteractive cmdArg - case pargs of - CmdFind symbol -> - lookupSymbol symbol =<< getAsyncSymbolDb asyncSymbolDb - -- other commands are handled here - x -> ghcCommands x - - gmPutStr res >> gmPutStrLn "OK" >> liftIO (hFlush stdout) - legacyInteractiveLoop asyncSymbolDb world' - where - interactiveHandlers = - [ GHandler $ \(e :: ExitCode) -> throw e - , GHandler $ \(InvalidCommandLine e) -> do - let err = notGood $ either ("Invalid command line: "++) Prelude.id e - liftIO $ do - putStr err - exitFailure - , GHandler $ \(SomeException e) -> gmErrStrLn (show e) >> return "" - ] - notGood msg = "NG " ++ escapeNewlines msg - escapeNewlines = replace "\n" "\\n" . replace "\\n" "\\\\n" - replace needle replacement = intercalate replacement . splitOn needle - -getFileSourceFromStdin :: IO String -getFileSourceFromStdin = do - linesIn <- readStdin' - return (intercalate "\n" linesIn) - where - readStdin' = do - x <- getLine - if x/="\EOT" - 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) $ - uncurry loadMMappedFiles - - gmPutStr =<< ghcCommands cmd - where - handleGmError action = do - (e, _l) <- liftIO . evaluate =<< action - case e of - Right _ -> - return () - Left ed -> - exitError $ renderStyle ghcModStyle (gmeDoc ed) - - loadMMappedFiles from (Just to) = loadMappedFile from to - loadMMappedFiles from (Nothing) = do - src <- liftIO getFileSourceFromStdin - loadMappedFileSource from src - - -ghcCommands :: IOish m => GhcModCommands -> GhcModT m String --- ghcCommands cmd = action args -ghcCommands (CmdLang) = languages -ghcCommands (CmdFlag) = flags -ghcCommands (CmdDebug) = debugInfo -ghcCommands (CmdDebugComponent ts) = componentInfo ts -ghcCommands (CmdBoot) = boot --- ghcCommands (CmdNukeCaches) = nukeCaches >> return "" --- ghcCommands (CmdRoot) = undefined -- handled in wrapGhcCommands -ghcCommands (CmdLegacyInteractive) = legacyInteractive >> return "" -ghcCommands (CmdModules detail) = modules detail -ghcCommands (CmdDumpSym) = dumpSymbol >> return "" -ghcCommands (CmdFind symb) = findSymbol symb -ghcCommands (CmdDoc m) = pkgDoc m -ghcCommands (CmdLint opts file) = lint opts file -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 (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 -ghcCommands (CmdRefine file (line, col) expr) = refine file line col $ Expression expr --- interactive-only commands -ghcCommands (CmdMapFile f) = - liftIO getFileSourceFromStdin - >>= loadMappedFileSource f - >> return "" -ghcCommands (CmdUnmapFile f) = unloadMappedFile f >> return "" -ghcCommands (CmdQuit) = liftIO exitSuccess -ghcCommands (CmdTest file) = test file -ghcCommands cmd = throw $ InvalidCommandLine $ Left $ show cmd - -newtype InvalidCommandLine = InvalidCommandLine (Either String String) - deriving (Show, Typeable) -instance Exception InvalidCommandLine - -exitError :: (MonadIO m, GmOut m) => String -> m a -exitError msg = gmErrStrLn (dropWhileEnd (=='\n') msg) >> liftIO exitFailure - -nukeCaches :: IOish m => GhcModT m () -nukeCaches = do - chdir <- liftIO $ ( "cabal-helper") <$> getAppUserDataDirectory "ghc-mod" - c <- cradle - - when (isCabalHelperProject $ cradleProject c) $ do - let root = cradleRootDir c - let dist = cradleDistDir c - liftIO $ (trySome . removeDirectoryRecursive) `mapM_` [chdir, root dist] - -trySome :: IO a -> IO (Either SomeException a) -trySome = try diff --git a/src/GHCMod/Options.hs b/src/GHCMod/Options.hs deleted file mode 100644 --- a/src/GHCMod/Options.hs +++ /dev/null @@ -1,201 +0,0 @@ --- ghc-mod: Making Haskell development *more* fun --- Copyright (C) 2015 Nikolay Yakimov --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU Affero General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU Affero General Public License for more details. --- --- You should have received a copy of the GNU Affero General Public License --- along with this program. If not, see . -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} - -module GHCMod.Options ( - parseArgs, - parseArgsInteractive, - GhcModCommands(..) -) 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 GHCMod.Options.Commands -import GHCMod.Version -import GHCMod.Options.DocUtils -import GHCMod.Options.Help -import GHCMod.Options.ShellParse - -parseArgs :: IO (Options, GhcModCommands) -parseArgs = - execParser opts - where - opts = info (argAndCmdSpec <**> helpVersion) - $$ fullDesc - <=> header "ghc-mod: Happy Haskell Programming" - -parseArgsInteractive :: String -> Either String GhcModCommands -parseArgsInteractive args = - handle $ execParserPure (prefs idm) opts $ parseCmdLine args - where - opts = info interactiveCommandsSpec $$ fullDesc - handle (Success a) = Right a - handle (Failure failure) = - Left $ fst $ renderFailure failure "" - handle _ = Left "Completion invoked" - -helpVersion :: Parser (a -> a) -helpVersion = - helper - <*> abortOption (InfoMsg ghcModVersion) - $$ long "version" - <=> help "Print the version of the program." - <*> argument r - $$ value id - <=> metavar "" - where - r :: ReadM (a -> a) - r = do - v <- readerAsk - case v of - "help" -> readerAbort ShowHelpText - "version" -> readerAbort $ InfoMsg ghcModVersion - _ -> return id - -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) diff --git a/src/GHCMod/Options/Commands.hs b/src/GHCMod/Options/Commands.hs deleted file mode 100644 --- a/src/GHCMod/Options/Commands.hs +++ /dev/null @@ -1,292 +0,0 @@ --- ghc-mod: Making Haskell development *more* fun --- Copyright (C) 2015 Nikolay Yakimov --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU Affero General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU Affero General Public License for more details. --- --- You should have received a copy of the GNU Affero General Public License --- along with this program. If not, see . -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} - -module GHCMod.Options.Commands where - -import Options.Applicative -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 - -type Symbol = String -type Expr = String -type Module = String -type Line = Int -type Col = Int -type Point = (Line, Col) - -data GhcModCommands = - CmdLang - | CmdFlag - | CmdDebug - | CmdBoot - | CmdNukeCaches - | CmdRoot - | CmdLegacyInteractive - | CmdModules Bool - | CmdDumpSym - | CmdFind Symbol - | CmdDoc Module - | CmdLint LintOpts FilePath - | CmdBrowse BrowseOpts [Module] - | CmdDebugComponent [String] - | CmdCheck [FilePath] - | CmdExpand [FilePath] - | CmdInfo FilePath Symbol - | CmdType FilePath Point - | CmdSplit FilePath Point - | CmdSig FilePath Point - | CmdAuto FilePath Point - | CmdRefine FilePath Point Expr - | CmdTest FilePath - -- interactive-only commands - | CmdMapFile FilePath - | CmdUnmapFile FilePath - | CmdQuit - deriving (Show) - -commandsSpec :: Parser GhcModCommands -commandsSpec = - hsubparser commands - -commands :: Mod CommandFields GhcModCommands -commands = - command "lang" - $$ info (pure CmdLang) - $$ progDesc "List all known GHC language extensions" - <> command "flag" - $$ info (pure CmdFlag) - $$ progDesc "List GHC -f flags" - <> command "debug" - $$ info (pure CmdDebug) - $$ progDesc' $$$ do - "Print debugging information. Please include" - \\ "the output in any bug reports you submit" - <> command "debug-component" - $$ info debugComponentArgSpec - $$ progDesc' $$$ do - "Debugging information related to cabal component" - \\ "resolution" - <> command "boot" - $$ info (pure CmdBoot) - $$ progDesc "Internal command used by the emacs frontend" - -- <> command "nuke-caches" - -- $$ info (pure CmdNukeCaches) idm - <> command "root" - $$ info (pure CmdRoot) - $$ progDesc' - "Try to find the project directory." - <=> desc $$$ do - "For Cabal projects this is the" - \\ "directory containing the cabal file, for projects" - \\ "that use a cabal sandbox but have no cabal file" - \\ "this is the directory containing the cabal.sandbox.config" - \\ "file and otherwise this is the current directory" - <> command "legacy-interactive" - $$ info legacyInteractiveArgSpec - $$ progDesc "ghc-modi compatibility mode" - <> command "list" - $$ info modulesArgSpec - $$ progDesc "List all visible modules" - <> command "modules" - $$ info modulesArgSpec - $$ progDesc "List all visible modules" - <> command "dumpsym" - $$ info (pure CmdDumpSym) idm - <> command "find" - $$ info findArgSpec - $$ progDesc "List all modules that define SYMBOL" - <> command "doc" - $$ info docArgSpec - $$ progDesc' $$$ do - "Try finding the html documentation directory" - \\ "for the given MODULE" - <> command "lint" - $$ info lintArgSpec - $$ progDesc "Check files using `hlint'" - <> command "browse" - $$ info browseArgSpec - $$ progDesc "List symbols in a module" - <> command "check" - $$ info checkArgSpec - $$ progDesc' $$$ do - "Load the given files using GHC and report errors/warnings," - \\ "but don't produce output files" - <> command "expand" - $$ info expandArgSpec - $$ progDesc "Like `check' but also pass `-ddump-splices' to GHC" - <> command "info" - $$ info infoArgSpec - $$ progDesc' $$$ do - "Look up an identifier in the context" - \\ "of FILE (like ghci's `:info')" - <> command "type" - $$ info typeArgSpec - $$ progDesc "Get the type of the expression under (LINE,COL)" - <> command "split" - $$ info splitArgSpec - $$ progDesc - "Split a function case by examining a type's constructors" - <=> desc $$$ do - "For example given the following code snippet:" - code $ do - "f :: [a] -> a" - "f x = _body" - "would be replaced by:" - code $ do - "f :: [a] -> a" - "f [] = _body" - "f (x:xs) = _body" - "(See https://github.com/kazu-yamamoto/ghc-mod/pull/274)" - <> command "sig" - $$ info sigArgSpec - $$ progDesc "Generate initial code given a signature" - <=> desc $$$ do - "For example when (LINE,COL) is on the" - \\ "signature in the following code snippet:" - code "func :: [a] -> Maybe b -> (a -> b) -> (a,b)" - "ghc-mod would add the following on the next line:" - code "func x y z f = _func_body" - "(See: https://github.com/kazu-yamamoto/ghc-mod/pull/274)" - <> command "auto" - $$ info autoArgSpec - $$ progDesc "Try to automatically fill the contents of a hole" - <> command "refine" - $$ info refineArgSpec - $$ progDesc "Refine the typed hole at (LINE,COL) given EXPR" - <=> desc $$$ do - "For example if EXPR is `filter', which has type" - \\ "`(a -> Bool) -> [a] -> [a]' and (LINE,COL) is on" - \\ " the hole `_body' in the following code snippet:" - code $ do - "filterNothing :: [Maybe a] -> [a]" - "filterNothing xs = _body" - "ghc-mod changes the code to get a value of type" - \\ " `[a]', which results in:" - code "filterNothing xs = filter _body_1 _body_2" - "(See also: https://github.com/kazu-yamamoto/ghc-mod/issues/311)" - <> command "test" - $$ info (CmdTest <$> strArg "FILE") - $$ progDesc "" - - -interactiveCommandsSpec :: Parser GhcModCommands -interactiveCommandsSpec = - hsubparser' - $ commands - <> command "map-file" - $$ info mapArgSpec - $$ progDesc "tells ghc-modi to read `file.hs` source from stdin" - <=> desc $$$ do - "Works the same as second form of" - \\ "`--map-file` CLI option." - <> command "unmap-file" - $$ info unmapArgSpec - $$ progDesc' $$$ do - "unloads previously mapped file," - \\ "so that it's no longer mapped." - <=> desc $$$ do - "`file.hs` can be full path or relative" - \\ "to project root, either will work." - <> command "quit" - $$ info (pure CmdQuit) - $$ progDesc "Exit interactive mode" - <> command "" - $$ info (pure CmdQuit) idm - -strArg :: String -> Parser String -strArg = argument str . metavar - -filesArgsSpec :: ([String] -> b) -> Parser b -filesArgsSpec x = x <$> some (strArg "FILES..") - -locArgSpec :: (String -> (Int, Int) -> b) -> Parser b -locArgSpec x = x - <$> strArg "FILE" - <*> ( (,) - <$> argument int (metavar "LINE") - <*> argument int (metavar "COL") - ) - -modulesArgSpec, docArgSpec, findArgSpec, - lintArgSpec, browseArgSpec, checkArgSpec, expandArgSpec, - infoArgSpec, typeArgSpec, autoArgSpec, splitArgSpec, - sigArgSpec, refineArgSpec, debugComponentArgSpec, - mapArgSpec, unmapArgSpec, legacyInteractiveArgSpec :: Parser GhcModCommands - -modulesArgSpec = CmdModules - <$> switch - $$ long "detailed" - <=> short 'd' - <=> help "Print package modules belong to" -findArgSpec = CmdFind <$> strArg "SYMBOL" -docArgSpec = CmdDoc <$> strArg "MODULE" -lintArgSpec = CmdLint - <$> LintOpts <$$> many $$ strOption - $$ long "hlintOpt" - <=> short 'h' - <=> help "Option to be passed to hlint" - <*> strArg "FILE" -browseArgSpec = CmdBrowse - <$> (BrowseOpts - <$> switch - $$ long "operators" - <=> short 'o' - <=> help "Also print operators" - <*> switch - $$ long "detailed" - <=> short 'd' - <=> help "Print symbols with accompanying signature" - <*> switch - $$ long "qualified" - <=> short 'q' - <=> help "Qualify symbols" - ) - <*> some (strArg "MODULE") -debugComponentArgSpec = filesArgsSpec CmdDebugComponent -checkArgSpec = filesArgsSpec CmdCheck -expandArgSpec = filesArgsSpec CmdExpand -infoArgSpec = CmdInfo - <$> strArg "FILE" - <*> strArg "SYMBOL" -typeArgSpec = locArgSpec CmdType -autoArgSpec = locArgSpec CmdAuto -splitArgSpec = locArgSpec CmdSplit -sigArgSpec = locArgSpec CmdSig -refineArgSpec = locArgSpec CmdRefine <*> strArg "SYMBOL" -mapArgSpec = CmdMapFile <$> strArg "FILE" -unmapArgSpec = CmdUnmapFile <$> strArg "FILE" -legacyInteractiveArgSpec = const CmdLegacyInteractive <$> - optional interactiveCommandsSpec - -hsubparser' :: Mod CommandFields a -> Parser a -hsubparser' m = mkParser d g rdr - where - Mod _ d g = m `mappend` metavar "" - (cmds, subs) = mkCommand m - rdr = CmdReader cmds (fmap add_helper . subs) - add_helper pinfo = pinfo - { infoParser = infoParser pinfo <**> helper } - -int :: ReadM Int -int = do - v <- readerAsk - maybe (readerError $ "Not a number \"" ++ v ++ "\"") return $ readMaybe v diff --git a/src/GHCMod/Options/DocUtils.hs b/src/GHCMod/Options/DocUtils.hs deleted file mode 100644 --- a/src/GHCMod/Options/DocUtils.hs +++ /dev/null @@ -1,48 +0,0 @@ --- ghc-mod: Making Haskell development *more* fun --- Copyright (C) 2015 Nikolay Yakimov --- --- 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 . - -module GHCMod.Options.DocUtils ( - ($$), - ($$$), - (<=>), - (<$$>), - (<||>) -) where - -import Options.Applicative -import Data.Monoid -import Prelude - -infixl 6 <||> -infixr 7 <$$> -infixr 7 $$ -infixr 8 <=> -infixr 9 $$$ - -($$) :: (a -> b) -> a -> b -($$) = ($) - -($$$) :: (a -> b) -> a -> b -($$$) = ($) - -(<||>) :: Alternative a => a b -> a b -> a b -(<||>) = (<|>) - -(<=>) :: Monoid m => m -> m -> m -(<=>) = (<>) - -(<$$>) :: Functor f => (a -> b) -> f a -> f b -(<$$>) = (<$>) diff --git a/src/GHCMod/Options/Help.hs b/src/GHCMod/Options/Help.hs deleted file mode 100644 --- a/src/GHCMod/Options/Help.hs +++ /dev/null @@ -1,79 +0,0 @@ --- ghc-mod: Making Haskell development *more* fun --- Copyright (C) 2015 Nikolay Yakimov --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU Affero General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU Affero General Public License for more details. --- --- You should have received a copy of the GNU Affero General Public License --- along with this program. If not, see . -{-# LANGUAGE OverloadedStrings, FlexibleInstances, GeneralizedNewtypeDeriving #-} - -module GHCMod.Options.Help where - -import Options.Applicative -import Options.Applicative.Help.Pretty (Doc) -import qualified Options.Applicative.Help.Pretty as PP -import Control.Monad.State -import GHC.Exts( IsString(..) ) -import Data.Maybe -import Data.Monoid -import Prelude - -newtype MyDocM s a = MyDoc {unwrapState :: State s a} - deriving (Monad, Functor, Applicative, MonadState s) -type MyDoc = MyDocM (Maybe Doc) () - -instance IsString (MyDocM (Maybe Doc) a) where - fromString = append . para - -instance Monoid (MyDocM (Maybe Doc) ()) where - mappend a b = append $ doc a <> doc b - mempty = append PP.empty - -para :: String -> Doc -para = PP.fillSep . map PP.text . words - -append :: Doc -> MyDocM (Maybe Doc) a -append s = modify m >> return undefined - where - m :: Maybe Doc -> Maybe Doc - m Nothing = Just s - m (Just old) = Just $ old PP..$. s - -infixr 7 \\ -(\\) :: MyDoc -> MyDoc -> MyDoc -(\\) a b = append $ doc a PP.<+> doc b - -doc :: MyDoc -> Doc -doc = fromMaybe PP.empty . flip execState Nothing . unwrapState - -help' :: MyDoc -> Mod f a -help' = helpDoc . Just . doc - -desc :: MyDoc -> InfoMod a -desc = footerDoc . Just . doc . indent 2 - -code :: MyDoc -> MyDoc -code x = do - _ <- " " - indent 4 x - " " - -progDesc' :: MyDoc -> InfoMod a -progDesc' = progDescDoc . Just . doc - -indent :: Int -> MyDoc -> MyDoc -indent n = append . PP.indent n . doc - -int' :: Int -> MyDoc -int' = append . PP.int - -para' :: String -> MyDoc -para' = append . para diff --git a/src/GHCMod/Options/ShellParse.hs b/src/GHCMod/Options/ShellParse.hs deleted file mode 100644 --- a/src/GHCMod/Options/ShellParse.hs +++ /dev/null @@ -1,44 +0,0 @@ --- ghc-mod: Making Haskell development *more* fun --- Copyright (C) 2015 Nikolay Yakimov --- --- 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 . -module GHCMod.Options.ShellParse (parseCmdLine) where - -import Data.Char -import Data.List - -go :: String -> String -> [String] -> Bool -> [String] --- result -go [] curarg accargs _ = reverse $ reverse curarg : accargs -go (c:cl) curarg accargs quotes - -- open quotes - | c == '\STX', not quotes - = go cl curarg accargs True - -- close quotes - | c == '\ETX', quotes - = go cl curarg accargs False - -- space separates arguments outside quotes - | isSpace c, not quotes - = if null curarg - then go cl curarg accargs quotes - else go cl [] (reverse curarg : accargs) quotes - -- general character - | otherwise = go cl (c:curarg) accargs quotes - -parseCmdLine :: String -> [String] -parseCmdLine comline' - | Just comline <- stripPrefix "ascii-escape " $ dropWhile isSpace comline' - = go (dropWhile isSpace comline) [] [] False -parseCmdLine [] = [""] -parseCmdLine comline = words comline diff --git a/src/GHCMod/Version.hs b/src/GHCMod/Version.hs deleted file mode 100644 --- a/src/GHCMod/Version.hs +++ /dev/null @@ -1,32 +0,0 @@ --- ghc-mod: Making Haskell development *more* fun --- Copyright (C) 2015 Nikolay Yakimov --- --- 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 . - -module GHCMod.Version where - -import Paths_ghc_mod -import Data.Version (showVersion) -import Config (cProjectVersion) - -progVersion :: String -> String -progVersion pf = - "ghc-mod"++pf++" version " ++ showVersion version ++ " compiled by GHC " - ++ cProjectVersion - -ghcModVersion :: String -ghcModVersion = progVersion "" - -ghcModiVersion :: String -ghcModiVersion = progVersion "i" diff --git a/src/GHCModi.hs b/src/GHCModi.hs deleted file mode 100644 --- a/src/GHCModi.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - --- | WARNING --- This program is deprecated, use `ghc-mod legacy-interactive` instead. - -module Main where - -import Control.Applicative -import Control.Monad -import Control.Exception -import Data.Version -import Data.Maybe -import System.IO -import System.Exit -import System.Process -import System.FilePath -import System.Environment -import Paths_ghc_mod -import Utils -import Prelude - -main :: IO () -main = do - hPutStrLn stderr $ - "Warning: ghc-modi is deprecated please use 'ghc-mod legacy-interactive' instead" - - args <- getArgs - bindir <- getBinDir - let installedExe = bindir "ghc-mod" - mexe <- mplus <$> mightExist installedExe <*> pathExe - case mexe of - Nothing -> do - hPutStrLn stderr $ - "ghc-modi: Could not find '"++installedExe++"', check your installation!" - exitWith $ ExitFailure 1 - - Just exe -> do - (_, _, _, h) <- - createProcess $ proc exe $ ["legacy-interactive"] ++ args - exitWith =<< waitForProcess h - -pathExe :: IO (Maybe String) -pathExe = do - ev <- try $ words <$> readProcess "ghc-mod" ["--version"] "" - let mexe = case ev of - Left (SomeException _) -> Nothing - Right ["ghc-mod", "version", ver - , "compiled", "by", "GHC", _] - | showVersion version == ver -> do - Just "ghc-mod" - Right _ -> Nothing - - when (isNothing mexe) $ - hPutStrLn stderr "ghc-modi: ghc-mod executable on PATH has different version, check your installation!" - return mexe diff --git a/src/GhcMod/Exe/Options.hs b/src/GhcMod/Exe/Options.hs new file mode 100644 --- /dev/null +++ b/src/GhcMod/Exe/Options.hs @@ -0,0 +1,72 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Nikolay Yakimov +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} + +module GhcMod.Exe.Options ( + parseArgs, + parseArgsInteractive, + GhcModCommands(..) +) where + +import Options.Applicative +import Options.Applicative.Types + +import GhcMod.Exe.Options.Commands +import GhcMod.Exe.Options.ShellParse +import GhcMod.Exe.Version +import GhcMod.Options.DocUtils +import GhcMod.Options.Options +import GhcMod.Types + +parseArgs :: IO (Options, GhcModCommands) +parseArgs = + execParser opts + where + opts = info (argAndCmdSpec <**> helpVersion) + $$ fullDesc + <=> header "ghc-mod: Happy Haskell Hacking" + +parseArgsInteractive :: String -> Either String GhcModCommands +parseArgsInteractive args = + handle $ execParserPure (prefs idm) opts $ parseCmdLine args + where + opts = info interactiveCommandsSpec $$ fullDesc + handle (Success a) = Right a + handle (Failure failure) = + Left $ fst $ renderFailure failure "" + handle _ = Left "Completion invoked" + +helpVersion :: Parser (a -> a) +helpVersion = + helper + <*> abortOption (InfoMsg ghcModVersion) + $$ long "version" + <=> help "Print the version of the program." + <*> argument r + $$ value id + <=> metavar "" + where + r :: ReadM (a -> a) + r = do + v <- readerAsk + case v of + "help" -> readerAbort ShowHelpText + "version" -> readerAbort $ InfoMsg ghcModVersion + _ -> return id + +argAndCmdSpec :: Parser (Options, GhcModCommands) +argAndCmdSpec = (,) <$> globalArgSpec <*> commandsSpec diff --git a/src/GhcMod/Exe/Options/Commands.hs b/src/GhcMod/Exe/Options/Commands.hs new file mode 100644 --- /dev/null +++ b/src/GhcMod/Exe/Options/Commands.hs @@ -0,0 +1,301 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Nikolay Yakimov +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} + +module GhcMod.Exe.Options.Commands where + +import Data.Semigroup +import Options.Applicative +import Options.Applicative.Types +import Options.Applicative.Builder.Internal +import GhcMod.Types +import GhcMod.Read +import GhcMod.Options.DocUtils +import GhcMod.Options.Help + +type Symbol = String +type Expr = String +type Module = String +type Line = Int +type Col = Int +type Point = (Line, Col) + +data GhcModCommands = + CmdLang + | CmdFlag + | CmdDebug + | CmdBoot + | CmdNukeCaches + | CmdRoot + | CmdLegacyInteractive + | CmdModules Bool + | CmdDumpSym + | CmdFind Symbol + | CmdDoc Module + | CmdLint LintOpts FilePath + | CmdBrowse BrowseOpts [Module] + | CmdDebugComponent [String] + | CmdCheck [FilePath] + | CmdExpand [FilePath] + | CmdInfo FilePath Symbol + | CmdType Bool FilePath Point + | CmdSplit FilePath Point + | CmdSig FilePath Point + | CmdAuto FilePath Point + | CmdRefine FilePath Point Expr + | CmdTest FilePath + -- interactive-only commands + | CmdMapFile FilePath + | CmdUnmapFile FilePath + | CmdQuit + deriving (Show) + +commandsSpec :: Parser GhcModCommands +commandsSpec = + hsubparser commands + +commands :: Mod CommandFields GhcModCommands +commands = + command "lang" + $$ info (pure CmdLang) + $$ progDesc "List all known GHC language extensions" + <> command "flag" + $$ info (pure CmdFlag) + $$ progDesc "List GHC -f flags" + <> command "debug" + $$ info (pure CmdDebug) + $$ progDesc' $$$ do + "Print debugging information. Please include" + \\ "the output in any bug reports you submit" + <> command "debug-component" + $$ info debugComponentArgSpec + $$ progDesc' $$$ do + "Debugging information related to cabal component" + \\ "resolution" + <> command "boot" + $$ info (pure CmdBoot) + $$ progDesc "Internal command used by the emacs frontend" + -- <> command "nuke-caches" + -- $$ info (pure CmdNukeCaches) idm + <> command "root" + $$ info (pure CmdRoot) + $$ progDesc' + "Try to find the project directory." + <=> desc $$$ do + "For Cabal projects this is the" + \\ "directory containing the cabal file, for projects" + \\ "that use a cabal sandbox but have no cabal file" + \\ "this is the directory containing the cabal.sandbox.config" + \\ "file and otherwise this is the current directory" + <> command "legacy-interactive" + $$ info legacyInteractiveArgSpec + $$ progDesc "ghc-modi compatibility mode" + <> command "list" + $$ info modulesArgSpec + $$ progDesc "List all visible modules" + <> command "modules" + $$ info modulesArgSpec + $$ progDesc "List all visible modules" + <> command "dumpsym" + $$ info (pure CmdDumpSym) idm + <> command "find" + $$ info findArgSpec + $$ progDesc "List all modules that define SYMBOL" + <> command "doc" + $$ info docArgSpec + $$ progDesc' $$$ do + "Try finding the html documentation directory" + \\ "for the given MODULE" + <> command "lint" + $$ info lintArgSpec + $$ progDesc "Check files using `hlint'" + <> command "browse" + $$ info browseArgSpec + $$ progDesc "List symbols in a module" + <> command "check" + $$ info checkArgSpec + $$ progDesc' $$$ do + "Load the given files using GHC and report errors/warnings," + \\ "but don't produce output files" + <> command "expand" + $$ info expandArgSpec + $$ progDesc "Like `check' but also pass `-ddump-splices' to GHC" + <> command "info" + $$ info infoArgSpec + $$ progDesc' $$$ do + "Look up an identifier in the context" + \\ "of FILE (like ghci's `:info')" + <> command "type" + $$ info typeArgSpec + $$ progDesc "Get the type of the expression under (LINE,COL)" + <> command "split" + $$ info splitArgSpec + $$ progDesc + "Split a function case by examining a type's constructors" + <=> desc $$$ do + "For example given the following code snippet:" + code $ do + "f :: [a] -> a" + "f x = _body" + "would be replaced by:" + code $ do + "f :: [a] -> a" + "f [] = _body" + "f (x:xs) = _body" + "(See https://github.com/DanielG/ghc-mod/pull/274)" + <> command "sig" + $$ info sigArgSpec + $$ progDesc "Generate initial code given a signature" + <=> desc $$$ do + "For example when (LINE,COL) is on the" + \\ "signature in the following code snippet:" + code "func :: [a] -> Maybe b -> (a -> b) -> (a,b)" + "ghc-mod would add the following on the next line:" + code "func x y z f = _func_body" + "(See: https://github.com/DanielG/ghc-mod/pull/274)" + <> command "auto" + $$ info autoArgSpec + $$ progDesc "Try to automatically fill the contents of a hole" + <> command "refine" + $$ info refineArgSpec + $$ progDesc "Refine the typed hole at (LINE,COL) given EXPR" + <=> desc $$$ do + "For example if EXPR is `filter', which has type" + \\ "`(a -> Bool) -> [a] -> [a]' and (LINE,COL) is on" + \\ " the hole `_body' in the following code snippet:" + code $ do + "filterNothing :: [Maybe a] -> [a]" + "filterNothing xs = _body" + "ghc-mod changes the code to get a value of type" + \\ " `[a]', which results in:" + code "filterNothing xs = filter _body_1 _body_2" + "(See also: https://github.com/DanielG/ghc-mod/issues/311)" + <> command "test" + $$ info (CmdTest <$> strArg "FILE") + $$ progDesc "" + + +interactiveCommandsSpec :: Parser GhcModCommands +interactiveCommandsSpec = + hsubparser' + $ commands + <> command "map-file" + $$ info mapArgSpec + $$ progDesc "tells ghc-modi to read `file.hs` source from stdin" + <=> desc $$$ do + "Works the same as second form of" + \\ "`--map-file` CLI option." + <> command "unmap-file" + $$ info unmapArgSpec + $$ progDesc' $$$ do + "unloads previously mapped file," + \\ "so that it's no longer mapped." + <=> desc $$$ do + "`file.hs` can be full path or relative" + \\ "to project root, either will work." + <> command "quit" + $$ info (pure CmdQuit) + $$ progDesc "Exit interactive mode" + <> command "" + $$ info (pure CmdQuit) idm + +strArg :: String -> Parser String +strArg = argument str . metavar + +filesArgsSpec :: Parser ([String] -> b) -> Parser b +filesArgsSpec x = x <*> some (strArg "FILES..") + +locArgSpec :: Parser (String -> (Int, Int) -> b) -> Parser b +locArgSpec x = x + <*> strArg "FILE" + <*> ( (,) + <$> argument int (metavar "LINE") + <*> argument int (metavar "COL") + ) + +modulesArgSpec, docArgSpec, findArgSpec, + lintArgSpec, browseArgSpec, checkArgSpec, expandArgSpec, + infoArgSpec, typeArgSpec, autoArgSpec, splitArgSpec, + sigArgSpec, refineArgSpec, debugComponentArgSpec, + mapArgSpec, unmapArgSpec, legacyInteractiveArgSpec :: Parser GhcModCommands + +modulesArgSpec = CmdModules + <$> switch + $$ long "detailed" + <=> short 'd' + <=> help "Print package modules belong to" +findArgSpec = CmdFind <$> strArg "SYMBOL" +docArgSpec = CmdDoc <$> strArg "MODULE" +lintArgSpec = CmdLint + <$> LintOpts <$$> many $$ strOption + $$ long "hlintOpt" + <=> short 'h' + <=> help "Option to be passed to hlint" + <*> strArg "FILE" +browseArgSpec = CmdBrowse + <$> (BrowseOpts + <$> switch + $$ long "operators" + <=> short 'o' + <=> help "Also print operators" + <*> switch + $$ 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 (pure CmdDebugComponent) +checkArgSpec = filesArgsSpec (pure CmdCheck) +expandArgSpec = filesArgsSpec (pure CmdExpand) +infoArgSpec = CmdInfo + <$> strArg "FILE" + <*> 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 <$> + optional interactiveCommandsSpec + +hsubparser' :: Mod CommandFields a -> Parser a +hsubparser' m = mkParser d g rdr + where + Mod _ d g = m `mappend` metavar "" + (ms, cmds, subs) = mkCommand m + rdr = CmdReader ms cmds (fmap add_helper . subs) + add_helper pinfo = pinfo + { infoParser = infoParser pinfo <**> helper } + +int :: ReadM Int +int = do + v <- readerAsk + maybe (readerError $ "Not a number \"" ++ v ++ "\"") return $ readMaybe v diff --git a/src/GhcMod/Exe/Options/ShellParse.hs b/src/GhcMod/Exe/Options/ShellParse.hs new file mode 100644 --- /dev/null +++ b/src/GhcMod/Exe/Options/ShellParse.hs @@ -0,0 +1,44 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Nikolay Yakimov +-- +-- 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 . +module GhcMod.Exe.Options.ShellParse (parseCmdLine) where + +import Data.Char +import Data.List + +go :: String -> String -> [String] -> Bool -> [String] +-- result +go [] curarg accargs _ = reverse $ reverse curarg : accargs +go (c:cl) curarg accargs quotes + -- open quotes + | c == '\STX', not quotes + = go cl curarg accargs True + -- close quotes + | c == '\ETX', quotes + = go cl curarg accargs False + -- space separates arguments outside quotes + | isSpace c, not quotes + = if null curarg + then go cl curarg accargs quotes + else go cl [] (reverse curarg : accargs) quotes + -- general character + | otherwise = go cl (c:curarg) accargs quotes + +parseCmdLine :: String -> [String] +parseCmdLine comline' + | Just comline <- stripPrefix "ascii-escape " $ dropWhile isSpace comline' + = go (dropWhile isSpace comline) [] [] False +parseCmdLine [] = [""] +parseCmdLine comline = words comline diff --git a/src/GhcMod/Exe/Version.hs b/src/GhcMod/Exe/Version.hs new file mode 100644 --- /dev/null +++ b/src/GhcMod/Exe/Version.hs @@ -0,0 +1,32 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Nikolay Yakimov +-- +-- 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 . + +module GhcMod.Exe.Version where + +import Paths_ghc_mod +import Data.Version (showVersion) +import Config (cProjectVersion) + +progVersion :: String -> String +progVersion pf = + "ghc-mod"++pf++" version " ++ showVersion version ++ " compiled by GHC " + ++ cProjectVersion + +ghcModVersion :: String +ghcModVersion = progVersion "" + +ghcModiVersion :: String +ghcModiVersion = progVersion "i" diff --git a/src/GhcModMain.hs b/src/GhcModMain.hs new file mode 100644 --- /dev/null +++ b/src/GhcModMain.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-} + +module Main where + +import Control.Applicative +import Control.Monad +import Data.Typeable (Typeable) +import Data.List +import Data.List.Split +import GhcMod.Pretty +import System.FilePath (()) +import System.Directory (setCurrentDirectory, getAppUserDataDirectory, + removeDirectoryRecursive) +import System.IO +import System.Exit +import Prelude + +import GhcMod +import GhcMod.Exe.Find +import GhcMod.Exe.Options +import GhcMod.Exe.Internal hiding (MonadIO,liftIO) +import GhcMod.Monad +import GhcMod.Types + +import Exception + +handler :: IOish m => GhcModT m a -> GhcModT m a +handler = flip gcatches + [ GHandler $ \(e :: ExitCode) -> throw e + , GHandler $ \(SomeException e) -> exitError $ "ghc-mod: " ++ show e + ] + +main :: IO () +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 $ renderGm (gmeDoc e) + ] + +progMain :: (Options, GhcModCommands) -> IO () +progMain (globalOptions, commands) = runGmOutT globalOptions $ + wrapGhcCommands globalOptions commands + +-- ghc-modi +legacyInteractive :: IOish m => GhcModT m () +legacyInteractive = do + prepareCabalHelper + asyncSymbolDb <- newAsyncSymbolDb + world <- getCurrentWorld + legacyInteractiveLoop asyncSymbolDb world + +legacyInteractiveLoop :: IOish m => AsyncSymbolDb -> World -> GhcModT m () +legacyInteractiveLoop asyncSymbolDb world = do + liftIO . setCurrentDirectory =<< cradleRootDir <$> cradle + + -- blocking + cmdArg <- liftIO getLine + + -- after blocking, we need to see if the world has changed. + + changed <- didWorldChange world + + world' <- if changed + then getCurrentWorld -- TODO: gah, we're hitting the fs twice + else return world + + when changed dropSession + + res <- flip gcatches interactiveHandlers $ do + pargs <- either (throw . InvalidCommandLine . Right) return + $ parseArgsInteractive cmdArg + case pargs of + CmdFind symbol -> + lookupSymbol symbol =<< getAsyncSymbolDb asyncSymbolDb + -- other commands are handled here + x -> ghcCommands x + + gmPutStr res >> gmPutStrLn "OK" >> liftIO (hFlush stdout) + legacyInteractiveLoop asyncSymbolDb world' + where + interactiveHandlers = + [ GHandler $ \(e :: ExitCode) -> throw e + , GHandler $ \(InvalidCommandLine e) -> do + let err = notGood $ either ("Invalid command line: "++) Prelude.id e + liftIO $ do + putStr err + exitFailure + , GHandler $ \(SomeException e) -> gmErrStrLn (show e) >> return "" + ] + notGood msg = "NG " ++ escapeNewlines msg + escapeNewlines = replace "\n" "\\n" . replace "\\n" "\\\\n" + replace needle replacement = intercalate replacement . splitOn needle + +getFileSourceFromStdin :: IO String +getFileSourceFromStdin = do + linesIn <- readStdin' + return (intercalate "\n" linesIn) + where + readStdin' = do + x <- getLine + if x/="\EOT" + then fmap (x:) readStdin' + else return [] + +wrapGhcCommands :: (IOish m, GmOut m) => Options -> GhcModCommands -> m () +wrapGhcCommands opts cmd = + handleGmError $ runGhcModT opts $ handler $ do + forM_ (reverse $ optFileMappings opts) $ + uncurry loadMMappedFiles + + gmPutStr =<< ghcCommands cmd + where + handleGmError action = do + (e, _l) <- liftIO . evaluate =<< action + case e of + Right _ -> + return () + Left ed -> + exitError $ renderGm (gmeDoc ed) + + loadMMappedFiles from (Just to) = loadMappedFile from to + loadMMappedFiles from (Nothing) = do + src <- liftIO getFileSourceFromStdin + loadMappedFileSource from src + + +ghcCommands :: IOish m => GhcModCommands -> GhcModT m String +-- ghcCommands cmd = action args +ghcCommands (CmdLang) = languages +ghcCommands (CmdFlag) = flags +ghcCommands (CmdDebug) = debugInfo +ghcCommands (CmdDebugComponent ts) = componentInfo ts +ghcCommands (CmdBoot) = boot +-- ghcCommands (CmdNukeCaches) = nukeCaches >> return "" +ghcCommands (CmdRoot) = rootInfo +ghcCommands (CmdLegacyInteractive) = legacyInteractive >> return "" +ghcCommands (CmdModules detail) = modules detail +ghcCommands (CmdDumpSym) = dumpSymbol >> return "" +ghcCommands (CmdFind symb) = findSymbol symb +ghcCommands (CmdDoc m) = pkgDoc m +ghcCommands (CmdLint opts file) = lint opts file +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 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 +ghcCommands (CmdRefine file (line, col) expr) = refine file line col $ Expression expr +-- interactive-only commands +ghcCommands (CmdMapFile f) = + liftIO getFileSourceFromStdin + >>= loadMappedFileSource f + >> return "" +ghcCommands (CmdUnmapFile f) = unloadMappedFile f >> return "" +ghcCommands (CmdQuit) = liftIO exitSuccess +ghcCommands (CmdTest file) = test file +ghcCommands cmd = throw $ InvalidCommandLine $ Left $ show cmd + +newtype InvalidCommandLine = InvalidCommandLine (Either String String) + deriving (Show, Typeable) +instance Exception InvalidCommandLine + +exitError :: (MonadIO m, GmOut m) => String -> m a +exitError msg = gmErrStrLn (dropWhileEnd (=='\n') msg) >> liftIO exitFailure + +nukeCaches :: IOish m => GhcModT m () +nukeCaches = do + chdir <- liftIO $ ( "cabal-helper") <$> getAppUserDataDirectory "ghc-mod" + c <- cradle + + when (isCabalHelperProject $ cradleProject c) $ do + let root = cradleRootDir c + let dist = cradleDistDir c + liftIO $ (trySome . removeDirectoryRecursive) `mapM_` [chdir, root dist] + +trySome :: IO a -> IO (Either SomeException a) +trySome = try diff --git a/src/GhcModi.hs b/src/GhcModi.hs new file mode 100644 --- /dev/null +++ b/src/GhcModi.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- | WARNING +-- This program is deprecated, use `ghc-mod legacy-interactive` instead. + +module Main where + +import Control.Applicative +import Control.Monad +import Control.Exception +import Data.Version +import Data.Maybe +import System.IO +import System.Exit +import System.Process +import System.FilePath +import System.Environment +import Paths_ghc_mod +import Utils +import Prelude + +main :: IO () +main = do + hPutStrLn stderr $ + "Warning: ghc-modi is deprecated please use 'ghc-mod legacy-interactive' instead" + + args <- getArgs + bindir <- getBinDir + let installedExe = bindir "ghc-mod" + mexe <- mplus <$> mightExist installedExe <*> pathExe + case mexe of + Nothing -> do + hPutStrLn stderr $ + "ghc-modi: Could not find '"++installedExe++"', check your installation!" + exitWith $ ExitFailure 1 + + Just exe -> do + (_, _, _, h) <- + createProcess $ proc exe $ ["legacy-interactive"] ++ args + exitWith =<< waitForProcess h + +pathExe :: IO (Maybe String) +pathExe = do + ev <- try $ words <$> readProcess "ghc-mod" ["--version"] "" + let mexe = case ev of + Left (SomeException _) -> Nothing + Right ["ghc-mod", "version", ver + , "compiled", "by", "GHC", _] + | showVersion version == ver -> do + Just "ghc-mod" + Right _ -> Nothing + + when (isNothing mexe) $ + hPutStrLn stderr "ghc-modi: ghc-mod executable on PATH has different version, check your installation!" + return mexe diff --git a/test/BrowseSpec.hs b/test/BrowseSpec.hs --- a/test/BrowseSpec.hs +++ b/test/BrowseSpec.hs @@ -1,7 +1,7 @@ module BrowseSpec where import Control.Applicative -import Language.Haskell.GhcMod +import GhcMod import Test.Hspec import Prelude diff --git a/test/CabalHelperSpec.hs b/test/CabalHelperSpec.hs new file mode 100644 --- /dev/null +++ b/test/CabalHelperSpec.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE CPP #-} +module CabalHelperSpec where + +import Control.Arrow +import Control.Applicative +import Distribution.Helper +import GhcMod.CabalHelper +import GhcMod.PathsAndFiles +import GhcMod.Error +import Test.Hspec +import System.Directory +import System.FilePath +import System.Process +import Prelude + +import Dir +import TestUtils +import Data.List + +import Config (cProjectVersionInt) + +ghcVersion :: Int +ghcVersion = read cProjectVersionInt + +gmeProcessException :: GhcModError -> Bool +gmeProcessException GMEProcess {} = True +gmeProcessException _ = False + +pkgOptions :: [String] -> [String] +pkgOptions [] = [] +pkgOptions (_:[]) = [] +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`)) + +spec :: Spec +spec = do + describe "getComponents" $ do + it "throws an exception if the cabal file is broken" $ do + let tdir = "test/data/broken-cabal" + runD' tdir getComponents `shouldThrow` anyIOException + + it "handles sandboxes correctly" $ do + let tdir = "test/data/cabal-project" + cwd <- getCurrentDirectory + + -- TODO: ChSetupHsName should also have sandbox stuff, see related + -- comment in cabal-helper + opts <- map gmcGhcOpts . filter ((/= ChSetupHsName) . gmcName) <$> runD' tdir getComponents + + bp <- buildPlatform readProcess + if ghcVersion < 706 + then forM_ opts (\o -> o `shouldContain` ["-no-user-package-conf","-package-conf", cwd "test/data/cabal-project/.cabal-sandbox/"++ghcSandboxPkgDbDir bp]) + else forM_ opts (\o -> o `shouldContain` ["-no-user-package-db","-package-db",cwd "test/data/cabal-project/.cabal-sandbox/"++ghcSandboxPkgDbDir bp]) + +#if !MIN_VERSION_ghc(7,8,0) + it "handles stack project" $ do + let tdir = "test/data/stack-project" + [ghcOpts] <- map gmcGhcOpts . filter ((==ChExeName "new-template-exe") . gmcName) <$> runD' tdir getComponents + let pkgs = pkgOptions ghcOpts + sort pkgs `shouldBe` ["base", "bytestring"] +#endif + + it "extracts build dependencies" $ do + let tdir = "test/data/cabal-project" + opts <- map gmcGhcOpts <$> runD' tdir getComponents + let ghcOpts:_ = opts + pkgs = pkgOptions ghcOpts + pkgs `shouldBe` ["Cabal","base","template-haskell"] + + it "uses non default flags and preserves them across reconfigures" $ do + let tdir = "test/data/cabal-flags" + _ <- withDirectory_ tdir $ + readProcess "cabal" ["configure", "-ftest-flag"] "" + + let test = do + opts <- map gmcGhcOpts <$> runD' tdir getComponents + let ghcOpts = head opts + pkgs = pkgOptions ghcOpts + pkgs `shouldBe` ["Cabal","base"] + + test + + touch $ tdir "cabal-flags.cabal" + + test + +touch :: FilePath -> IO () +touch fn = do + f <- readFile fn + writeFile (fn <.> "tmp") f + renameFile (fn <.> "tmp") fn diff --git a/test/CaseSplitSpec.hs b/test/CaseSplitSpec.hs new file mode 100644 --- /dev/null +++ b/test/CaseSplitSpec.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE CPP #-} +module CaseSplitSpec where + +import GhcMod +import Test.Hspec +import TestUtils +import Dir + +main :: IO () +main = do + hspec spec + +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 + res `shouldBe` "24 1 24 30"++ + " \"mlAppend Nil y = _mlAppend_body\NUL"++ + "mlAppend (Cons x1 x2) y = _mlAppend_body\"\n" + + it "works with case expressions" $ do + withDirectory_ "test/data/case-split" $ do + res <- runD $ splits "Vect.hs" 28 20 + res `shouldBe` "28 19 28 39"++ + " \"Nil -> _mlAppend_body\NUL"++ + " (Cons x'1 x'2) -> _mlAppend_body\"\n" + + it "works with where clauses" $ do + withDirectory_ "test/data/case-split" $ do + res <- runD $ splits "Vect.hs" 34 17 + res `shouldBe` "34 5 34 43"++ + " \"mlReverse' Nil accum = _mlReverse_body\NUL"++ + " mlReverse' (Cons xs'1 xs'2) accum = _mlReverse_body\"\n" + + it "works with let bindings" $ do + withDirectory_ "test/data/case-split" $ do + res <- runD $ splits "Vect.hs" 38 33 + 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 diff --git a/test/CheckSpec.hs b/test/CheckSpec.hs --- a/test/CheckSpec.hs +++ b/test/CheckSpec.hs @@ -1,7 +1,7 @@ {-# LANGUAGE CPP #-} module CheckSpec where -import Language.Haskell.GhcMod +import GhcMod import Data.List import System.Process @@ -58,7 +58,7 @@ 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 @@ 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" diff --git a/test/CradleSpec.hs b/test/CradleSpec.hs new file mode 100644 --- /dev/null +++ b/test/CradleSpec.hs @@ -0,0 +1,67 @@ +module CradleSpec where + +import Control.Applicative +import Data.List (isSuffixOf) +import GhcMod.Cradle +import GhcMod.Types +import System.Directory (canonicalizePath) +import System.FilePath (pathSeparator) +import Test.Hspec +import TestUtils +import Prelude + +import Dir + +clean_ :: IO Cradle -> IO Cradle +clean_ f = do + crdl <- f + cleanupCradle crdl + return crdl + +relativeCradle :: FilePath -> Cradle -> Cradle +relativeCradle dir crdl = crdl { + cradleCurrentDir = toRelativeDir dir $ cradleCurrentDir crdl + , cradleRootDir = toRelativeDir dir $ cradleRootDir crdl + , cradleCabalFile = toRelativeDir dir <$> cradleCabalFile crdl + } + +-- Work around GHC 7.2.2 where `canonicalizePath "/"` returns "/.". +stripLastDot :: FilePath -> FilePath +stripLastDot path + | (pathSeparator:'.':"") `isSuffixOf` path = init path + | otherwise = path + +spec :: Spec +spec = do + describe "findCradle" $ do + it "returns the current directory" $ do + withDirectory_ "/" $ do + curDir <- stripLastDot <$> canonicalizePath "/" + 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 $ optPrograms defaultOptions) + + cradleCurrentDir res `shouldBe` + "test/data/cabal-project/subdir1/subdir2" + + cradleRootDir res `shouldBe` "test/data/cabal-project" + + cradleCabalFile res `shouldBe` + Just ("test/data/cabal-project/cabalapi.cabal") + + it "works even if a sandbox config file is broken" $ do + withDirectory "test/data/broken-sandbox" $ \dir -> do + res <- relativeCradle dir <$> clean_ (runGmOutDef $ findCradleNoLog $ optPrograms defaultOptions) + cradleCurrentDir res `shouldBe` + "test" "data" "broken-sandbox" + + cradleRootDir res `shouldBe` + "test" "data" "broken-sandbox" + + cradleCabalFile res `shouldBe` + Just ("test" "data" "broken-sandbox" "dummy.cabal") diff --git a/test/CustomPackageDbSpec.hs b/test/CustomPackageDbSpec.hs --- a/test/CustomPackageDbSpec.hs +++ b/test/CustomPackageDbSpec.hs @@ -1,8 +1,8 @@ module CustomPackageDbSpec where -import Language.Haskell.GhcMod.CabalHelper -import Language.Haskell.GhcMod.CustomPackageDb -import Language.Haskell.GhcMod.Error +import GhcMod.CabalHelper +import GhcMod.CustomPackageDb +import GhcMod.Error import System.Process import Test.Hspec import Prelude diff --git a/test/FileMappingSpec.hs b/test/FileMappingSpec.hs --- a/test/FileMappingSpec.hs +++ b/test/FileMappingSpec.hs @@ -1,7 +1,7 @@ module FileMappingSpec where -import Language.Haskell.GhcMod.FileMapping -import Language.Haskell.GhcMod.Utils (withMappedFile) +import GhcMod.FileMapping +import GhcMod.Utils (withMappedFile) import Test.Hspec import TestUtils import qualified Data.Map as M @@ -9,7 +9,7 @@ import System.IO.Temp import System.Directory -import Language.Haskell.GhcMod +import GhcMod spec :: Spec spec = do @@ -122,25 +122,31 @@ withDirectory_ "test/data/file-mapping" $ 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" + lint lintOpts "File.hs" + 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" + lint lintOpts "File.hs" + 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" @@ -183,15 +189,15 @@ withDirectory_ "test/data/file-mapping/preprocessor" $ 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" + lint lintOpts "File.hs" + 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" + lint lintOpts "File.hs" + 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 @@ ,("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,10 @@ ,("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]\""] + + +lintOpts :: LintOpts +lintOpts = + defaultLintOpts { optLintHlintOpts = ["--ignore=Use module export list"] } diff --git a/test/FindSpec.hs b/test/FindSpec.hs new file mode 100644 --- /dev/null +++ b/test/FindSpec.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE OverloadedStrings #-} +module FindSpec where + +import GhcMod.Exe.Find +import Test.Hspec +import TestUtils + +spec :: Spec +spec = do + describe "db <- loadSymbolDb" $ do + it "lookupSymbol' db \"head\" contains at least `Data.List'" $ do + db <- runD $ loadSymbolDb + lookupSym "head" db `shouldContain` [ModuleString "Data.List"] diff --git a/test/FlagSpec.hs b/test/FlagSpec.hs --- a/test/FlagSpec.hs +++ b/test/FlagSpec.hs @@ -1,7 +1,7 @@ module FlagSpec where import Control.Applicative -import Language.Haskell.GhcMod +import GhcMod import Test.Hspec import TestUtils import Prelude @@ -9,6 +9,6 @@ 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"] diff --git a/test/GhcPkgSpec.hs b/test/GhcPkgSpec.hs new file mode 100644 --- /dev/null +++ b/test/GhcPkgSpec.hs @@ -0,0 +1,23 @@ +module GhcPkgSpec where + +import GhcMod.GhcPkg +import GhcMod.CabalHelper +import GhcMod.CustomPackageDb +import Test.Hspec +import System.Process (system) + +import Dir +import TestUtils + +spec :: Spec +spec = do + describe "getPackageDbStack'" $ do + it "fixes out of sync custom pkg-db stack" $ do + withDirectory_ "test/data/custom-cradle" $ do + _ <- system "cabal configure" + (s, s') <- runD $ do + Just stack <- getCustomPkgDbStack + withCabal $ do + stack' <- getPackageDbStack + return (stack, stack') + s' `shouldBe` s diff --git a/test/HomeModuleGraphSpec.hs b/test/HomeModuleGraphSpec.hs --- a/test/HomeModuleGraphSpec.hs +++ b/test/HomeModuleGraphSpec.hs @@ -1,4 +1,4 @@ --- ghc-mod: Making Haskell development *more* fun +-- ghc-mod: Happy Haskell Hacking -- Copyright (C) 2015 Daniel Gröber -- -- This program is free software: you can redistribute it and/or modify @@ -18,8 +18,8 @@ module HomeModuleGraphSpec where -import Language.Haskell.GhcMod.HomeModuleGraph -import Language.Haskell.GhcMod.LightGhc +import GhcMod.HomeModuleGraph +import GhcMod.LightGhc import TestUtils import GHC diff --git a/test/InfoSpec.hs b/test/InfoSpec.hs --- a/test/InfoSpec.hs +++ b/test/InfoSpec.hs @@ -3,7 +3,7 @@ import Control.Applicative import Data.List (isPrefixOf) -import Language.Haskell.GhcMod +import GhcMod #if __GLASGOW_HASKELL__ < 706 import System.Environment.Executable (getExecutablePath) #else @@ -19,17 +19,31 @@ 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 diff --git a/test/LangSpec.hs b/test/LangSpec.hs --- a/test/LangSpec.hs +++ b/test/LangSpec.hs @@ -1,7 +1,7 @@ module LangSpec where import Control.Applicative -import Language.Haskell.GhcMod +import GhcMod import Test.Hspec import TestUtils import Prelude diff --git a/test/LintSpec.hs b/test/LintSpec.hs --- a/test/LintSpec.hs +++ b/test/LintSpec.hs @@ -1,6 +1,6 @@ module LintSpec where -import Language.Haskell.GhcMod +import GhcMod import Test.Hspec import TestUtils @@ -8,10 +8,14 @@ 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 <- runD $ lint lintOpts "test/data/hlint/hlint.hs" + 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 - res <- runD $ lint defaultLintOpts "test/data/ghc-mod-check/lib/Data/Foo.hs" + res <- runD $ lint lintOpts "test/data/ghc-mod-check/lib/Data/Foo.hs" res `shouldBe` "" + +lintOpts :: LintOpts +lintOpts = + defaultLintOpts { optLintHlintOpts = ["--ignore=Use module export list"] } diff --git a/test/ListSpec.hs b/test/ListSpec.hs --- a/test/ListSpec.hs +++ b/test/ListSpec.hs @@ -1,7 +1,7 @@ module ListSpec where import Control.Applicative -import Language.Haskell.GhcMod +import GhcMod import Test.Hspec import TestUtils import Prelude diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,58 +1,92 @@ {-# LANGUAGE CPP, ScopedTypeVariables #-} -import Spec import Dir import Control.Exception as E import Control.Monad (void) -import Data.List -import Language.Haskell.GhcMod (debugInfo) +import GhcMod (debugInfo) import System.Process +import System.Environment import Test.Hspec import TestUtils +import qualified BrowseSpec +import qualified CabalHelperSpec +import qualified CaseSplitSpec +import qualified CheckSpec +import qualified CradleSpec +import qualified CustomPackageDbSpec +import qualified FileMappingSpec +import qualified FindSpec +import qualified FlagSpec +import qualified GhcPkgSpec +import qualified HomeModuleGraphSpec +import qualified InfoSpec +import qualified LangSpec +import qualified LintSpec +import qualified ListSpec +import qualified MonadSpec +import qualified PathsAndFilesSpec +import qualified ShellParseSpec +import qualified TargetSpec + +spec :: Spec +spec = do + describe "Browse" BrowseSpec.spec + describe "CabalHelper" CabalHelperSpec.spec + describe "CaseSplit" CaseSplitSpec.spec + describe "Check" CheckSpec.spec + describe "Cradle" CradleSpec.spec + describe "CustomPackageDb" CustomPackageDbSpec.spec + describe "FileMapping" FileMappingSpec.spec + describe "Find" FindSpec.spec + describe "Flag" FlagSpec.spec + describe "GhcPkg" GhcPkgSpec.spec + describe "HomeModuleGraph" HomeModuleGraphSpec.spec + describe "Info" InfoSpec.spec + describe "Lang" LangSpec.spec + describe "Lint" LintSpec.spec + describe "List" ListSpec.spec + describe "Monad" MonadSpec.spec + describe "PathsAndFiles" PathsAndFilesSpec.spec + describe "ShellParse" ShellParseSpec.spec + describe "Target" TargetSpec.spec + main :: IO () main = do +#if __GLASGOW_HASKELL__ >= 708 + unsetEnv "GHC_PACKAGE_PATH" +#endif let sandboxes = [ "test/data/cabal-project" , "test/data/check-packageid" , "test/data/duplicate-pkgver/" , "test/data/broken-cabal/" ] genSandboxCfg dir = withDirectory dir $ \cwdir -> do - system ("sed 's|@CWD@|" ++ cwdir ++ "|g' cabal.sandbox.config.in > cabal.sandbox.config") + system ("rm cabal.sandbox.config; cabal sandbox init") pkgDirs = [ "test/data/cabal-project/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d" , "test/data/check-packageid/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d" , "test/data/duplicate-pkgver/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d"] genGhcPkgCache dir = system $ "ghc-pkg recache --force -f" ++ dir - genSandboxCfg `mapM_` sandboxes - genGhcPkgCache `mapM_` pkgDirs - - let caches = [ "setup-config" - , "setup-config.ghc-mod.cabal-helper" - , "setup-config.ghc-mod.cabal-components" - , "setup-config.ghc-mod.resolved-components" - , "setup-config.ghc-mod.package-options" - , "setup-config.ghc-mod.package-db-stack" - , "ghc-mod.cache" - ] - findExp = unwords $ intersperse "-o " $ concat [ - stackWorkFindExp, - cachesFindExp - ] - cachesFindExp = map ("-name "++) caches - stackWorkFindExp = ["-name .stack-work -type d"] - - cleanCmd = "find test \\( "++ findExp ++" \\) -exec rm -r {} \\;" - + let cleanCmd = "git clean -dXf test/data/" putStrLn $ "$ " ++ cleanCmd void $ system cleanCmd void $ system "cabal --version" void $ system "ghc --version" + genSandboxCfg `mapM_` sandboxes + genGhcPkgCache `mapM_` pkgDirs + let stackDir = "test/data/stack-project" void $ withDirectory_ stackDir $ do --- void $ system "stack init --force" + let ghcver = let gvn = show (__GLASGOW_HASKELL__ :: Int) + (major, minor') = splitAt (length gvn - 2) gvn + minor = case dropWhile (=='0') minor' of + "" -> "0" + x -> x + in major ++ "." ++ minor + void $ system $ "sed '$ a resolver: ghc-" ++ ghcver ++ "' stack.yaml.in > stack.yaml" void $ system "stack setup" void $ system "stack build" diff --git a/test/MonadSpec.hs b/test/MonadSpec.hs --- a/test/MonadSpec.hs +++ b/test/MonadSpec.hs @@ -23,16 +23,18 @@ mv_ex :: MVar (Either SomeException ()) <- newEmptyMVar - mv_startup_barrier :: MVar () <- newEmptyMVar + mv_startup_barrier :: MVar () + <- newEmptyMVar _t1 <- forkOS $ do - putMVar mv_startup_barrier () -- wait (inside GhcModT) for t2 to receive the exception - _ <- runD $ liftIO $ readMVar mv_ex + _ <- runD $ liftIO $ do + putMVar mv_startup_barrier () + readMVar mv_ex return () _t2 <- forkOS $ do - readMVar mv_startup_barrier -- wait for t1 to start up + readMVar mv_startup_barrier -- wait for t1 to be in GhcModT res <- try $ runD $ return () res' <- evaluate res putMVar mv_ex res' diff --git a/test/PathsAndFilesSpec.hs b/test/PathsAndFilesSpec.hs --- a/test/PathsAndFilesSpec.hs +++ b/test/PathsAndFilesSpec.hs @@ -1,9 +1,9 @@ module PathsAndFilesSpec where -import Language.Haskell.GhcMod.PathsAndFiles -import Language.Haskell.GhcMod.Cradle -import qualified Language.Haskell.GhcMod.Utils as U +import GhcMod.PathsAndFiles +import GhcMod.Cradle +import qualified GhcMod.Utils as U import Control.Monad.Trans.Maybe import System.Directory @@ -16,12 +16,12 @@ 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 diff --git a/test/ShellParseSpec.hs b/test/ShellParseSpec.hs --- a/test/ShellParseSpec.hs +++ b/test/ShellParseSpec.hs @@ -1,7 +1,7 @@ module ShellParseSpec where -import GHCMod.Options.ShellParse +import GhcMod.Exe.Options.ShellParse import Test.Hspec diff --git a/test/Spec.hs b/test/Spec.hs deleted file mode 100644 --- a/test/Spec.hs +++ /dev/null @@ -1,1 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --no-main #-} diff --git a/test/TargetSpec.hs b/test/TargetSpec.hs new file mode 100644 --- /dev/null +++ b/test/TargetSpec.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} +module TargetSpec where + +import GhcMod.Target +import GhcMod.LightGhc +import GhcMod.Gap +import Test.Hspec + +import TestUtils + +import GHC +import Data.List +import Data.Maybe +import System.Directory +import System.FilePath + +spec :: Spec +spec = do + describe "runLightGhc" $ do + it "works at all" $ do + withLightHscEnv [] $ \env -> + runLightGhc env (return ()) `shouldReturn` () + + it "has modules in scope" $ do + (withLightHscEnv [] $ \env -> + runLightGhc env $ do + dflags <- getSessionDynFlags + let i = intersect (listVisibleModuleNames dflags) + ["Control.Applicative", "Control.Arrow" + ,"Control.Exception", "GHC.Exts", "GHC.Float"] + liftIO $ i `shouldSatisfy` not . null) :: IO () + + it "can get module info" $ do + (withLightHscEnv [] $ \env -> + runLightGhc env $ do + mdl <- findModule "Data.List" Nothing + mmi <- getModuleInfo mdl + liftIO $ isJust mmi `shouldBe` True) :: IO () + + + describe "resolveModule" $ do + it "Works when a module given as path uses CPP" $ do + dir <- getCurrentDirectory + let srcDirs = [dir "test/data/target/src"] + x <- withLightHscEnv [] $ \env -> runD $ do + resolveModule env srcDirs (Left $ dir "test/data/target/Cpp.hs") + liftIO $ x `shouldBe` Just (ModulePath "Cpp" $ dir "test/data/target/Cpp.hs") diff --git a/test/TestUtils.hs b/test/TestUtils.hs --- a/test/TestUtils.hs +++ b/test/TestUtils.hs @@ -6,17 +6,18 @@ , runE , runNullLog , runGmOutDef + , runLogDef , shouldReturnError , isPkgDbAt , isPkgConfDAt - , module Language.Haskell.GhcMod.Monad - , module Language.Haskell.GhcMod.Types + , module GhcMod.Monad + , module GhcMod.Types ) where -import Language.Haskell.GhcMod.Logging -import Language.Haskell.GhcMod.Monad -import Language.Haskell.GhcMod.Cradle -import Language.Haskell.GhcMod.Types +import GhcMod.Logging +import GhcMod.Monad +import GhcMod.Cradle +import GhcMod.Types import Control.Arrow import Control.Category @@ -43,10 +44,6 @@ 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,7 +56,14 @@ 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 run opt a = extract $ runGhcModTSpec opt a @@ -87,6 +91,9 @@ 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) diff --git a/test/data/broken-cabal/cabal.sandbox.config.in b/test/data/broken-cabal/cabal.sandbox.config.in deleted file mode 100644 --- a/test/data/broken-cabal/cabal.sandbox.config.in +++ /dev/null @@ -1,25 +0,0 @@ --- This is a Cabal package environment file. --- THIS FILE IS AUTO-GENERATED. DO NOT EDIT DIRECTLY. --- Please create a 'cabal.config' file in the same directory --- if you want to change the default settings for this sandbox. - - -local-repo: @CWD@/test/data/broken-cabal/.cabal-sandbox/packages -logs-dir: @CWD@/test/data/broken-cabal/.cabal-sandbox/logs -world-file: @CWD@/test/data/broken-cabal/.cabal-sandbox/world -user-install: False -package-db: @CWD@/test/data/broken-cabal/.cabal-sandbox/x86_64-linux-ghc-7.8.3-packages.conf.d -build-summary: @CWD@/test/data/broken-cabal/.cabal-sandbox/logs/build.log - -install-dirs - prefix: @CWD@/test/data/broken-cabal/.cabal-sandbox - bindir: $prefix/bin - libdir: $prefix/lib - libsubdir: $arch-$os-$compiler/$pkgid - libexecdir: $prefix/libexec - datadir: $prefix/share - datasubdir: $arch-$os-$compiler/$pkgid - docdir: $datadir/doc/$arch-$os-$compiler/$pkgid - htmldir: $docdir/html - haddockdir: $htmldir - sysconfdir: $prefix/etc diff --git a/test/data/cabal-project/cabal.sandbox.config.in b/test/data/cabal-project/cabal.sandbox.config.in deleted file mode 100644 --- a/test/data/cabal-project/cabal.sandbox.config.in +++ /dev/null @@ -1,25 +0,0 @@ --- This is a Cabal package environment file. --- THIS FILE IS AUTO-GENERATED. DO NOT EDIT DIRECTLY. --- Please create a 'cabal.config' file in the same directory --- if you want to change the default settings for this sandbox. - - -local-repo: @CWD@/test/data/cabal-project/.cabal-sandbox/packages -logs-dir: @CWD@/test/data/cabal-project/.cabal-sandbox/logs -world-file: @CWD@/test/data/cabal-project/.cabal-sandbox/world -user-install: False -package-db: @CWD@/test/data/cabal-project/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d -build-summary: @CWD@/test/data/cabal-project/.cabal-sandbox/logs/build.log - -install-dirs - prefix: @CWD@/test/data/cabal-project/.cabal-sandbox - bindir: $prefix/bin - libdir: $prefix/lib - libsubdir: $arch-$os-$compiler/$pkgid - libexecdir: $prefix/libexec - datadir: $prefix/share - datasubdir: $arch-$os-$compiler/$pkgid - docdir: $datadir/doc/$arch-$os-$compiler/$pkgid - htmldir: $docdir/html - haddockdir: $htmldir - sysconfdir: $prefix/etc diff --git a/test/data/case-split/Crash.hs b/test/data/case-split/Crash.hs new file mode 100644 --- /dev/null +++ b/test/data/case-split/Crash.hs @@ -0,0 +1,4 @@ +module Crash where + +test :: Maybe a +test x = undefined diff --git a/test/data/case-split/Vect706.hs b/test/data/case-split/Vect706.hs new file mode 100644 --- /dev/null +++ b/test/data/case-split/Vect706.hs @@ -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 diff --git a/test/data/check-packageid/cabal.sandbox.config.in b/test/data/check-packageid/cabal.sandbox.config.in deleted file mode 100644 --- a/test/data/check-packageid/cabal.sandbox.config.in +++ /dev/null @@ -1,25 +0,0 @@ --- This is a Cabal package environment file. --- THIS FILE IS AUTO-GENERATED. DO NOT EDIT DIRECTLY. --- Please create a 'cabal.config' file in the same directory --- if you want to change the default settings for this sandbox. - - -local-repo: @CWD@/test/data/check-packageid/.cabal-sandbox/packages -logs-dir: @CWD@/test/data/check-packageid/.cabal-sandbox/logs -world-file: @CWD@/test/data/check-packageid/.cabal-sandbox/world -user-install: False -package-db: @CWD@/test/data/check-packageid/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d -build-summary: @CWD@/test/data/check-packageid/.cabal-sandbox/logs/build.log - -install-dirs - prefix: @CWD@/test/data/check-packageid/.cabal-sandbox - bindir: $prefix/bin - libdir: $prefix/lib - libsubdir: $arch-$os-$compiler/$pkgid - libexecdir: $prefix/libexec - datadir: $prefix/share - datasubdir: $arch-$os-$compiler/$pkgid - docdir: $datadir/doc/$arch-$os-$compiler/$pkgid - htmldir: $docdir/html - haddockdir: $htmldir - sysconfdir: $prefix/etc diff --git a/test/data/duplicate-pkgver/cabal.sandbox.config.in b/test/data/duplicate-pkgver/cabal.sandbox.config.in deleted file mode 100644 --- a/test/data/duplicate-pkgver/cabal.sandbox.config.in +++ /dev/null @@ -1,25 +0,0 @@ --- This is a Cabal package environment file. --- THIS FILE IS AUTO-GENERATED. DO NOT EDIT DIRECTLY. --- Please create a 'cabal.config' file in the same directory --- if you want to change the default settings for this sandbox. - - -local-repo: @CWD@/test/data/duplicate-pkgver/.cabal-sandbox/packages -logs-dir: @CWD@/test/data/duplicate-pkgver/.cabal-sandbox/logs -world-file: @CWD@/test/data/duplicate-pkgver/.cabal-sandbox/world -user-install: False -package-db: @CWD@/test/data/duplicate-pkgver/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d -build-summary: @CWD@/test/data/duplicate-pkgver/.cabal-sandbox/logs/build.log - -install-dirs - prefix: @CWD@/test/data/duplicate-pkgver/.cabal-sandbox - bindir: $prefix/bin - libdir: $prefix/lib - libsubdir: $arch-$os-$compiler/$pkgid - libexecdir: $prefix/libexec - datadir: $prefix/share - datasubdir: $arch-$os-$compiler/$pkgid - docdir: $datadir/doc/$arch-$os-$compiler/$pkgid - htmldir: $docdir/html - haddockdir: $htmldir - sysconfdir: $prefix/etc diff --git a/test/data/home-module-graph/errors/A1.hs b/test/data/home-module-graph/errors/A1.hs --- a/test/data/home-module-graph/errors/A1.hs +++ b/test/data/home-module-graph/errors/A1.hs @@ -1,4 +1,4 @@ module A1 where -psogduapzsü9 +psogduapzs9 import B -lxäö,vLMCks +lx,vLMCks diff --git a/test/data/pattern-synonyms/A.hs b/test/data/pattern-synonyms/A.hs --- a/test/data/pattern-synonyms/A.hs +++ b/test/data/pattern-synonyms/A.hs @@ -1,4 +1,5 @@ {-# LANGUAGE PatternSynonyms #-} + module A where data SomeType a b = SomeType (a,b) diff --git a/test/data/pattern-synonyms/pattern-synonyms.cabal b/test/data/pattern-synonyms/pattern-synonyms.cabal --- a/test/data/pattern-synonyms/pattern-synonyms.cabal +++ b/test/data/pattern-synonyms/pattern-synonyms.cabal @@ -23,3 +23,5 @@ -- hs-source-dirs: default-language: Haskell2010 ghc-options: -Wall + if impl(ghc >= 8.0.1) + ghc-options: -Wno-missing-pattern-synonym-signatures diff --git a/test/data/stack-project/new-template.cabal b/test/data/stack-project/new-template.cabal --- a/test/data/stack-project/new-template.cabal +++ b/test/data/stack-project/new-template.cabal @@ -16,7 +16,7 @@ library hs-source-dirs: src exposed-modules: Lib - build-depends: base >= 4.7 && < 5 + build-depends: base default-language: Haskell2010 executable new-template-exe diff --git a/test/data/stack-project/stack.yaml b/test/data/stack-project/stack.yaml deleted file mode 100644 --- a/test/data/stack-project/stack.yaml +++ /dev/null @@ -1,5 +0,0 @@ -flags: {} -packages: -- '.' -extra-deps: [] -resolver: lts-2.17 diff --git a/test/data/stack-project/stack.yaml.in b/test/data/stack-project/stack.yaml.in new file mode 100644 --- /dev/null +++ b/test/data/stack-project/stack.yaml.in @@ -0,0 +1,4 @@ +flags: {} +packages: +- '.' +extra-deps: [] diff --git a/test/doctests.hs b/test/doctests.hs --- a/test/doctests.hs +++ b/test/doctests.hs @@ -2,16 +2,22 @@ module Main where import Test.DocTest +import System.Environment +import Data.Maybe main :: IO () -main = doctest - [ "-package", "ghc-" ++ VERSION_ghc - , "-package", "transformers-" ++ VERSION_transformers - , "-package", "mtl-" ++ VERSION_mtl - , "-package", "directory-" ++ VERSION_directory - , "-XScopedTypeVariables", "-XRecordWildCards", "-XNamedFieldPuns", "-XConstraintKinds", "-XFlexibleContexts", "-XDataKinds", "-XKindSignatures", "-XTypeOperators", "-XViewPatterns" - , "-idist/build/autogen/" - , "-optP-include" - , "-optPdist/build/autogen/cabal_macros.h" - , "Language/Haskell/GhcMod.hs" - ] +main = do + distdir <- (fromMaybe "dist" . lookup "DOCTEST_DIST_DIR") `fmap` getEnvironment + doctest + [ "-package", "ghc-" ++ VERSION_ghc + , "-package", "transformers-" ++ VERSION_transformers + , "-package", "mtl-" ++ VERSION_mtl + , "-package", "directory-" ++ VERSION_directory + , "-XScopedTypeVariables", "-XRecordWildCards", "-XNamedFieldPuns", "-XConstraintKinds", "-XFlexibleContexts", "-XDataKinds", "-XKindSignatures", "-XTypeOperators", "-XViewPatterns" + , "-i" ++ distdir ++ "/build/autogen/" + , "-icore/" + , "-ishared" +-- , "-optP-include" +-- , "-optP" ++ distdir ++ "/build/autogen/cabal_macros.h" + , "GhcMod.hs" + ]