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

Improve style

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.
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 = [

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

@ -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 | _

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

@ -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])
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,7 +337,8 @@ refine :: IOish m
-> Expression -- ^ A Haskell expression.
-> GhcModT m String
refine file lineNo colNo expr =
ghandle handler $ runGmlT' [Left file] deferErrors $ do
ghandle handler $
runGmlT' [Left file] deferErrors $ do
opt <- options
style <- getStyle
dflag <- G.getSessionDynFlags
@ -355,22 +355,27 @@ refine file lineNo colNo expr =
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

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

@ -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
----------------------------------------------------------------
@ -88,7 +78,7 @@ loadSymbolDb = do
, symbolDbCachePath = file
}
where
conv :: String -> (Symbol,[ModuleString])
conv :: String -> (Symbol, [ModuleString])
conv = read
chop :: String -> String
chop "" = ""
@ -113,7 +103,7 @@ dumpSymbol dir = do
cache = dir </> symbolCacheFile
writeSymbolCache :: FilePath
-> [(Symbol,[ModuleString])]
-> [(Symbol, [ModuleString])]
-> IO ()
writeSymbolCache cache sm =
void . withFile cache WriteMode $ \hdl ->
@ -131,7 +121,7 @@ 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
@ -141,14 +131,14 @@ getGlobalSymbolTable = do
extractBindings :: (Maybe G.ModuleInfo, G.Module)
-> [(Symbol, ModuleString)]
extractBindings (Nothing,_) = []
extractBindings (Just inf,mdl) =
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)

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

@ -30,21 +30,22 @@ info :: IOish m
-> Expression -- ^ A Haskell expression.
-> GhcModT m String
info file expr =
ghandle handler $ runGmlT' [Left file] deferErrors $ withContext $
ghandle handler $
runGmlT' [Left file] deferErrors $
withContext $
convert <$> options <*> body
where
handler (SomeException ex) = do
gmLog GmException "info" $
text "" $$ nest 4 (showDoc ex)
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
----------------------------------------------------------------
-- | Obtaining type of a target expression. (GHCi's type:)
@ -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
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
convert' $ map (toTup dflag st) $ sortBy (cmp `on` fst) srcSpanTypes
where
handler (SomeException ex) = do

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

@ -83,7 +83,6 @@ data Options = Options {
, hlintOpts :: [String]
} deriving (Show)
-- | A default 'Options'.
defaultOptions :: Options
defaultOptions = Options {
@ -93,7 +92,7 @@ defaultOptions = Options {
, ghcProgram = "ghc"
, ghcPkgProgram = "ghc-pkg"
, cabalProgram = "cabal"
, ghcUserOptions= []
, ghcUserOptions = []
, operators = False
, detailed = False
, qualified = False
@ -140,19 +139,19 @@ type PackageId = String
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,7 +162,8 @@ type ModuleString = String
-- | A Module
type Module = [String]
data GmLogLevel = GmSilent
data GmLogLevel =
GmSilent
| GmPanic
| GmException
| GmError
@ -180,28 +180,25 @@ data GmModuleGraph = GmModuleGraph {
} deriving (Eq, Ord, Show, Read, Generic, Typeable)
instance Serialize GmModuleGraph where
put GmModuleGraph {..} = let
put GmModuleGraph {..} = put (mpim, graph)
where
mpim :: Map ModulePath Integer
mpim = Map.fromList $ Map.keys gmgGraph `zip` [0..]
graph :: Map Integer (Set Integer)
mpim = Map.fromList $
(Map.keys gmgGraph) `zip` [0..]
graph = Map.map (Set.map mpToInt) $ Map.mapKeys mpToInt gmgGraph
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
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
@ -211,15 +208,15 @@ instance Monoid GmModuleGraph where
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]
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)
@ -236,11 +233,15 @@ instance Show ModuleName where
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

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

@ -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,18 +46,21 @@ 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)
gbracket
(liftIO getCurrentDirectory)
(liftIO . setCurrentDirectory)
(\_ -> liftIO (setCurrentDirectory dir) >> action)
uniqTempDirName :: FilePath -> FilePath
uniqTempDirName dir = ("ghc-mod"++) $ uncurry (++)
$ map escapeDriveChar *** map escapePathChar
$ splitDrive dir
uniqTempDirName dir =
"ghc-mod" ++ map escapeDriveChar drive ++ map escapePathChar path
where
(drive, path) = splitDrive dir
escapeDriveChar :: Char -> Char
escapeDriveChar c
| isAlphaNum c = c
| otherwise = '-'
escapePathChar :: Char -> Char
escapePathChar c
| c `elem` pathSeparators = '-'
| otherwise = c
@ -119,10 +122,8 @@ 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