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

Improve style

Browse Source
This commit is contained in:
Sergey Vinokurov 2015-06-01 17:54:50 +03:00
parent a23f1f3b75
commit 4a9d578681
8 changed files with 263 additions and 263 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -9,8 +9,9 @@ import Language.Haskell.GhcMod.Modules
-- | Printing necessary information for front-end booting. -- | Printing necessary information for front-end booting.
boot :: IOish m => GhcModT m String boot :: IOish m => GhcModT m String
boot = concat <$> sequence [modules, languages, flags, boot = concat <$> sequence ms
concat <$> mapM browse preBrowsedModules] where
ms = [modules, languages, flags, concat <$> mapM browse preBrowsedModules]
preBrowsedModules :: [String] preBrowsedModules :: [String]
preBrowsedModules = [ preBrowsedModules = [

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

@ -48,7 +48,7 @@ browse pkgmdl = do
tryModuleInfo m = fromJust <$> G.getModuleInfo m tryModuleInfo m = fromJust <$> G.getModuleInfo m
(mpkg,mdl) = splitPkgMdl pkgmdl (mpkg, mdl) = splitPkgMdl pkgmdl
mdlname = G.mkModuleName mdl mdlname = G.mkModuleName mdl
mpkgid = mkFastString <$> mpkg mpkgid = mkFastString <$> mpkg
@ -59,9 +59,10 @@ browse pkgmdl = do
-- >>> splitPkgMdl "Prelude" -- >>> splitPkgMdl "Prelude"
-- (Nothing,"Prelude") -- (Nothing,"Prelude")
splitPkgMdl :: String -> (Maybe String,String) splitPkgMdl :: String -> (Maybe String,String)
splitPkgMdl pkgmdl = case break (==':') pkgmdl of splitPkgMdl pkgmdl =
(mdl,"") -> (Nothing,mdl) case break (==':') pkgmdl of
(pkg,_:mdl) -> (Just pkg,mdl) (mdl, "") -> (Nothing, mdl)
(pkg, _:mdl) -> (Just pkg, mdl)
-- Haskell 2010: -- Haskell 2010:
-- small -> ascSmall | uniSmall | _ -- small -> ascSmall | uniSmall | _

36
Language/Haskell/GhcMod/Convert.hs
View File

@ -27,7 +27,7 @@ convert' :: (ToString a, IOish m, GmEnv m) => a -> m String
convert' x = flip convert x <$> options convert' x = flip convert x <$> options
convert :: ToString a => Options -> a -> String 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 convert opt@Options { outputStyle = PlainStyle } x
| str == "\n" = "" | str == "\n" = ""
| otherwise = str | otherwise = str
@ -35,8 +35,8 @@ convert opt@Options { outputStyle = PlainStyle } x
str = toPlain opt x "\n" str = toPlain opt x "\n"
class ToString a where class ToString a where
toLisp :: Options -> a -> Builder toLisp :: Options -> a -> Builder
toPlain :: Options -> a -> Builder toPlain :: Options -> a -> Builder
lineSep :: Options -> String lineSep :: Options -> String
lineSep opt = interpret lsep lineSep opt = interpret lsep
@ -51,8 +51,8 @@ lineSep opt = interpret lsep
-- >>> toPlain defaultOptions "foo" "" -- >>> toPlain defaultOptions "foo" ""
-- "foo" -- "foo"
instance ToString String where instance ToString String where
toLisp opt = quote opt toLisp opt = quote opt
toPlain opt = replace '\n' (lineSep opt) toPlain opt = replace '\n' (lineSep opt)
-- | -- |
-- --
@ -61,8 +61,8 @@ instance ToString String where
-- >>> toPlain defaultOptions ["foo", "bar", "baz"] "" -- >>> toPlain defaultOptions ["foo", "bar", "baz"] ""
-- "foo\nbar\nbaz" -- "foo\nbar\nbaz"
instance ToString [String] where instance ToString [String] where
toLisp opt = toSexp1 opt toLisp opt = toSexp1 opt
toPlain opt = inter '\n' . map (toPlain opt) toPlain opt = inter '\n' . map (toPlain opt)
-- | -- |
-- --
@ -72,23 +72,23 @@ instance ToString [String] where
-- >>> toPlain defaultOptions inp "" -- >>> toPlain defaultOptions inp ""
-- "1 2 3 4 \"foo\"\n5 6 7 8 \"bar\"" -- "1 2 3 4 \"foo\"\n5 6 7 8 \"bar\""
instance ToString [((Int,Int,Int,Int),String)] where instance ToString [((Int,Int,Int,Int),String)] where
toLisp opt = toSexp2 . map toS toLisp opt = toSexp2 . map toS
where where
toS x = ('(' :) . tupToString opt x . (')' :) toS x = ('(' :) . tupToString opt x . (')' :)
toPlain opt = inter '\n' . map (tupToString opt) toPlain opt = inter '\n' . map (tupToString opt)
instance ToString ((Int,Int,Int,Int),String) where instance ToString ((Int,Int,Int,Int),String) where
toLisp opt x = ('(' :) . tupToString opt x . (')' :) toLisp opt x = ('(' :) . tupToString opt x . (')' :)
toPlain opt x = tupToString opt x toPlain opt x = tupToString opt x
instance ToString ((Int,Int,Int,Int),[String]) where instance ToString ((Int,Int,Int,Int),[String]) where
toLisp opt (x,s) = ('(' :) . fourIntsToString opt x . toLisp opt (x,s) = ('(' :) . fourIntsToString opt x .
(' ' :) . toLisp opt s . (')' :) (' ' :) . toLisp opt s . (')' :)
toPlain opt (x,s) = fourIntsToString opt x . ('\n' :) . toPlain opt s toPlain opt (x,s) = fourIntsToString opt x . ('\n' :) . toPlain opt s
instance ToString (String, (Int,Int,Int,Int),[String]) where instance ToString (String, (Int,Int,Int,Int),[String]) where
toLisp opt (s,x,y) = toSexp2 [toLisp opt s, ('(' :) . fourIntsToString opt x . (')' :), toLisp 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] toPlain opt (s,x,y) = inter '\n' [toPlain opt s, fourIntsToString opt x, toPlain opt y]
toSexp1 :: Options -> [String] -> Builder toSexp1 :: Options -> [String] -> Builder
toSexp1 opt ss = ('(' :) . inter ' ' (map (quote opt) ss) . (')' :) toSexp1 opt ss = ('(' :) . inter ' ' (map (quote opt) ss) . (')' :)

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

@ -79,17 +79,14 @@ sig file lineNo colNo =
Signature loc names ty -> Signature loc names ty ->
("function", fourInts loc, map (initialBody dflag style ty) names) ("function", fourInts loc, map (initialBody dflag style ty) names)
InstanceDecl loc cls -> let InstanceDecl loc cls ->
body x = initialBody dflag style (G.idType x) x let body x = initialBody dflag style (G.idType x) x
in in ("instance", fourInts loc, body `map` Ty.classMethods cls)
("instance", fourInts loc, body `map` Ty.classMethods cls)
TyFamDecl loc name flavour vars -> TyFamDecl loc name flavour vars ->
let (rTy, initial) = initialTyFamString flavour let (rTy, initial) = initialTyFamString flavour
body = initialFamBody dflag style name vars body = initialFamBody dflag style name vars
in (rTy, fourInts loc, [initial ++ body]) in (rTy, fourInts loc, [initial ++ body])
where where
fallback (SomeException _) = do fallback (SomeException _) = do
opt <- options opt <- options
@ -244,9 +241,11 @@ initialHead1 :: String -> [FnArg] -> [String] -> String
initialHead1 fname args elts = initialHead1 fname args elts =
case initialBodyArgs1 args elts of case initialBodyArgs1 args elts of
[] -> fname [] -> fname
arglist -> if isSymbolName fname arglist
then head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist) | isSymbolName fname ->
else fname ++ " " ++ unwords arglist head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist)
| otherwise ->
fname ++ " " ++ unwords arglist
initialBodyArgs1 :: [FnArg] -> [String] -> [String] initialBodyArgs1 :: [FnArg] -> [String] -> [String]
initialBodyArgs1 args elts = take (length args) elts initialBodyArgs1 args elts = take (length args) elts
@ -338,39 +337,45 @@ refine :: IOish m
-> Expression -- ^ A Haskell expression. -> Expression -- ^ A Haskell expression.
-> GhcModT m String -> GhcModT m String
refine file lineNo colNo expr = refine file lineNo colNo expr =
ghandle handler $ runGmlT' [Left file] deferErrors $ do ghandle handler $
opt <- options runGmlT' [Left file] deferErrors $ do
style <- getStyle opt <- options
dflag <- G.getSessionDynFlags style <- getStyle
modSum <- Gap.fileModSummary file dflag <- G.getSessionDynFlags
p <- G.parseModule modSum modSum <- Gap.fileModSummary file
tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p p <- G.parseModule modSum
ety <- G.exprType expr tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p
whenFound opt (findVar dflag style tcm tcs lineNo colNo) $ ety <- G.exprType expr
\(loc, name, rty, paren) -> whenFound opt (findVar dflag style tcm tcs lineNo colNo) $
let eArgs = getFnArgs ety \(loc, name, rty, paren) ->
rArgs = getFnArgs rty let eArgs = getFnArgs ety
diffArgs' = length eArgs - length rArgs rArgs = getFnArgs rty
diffArgs = if diffArgs' < 0 then 0 else diffArgs' diffArgs' = length eArgs - length rArgs
iArgs = take diffArgs eArgs diffArgs = if diffArgs' < 0 then 0 else diffArgs'
text = initialHead1 expr iArgs (infinitePrefixSupply name) iArgs = take diffArgs eArgs
in (fourInts loc, doParen paren text) text = initialHead1 expr iArgs (infinitePrefixSupply name)
in (fourInts loc, doParen paren text)
where where
handler (SomeException _) = emptyResult =<< options handler (SomeException _) = emptyResult =<< options
-- Look for the variable in the specified position -- Look for the variable in the specified position
findVar :: GhcMonad m => DynFlags -> PprStyle findVar
-> G.TypecheckedModule -> G.TypecheckedSource :: GhcMonad m
-> Int -> Int -> m (Maybe (SrcSpan, String, Type, Bool)) => DynFlags
-> PprStyle
-> G.TypecheckedModule
-> G.TypecheckedSource
-> Int
-> Int
-> m (Maybe (SrcSpan, String, Type, Bool))
findVar dflag style tcm tcs lineNo colNo = findVar dflag style tcm tcs lineNo colNo =
case lst of case lst of
e@(L _ (G.HsVar i)):others -> do e@(L _ (G.HsVar i)):others -> do
tyInfo <- Gap.getType tcm e tyInfo <- Gap.getType tcm e
case tyInfo of case tyInfo of
Just (span, typ) Just (s, typ)
| name == "undefined" || head name == '_' -> | name == "undefined" || head name == '_' ->
return $ Just (span, name, typ, b) return $ Just (s, name, typ, b)
where where
name = getFnName dflag style i name = getFnName dflag style i
-- If inside an App, we need parenthesis -- If inside an App, we need parenthesis

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

