diff --git a/Language/Haskell/GhcMod/Boot.hs b/Language/Haskell/GhcMod/Boot.hs index 7e261d5..70c77b6 100644 --- a/Language/Haskell/GhcMod/Boot.hs +++ b/Language/Haskell/GhcMod/Boot.hs @@ -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 = [ diff --git a/Language/Haskell/GhcMod/Browse.hs b/Language/Haskell/GhcMod/Browse.hs index bc45f82..f691464 100644 --- a/Language/Haskell/GhcMod/Browse.hs +++ b/Language/Haskell/GhcMod/Browse.hs @@ -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 | _ diff --git a/Language/Haskell/GhcMod/Convert.hs b/Language/Haskell/GhcMod/Convert.hs index 248adde..39bb426 100644 --- a/Language/Haskell/GhcMod/Convert.hs +++ b/Language/Haskell/GhcMod/Convert.hs @@ -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) . (')' :) diff --git a/Language/Haskell/GhcMod/FillSig.hs b/Language/Haskell/GhcMod/FillSig.hs index f84675e..ecfc93d 100644 --- a/Language/Haskell/GhcMod/FillSig.hs +++ b/Language/Haskell/GhcMod/FillSig.hs @@ -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 diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs index 039e83b..d361f20 100644 --- a/Language/Haskell/GhcMod/Find.hs +++ b/Language/Haskell/GhcMod/Find.hs @@ -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) diff --git a/Language/Haskell/GhcMod/Info.hs b/Language/Haskell/GhcMod/Info.hs index d109f02..6344a5d 100644 --- a/Language/Haskell/GhcMod/Info.hs +++ b/Language/Haskell/GhcMod/Info.hs @@ -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] diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index b1be7f0..e5e0909 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -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) diff --git a/Language/Haskell/GhcMod/Utils.hs b/Language/Haskell/GhcMod/Utils.hs index d562290..a9a092b 100644 --- a/Language/Haskell/GhcMod/Utils.hs +++ b/Language/Haskell/GhcMod/Utils.hs @@ -15,26 +15,26 @@ -- 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.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