Improve style
This commit is contained in:
Sergey Vinokurov
parent
a23f1f3b75
commit
4a9d578681
|
|
@ -9,8 +9,9 @@ import Language.Haskell.GhcMod.Modules
|
|||
|
||||
-- | Printing necessary information for front-end booting.
|
||||
boot :: IOish m => GhcModT m String
|
||||
boot = concat <$> sequence [modules, languages, flags,
|
||||
concat <$> mapM browse preBrowsedModules]
|
||||
boot = concat <$> sequence ms
|
||||
where
|
||||
ms = [modules, languages, flags, concat <$> mapM browse preBrowsedModules]
|
||||
|
||||
preBrowsedModules :: [String]
|
||||
preBrowsedModules = [
|
||||
|
|
|
|||
|
|
@ -48,7 +48,7 @@ browse pkgmdl = do
|
|||
|
||||
tryModuleInfo m = fromJust <$> G.getModuleInfo m
|
||||
|
||||
(mpkg,mdl) = splitPkgMdl pkgmdl
|
||||
(mpkg, mdl) = splitPkgMdl pkgmdl
|
||||
mdlname = G.mkModuleName mdl
|
||||
mpkgid = mkFastString <$> mpkg
|
||||
|
||||
|
|
@ -59,9 +59,10 @@ browse pkgmdl = do
|
|||
-- >>> splitPkgMdl "Prelude"
|
||||
-- (Nothing,"Prelude")
|
||||
splitPkgMdl :: String -> (Maybe String,String)
|
||||
splitPkgMdl pkgmdl = case break (==':') pkgmdl of
|
||||
(mdl,"") -> (Nothing,mdl)
|
||||
(pkg,_:mdl) -> (Just pkg,mdl)
|
||||
splitPkgMdl pkgmdl =
|
||||
case break (==':') pkgmdl of
|
||||
(mdl, "") -> (Nothing, mdl)
|
||||
(pkg, _:mdl) -> (Just pkg, mdl)
|
||||
|
||||
-- Haskell 2010:
|
||||
-- small -> ascSmall | uniSmall | _
|
||||
|
|
|
|||
|
|
@ -27,7 +27,7 @@ convert' :: (ToString a, IOish m, GmEnv m) => a -> m String
|
|||
convert' x = flip convert x <$> options
|
||||
|
||||
convert :: ToString a => Options -> a -> String
|
||||
convert opt@Options { outputStyle = LispStyle } x = toLisp opt x "\n"
|
||||
convert opt@Options { outputStyle = LispStyle } x = toLisp opt x "\n"
|
||||
convert opt@Options { outputStyle = PlainStyle } x
|
||||
| str == "\n" = ""
|
||||
| otherwise = str
|
||||
|
|
@ -35,8 +35,8 @@ convert opt@Options { outputStyle = PlainStyle } x
|
|||
str = toPlain opt x "\n"
|
||||
|
||||
class ToString a where
|
||||
toLisp :: Options -> a -> Builder
|
||||
toPlain :: Options -> a -> Builder
|
||||
toLisp :: Options -> a -> Builder
|
||||
toPlain :: Options -> a -> Builder
|
||||
|
||||
lineSep :: Options -> String
|
||||
lineSep opt = interpret lsep
|
||||
|
|
@ -51,8 +51,8 @@ lineSep opt = interpret lsep
|
|||
-- >>> toPlain defaultOptions "foo" ""
|
||||
-- "foo"
|
||||
instance ToString String where
|
||||
toLisp opt = quote opt
|
||||
toPlain opt = replace '\n' (lineSep opt)
|
||||
toLisp opt = quote opt
|
||||
toPlain opt = replace '\n' (lineSep opt)
|
||||
|
||||
-- |
|
||||
--
|
||||
|
|
@ -61,8 +61,8 @@ instance ToString String where
|
|||
-- >>> toPlain defaultOptions ["foo", "bar", "baz"] ""
|
||||
-- "foo\nbar\nbaz"
|
||||
instance ToString [String] where
|
||||
toLisp opt = toSexp1 opt
|
||||
toPlain opt = inter '\n' . map (toPlain opt)
|
||||
toLisp opt = toSexp1 opt
|
||||
toPlain opt = inter '\n' . map (toPlain opt)
|
||||
|
||||
-- |
|
||||
--
|
||||
|
|
@ -72,23 +72,23 @@ instance ToString [String] where
|
|||
-- >>> toPlain defaultOptions inp ""
|
||||
-- "1 2 3 4 \"foo\"\n5 6 7 8 \"bar\""
|
||||
instance ToString [((Int,Int,Int,Int),String)] where
|
||||
toLisp opt = toSexp2 . map toS
|
||||
where
|
||||
toS x = ('(' :) . tupToString opt x . (')' :)
|
||||
toPlain opt = inter '\n' . map (tupToString opt)
|
||||
toLisp opt = toSexp2 . map toS
|
||||
where
|
||||
toS x = ('(' :) . tupToString opt x . (')' :)
|
||||
toPlain opt = inter '\n' . map (tupToString opt)
|
||||
|
||||
instance ToString ((Int,Int,Int,Int),String) where
|
||||
toLisp opt x = ('(' :) . tupToString opt x . (')' :)
|
||||
toPlain opt x = tupToString opt x
|
||||
toLisp opt x = ('(' :) . tupToString opt x . (')' :)
|
||||
toPlain opt x = tupToString opt x
|
||||
|
||||
instance ToString ((Int,Int,Int,Int),[String]) where
|
||||
toLisp opt (x,s) = ('(' :) . fourIntsToString opt x .
|
||||
(' ' :) . toLisp opt s . (')' :)
|
||||
toPlain opt (x,s) = fourIntsToString opt x . ('\n' :) . toPlain opt s
|
||||
toLisp opt (x,s) = ('(' :) . fourIntsToString opt x .
|
||||
(' ' :) . toLisp opt s . (')' :)
|
||||
toPlain opt (x,s) = fourIntsToString opt x . ('\n' :) . toPlain opt s
|
||||
|
||||
instance ToString (String, (Int,Int,Int,Int),[String]) where
|
||||
toLisp opt (s,x,y) = toSexp2 [toLisp opt s, ('(' :) . fourIntsToString opt x . (')' :), toLisp opt y]
|
||||
toPlain opt (s,x,y) = inter '\n' [toPlain opt s, fourIntsToString opt x, toPlain opt y]
|
||||
toLisp opt (s,x,y) = toSexp2 [toLisp opt s, ('(' :) . fourIntsToString opt x . (')' :), toLisp opt y]
|
||||
toPlain opt (s,x,y) = inter '\n' [toPlain opt s, fourIntsToString opt x, toPlain opt y]
|
||||
|
||||
toSexp1 :: Options -> [String] -> Builder
|
||||
toSexp1 opt ss = ('(' :) . inter ' ' (map (quote opt) ss) . (')' :)
|
||||
|
|
|
|||
|
|
@ -79,17 +79,14 @@ sig file lineNo colNo =
|
|||
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)
|
||||
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])
|
||||
|
||||
|
||||
in (rTy, fourInts loc, [initial ++ body])
|
||||
where
|
||||
fallback (SomeException _) = do
|
||||
opt <- options
|
||||
|
|
@ -244,9 +241,11 @@ initialHead1 :: String -> [FnArg] -> [String] -> String
|
|||
initialHead1 fname args elts =
|
||||
case initialBodyArgs1 args elts of
|
||||
[] -> fname
|
||||
arglist -> if isSymbolName fname
|
||||
then head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist)
|
||||
else fname ++ " " ++ unwords arglist
|
||||
arglist
|
||||
| isSymbolName fname ->
|
||||
head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist)
|
||||
| otherwise ->
|
||||
fname ++ " " ++ unwords arglist
|
||||
|
||||
initialBodyArgs1 :: [FnArg] -> [String] -> [String]
|
||||
initialBodyArgs1 args elts = take (length args) elts
|
||||
|
|
@ -338,39 +337,45 @@ refine :: IOish m
|
|||
-> Expression -- ^ A Haskell expression.
|
||||
-> GhcModT m String
|
||||
refine file lineNo colNo expr =
|
||||
ghandle handler $ runGmlT' [Left file] deferErrors $ do
|
||||
opt <- options
|
||||
style <- getStyle
|
||||
dflag <- G.getSessionDynFlags
|
||||
modSum <- Gap.fileModSummary file
|
||||
p <- G.parseModule modSum
|
||||
tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p
|
||||
ety <- G.exprType expr
|
||||
whenFound opt (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
|
||||
text = initialHead1 expr iArgs (infinitePrefixSupply name)
|
||||
in (fourInts loc, doParen paren text)
|
||||
|
||||
where
|
||||
handler (SomeException _) = emptyResult =<< options
|
||||
ghandle handler $
|
||||
runGmlT' [Left file] deferErrors $ do
|
||||
opt <- options
|
||||
style <- getStyle
|
||||
dflag <- G.getSessionDynFlags
|
||||
modSum <- Gap.fileModSummary file
|
||||
p <- G.parseModule modSum
|
||||
tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p
|
||||
ety <- G.exprType expr
|
||||
whenFound opt (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
|
||||
text = initialHead1 expr iArgs (infinitePrefixSupply name)
|
||||
in (fourInts loc, doParen paren text)
|
||||
where
|
||||
handler (SomeException _) = emptyResult =<< options
|
||||
|
||||
-- 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
|
||||
:: 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 (span, typ)
|
||||
Just (s, typ)
|
||||
| name == "undefined" || head name == '_' ->
|
||||
return $ Just (span, name, typ, b)
|
||||
return $ Just (s, name, typ, b)
|
||||
where
|
||||
name = getFnName dflag style i
|
||||
-- If inside an App, we need parenthesis
|
||||
|
|
|
|||
|
|
@ -2,8 +2,7 @@
|
|||
|
||||
module Language.Haskell.GhcMod.Find
|
||||
#ifndef SPEC
|
||||
(
|
||||
Symbol
|
||||
( Symbol
|
||||
, SymbolDb
|
||||
, loadSymbolDb
|
||||
, lookupSymbol
|
||||
|
|
@ -33,17 +32,8 @@ import System.Directory (doesFileExist, getModificationTime)
|
|||
import System.FilePath ((</>))
|
||||
import System.IO
|
||||
|
||||
#ifndef MIN_VERSION_containers
|
||||
#define MIN_VERSION_containers(x,y,z) 1
|
||||
#endif
|
||||
|
||||
#if MIN_VERSION_containers(0,5,0)
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as M
|
||||
#else
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as M
|
||||
#endif
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
|
|
@ -79,16 +69,16 @@ lookupSym sym db = M.findWithDefault [] sym $ table db
|
|||
-- | Loading a file and creates 'SymbolDb'.
|
||||
loadSymbolDb :: IOish m => GhcModT m SymbolDb
|
||||
loadSymbolDb = do
|
||||
ghcMod <- liftIO ghcModExecutable
|
||||
tmpdir <- cradleTempDir <$> cradle
|
||||
file <- liftIO $ chop <$> readProcess ghcMod ["dumpsym", tmpdir] ""
|
||||
!db <- M.fromAscList . map conv . lines <$> liftIO (readFile file)
|
||||
return $ SymbolDb
|
||||
{ table = db
|
||||
, symbolDbCachePath = file
|
||||
}
|
||||
ghcMod <- liftIO ghcModExecutable
|
||||
tmpdir <- cradleTempDir <$> cradle
|
||||
file <- liftIO $ chop <$> readProcess ghcMod ["dumpsym", tmpdir] ""
|
||||
!db <- M.fromAscList . map conv . lines <$> liftIO (readFile file)
|
||||
return $ SymbolDb
|
||||
{ table = db
|
||||
, symbolDbCachePath = file
|
||||
}
|
||||
where
|
||||
conv :: String -> (Symbol,[ModuleString])
|
||||
conv :: String -> (Symbol, [ModuleString])
|
||||
conv = read
|
||||
chop :: String -> String
|
||||
chop "" = ""
|
||||
|
|
@ -113,11 +103,11 @@ dumpSymbol dir = do
|
|||
cache = dir </> symbolCacheFile
|
||||
|
||||
writeSymbolCache :: FilePath
|
||||
-> [(Symbol,[ModuleString])]
|
||||
-> [(Symbol, [ModuleString])]
|
||||
-> IO ()
|
||||
writeSymbolCache cache sm =
|
||||
void . withFile cache WriteMode $ \hdl ->
|
||||
mapM (hPrint hdl) sm
|
||||
mapM (hPrint hdl) sm
|
||||
|
||||
-- | Check whether given file is older than any file from the given set.
|
||||
-- Returns True if given file does not exist.
|
||||
|
|
@ -131,24 +121,24 @@ isOlderThan cache files = do
|
|||
return $ any (tCache <=) $ map tfTime files -- including equal just in case
|
||||
|
||||
-- | Browsing all functions in all system modules.
|
||||
getGlobalSymbolTable :: LightGhc [(Symbol,[ModuleString])]
|
||||
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)
|
||||
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, moduleNameString $ moduleName mdl)) names
|
||||
extractBindings (Nothing, _) = []
|
||||
extractBindings (Just inf, mdl) =
|
||||
map (\name -> (getOccString name, moduleNameString $ moduleName mdl)) names
|
||||
where
|
||||
names = G.modInfoExports inf
|
||||
|
||||
collectModules :: [(Symbol,ModuleString)]
|
||||
-> [(Symbol,[ModuleString])]
|
||||
collectModules :: [(Symbol, ModuleString)]
|
||||
-> [(Symbol, [ModuleString])]
|
||||
collectModules = map tieup . groupBy ((==) `on` fst) . sort
|
||||
where
|
||||
tieup x = (head (map fst x), map snd x)
|
||||
|
|
|
|||
|
|
@ -30,20 +30,21 @@ info :: IOish m
|
|||
-> Expression -- ^ A Haskell expression.
|
||||
-> GhcModT m String
|
||||
info file expr =
|
||||
ghandle handler $ runGmlT' [Left file] deferErrors $ withContext $
|
||||
convert <$> options <*> body
|
||||
ghandle handler $
|
||||
runGmlT' [Left file] deferErrors $
|
||||
withContext $
|
||||
convert <$> options <*> body
|
||||
where
|
||||
handler (SomeException ex) = do
|
||||
gmLog GmException "info" $
|
||||
text "" $$ nest 4 (showDoc ex)
|
||||
convert' "Cannot show info"
|
||||
gmLog GmException "info" $ text "" $$ nest 4 (showDoc ex)
|
||||
convert' "Cannot show info"
|
||||
|
||||
body :: GhcMonad m => m String
|
||||
body = do
|
||||
sdoc <- Gap.infoThing expr
|
||||
st <- getStyle
|
||||
dflag <- G.getSessionDynFlags
|
||||
return $ showPage dflag st sdoc
|
||||
|
||||
sdoc <- Gap.infoThing expr
|
||||
st <- getStyle
|
||||
dflag <- G.getSessionDynFlags
|
||||
return $ showPage dflag st sdoc
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
|
|
@ -54,14 +55,14 @@ types :: IOish m
|
|||
-> Int -- ^ Column number.
|
||||
-> GhcModT m String
|
||||
types file lineNo colNo =
|
||||
ghandle handler $ runGmlT' [Left file] deferErrors $ withContext $ do
|
||||
crdl <- cradle
|
||||
modSum <- Gap.fileModSummary (cradleCurrentDir crdl </> file)
|
||||
ghandle handler $
|
||||
runGmlT' [Left file] deferErrors $
|
||||
withContext $ do
|
||||
crdl <- cradle
|
||||
modSum <- Gap.fileModSummary (cradleCurrentDir crdl </> file)
|
||||
srcSpanTypes <- getSrcSpanType modSum lineNo colNo
|
||||
|
||||
dflag <- G.getSessionDynFlags
|
||||
st <- getStyle
|
||||
|
||||
dflag <- G.getSessionDynFlags
|
||||
st <- getStyle
|
||||
convert' $ map (toTup dflag st) $ sortBy (cmp `on` fst) srcSpanTypes
|
||||
where
|
||||
handler (SomeException ex) = do
|
||||
|
|
@ -70,12 +71,12 @@ types file lineNo colNo =
|
|||
|
||||
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]
|
||||
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]
|
||||
|
|
|
|||
|
|
@ -50,7 +50,7 @@ type MonadIOC m = (MTL.MonadIO m)
|
|||
#endif
|
||||
|
||||
class MonadIOC m => MonadIO m where
|
||||
liftIO :: IO a -> m a
|
||||
liftIO :: IO a -> m a
|
||||
|
||||
-- | Output style.
|
||||
data OutputStyle = LispStyle -- ^ S expression style.
|
||||
|
|
@ -83,21 +83,20 @@ data Options = Options {
|
|||
, hlintOpts :: [String]
|
||||
} deriving (Show)
|
||||
|
||||
|
||||
-- | A default 'Options'.
|
||||
defaultOptions :: Options
|
||||
defaultOptions = Options {
|
||||
outputStyle = PlainStyle
|
||||
, lineSeparator = LineSeparator "\0"
|
||||
, logLevel = GmWarning
|
||||
, ghcProgram = "ghc"
|
||||
, ghcPkgProgram = "ghc-pkg"
|
||||
, cabalProgram = "cabal"
|
||||
, ghcUserOptions= []
|
||||
, operators = False
|
||||
, detailed = False
|
||||
, qualified = False
|
||||
, hlintOpts = []
|
||||
outputStyle = PlainStyle
|
||||
, lineSeparator = LineSeparator "\0"
|
||||
, logLevel = GmWarning
|
||||
, ghcProgram = "ghc"
|
||||
, ghcPkgProgram = "ghc-pkg"
|
||||
, cabalProgram = "cabal"
|
||||
, ghcUserOptions = []
|
||||
, operators = False
|
||||
, detailed = False
|
||||
, qualified = False
|
||||
, hlintOpts = []
|
||||
}
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
|
@ -113,7 +112,7 @@ data Cradle = Cradle {
|
|||
-- | The file name of the found cabal file.
|
||||
, cradleCabalFile :: Maybe FilePath
|
||||
-- | Package database stack
|
||||
, cradlePkgDbStack :: [GhcPkgDb]
|
||||
, cradlePkgDbStack :: [GhcPkgDb]
|
||||
} deriving (Eq, Show)
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
|
@ -122,7 +121,7 @@ data Cradle = Cradle {
|
|||
data GhcPkgDb = GlobalDb | UserDb | PackageDb String deriving (Eq, Show)
|
||||
|
||||
-- | A single GHC command line option.
|
||||
type GHCOption = String
|
||||
type GHCOption = String
|
||||
|
||||
-- | An include directory for modules.
|
||||
type IncludeDir = FilePath
|
||||
|
|
@ -131,28 +130,28 @@ type IncludeDir = FilePath
|
|||
type PackageBaseName = String
|
||||
|
||||
-- | A package version.
|
||||
type PackageVersion = String
|
||||
type PackageVersion = String
|
||||
|
||||
-- | A package id.
|
||||
type PackageId = String
|
||||
type PackageId = String
|
||||
|
||||
-- | A package's name, verson and id.
|
||||
type Package = (PackageBaseName, PackageVersion, PackageId)
|
||||
type Package = (PackageBaseName, PackageVersion, PackageId)
|
||||
|
||||
pkgName :: Package -> PackageBaseName
|
||||
pkgName (n,_,_) = n
|
||||
pkgName (n, _, _) = n
|
||||
|
||||
pkgVer :: Package -> PackageVersion
|
||||
pkgVer (_,v,_) = v
|
||||
pkgVer (_, v, _) = v
|
||||
|
||||
pkgId :: Package -> PackageId
|
||||
pkgId (_,_,i) = i
|
||||
pkgId (_, _, i) = i
|
||||
|
||||
showPkg :: Package -> String
|
||||
showPkg (n,v,_) = intercalate "-" [n,v]
|
||||
showPkg (n, v, _) = intercalate "-" [n, v]
|
||||
|
||||
showPkgId :: Package -> String
|
||||
showPkgId (n,v,i) = intercalate "-" [n,v,i]
|
||||
showPkgId (n, v, i) = intercalate "-" [n, v, i]
|
||||
|
||||
-- | Haskell expression.
|
||||
type Expression = String
|
||||
|
|
@ -163,131 +162,133 @@ type ModuleString = String
|
|||
-- | A Module
|
||||
type Module = [String]
|
||||
|
||||
data GmLogLevel = GmSilent
|
||||
| GmPanic
|
||||
| GmException
|
||||
| GmError
|
||||
| GmWarning
|
||||
| GmInfo
|
||||
| GmDebug
|
||||
deriving (Eq, Ord, Enum, Bounded, Show, Read)
|
||||
data GmLogLevel =
|
||||
GmSilent
|
||||
| GmPanic
|
||||
| GmException
|
||||
| GmError
|
||||
| GmWarning
|
||||
| GmInfo
|
||||
| GmDebug
|
||||
deriving (Eq, Ord, Enum, Bounded, Show, Read)
|
||||
|
||||
-- | Collection of packages
|
||||
type PkgDb = (Map Package PackageConfig)
|
||||
|
||||
data GmModuleGraph = GmModuleGraph {
|
||||
gmgGraph :: Map ModulePath (Set ModulePath)
|
||||
} deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
||||
gmgGraph :: Map ModulePath (Set ModulePath)
|
||||
} deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
||||
|
||||
instance Serialize GmModuleGraph where
|
||||
put GmModuleGraph {..} = let
|
||||
mpim :: Map ModulePath Integer
|
||||
graph :: Map Integer (Set Integer)
|
||||
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
|
||||
|
||||
mpim = Map.fromList $
|
||||
(Map.keys gmgGraph) `zip` [0..]
|
||||
mpToInt :: ModulePath -> Integer
|
||||
mpToInt mp = fromJust $ Map.lookup mp mpim
|
||||
|
||||
graph = Map.map (Set.map mpToInt) $ Map.mapKeys mpToInt gmgGraph
|
||||
in put (mpim, graph)
|
||||
|
||||
get = do
|
||||
(mpim :: Map ModulePath Integer, graph :: Map Integer (Set Integer)) <- get
|
||||
let
|
||||
swapMap = Map.fromList . map swap . Map.toList
|
||||
swap (a,b) = (b,a)
|
||||
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
|
||||
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')
|
||||
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)
|
||||
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 Serialize eps => Serialize (GmComponent t eps)
|
||||
|
||||
data ModulePath = ModulePath { mpModule :: ModuleName, mpPath :: FilePath }
|
||||
deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
||||
deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
||||
instance Serialize ModulePath
|
||||
|
||||
instance Serialize ModuleName where
|
||||
get = mkModuleName <$> get
|
||||
put mn = put (moduleNameString mn)
|
||||
get = mkModuleName <$> get
|
||||
put mn = put (moduleNameString mn)
|
||||
|
||||
instance Show ModuleName where
|
||||
show mn = "ModuleName " ++ show (moduleNameString mn)
|
||||
show mn = "ModuleName " ++ show (moduleNameString mn)
|
||||
|
||||
instance Read ModuleName where
|
||||
readsPrec d r = readParen (d > app_prec)
|
||||
(\r' -> [(mkModuleName m,t) |
|
||||
("ModuleName",s) <- lex r',
|
||||
(m,t) <- readsPrec (app_prec+1) s]) r
|
||||
where app_prec = 10
|
||||
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
|
||||
= GMENoMsg
|
||||
-- ^ Unknown error
|
||||
|
||||
| GMEString String
|
||||
-- ^ Some Error with a message. These are produced mostly by
|
||||
-- 'fail' calls on GhcModT.
|
||||
| GMEString String
|
||||
-- ^ Some Error with a message. These are produced mostly by
|
||||
-- 'fail' calls on GhcModT.
|
||||
|
||||
| GMECabalConfigure GhcModError
|
||||
-- ^ Configuring a cabal project failed.
|
||||
| GMECabalConfigure GhcModError
|
||||
-- ^ Configuring a cabal project failed.
|
||||
|
||||
| GMECabalFlags GhcModError
|
||||
-- ^ Retrieval of the cabal configuration flags failed.
|
||||
| GMECabalFlags GhcModError
|
||||
-- ^ Retrieval of the cabal configuration flags failed.
|
||||
|
||||
| GMECabalComponent ChComponentName
|
||||
-- ^ Cabal component could not be found
|
||||
| GMECabalComponent ChComponentName
|
||||
-- ^ Cabal component could not be found
|
||||
|
||||
| GMECabalCompAssignment [(Either FilePath ModuleName, Set ChComponentName)]
|
||||
-- ^ Could not find a consistent component assignment for modules
|
||||
| GMECabalCompAssignment [(Either FilePath ModuleName, Set ChComponentName)]
|
||||
-- ^ Could not find a consistent component assignment for modules
|
||||
|
||||
| GMEProcess String [String] (Either (String, String, Int) GhcModError)
|
||||
-- ^ Launching an operating system process failed. Fields in
|
||||
-- order: command, arguments, (stdout, stderr, exitcode)
|
||||
| GMEProcess String [String] (Either (String, String, Int) GhcModError)
|
||||
-- ^ Launching an operating system process failed. Fields in
|
||||
-- order: command, arguments, (stdout, stderr, exitcode)
|
||||
|
||||
| GMENoCabalFile
|
||||
-- ^ No cabal file found.
|
||||
| GMENoCabalFile
|
||||
-- ^ No cabal file found.
|
||||
|
||||
| GMETooManyCabalFiles [FilePath]
|
||||
-- ^ Too many cabal files found.
|
||||
| GMETooManyCabalFiles [FilePath]
|
||||
-- ^ Too many cabal files found.
|
||||
|
||||
| GMECabalStateFile GMConfigStateFileError
|
||||
-- ^ Reading Cabal's state configuration file falied somehow.
|
||||
deriving (Eq,Show,Typeable)
|
||||
| GMECabalStateFile GMConfigStateFileError
|
||||
-- ^ Reading Cabal's state configuration file falied somehow.
|
||||
deriving (Eq,Show,Typeable)
|
||||
|
||||
instance Error GhcModError where
|
||||
noMsg = GMENoMsg
|
||||
strMsg = GMEString
|
||||
noMsg = GMENoMsg
|
||||
strMsg = GMEString
|
||||
|
||||
instance Exception GhcModError
|
||||
|
||||
data GMConfigStateFileError
|
||||
= GMConfigStateFileNoHeader
|
||||
| GMConfigStateFileBadHeader
|
||||
| GMConfigStateFileNoParse
|
||||
| GMConfigStateFileMissing
|
||||
-- | GMConfigStateFileBadVersion PackageIdentifier PackageIdentifier (Either ConfigStateFileError LocalBuildInfo)
|
||||
= GMConfigStateFileNoHeader
|
||||
| GMConfigStateFileBadHeader
|
||||
| GMConfigStateFileNoParse
|
||||
| GMConfigStateFileMissing
|
||||
-- | GMConfigStateFileBadVersion PackageIdentifier PackageIdentifier (Either ConfigStateFileError LocalBuildInfo)
|
||||
deriving (Eq, Show, Read, Typeable)
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -15,26 +15,26 @@
|
|||
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DoAndIfThenElse #-}
|
||||
|
||||
module Language.Haskell.GhcMod.Utils (
|
||||
module Language.Haskell.GhcMod.Utils
|
||||
, module Utils
|
||||
, readProcess
|
||||
) where
|
||||
|
||||
import Control.Arrow
|
||||
import Control.Applicative
|
||||
import Data.Char
|
||||
import Exception
|
||||
import Language.Haskell.GhcMod.Error
|
||||
import Language.Haskell.GhcMod.Monad.Types
|
||||
import Exception
|
||||
import System.Directory (getCurrentDirectory, setCurrentDirectory, doesFileExist,
|
||||
getTemporaryDirectory, canonicalizePath, doesFileExist)
|
||||
import System.Process (readProcess)
|
||||
import System.Directory ()
|
||||
getTemporaryDirectory, canonicalizePath)
|
||||
import System.Environment
|
||||
import System.FilePath (splitDrive, takeDirectory, takeFileName, pathSeparators,
|
||||
(</>))
|
||||
import System.IO.Temp (createTempDirectory)
|
||||
import System.Environment
|
||||
import System.Process (readProcess)
|
||||
import Text.Printf
|
||||
|
||||
import Paths_ghc_mod (getLibexecDir)
|
||||
|
|
@ -46,25 +46,28 @@ 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)
|
||||
gbracket
|
||||
(liftIO getCurrentDirectory)
|
||||
(liftIO . setCurrentDirectory)
|
||||
(\_ -> liftIO (setCurrentDirectory dir) >> action)
|
||||
|
||||
uniqTempDirName :: FilePath -> FilePath
|
||||
uniqTempDirName dir = ("ghc-mod"++) $ uncurry (++)
|
||||
$ map escapeDriveChar *** map escapePathChar
|
||||
$ splitDrive dir
|
||||
where
|
||||
uniqTempDirName dir =
|
||||
"ghc-mod" ++ map escapeDriveChar drive ++ map escapePathChar path
|
||||
where
|
||||
(drive, path) = splitDrive dir
|
||||
escapeDriveChar :: Char -> Char
|
||||
escapeDriveChar c
|
||||
| isAlphaNum c = c
|
||||
| otherwise = '-'
|
||||
|
||||
| isAlphaNum c = c
|
||||
| otherwise = '-'
|
||||
escapePathChar :: Char -> Char
|
||||
escapePathChar c
|
||||
| c `elem` pathSeparators = '-'
|
||||
| otherwise = c
|
||||
| c `elem` pathSeparators = '-'
|
||||
| otherwise = c
|
||||
|
||||
newTempDir :: FilePath -> IO FilePath
|
||||
newTempDir dir =
|
||||
flip createTempDirectory (uniqTempDirName dir) =<< getTemporaryDirectory
|
||||
flip createTempDirectory (uniqTempDirName dir) =<< getTemporaryDirectory
|
||||
|
||||
whenM :: IO Bool -> IO () -> IO ()
|
||||
whenM mb ma = mb >>= flip when ma
|
||||
|
|
@ -82,21 +85,21 @@ ghcModExecutable = fmap (</> "dist/build/ghc-mod/ghc-mod") getCurrentDirectory
|
|||
|
||||
findLibexecExe :: String -> IO FilePath
|
||||
findLibexecExe "cabal-helper-wrapper" = do
|
||||
libexecdir <- getLibexecDir
|
||||
let exeName = "cabal-helper-wrapper"
|
||||
exe = libexecdir </> exeName
|
||||
libexecdir <- getLibexecDir
|
||||
let exeName = "cabal-helper-wrapper"
|
||||
exe = libexecdir </> exeName
|
||||
|
||||
exists <- doesFileExist exe
|
||||
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
|
||||
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
|
||||
|
|
@ -119,22 +122,20 @@ tryFindGhcModTreeLibexecDir :: IO (Maybe FilePath)
|
|||
tryFindGhcModTreeLibexecDir = do
|
||||
exe <- getExecutablePath'
|
||||
dir <- case takeFileName exe of
|
||||
"ghc" -> do -- we're probably in ghci; try CWD
|
||||
getCurrentDirectory
|
||||
_ ->
|
||||
return $ (!!4) $ iterate takeDirectory exe
|
||||
"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
|
||||
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
|
||||
then Just dir
|
||||
else Nothing
|
||||
|
||||
readLibExecProcess' :: (MonadIO m, ExceptionMonad m)
|
||||
=> String -> [String] -> m String
|
||||
|
|
|
|||
Loading…
Reference in New Issue