@ -2,8 +2,7 @@
module Language.Haskell.GhcMod.Find module Language.Haskell.GhcMod.Find
#ifndef SPEC #ifndef SPEC
( ( Symbol
Symbol
, SymbolDb , SymbolDb
, loadSymbolDb , loadSymbolDb
, lookupSymbol , lookupSymbol
@ -33,17 +32,8 @@ import System.Directory (doesFileExist, getModificationTime)
import System.FilePath ((</>)) import System.FilePath ((</>))
import System.IO 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 Data.Map (Map)
import qualified Data.Map as M 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'. -- | Loading a file and creates 'SymbolDb'.
loadSymbolDb :: IOish m => GhcModT m SymbolDb loadSymbolDb :: IOish m => GhcModT m SymbolDb
loadSymbolDb = do loadSymbolDb = do
ghcMod <- liftIO ghcModExecutable ghcMod <- liftIO ghcModExecutable
tmpdir <- cradleTempDir <$> cradle tmpdir <- cradleTempDir <$> cradle
file <- liftIO $ chop <$> readProcess ghcMod ["dumpsym", tmpdir] "" file <- liftIO $ chop <$> readProcess ghcMod ["dumpsym", tmpdir] ""
!db <- M.fromAscList . map conv . lines <$> liftIO (readFile file) !db <- M.fromAscList . map conv . lines <$> liftIO (readFile file)
return $ SymbolDb return $ SymbolDb
{ table = db { table = db
, symbolDbCachePath = file , symbolDbCachePath = file
} }
where where
conv :: String -> (Symbol,[ModuleString]) conv :: String -> (Symbol, [ModuleString])
conv = read conv = read
chop :: String -> String chop :: String -> String
chop "" = "" chop "" = ""
@ -113,11 +103,11 @@ dumpSymbol dir = do
cache = dir </> symbolCacheFile cache = dir </> symbolCacheFile
writeSymbolCache :: FilePath writeSymbolCache :: FilePath
-> [(Symbol,[ModuleString])] -> [(Symbol, [ModuleString])]
-> IO () -> IO ()
writeSymbolCache cache sm = writeSymbolCache cache sm =
void . withFile cache WriteMode $ \hdl -> 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. -- | Check whether given file is older than any file from the given set.
-- Returns True if given file does not exist. -- 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 return $ any (tCache <=) $ map tfTime files -- including equal just in case
-- | Browsing all functions in all system modules. -- | Browsing all functions in all system modules.
getGlobalSymbolTable :: LightGhc [(Symbol,[ModuleString])] getGlobalSymbolTable :: LightGhc [(Symbol, [ModuleString])]
getGlobalSymbolTable = do getGlobalSymbolTable = do
df <- G.getSessionDynFlags df <- G.getSessionDynFlags
let mods = listVisibleModules df let mods = listVisibleModules df
moduleInfos <- mapM G.getModuleInfo mods moduleInfos <- mapM G.getModuleInfo mods
return $ collectModules return $ collectModules
$ extractBindings `concatMap` (moduleInfos `zip` mods) $ extractBindings `concatMap` (moduleInfos `zip` mods)
extractBindings :: (Maybe G.ModuleInfo, G.Module) extractBindings :: (Maybe G.ModuleInfo, G.Module)
-> [(Symbol, ModuleString)] -> [(Symbol, ModuleString)]
extractBindings (Nothing,_) = [] extractBindings (Nothing, _) = []
extractBindings (Just inf,mdl) = extractBindings (Just inf, mdl) =
map (\name -> (getOccString name, moduleNameString $ moduleName mdl)) names map (\name -> (getOccString name, moduleNameString $ moduleName mdl)) names
where where
names = G.modInfoExports inf names = G.modInfoExports inf
collectModules :: [(Symbol,ModuleString)] collectModules :: [(Symbol, ModuleString)]
-> [(Symbol,[ModuleString])] -> [(Symbol, [ModuleString])]
collectModules = map tieup . groupBy ((==) `on` fst) . sort collectModules = map tieup . groupBy ((==) `on` fst) . sort
where where
tieup x = (head (map fst x), map snd x) tieup x = (head (map fst x), map snd x)

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

@ -30,20 +30,21 @@ info :: IOish m
-> Expression -- ^ A Haskell expression. -> Expression -- ^ A Haskell expression.
-> GhcModT m String -> GhcModT m String
info file expr = info file expr =
ghandle handler $ runGmlT' [Left file] deferErrors $ withContext $ ghandle handler $
convert <$> options <*> body runGmlT' [Left file] deferErrors $
withContext $
convert <$> options <*> body
where where
handler (SomeException ex) = do handler (SomeException ex) = do
gmLog GmException "info" $ gmLog GmException "info" $ text "" $$ nest 4 (showDoc ex)
text "" $$ nest 4 (showDoc ex) convert' "Cannot show info"
convert' "Cannot show info"
body :: GhcMonad m => m String
body = do body = do
sdoc <- Gap.infoThing expr sdoc <- Gap.infoThing expr
st <- getStyle st <- getStyle
dflag <- G.getSessionDynFlags dflag <- G.getSessionDynFlags
return $ showPage dflag st sdoc return $ showPage dflag st sdoc
---------------------------------------------------------------- ----------------------------------------------------------------
@ -54,14 +55,14 @@ types :: IOish m
-> Int -- ^ Column number. -> Int -- ^ Column number.
-> GhcModT m String -> GhcModT m String
types file lineNo colNo = types file lineNo colNo =
ghandle handler $ runGmlT' [Left file] deferErrors $ withContext $ do ghandle handler $
crdl <- cradle runGmlT' [Left file] deferErrors $
modSum <- Gap.fileModSummary (cradleCurrentDir crdl </> file) withContext $ do
crdl <- cradle
modSum <- Gap.fileModSummary (cradleCurrentDir crdl </> file)
srcSpanTypes <- getSrcSpanType modSum lineNo colNo srcSpanTypes <- getSrcSpanType modSum lineNo colNo
dflag <- G.getSessionDynFlags
dflag <- G.getSessionDynFlags st <- getStyle
st <- getStyle
convert' $ map (toTup dflag st) $ sortBy (cmp `on` fst) srcSpanTypes convert' $ map (toTup dflag st) $ sortBy (cmp `on` fst) srcSpanTypes
where where
handler (SomeException ex) = do handler (SomeException ex) = do
@ -70,12 +71,12 @@ types file lineNo colNo =
getSrcSpanType :: GhcMonad m => G.ModSummary -> Int -> Int -> m [(SrcSpan, Type)] getSrcSpanType :: GhcMonad m => G.ModSummary -> Int -> Int -> m [(SrcSpan, Type)]
getSrcSpanType modSum lineNo colNo = do getSrcSpanType modSum lineNo colNo = do
p <- G.parseModule modSum p <- G.parseModule modSum
tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p
let bs = listifySpans tcs (lineNo, colNo) :: [LHsBind Id] let bs = listifySpans tcs (lineNo, colNo) :: [LHsBind Id]
es = listifySpans tcs (lineNo, colNo) :: [LHsExpr Id] es = listifySpans tcs (lineNo, colNo) :: [LHsExpr Id]
ps = listifySpans tcs (lineNo, colNo) :: [LPat Id] ps = listifySpans tcs (lineNo, colNo) :: [LPat Id]
bts <- mapM (getType tcm) bs bts <- mapM (getType tcm) bs
ets <- mapM (getType tcm) es ets <- mapM (getType tcm) es
pts <- mapM (getType tcm) ps pts <- mapM (getType tcm) ps
return $ catMaybes $ concat [ets, bts, pts] return $ catMaybes $ concat [ets, bts, pts]

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

@ -50,7 +50,7 @@ type MonadIOC m = (MTL.MonadIO m)
#endif #endif
class MonadIOC m => MonadIO m where class MonadIOC m => MonadIO m where
liftIO :: IO a -> m a liftIO :: IO a -> m a
-- | Output style. -- | Output style.
data OutputStyle = LispStyle -- ^ S expression style. data OutputStyle = LispStyle -- ^ S expression style.
@ -83,21 +83,20 @@ data Options = Options {
, hlintOpts :: [String] , hlintOpts :: [String]
} deriving (Show) } deriving (Show)
-- | A default 'Options'. -- | A default 'Options'.
defaultOptions :: Options defaultOptions :: Options
defaultOptions = Options { defaultOptions = Options {
outputStyle = PlainStyle outputStyle = PlainStyle
, lineSeparator = LineSeparator "\0" , lineSeparator = LineSeparator "\0"
, logLevel = GmWarning , logLevel = GmWarning
, ghcProgram = "ghc" , ghcProgram = "ghc"
, ghcPkgProgram = "ghc-pkg" , ghcPkgProgram = "ghc-pkg"
, cabalProgram = "cabal" , cabalProgram = "cabal"
, ghcUserOptions= [] , ghcUserOptions = []
, operators = False , operators = False
, detailed = False , detailed = False
, qualified = False , qualified = False
, hlintOpts = [] , hlintOpts = []
} }
---------------------------------------------------------------- ----------------------------------------------------------------
@ -113,7 +112,7 @@ data Cradle = Cradle {
-- | The file name of the found cabal file. -- | The file name of the found cabal file.
, cradleCabalFile :: Maybe FilePath , cradleCabalFile :: Maybe FilePath
-- | Package database stack -- | Package database stack
, cradlePkgDbStack :: [GhcPkgDb] , cradlePkgDbStack :: [GhcPkgDb]
} deriving (Eq, Show) } deriving (Eq, Show)
---------------------------------------------------------------- ----------------------------------------------------------------
@ -122,7 +121,7 @@ data Cradle = Cradle {
data GhcPkgDb = GlobalDb | UserDb | PackageDb String deriving (Eq, Show) data GhcPkgDb = GlobalDb | UserDb | PackageDb String deriving (Eq, Show)
-- | A single GHC command line option. -- | A single GHC command line option.
type GHCOption = String type GHCOption = String
-- | An include directory for modules. -- | An include directory for modules.
type IncludeDir = FilePath type IncludeDir = FilePath
@ -131,28 +130,28 @@ type IncludeDir = FilePath
type PackageBaseName = String type PackageBaseName = String
-- | A package version. -- | A package version.
type PackageVersion = String type PackageVersion = String
-- | A package id. -- | A package id.
type PackageId = String type PackageId = String
-- | A package's name, verson and id. -- | A package's name, verson and id.
type Package = (PackageBaseName, PackageVersion, PackageId) type Package = (PackageBaseName, PackageVersion, PackageId)
pkgName :: Package -> PackageBaseName pkgName :: Package -> PackageBaseName
pkgName (n,_,_) = n pkgName (n, _, _) = n
pkgVer :: Package -> PackageVersion pkgVer :: Package -> PackageVersion
pkgVer (_,v,_) = v pkgVer (_, v, _) = v
pkgId :: Package -> PackageId pkgId :: Package -> PackageId
pkgId (_,_,i) = i pkgId (_, _, i) = i
showPkg :: Package -> String showPkg :: Package -> String
showPkg (n,v,_) = intercalate "-" [n,v] showPkg (n, v, _) = intercalate "-" [n, v]
showPkgId :: Package -> String showPkgId :: Package -> String
showPkgId (n,v,i) = intercalate "-" [n,v,i] showPkgId (n, v, i) = intercalate "-" [n, v, i]
-- | Haskell expression. -- | Haskell expression.
type Expression = String type Expression = String
@ -163,131 +162,133 @@ type ModuleString = String
-- | A Module -- | A Module
type Module = [String] type Module = [String]
data GmLogLevel = GmSilent data GmLogLevel =
| GmPanic GmSilent
| GmException | GmPanic
| GmError | GmException
| GmWarning | GmError
| GmInfo | GmWarning
| GmDebug | GmInfo
deriving (Eq, Ord, Enum, Bounded, Show, Read) | GmDebug
deriving (Eq, Ord, Enum, Bounded, Show, Read)
-- | Collection of packages -- | Collection of packages
type PkgDb = (Map Package PackageConfig) type PkgDb = (Map Package PackageConfig)
data GmModuleGraph = GmModuleGraph { data GmModuleGraph = GmModuleGraph {
gmgGraph :: Map ModulePath (Set ModulePath) gmgGraph :: Map ModulePath (Set ModulePath)
} deriving (Eq, Ord, Show, Read, Generic, Typeable) } deriving (Eq, Ord, Show, Read, Generic, Typeable)
instance Serialize GmModuleGraph where instance Serialize GmModuleGraph where
put GmModuleGraph {..} = let put GmModuleGraph {..} = put (mpim, graph)
mpim :: Map ModulePath Integer where
graph :: Map Integer (Set Integer) 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 $ get = do
(Map.keys gmgGraph) `zip` [0..] (mpim :: Map ModulePath Integer, graph :: Map Integer (Set Integer)) <- get
mpToInt :: ModulePath -> Integer let impm = swapMap mpim
mpToInt mp = fromJust $ Map.lookup mp mpim intToMp i = fromJust $ Map.lookup i impm
mpGraph :: Map ModulePath (Set ModulePath)
graph = Map.map (Set.map mpToInt) $ Map.mapKeys mpToInt gmgGraph mpGraph = Map.map (Set.map intToMp) $ Map.mapKeys intToMp graph
in put (mpim, graph) return $ GmModuleGraph mpGraph
where
get = do swapMap :: (Ord k, Ord v) => Map k v -> Map v k
(mpim :: Map ModulePath Integer, graph :: Map Integer (Set Integer)) <- get swapMap = Map.fromList . map (\(x, y) -> (y, x)) . Map.toList
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
instance Monoid GmModuleGraph where instance Monoid GmModuleGraph where
mempty = GmModuleGraph mempty mempty = GmModuleGraph mempty
mappend (GmModuleGraph a) (GmModuleGraph a') = mappend (GmModuleGraph a) (GmModuleGraph a') =
GmModuleGraph (Map.unionWith Set.union a a') GmModuleGraph (Map.unionWith Set.union a a')
data GmComponentType = GMCRaw data GmComponentType = GMCRaw
| GMCResolved | GMCResolved
data GmComponent (t :: GmComponentType) eps = GmComponent { data GmComponent (t :: GmComponentType) eps = GmComponent {
gmcHomeModuleGraph :: GmModuleGraph, gmcHomeModuleGraph :: GmModuleGraph
gmcName :: ChComponentName, , gmcName :: ChComponentName
gmcGhcOpts :: [GHCOption], , gmcGhcOpts :: [GHCOption]
gmcGhcPkgOpts :: [GHCOption], , gmcGhcPkgOpts :: [GHCOption]
gmcGhcSrcOpts :: [GHCOption], , gmcGhcSrcOpts :: [GHCOption]
gmcGhcLangOpts :: [GHCOption], , gmcGhcLangOpts :: [GHCOption]
gmcRawEntrypoints :: ChEntrypoint, , gmcRawEntrypoints :: ChEntrypoint
gmcEntrypoints :: eps, , gmcEntrypoints :: eps
gmcSourceDirs :: [FilePath] , gmcSourceDirs :: [FilePath]
} deriving (Eq, Ord, Show, Read, Generic, Functor) } deriving (Eq, Ord, Show, Read, Generic, Functor)
instance Serialize eps => Serialize (GmComponent t eps) instance Serialize eps => Serialize (GmComponent t eps)
data ModulePath = ModulePath { mpModule :: ModuleName, mpPath :: FilePath } 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 ModulePath
instance Serialize ModuleName where instance Serialize ModuleName where
get = mkModuleName <$> get get = mkModuleName <$> get
put mn = put (moduleNameString mn) put mn = put (moduleNameString mn)
instance Show ModuleName where instance Show ModuleName where
show mn = "ModuleName " ++ show (moduleNameString mn) show mn = "ModuleName " ++ show (moduleNameString mn)
instance Read ModuleName where instance Read ModuleName where
readsPrec d r = readParen (d > app_prec) readsPrec d =
(\r' -> [(mkModuleName m,t) | readParen
("ModuleName",s) <- lex r', (d > app_prec)
(m,t) <- readsPrec (app_prec+1) s]) r (\r' -> [ (mkModuleName m, t)
where app_prec = 10 | ("ModuleName", s) <- lex r'
, (m, t) <- readsPrec (app_prec + 1) s
])
where
app_prec = 10
data GhcModError data GhcModError
= GMENoMsg = GMENoMsg
-- ^ Unknown error -- ^ Unknown error
| GMEString String | GMEString String
-- ^ Some Error with a message. These are produced mostly by -- ^ Some Error with a message. These are produced mostly by
-- 'fail' calls on GhcModT. -- 'fail' calls on GhcModT.
| GMECabalConfigure GhcModError | GMECabalConfigure GhcModError
-- ^ Configuring a cabal project failed. -- ^ Configuring a cabal project failed.
| GMECabalFlags GhcModError | GMECabalFlags GhcModError
-- ^ Retrieval of the cabal configuration flags failed. -- ^ Retrieval of the cabal configuration flags failed.
| GMECabalComponent ChComponentName | GMECabalComponent ChComponentName
-- ^ Cabal component could not be found -- ^ Cabal component could not be found
| GMECabalCompAssignment [(Either FilePath ModuleName, Set ChComponentName)] | GMECabalCompAssignment [(Either FilePath ModuleName, Set ChComponentName)]
-- ^ Could not find a consistent component assignment for modules -- ^ Could not find a consistent component assignment for modules
| GMEProcess String [String] (Either (String, String, Int) GhcModError) | GMEProcess String [String] (Either (String, String, Int) GhcModError)
-- ^ Launching an operating system process failed. Fields in -- ^ Launching an operating system process failed. Fields in
-- order: command, arguments, (stdout, stderr, exitcode) -- order: command, arguments, (stdout, stderr, exitcode)
| GMENoCabalFile | GMENoCabalFile
-- ^ No cabal file found. -- ^ No cabal file found.
| GMETooManyCabalFiles [FilePath] | GMETooManyCabalFiles [FilePath]
-- ^ Too many cabal files found. -- ^ Too many cabal files found.
| GMECabalStateFile GMConfigStateFileError | GMECabalStateFile GMConfigStateFileError
-- ^ Reading Cabal's state configuration file falied somehow. -- ^ Reading Cabal's state configuration file falied somehow.
deriving (Eq,Show,Typeable) deriving (Eq,Show,Typeable)
instance Error GhcModError where instance Error GhcModError where
noMsg = GMENoMsg noMsg = GMENoMsg
strMsg = GMEString strMsg = GMEString
instance Exception GhcModError instance Exception GhcModError
data GMConfigStateFileError data GMConfigStateFileError
= GMConfigStateFileNoHeader = GMConfigStateFileNoHeader
| GMConfigStateFileBadHeader | GMConfigStateFileBadHeader
| GMConfigStateFileNoParse | GMConfigStateFileNoParse
| GMConfigStateFileMissing | GMConfigStateFileMissing
-- | GMConfigStateFileBadVersion PackageIdentifier PackageIdentifier (Either ConfigStateFileError LocalBuildInfo) -- | GMConfigStateFileBadVersion PackageIdentifier PackageIdentifier (Either ConfigStateFileError LocalBuildInfo)
deriving (Eq, Show, Read, Typeable) deriving (Eq, Show, Read, Typeable)

79
Language/Haskell/GhcMod/Utils.hs
View File

@ -15,26 +15,26 @@
-- along with this program. If not, see <http://www.gnu.org/licenses/>. -- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE DoAndIfThenElse #-}
module Language.Haskell.GhcMod.Utils ( module Language.Haskell.GhcMod.Utils (
module Language.Haskell.GhcMod.Utils module Language.Haskell.GhcMod.Utils
, module Utils , module Utils
, readProcess , readProcess
) where ) where
import Control.Arrow
import Control.Applicative import Control.Applicative
import Data.Char import Data.Char
import Exception
import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.Error
import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Monad.Types
import Exception
import System.Directory (getCurrentDirectory, setCurrentDirectory, doesFileExist, import System.Directory (getCurrentDirectory, setCurrentDirectory, doesFileExist,
getTemporaryDirectory, canonicalizePath, doesFileExist) getTemporaryDirectory, canonicalizePath)
import System.Process (readProcess) import System.Environment
import System.Directory ()
import System.FilePath (splitDrive, takeDirectory, takeFileName, pathSeparators, import System.FilePath (splitDrive, takeDirectory, takeFileName, pathSeparators,
(</>)) (</>))
import System.IO.Temp (createTempDirectory) import System.IO.Temp (createTempDirectory)
import System.Environment import System.Process (readProcess)
import Text.Printf import Text.Printf
import Paths_ghc_mod (getLibexecDir) 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_ :: (MonadIO m, ExceptionMonad m) => FilePath -> m a -> m a
withDirectory_ dir action = withDirectory_ dir action =
gbracket (liftIO getCurrentDirectory) (liftIO . setCurrentDirectory) gbracket
(\_ -> liftIO (setCurrentDirectory dir) >> action) (liftIO getCurrentDirectory)
(liftIO . setCurrentDirectory)
(\_ -> liftIO (setCurrentDirectory dir) >> action)
uniqTempDirName :: FilePath -> FilePath uniqTempDirName :: FilePath -> FilePath
uniqTempDirName dir = ("ghc-mod"++) $ uncurry (++) uniqTempDirName dir =
$ map escapeDriveChar *** map escapePathChar "ghc-mod" ++ map escapeDriveChar drive ++ map escapePathChar path
$ splitDrive dir where
where (drive, path) = splitDrive dir
escapeDriveChar :: Char -> Char
escapeDriveChar c escapeDriveChar c
| isAlphaNum c = c | isAlphaNum c = c
| otherwise = '-' | otherwise = '-'
escapePathChar :: Char -> Char
escapePathChar c escapePathChar c
| c `elem` pathSeparators = '-' | c `elem` pathSeparators = '-'
| otherwise = c | otherwise = c
newTempDir :: FilePath -> IO FilePath newTempDir :: FilePath -> IO FilePath
newTempDir dir = newTempDir dir =
flip createTempDirectory (uniqTempDirName dir) =<< getTemporaryDirectory flip createTempDirectory (uniqTempDirName dir) =<< getTemporaryDirectory
whenM :: IO Bool -> IO () -> IO () whenM :: IO Bool -> IO () -> IO ()
whenM mb ma = mb >>= flip when ma 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 :: String -> IO FilePath
findLibexecExe "cabal-helper-wrapper" = do findLibexecExe "cabal-helper-wrapper" = do
libexecdir <- getLibexecDir libexecdir <- getLibexecDir
let exeName = "cabal-helper-wrapper" let exeName = "cabal-helper-wrapper"
exe = libexecdir </> exeName exe = libexecdir </> exeName
exists <- doesFileExist exe exists <- doesFileExist exe
if exists if exists
then return exe then return exe
else do else do
mdir <- tryFindGhcModTreeDataDir mdir <- tryFindGhcModTreeDataDir
case mdir of case mdir of
Nothing -> Nothing ->
error $ libexecNotExitsError exeName libexecdir error $ libexecNotExitsError exeName libexecdir
Just dir -> Just dir ->
return $ dir </> "dist" </> "build" </> exeName </> exeName return $ dir </> "dist" </> "build" </> exeName </> exeName
findLibexecExe exe = error $ "findLibexecExe: Unknown executable: " ++ exe findLibexecExe exe = error $ "findLibexecExe: Unknown executable: " ++ exe
libexecNotExitsError :: String -> FilePath -> String libexecNotExitsError :: String -> FilePath -> String
@ -119,22 +122,20 @@ tryFindGhcModTreeLibexecDir :: IO (Maybe FilePath)
tryFindGhcModTreeLibexecDir = do tryFindGhcModTreeLibexecDir = do
exe <- getExecutablePath' exe <- getExecutablePath'
dir <- case takeFileName exe of dir <- case takeFileName exe of
"ghc" -> do -- we're probably in ghci; try CWD "ghc" -> getCurrentDirectory -- we're probably in ghci; try CWD
getCurrentDirectory _ -> return $ (!!4) $ iterate takeDirectory exe
_ ->
return $ (!!4) $ iterate takeDirectory exe
exists <- doesFileExist $ dir </> "ghc-mod.cabal" exists <- doesFileExist $ dir </> "ghc-mod.cabal"
return $ if exists return $ if exists
then Just dir then Just dir
else Nothing else Nothing
tryFindGhcModTreeDataDir :: IO (Maybe FilePath) tryFindGhcModTreeDataDir :: IO (Maybe FilePath)
tryFindGhcModTreeDataDir = do tryFindGhcModTreeDataDir = do
dir <- (!!4) . iterate takeDirectory <$> getExecutablePath' dir <- (!!4) . iterate takeDirectory <$> getExecutablePath'
exists <- doesFileExist $ dir </> "ghc-mod.cabal" exists <- doesFileExist $ dir </> "ghc-mod.cabal"
return $ if exists return $ if exists
then Just dir then Just dir
else Nothing else Nothing
readLibExecProcess' :: (MonadIO m, ExceptionMonad m) readLibExecProcess' :: (MonadIO m, ExceptionMonad m)
=> String -> [String] -> m String => String -> [String] -> m String