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

Merge branch 'serras-master'

Browse Source
This commit is contained in:
Kazu Yamamoto 2014-07-03 17:04:00 +09:00
commit 609ca52dee
18 changed files with 761 additions and 104 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
Language/Haskell/GhcMod.hs
View File

@ -20,6 +20,7 @@ module Language.Haskell.GhcMod (
, expandTemplate
, infoExpr
, typeExpr
, fillSig
, listModules
, listLanguages
, listFlags
@ -27,6 +28,7 @@ module Language.Haskell.GhcMod (
, rootInfo
, packageDoc
, findSymbol
, splitVar
) where
import Language.Haskell.GhcMod.Boot
@ -41,4 +43,6 @@ import Language.Haskell.GhcMod.Lang
import Language.Haskell.GhcMod.Lint
import Language.Haskell.GhcMod.List
import Language.Haskell.GhcMod.PkgDoc
import Language.Haskell.GhcMod.FillSig
import Language.Haskell.GhcMod.CaseSplit
import Language.Haskell.GhcMod.Types

6
Language/Haskell/GhcMod/CabalConfig.hs
View File

@ -1,3 +1,5 @@
{-# LANGUAGE CPP #-}
-- | Reading cabal @dist/setup-config@
module Language.Haskell.GhcMod.CabalConfig (
CabalConfig
@ -15,7 +17,11 @@ import qualified Language.Haskell.GhcMod.Cabal18 as C18
import qualified Control.Exception as E
import Control.Applicative ((<$>))
import Control.Monad (mplus)
#if MIN_VERSION_mtl(2,2,1)
import Control.Monad.Except ()
#else
import Control.Monad.Error ()
#endif
import Data.Maybe ()
import Data.Set ()
import Data.List (find,tails,isPrefixOf,isInfixOf,nub,stripPrefix)

225
Language/Haskell/GhcMod/CaseSplit.hs Normal file
View File

@ -0,0 +1,225 @@
{-# LANGUAGE CPP #-}
module Language.Haskell.GhcMod.CaseSplit (
splitVar
, splits
) where
import Data.List (find, intercalate)
import qualified Data.Text as T
import qualified Data.Text.IO as T (readFile)
import Exception (ghandle, SomeException(..))
import GHC (GhcMonad, LHsBind, LHsExpr, LPat, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L))
import qualified GHC as G
import Language.Haskell.GhcMod.GHCApi
import Language.Haskell.GhcMod.Gap (HasType(..))
import qualified Language.Haskell.GhcMod.Gap as Gap
import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.SrcUtils
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Convert
import MonadUtils (liftIO)
import Outputable (PprStyle)
import qualified Type as Ty
import qualified TyCon as Ty
import qualified DataCon as Ty
----------------------------------------------------------------
-- CASE SPLITTING
----------------------------------------------------------------
data SplitInfo = SplitInfo G.Name (SrcSpan,Type) (SrcSpan, Type) [SrcSpan]
data SplitToTextInfo = SplitToTextInfo { sVarName :: String
, sBindingSpan :: SrcSpan
, sVarSpan :: SrcSpan
, sTycons :: [String]
}
-- | Splitting a variable in a equation.
splitVar :: Options
-> Cradle
-> FilePath -- ^ A target file.
-> Int -- ^ Line number.
-> Int -- ^ Column number.
-> IO String
splitVar opt cradle file lineNo colNo = runGhcMod opt $ do
initializeFlagsWithCradle opt cradle
splits file lineNo colNo
-- | Splitting a variable in a equation.
splits :: FilePath -- ^ A target file.
-> Int -- ^ Line number.
-> Int -- ^ Column number.
-> GhcMod String
splits file lineNo colNo = ghandle handler body
where
body = inModuleContext file $ \dflag style -> do
opt <- options
modSum <- Gap.fileModSummary file
whenFound' opt (getSrcSpanTypeForSplit modSum lineNo colNo) $
\(SplitInfo varName (bndLoc,_) (varLoc,varT) _matches) -> do
let varName' = showName dflag style varName -- Convert name to string
text <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $
getTyCons dflag style varName varT)
return (fourInts bndLoc, text)
handler (SomeException _) = emptyResult =<< options
----------------------------------------------------------------
-- a. Code for getting the information of the variable
getSrcSpanTypeForSplit :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SplitInfo)
getSrcSpanTypeForSplit modSum lineNo colNo = do
p@ParsedModule{pm_parsed_source = pms} <- G.parseModule modSum
tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p
let bs:_ = listifySpans tcs (lineNo, colNo) :: [LHsBind Id]
varPat = find isPatternVar $ listifySpans tcs (lineNo, colNo) :: Maybe (LPat Id)
match:_ = listifyParsedSpans pms (lineNo, colNo)
#if __GLASGOW_HASKELL__ < 708
:: [G.LMatch G.RdrName]
#else
:: [G.LMatch G.RdrName (LHsExpr G.RdrName)]
#endif
case varPat of
Nothing -> return Nothing
Just varPat' -> do
varT <- getType tcm varPat' -- Finally we get the type of the var
bsT <- getType tcm bs
case (varT, bsT) of
(Just varT', Just (_,bsT')) ->
let (L matchL (G.Match _ _ (G.GRHSs rhsLs _))) = match
in return $ Just (SplitInfo (getPatternVarName varPat') (matchL,bsT') varT' (map G.getLoc rhsLs) )
_ -> return Nothing
isPatternVar :: LPat Id -> Bool
isPatternVar (L _ (G.VarPat _)) = True
isPatternVar _ = False
getPatternVarName :: LPat Id -> G.Name
getPatternVarName (L _ (G.VarPat vName)) = G.getName vName
getPatternVarName _ = error "This should never happend"
----------------------------------------------------------------
-- b. Code for getting the possible constructors
getTyCons :: DynFlags -> PprStyle -> G.Name -> G.Type -> [String]
getTyCons dflag style name ty | Just (tyCon, _) <- Ty.splitTyConApp_maybe ty =
let name' = showName dflag style name -- Convert name to string
in getTyCon dflag style name' tyCon
getTyCons dflag style name _ = [showName dflag style name]
-- Write cases for one type
getTyCon :: DynFlags -> PprStyle -> String -> Ty.TyCon -> [String]
-- 1. Non-matcheable type constructors
getTyCon _ _ name tyCon | isNotMatcheableTyCon tyCon = [name]
-- 2. Special cases
-- 2.1. Tuples
getTyCon _ _ name tyCon | Ty.isTupleTyCon tyCon =
let [uniqueDataCon] = Ty.tyConDataCons tyCon
tupleArity = Ty.dataConSourceArity uniqueDataCon
-- Deal with both boxed and unboxed tuples
isUnboxed = Ty.isUnboxedTupleTyCon tyCon
startSign = if isUnboxed then "(#" else "("
endSign = if isUnboxed then "#)" else ")"
in [ startSign ++ intercalate "," (map (\n -> name ++ show n) [1 .. tupleArity]) ++ endSign ]
-- 3. General case
getTyCon dflag style name tyCon = map (getDataCon dflag style name) (Ty.tyConDataCons tyCon)
-- These type constructors should not be matched against
isNotMatcheableTyCon :: Ty.TyCon -> Bool
isNotMatcheableTyCon ty = Ty.isPrimTyCon ty -- Primitive types, such as Int#
|| Ty.isFunTyCon ty -- Function types
-- Write case for one constructor
getDataCon :: DynFlags -> PprStyle -> String -> Ty.DataCon -> String
-- 1. Infix constructors
getDataCon dflag style vName dcon | Ty.dataConIsInfix dcon =
let dName = showName dflag style $ Ty.dataConName dcon
in case Ty.dataConSourceArity dcon of
0 -> dName
1 -> vName ++ dName
n -> if dName == ":" -- Special case for lists
then vName ++ ":" ++ vName ++ "s"
else newVar vName 1 ++ " " ++ dName ++ " " ++ newVars vName 2 (n-1)
-- 2. Non-record, non-infix syntax
getDataCon dflag style vName dcon | [] <- Ty.dataConFieldLabels dcon =
let dName = showName dflag style $ Ty.dataConName dcon
in if last dName == '#' -- Special case for I#, C# and so on
then vName
else case Ty.dataConSourceArity dcon of
0 -> dName
_ -> dName ++ " " ++ newVarsSpecialSingleton vName 1 (Ty.dataConSourceArity dcon)
-- 3. Records
getDataCon dflag style vName dcon =
let dName = showName dflag style $ Ty.dataConName dcon
flds = Ty.dataConFieldLabels dcon
in dName ++ " { " ++ showFieldNames dflag style vName flds ++ " }"
-- Create a new variable by adjoining a number
newVar :: String -> Int -> String
newVar v n = v ++ show n
-- Create a list of variables which start with the same prefix
newVars :: String -> Int -> Int -> String
newVars _ _ 0 = ""
newVars v s 1 = newVar v s
newVars v s m = newVar v s ++ " " ++ newVars v (s+1) (m-1)
-- Create a list of variables which start with the same prefix
-- Special case for a single variable, in which case no number is adjoint
newVarsSpecialSingleton :: String -> Int -> Int -> String
newVarsSpecialSingleton v _ 1 = v
newVarsSpecialSingleton v start n = newVars v start n
showFieldNames :: DynFlags -> PprStyle -> String -> [G.Name] -> String
showFieldNames _ _ _ [] = "" -- This should never happen
showFieldNames dflag style v (x:xs) = let fName = showName dflag style x
fAcc = fName ++ " = " ++ v ++ "_" ++ fName
in case xs of
[] -> fAcc
_ -> fAcc ++ ", " ++ showFieldNames dflag style v xs
----------------------------------------------------------------
-- c. Code for performing the case splitting
genCaseSplitTextFile :: GhcMonad m => FilePath -> SplitToTextInfo -> m String
genCaseSplitTextFile file info = liftIO $ do
text <- T.readFile file
return $ getCaseSplitText (T.lines text) info
getCaseSplitText :: [T.Text] -> SplitToTextInfo -> String
getCaseSplitText text (SplitToTextInfo { sVarName = sVN, sBindingSpan = sBS
, sVarSpan = sVS, sTycons = sT }) =
let bindingText = getBindingText text sBS
difference = srcSpanDifference sBS sVS
replaced = concatMap (replaceVarWithTyCon bindingText difference sVN) sT
in T.unpack $ T.intercalate (T.pack "\n") replaced
getBindingText :: [T.Text] -> SrcSpan -> [T.Text]
getBindingText text srcSpan =
let Just (sl,sc,el,ec) = Gap.getSrcSpan srcSpan
lines_ = drop (sl - 1) $ take el text
in if sl == el
then -- only one line
[T.drop (sc - 1) $ T.take ec $ head lines_]
else -- several lines
let (first,rest,last_) = (head lines_, tail $ init lines_, last lines_)
in (T.drop (sc - 1) first) : rest ++ [T.take ec last_]
srcSpanDifference :: SrcSpan -> SrcSpan -> (Int,Int,Int,Int)
srcSpanDifference b v =
let Just (bsl,bsc,_ ,_) = Gap.getSrcSpan b
Just (vsl,vsc,vel,vec) = Gap.getSrcSpan v
in (vsl - bsl, vsc - bsc, vel - bsl, vec - bsc) -- assume variable in one line
replaceVarWithTyCon :: [T.Text] -> (Int,Int,Int,Int) -> String -> String -> [T.Text]
replaceVarWithTyCon text (vsl,vsc,_,vec) varname tycon =
let tycon' = if ' ' `elem` tycon || ':' `elem` tycon then "(" ++ tycon ++ ")" else tycon
lengthDiff = length tycon' - length varname
tycon'' = T.pack $ if lengthDiff < 0 then tycon' ++ replicate (-lengthDiff) ' ' else tycon'
spacesToAdd = if lengthDiff < 0 then 0 else lengthDiff
in zipWith (\n line -> if n < vsl
then line -- before variable starts
else if n == vsl
then T.take vsc line `T.append` tycon'' `T.append` T.drop vec line
else T.replicate spacesToAdd (T.pack " ") `T.append` line)
[0 ..] text

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

@ -1,6 +1,6 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleInstances, FlexibleContexts, OverlappingInstances #-}
module Language.Haskell.GhcMod.Convert (convert, convert') where
module Language.Haskell.GhcMod.Convert (convert, convert', emptyResult, whenFound, whenFound') where
import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.Types
@ -76,12 +76,26 @@ instance ToString [((Int,Int,Int,Int),String)] 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
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]
toSexp1 :: Options -> [String] -> Builder
toSexp1 opt ss = ('(' :) . inter ' ' (map (quote opt) ss) . (')' :)
toSexp2 :: [Builder] -> Builder
toSexp2 ss = ('(' :) . (inter ' ' ss) . (')' :)
fourIntsToString :: Options -> (Int,Int,Int,Int) -> Builder
fourIntsToString _ (a,b,c,d) = (show a ++) . (' ' :)
. (show b ++) . (' ' :)
. (show c ++) . (' ' :)
. (show d ++)
tupToString :: Options -> ((Int,Int,Int,Int),String) -> Builder
tupToString opt ((a,b,c,d),s) = (show a ++) . (' ' :)
. (show b ++) . (' ' :)
@ -101,3 +115,15 @@ quote opt str = ("\"" ++) . (quote' str ++) . ("\"" ++)
| otherwise = x : quote' xs
----------------------------------------------------------------
-- Empty result to be returned when no info can be gathered
emptyResult :: Monad m => Options -> m String
emptyResult opt = return $ convert opt ([] :: [String])
-- Return an emptyResult when Nothing
whenFound :: (Monad m, ToString b) => Options -> m (Maybe a) -> (a -> b) -> m String
whenFound opt from f = maybe (emptyResult opt) (return . convert opt . f) =<< from
-- Return an emptyResult when Nothing, inside a monad
whenFound' :: (Monad m, ToString b) => Options -> m (Maybe a) -> (a -> m b) -> m String
whenFound' opt from f = maybe (emptyResult opt) (\x -> do y <- f x ; return (convert opt y)) =<< from

4
Language/Haskell/GhcMod/Doc.hs
View File

@ -1,6 +1,6 @@
module Language.Haskell.GhcMod.Doc where
import GHC (Ghc, DynFlags)
import GHC (DynFlags, GhcMonad)
import qualified GHC as G
import Language.Haskell.GhcMod.Gap (withStyle, showDocWith)
import Outputable (SDoc, PprStyle, mkUserStyle, Depth(AllTheWay), neverQualify)
@ -12,7 +12,7 @@ showPage dflag style = showDocWith dflag PageMode . withStyle dflag style
showOneLine :: DynFlags -> PprStyle -> SDoc -> String
showOneLine dflag style = showDocWith dflag OneLineMode . withStyle dflag style
getStyle :: Ghc PprStyle
getStyle :: GhcMonad m => m PprStyle
getStyle = do
unqual <- G.getPrintUnqual
return $ mkUserStyle unqual AllTheWay

223
Language/Haskell/GhcMod/FillSig.hs Normal file
View File

@ -0,0 +1,223 @@
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, CPP #-}
module Language.Haskell.GhcMod.FillSig (
fillSig
, sig
) where
import Data.Char (isSymbol)
import Data.List (find, intercalate)
import Exception (ghandle, SomeException(..))
import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L))
import qualified GHC as G
import Language.Haskell.GhcMod.GHCApi
import qualified Language.Haskell.GhcMod.Gap as Gap
import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.SrcUtils
import Language.Haskell.GhcMod.Types
import MonadUtils (liftIO)
import Outputable (PprStyle)
import qualified Type as Ty
import qualified HsBinds as Ty
import qualified Class as Ty
#if __GLASGOW_HASKELL__ >= 706
import OccName (occName)
#else
import OccName (OccName)
import RdrName (rdrNameOcc)
#endif
import qualified Language.Haskell.Exts.Annotated as HE
----------------------------------------------------------------
-- INTIAL CODE FROM FUNCTION OR INSTANCE SIGNATURE
----------------------------------------------------------------
-- Possible signatures we can find: function or instance
data SigInfo = Signature SrcSpan [G.RdrName] (G.HsType G.RdrName)
| InstanceDecl SrcSpan G.Class
-- Signature for fallback operation via haskell-src-exts
data HESigInfo = HESignature HE.SrcSpan [HE.Name HE.SrcSpanInfo] (HE.Type HE.SrcSpanInfo)
-- | Create a initial body from a signature.
fillSig :: Options
-> Cradle
-> FilePath -- ^ A target file.
-> Int -- ^ Line number.
-> Int -- ^ Column number.
-> IO String
fillSig opt cradle file lineNo colNo = runGhcMod opt $ do
initializeFlagsWithCradle opt cradle
sig file lineNo colNo
-- | Create a initial body from a signature.
sig :: FilePath -- ^ A target file.
-> Int -- ^ Line number.
-> Int -- ^ Column number.
-> GhcMod String
sig file lineNo colNo = ghandle handler body
where
body = inModuleContext file $ \dflag style -> do
opt <- options
modSum <- Gap.fileModSummary file
whenFound opt (getSignature modSum lineNo colNo) $ \s -> case s of
Signature loc names ty ->
("function", fourInts loc, map (initialBody dflag style ty) names)
InstanceDecl loc cls -> do
("instance", fourInts loc, map (\x -> initialBody dflag style (G.idType x) x)
(Ty.classMethods cls))
handler (SomeException _) = do
opt <- options
-- Code cannot be parsed by ghc module
-- Fallback: try to get information via haskell-src-exts
whenFound opt (getSignatureFromHE file lineNo colNo) $
\(HESignature loc names ty) ->
("function", fourIntsHE loc, map (initialBody undefined undefined ty) names)
----------------------------------------------------------------
-- a. Code for getting the information
-- Get signature from ghc parsing and typechecking
getSignature :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SigInfo)
getSignature modSum lineNo colNo = do
p@ParsedModule{pm_parsed_source = ps} <- G.parseModule modSum
-- Inspect the parse tree to find the signature
case listifyParsedSpans ps (lineNo, colNo) :: [G.LHsDecl G.RdrName] of
[L loc (G.SigD (Ty.TypeSig names (L _ ty)))] ->
-- We found a type signature
return $ Just $ Signature loc (map G.unLoc names) ty
[L _ (G.InstD _)] -> do
-- We found an instance declaration
TypecheckedModule{tm_renamed_source = Just tcs
,tm_checked_module_info = minfo} <- G.typecheckModule p
case listifyRenamedSpans tcs (lineNo, colNo) :: [G.LInstDecl G.Name] of
-- Instance declarations of sort 'instance F (G a)'
#if __GLASGOW_HASKELL__ >= 708
[L loc (G.ClsInstD (G.ClsInstDecl {G.cid_poly_ty =
(L _ (G.HsForAllTy _ _ _ (L _ (G.HsAppTy (L _ (G.HsTyVar clsName)) _))))}))] ->
#elif __GLASGOW_HASKELL__ >= 706
[L loc (G.ClsInstD
(L _ (G.HsForAllTy _ _ _ (L _ (G.HsAppTy (L _ (G.HsTyVar clsName)) _)))) _ _ _)] ->
#else
[L loc (G.InstDecl
(L _ (G.HsForAllTy _ _ _ (L _ (G.HsAppTy (L _ (G.HsTyVar clsName)) _)))) _ _ _)] ->
#endif
obtainClassInfo minfo clsName loc
-- Instance declarations of sort 'instance F G' (no variables)
#if __GLASGOW_HASKELL__ >= 708
[L loc (G.ClsInstD (G.ClsInstDecl {G.cid_poly_ty =
(L _ (G.HsAppTy (L _ (G.HsTyVar clsName)) _))}))] ->
#elif __GLASGOW_HASKELL__ >= 706
[L loc (G.ClsInstD
(L _ (G.HsAppTy (L _ (G.HsTyVar clsName)) _)) _ _ _)] ->
#else
[L loc (G.InstDecl
(L _ (G.HsAppTy (L _ (G.HsTyVar clsName)) _)) _ _ _)] ->
#endif
obtainClassInfo minfo clsName loc
_ -> return Nothing
_ -> return Nothing
where obtainClassInfo :: GhcMonad m => G.ModuleInfo -> G.Name -> SrcSpan -> m (Maybe SigInfo)
obtainClassInfo minfo clsName loc = do
tyThing <- G.modInfoLookupName minfo clsName
return $ do Ty.ATyCon clsCon <- tyThing -- In Maybe
cls <- G.tyConClass_maybe clsCon
return $ InstanceDecl loc cls
-- Get signature from haskell-src-exts
getSignatureFromHE :: GhcMonad m => FilePath -> Int -> Int -> m (Maybe HESigInfo)
getSignatureFromHE file lineNo colNo = do
presult <- liftIO $ HE.parseFile file
return $ case presult of
HE.ParseOk (HE.Module _ _ _ _ mdecls) -> do
HE.TypeSig (HE.SrcSpanInfo s _) names ty <- find (typeSigInRangeHE lineNo colNo) mdecls
return $ HESignature s names ty
_ -> Nothing
----------------------------------------------------------------
-- b. Code for generating initial code
-- A list of function arguments, and whether they are functions or normal arguments
-- is built from either a function signature or an instance signature
data FnArg = FnArgFunction | FnArgNormal
initialBody :: FnArgsInfo ty name => DynFlags -> PprStyle -> ty -> name -> String
initialBody dflag style ty name = initialBody' (getFnName dflag style name) (getFnArgs ty)
initialBody' :: String -> [FnArg] -> String
initialBody' fname args =
case initialBodyArgs args infiniteVars infiniteFns of
[] -> fname
arglist -> if isSymbolName fname
then (head arglist) ++ " " ++ fname ++ " " ++ (intercalate " " (tail arglist))
else fname ++ " " ++ (intercalate " " arglist)
++ " = " ++ (if isSymbolName fname then "" else '_':fname) ++ "_body"
initialBodyArgs :: [FnArg] -> [String] -> [String] -> [String]
initialBodyArgs [] _ _ = []
initialBodyArgs (FnArgFunction:xs) vs (f:fs) = f : initialBodyArgs xs vs fs
initialBodyArgs (FnArgNormal:xs) (v:vs) fs = v : initialBodyArgs xs vs fs
initialBodyArgs _ _ _ = error "This should never happen" -- Lists are infinite
-- Getting the initial body of function and instances differ
-- This is because for functions we only use the parsed file
-- (so the full file doesn't have to be type correct)
-- but for instances we need to get information about the class
class FnArgsInfo ty name | ty -> name, name -> ty where
getFnName :: DynFlags -> PprStyle -> name -> String
getFnArgs :: ty -> [FnArg]
instance FnArgsInfo (G.HsType G.RdrName) (G.RdrName) where
getFnName dflag style name = showOccName dflag style $ occName name
getFnArgs (G.HsForAllTy _ _ _ (L _ iTy)) = getFnArgs iTy
getFnArgs (G.HsParTy (L _ iTy)) = getFnArgs iTy
getFnArgs (G.HsFunTy (L _ lTy) (L _ rTy)) = (if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy
where fnarg = \ty -> case ty of
(G.HsForAllTy _ _ _ (L _ iTy)) -> fnarg iTy
(G.HsParTy (L _ iTy)) -> fnarg iTy
(G.HsFunTy _ _) -> True
_ -> False
getFnArgs _ = []
#if __GLASGOW_HASKELL__ < 706
occName :: G.RdrName -> OccName
occName = rdrNameOcc
#endif
instance FnArgsInfo (HE.Type HE.SrcSpanInfo) (HE.Name HE.SrcSpanInfo) where
getFnName _ _ (HE.Ident _ s) = s
getFnName _ _ (HE.Symbol _ s) = s
getFnArgs (HE.TyForall _ _ _ iTy) = getFnArgs iTy
getFnArgs (HE.TyParen _ iTy) = getFnArgs iTy
getFnArgs (HE.TyFun _ lTy rTy) = (if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy
where fnarg = \ty -> case ty of
(HE.TyForall _ _ _ iTy) -> fnarg iTy
(HE.TyParen _ iTy) -> fnarg iTy
(HE.TyFun _ _ _) -> True
_ -> False
getFnArgs _ = []
instance FnArgsInfo Type Id where
getFnName dflag style method = showOccName dflag style $ G.getOccName method
getFnArgs = getFnArgs' . Ty.dropForAlls
where getFnArgs' ty | Just (lTy,rTy) <- Ty.splitFunTy_maybe ty =
maybe (if Ty.isPredTy lTy then getFnArgs' rTy else FnArgNormal:getFnArgs' rTy)
(\_ -> FnArgFunction:getFnArgs' rTy)
$ Ty.splitFunTy_maybe lTy
getFnArgs' ty | Just (_,iTy) <- Ty.splitForAllTy_maybe ty = getFnArgs' iTy
getFnArgs' _ = []
-- Infinite supply of variable and function variable names
infiniteVars, infiniteFns :: [String]
infiniteVars = infiniteSupply ["x","y","z","t","u","v","w"]
infiniteFns = infiniteSupply ["f","g","h"]
infiniteSupply :: [String] -> [String]
infiniteSupply initialSupply = initialSupply ++ concatMap (\n -> map (\v -> v ++ show n) initialSupply) ([1 .. ] :: [Integer])
-- Check whether a String is a symbol name
isSymbolName :: String -> Bool
isSymbolName (c:_) = c `elem` "!#$%&*+./<=>?@\\^|-~" || isSymbol c
isSymbolName [] = error "This should never happen"

4
Language/Haskell/GhcMod/GHCApi.hs
View File

@ -19,11 +19,11 @@ import Language.Haskell.GhcMod.GhcPkg
import Control.Applicative ((<$>))
import Control.Monad (forM, void)
import CoreMonad (liftIO)
import Data.Maybe (isJust, fromJust)
import Exception (ghandle, SomeException(..))
import GHC (Ghc, GhcMonad, DynFlags(..), GhcLink(..), HscTarget(..), LoadHowMuch(..))
import GHC (DynFlags(..), GhcLink(..), HscTarget(..), LoadHowMuch(..))
import qualified GHC as G
import GhcMonad
import GHC.Paths (libdir)
import qualified Language.Haskell.GhcMod.Gap as Gap
import Language.Haskell.GhcMod.Types

8
Language/Haskell/GhcMod/GHCChoice.hs
View File

@ -5,21 +5,21 @@ module Language.Haskell.GhcMod.GHCChoice where
import Control.Exception (IOException)
import CoreMonad (liftIO)
import qualified Exception as GE
import GHC (Ghc, GhcMonad)
import GHC (GhcMonad)
----------------------------------------------------------------
-- | Try the left 'Ghc' action. If 'IOException' occurs, try
-- the right 'Ghc' action.
(||>) :: Ghc a -> Ghc a -> Ghc a
(||>) :: GhcMonad m => m a -> m a -> m a
x ||> y = x `GE.gcatch` (\(_ :: IOException) -> y)
-- | Go to the next 'Ghc' monad by throwing 'AltGhcgoNext'.
goNext :: Ghc a
goNext :: GhcMonad m => m a
goNext = liftIO . GE.throwIO $ userError "goNext"
-- | Run any one 'Ghc' monad.
runAnyOne :: [Ghc a] -> Ghc a
runAnyOne :: GhcMonad m => [m a] -> m a
runAnyOne = foldr (||>) goNext
----------------------------------------------------------------

20
Language/Haskell/GhcMod/Gap.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, CPP #-}
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, CPP, ScopedTypeVariables, RankNTypes #-}
module Language.Haskell.GhcMod.Gap (
Language.Haskell.GhcMod.Gap.ClsInst
@ -24,6 +24,8 @@ module Language.Haskell.GhcMod.Gap (
, HasType(..)
, errorMsgSpan
, typeForUser
, nameForUser
, occNameForUser
, deSugar
, showDocWith
, GapThing(..)
@ -44,10 +46,12 @@ import Desugar (deSugarExpr)
import DynFlags
import ErrUtils
import FastString
import GhcMonad
import HscTypes
import Language.Haskell.GhcMod.GHCChoice
import Language.Haskell.GhcMod.Types
import NameSet
import OccName
import Outputable
import PprTyThing
import StringBuffer
@ -148,7 +152,7 @@ getSrcFile _ = Nothing
----------------------------------------------------------------
toStringBuffer :: [String] -> Ghc StringBuffer
toStringBuffer :: GhcMonad m => [String] -> m StringBuffer
#if __GLASGOW_HASKELL__ >= 702
toStringBuffer = return . stringToStringBuffer . unlines
#else
@ -171,13 +175,13 @@ fOptions = [option | (option,_,_,_) <- fFlags]
----------------------------------------------------------------
----------------------------------------------------------------
fileModSummary :: FilePath -> Ghc ModSummary
fileModSummary :: GhcMonad m => FilePath -> m ModSummary
fileModSummary file = do
mss <- getModuleGraph
let [ms] = filter (\m -> ml_hs_file (ms_location m) == Just file) mss
return ms
withContext :: Ghc a -> Ghc a
withContext :: GhcMonad m => m a -> m a
withContext action = gbracket setup teardown body
where
setup = getContext
@ -293,7 +297,7 @@ filterOutChildren get_thing xs
where
implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
infoThing :: String -> Ghc SDoc
infoThing :: GhcMonad m => String -> m SDoc
infoThing str = do
names <- parseName str
#if __GLASGOW_HASKELL__ >= 708
@ -345,6 +349,12 @@ typeForUser = pprTypeForUser
typeForUser = pprTypeForUser False
#endif
nameForUser :: Name -> SDoc
nameForUser = pprOccName . getOccName
occNameForUser :: OccName -> SDoc
occNameForUser = pprOccName
deSugar :: TypecheckedModule -> LHsExpr Id -> HscEnv
-> IO (Maybe CoreExpr)
#if __GLASGOW_HASKELL__ >= 708

4
Language/Haskell/GhcMod/Ghc.hs
View File

@ -8,6 +8,8 @@ module Language.Haskell.GhcMod.Ghc (
, check
, info
, types
, splits
, sig
, modules
-- * 'SymMdlDb'
, Symbol
@ -24,3 +26,5 @@ import Language.Haskell.GhcMod.Find
import Language.Haskell.GhcMod.GHCApi
import Language.Haskell.GhcMod.Info
import Language.Haskell.GhcMod.List
import Language.Haskell.GhcMod.FillSig
import Language.Haskell.GhcMod.CaseSplit

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

@ -1,6 +1,3 @@
{-# LANGUAGE TupleSections, FlexibleInstances, Rank2Types #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.Haskell.GhcMod.Info (
infoExpr
, info
@ -9,25 +6,20 @@ module Language.Haskell.GhcMod.Info (
) where
import Control.Applicative ((<$>))
import CoreMonad (liftIO)
import CoreUtils (exprType)
import Data.Function (on)
import Data.Generics
import Data.List (sortBy)
import Data.Maybe (catMaybes, fromMaybe)
import Data.Ord as O
import Data.Maybe (catMaybes)
import Exception (ghandle, SomeException(..))
import GHC (Ghc, LHsBind, LHsExpr, LPat, Id, TypecheckedModule(..), DynFlags, SrcSpan, Type, Located, TypecheckedSource, GenLocated(L))
import GHC (GhcMonad, LHsBind, LHsExpr, LPat, Id, TypecheckedModule(..), SrcSpan, Type)
import qualified GHC as G
import GHC.SYB.Utils (Stage(TypeChecker), everythingStaged)
import Language.Haskell.GhcMod.Doc (showPage, showOneLine, getStyle)
import Language.Haskell.GhcMod.Doc (showPage)
import Language.Haskell.GhcMod.GHCApi
import Language.Haskell.GhcMod.Gap (HasType(..), setWarnTypedHoles, setDeferTypeErrors)
import Language.Haskell.GhcMod.Gap (HasType(..))
import qualified Language.Haskell.GhcMod.Gap as Gap
import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.SrcUtils
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Convert
import Outputable (PprStyle)
import TcHsSyn (hsPatType)
----------------------------------------------------------------
@ -37,16 +29,17 @@ infoExpr :: Options
-> FilePath -- ^ A target file.
-> Expression -- ^ A Haskell expression.
-> IO String
infoExpr opt cradle file expr = withGHC' $ do
infoExpr opt cradle file expr = runGhcMod opt $ do
initializeFlagsWithCradle opt cradle
info opt file expr
info file expr
-- | Obtaining information of a target expression. (GHCi's info:)
info :: Options
-> FilePath -- ^ A target file.
info :: FilePath -- ^ A target file.
-> Expression -- ^ A Haskell expression.
-> Ghc String
info opt file expr = convert opt <$> ghandle handler body
-> GhcMod String
info file expr = do
opt <- options
convert opt <$> ghandle handler body
where
body = inModuleContext file $ \dflag style -> do
sdoc <- Gap.infoThing expr
@ -55,17 +48,6 @@ info opt file expr = convert opt <$> ghandle handler body
----------------------------------------------------------------
instance HasType (LHsExpr Id) where
getType tcm e = do
hs_env <- G.getSession
mbe <- liftIO $ Gap.deSugar tcm e hs_env
return $ (G.getLoc e, ) <$> CoreUtils.exprType <$> mbe
instance HasType (LPat Id) where
getType _ (G.L spn pat) = return $ Just (spn, hsPatType pat)
----------------------------------------------------------------
-- | Obtaining type of a target expression. (GHCi's type:)
typeExpr :: Options
-> Cradle
@ -73,17 +55,18 @@ typeExpr :: Options
-> Int -- ^ Line number.
-> Int -- ^ Column number.
-> IO String
typeExpr opt cradle file lineNo colNo = withGHC' $ do
typeExpr opt cradle file lineNo colNo = runGhcMod opt $ do
initializeFlagsWithCradle opt cradle
types opt file lineNo colNo
types file lineNo colNo
-- | Obtaining type of a target expression. (GHCi's type:)
types :: Options
-> FilePath -- ^ A target file.
types :: FilePath -- ^ A target file.
-> Int -- ^ Line number.
-> Int -- ^ Column number.
-> Ghc String
types opt file lineNo colNo = convert opt <$> ghandle handler body
-> GhcMod String
types file lineNo colNo = do
opt <- options
convert opt <$> ghandle handler body
where
body = inModuleContext file $ \dflag style -> do
modSum <- Gap.fileModSummary file
@ -91,7 +74,7 @@ types opt file lineNo colNo = convert opt <$> ghandle handler body
return $ map (toTup dflag style) $ sortBy (cmp `on` fst) srcSpanTypes
handler (SomeException _) = return []
getSrcSpanType :: G.ModSummary -> Int -> Int -> Ghc [(SrcSpan, Type)]
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
@ -103,36 +86,3 @@ getSrcSpanType modSum lineNo colNo = do
pts <- mapM (getType tcm) ps
return $ catMaybes $ concat [ets, bts, pts]
listifySpans :: Typeable a => TypecheckedSource -> (Int, Int) -> [Located a]
listifySpans tcs lc = listifyStaged TypeChecker p tcs
where
p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc
listifyStaged :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r]
listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x]))
cmp :: SrcSpan -> SrcSpan -> Ordering
cmp a b
| a `G.isSubspanOf` b = O.LT
| b `G.isSubspanOf` a = O.GT
| otherwise = O.EQ
toTup :: DynFlags -> PprStyle -> (SrcSpan, Type) -> ((Int,Int,Int,Int),String)
toTup dflag style (spn, typ) = (fourInts spn, pretty dflag style typ)
fourInts :: SrcSpan -> (Int,Int,Int,Int)
fourInts = fromMaybe (0,0,0,0) . Gap.getSrcSpan
pretty :: DynFlags -> PprStyle -> Type -> String
pretty dflag style = showOneLine dflag style . Gap.typeForUser
----------------------------------------------------------------
inModuleContext :: FilePath -> (DynFlags -> PprStyle -> Ghc a) -> Ghc a
inModuleContext file action =
withDynFlags (setWarnTypedHoles . setDeferTypeErrors . setNoWaringFlags) $ do
setTargetFiles [file]
Gap.withContext $ do
dflag <- G.getSessionDynFlags
style <- getStyle
action dflag style

97
Language/Haskell/GhcMod/SrcUtils.hs Normal file
View File

@ -0,0 +1,97 @@
{-# LANGUAGE TupleSections, FlexibleInstances, Rank2Types #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.Haskell.GhcMod.SrcUtils where
import Control.Applicative ((<$>))
import CoreUtils (exprType)
import Data.Generics
import Data.Maybe (fromMaybe)
import Data.Ord as O
import GHC (LHsExpr, LPat, Id, DynFlags, SrcSpan, Type, Located, ParsedSource, RenamedSource, TypecheckedSource, GenLocated(L))
import GhcMonad
import qualified GHC as G
import GHC.SYB.Utils (Stage(..), everythingStaged)
import Language.Haskell.GhcMod.Doc (showOneLine, getStyle)
import Language.Haskell.GhcMod.GHCApi
import Language.Haskell.GhcMod.Gap (HasType(..), setWarnTypedHoles, setDeferTypeErrors)
import qualified Language.Haskell.GhcMod.Gap as Gap
import Outputable (PprStyle)
import TcHsSyn (hsPatType)
import OccName (OccName)
import qualified Language.Haskell.Exts.Annotated as HE
----------------------------------------------------------------
instance HasType (LHsExpr Id) where
getType tcm e = do
hs_env <- G.getSession
mbe <- liftIO $ Gap.deSugar tcm e hs_env
return $ (G.getLoc e, ) <$> CoreUtils.exprType <$> mbe
instance HasType (LPat Id) where
getType _ (G.L spn pat) = return $ Just (spn, hsPatType pat)
----------------------------------------------------------------
listifySpans :: Typeable a => TypecheckedSource -> (Int, Int) -> [Located a]
listifySpans tcs lc = listifyStaged TypeChecker p tcs
where
p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc
listifyParsedSpans :: Typeable a => ParsedSource -> (Int, Int) -> [Located a]
listifyParsedSpans pcs lc = listifyStaged Parser p pcs
where
p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc
listifyRenamedSpans :: Typeable a => RenamedSource -> (Int, Int) -> [Located a]
listifyRenamedSpans pcs lc = listifyStaged Renamer p pcs
where
p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc
listifyStaged :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r]
listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x]))
cmp :: SrcSpan -> SrcSpan -> Ordering
cmp a b
| a `G.isSubspanOf` b = O.LT
| b `G.isSubspanOf` a = O.GT
| otherwise = O.EQ
toTup :: DynFlags -> PprStyle -> (SrcSpan, Type) -> ((Int,Int,Int,Int),String)
toTup dflag style (spn, typ) = (fourInts spn, pretty dflag style typ)
fourInts :: SrcSpan -> (Int,Int,Int,Int)
fourInts = fromMaybe (0,0,0,0) . Gap.getSrcSpan
fourIntsHE :: HE.SrcSpan -> (Int,Int,Int,Int)
fourIntsHE loc = ( HE.srcSpanStartLine loc, HE.srcSpanStartColumn loc
, HE.srcSpanEndLine loc, HE.srcSpanEndColumn loc)
-- Check whether (line,col) is inside a given SrcSpanInfo
typeSigInRangeHE :: Int -> Int -> HE.Decl HE.SrcSpanInfo -> Bool
typeSigInRangeHE lineNo colNo (HE.TypeSig (HE.SrcSpanInfo s _) _ _) =
HE.srcSpanStart s <= (lineNo, colNo) && HE.srcSpanEnd s >= (lineNo, colNo)
typeSigInRangeHE _ _ _= False
pretty :: DynFlags -> PprStyle -> Type -> String
pretty dflag style = showOneLine dflag style . Gap.typeForUser
----------------------------------------------------------------
inModuleContext ::GhcMonad m => FilePath -> (DynFlags -> PprStyle -> m a) -> m a
inModuleContext file action =
withDynFlags (setWarnTypedHoles . setDeferTypeErrors . setNoWaringFlags) $ do
setTargetFiles [file]
Gap.withContext $ do
dflag <- G.getSessionDynFlags
style <- getStyle
action dflag style
----------------------------------------------------------------
showName :: DynFlags -> PprStyle -> G.Name -> String
showName dflag style name = showOneLine dflag style $ Gap.nameForUser name
showOccName :: DynFlags -> PprStyle -> OccName -> String
showOccName dflag style name = showOneLine dflag style $ Gap.occNameForUser name

2
elisp/Makefile
View File

@ -1,5 +1,5 @@
SRCS = ghc.el ghc-func.el ghc-doc.el ghc-comp.el ghc-check.el ghc-process.el \
ghc-command.el ghc-info.el ghc-ins-mod.el ghc-indent.el
ghc-command.el ghc-info.el ghc-ins-mod.el ghc-indent.el ghc-rewrite.el
EMACS = emacs
DETECT = xemacs

77
elisp/ghc-rewrite.el Normal file
View File

@ -0,0 +1,77 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; ghc-rewrite.el
;;;
;; Author: Alejandro Serrano <trupill@gmail.com>
;; Created: Jun 17, 2014
;;; Code:
(require 'ghc-func)
(require 'ghc-process)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Case splitting
;;;
(ghc-defstruct sinfo beg-line beg-column end-line end-column info)
(defun ghc-case-split ()
(interactive)
(let ((info (ghc-obtain-case-split)))
(if (null info)
(message "Cannot split in cases")
(let* ((current-line (line-number-at-pos))
(begin-line (ghc-sinfo-get-beg-line info))
(begin-line-diff (+ 1 (- begin-line current-line)))
(begin-line-pos (line-beginning-position begin-line-diff))
(begin-pos (- (+ begin-line-pos (ghc-sinfo-get-beg-column info)) 1))
(end-line (ghc-sinfo-get-end-line info))
(end-line-diff (+ 1 (- end-line current-line)))
(end-line-pos (line-beginning-position end-line-diff))
(end-pos (- (+ end-line-pos (ghc-sinfo-get-end-column info)) 1)) )
(delete-region begin-pos end-pos)
(insert (ghc-sinfo-get-info info)) ) )))
(defun ghc-obtain-case-split ()
(let* ((ln (int-to-string (line-number-at-pos)))
(cn (int-to-string (1+ (current-column))))
(file (buffer-file-name))
(cmd (format "split %s %s %s\n" file ln cn)))
(ghc-sync-process cmd)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Initial code from signature
;;;
(ghc-defstruct icsinfo sort pos fns)
(defun ghc-initial-code-from-signature ()
(interactive)
(let ((info (ghc-obtain-initial-code-from-signature)))
(if (null info)
(message "Cannot obtain initial code")
(let* ((ln-current (line-number-at-pos))
(sort (ghc-icsinfo-get-sort info))
(pos (ghc-icsinfo-get-pos info))
(ln-end (ghc-sinfo-get-end-line pos))
(ln-diff (+ 1 (- ln-end ln-current)))
(fns-to-insert (ghc-icsinfo-get-fns info)))
(goto-char (line-end-position ln-diff))
(dolist (fn-to-insert fns-to-insert)
(if (equal sort "function")
(newline)
(newline-and-indent))
(insert fn-to-insert))))))
(defun ghc-obtain-initial-code-from-signature ()
(let* ((ln (int-to-string (line-number-at-pos)))
(cn (int-to-string (1+ (current-column))))
(file (buffer-file-name))
(cmd (format "sig %s %s %s\n" file ln cn)))
(ghc-sync-process cmd)))
(provide 'ghc-rewrite)

5
elisp/ghc.el
View File

@ -40,6 +40,7 @@
(require 'ghc-command)
(require 'ghc-ins-mod)
(require 'ghc-indent)
(require 'ghc-rewrite)
(require 'dabbrev)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -72,6 +73,8 @@
(defvar ghc-hoogle-key (format "\C-c%c" (ghc-find-C-h)))
(defvar ghc-shallower-key "\C-c<")
(defvar ghc-deeper-key "\C-c>")
(defvar ghc-case-split-key "\C-c\C-p")
(defvar ghc-initial-sig-key "\C-c\C-s")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
@ -104,6 +107,8 @@
(define-key haskell-mode-map ghc-hoogle-key 'haskell-hoogle)
(define-key haskell-mode-map ghc-shallower-key 'ghc-make-indent-shallower)
(define-key haskell-mode-map ghc-deeper-key 'ghc-make-indent-deeper)
(define-key haskell-mode-map ghc-case-split-key 'ghc-case-split)
(define-key haskell-mode-map ghc-initial-sig-key 'ghc-initial-code-from-signature)
(ghc-comp-init)
(setq ghc-initialized t))
(ghc-import-module)

7
ghc-mod.cabal
View File

@ -61,11 +61,13 @@ Library
Language.Haskell.GhcMod.CabalConfig
Language.Haskell.GhcMod.Cabal16
Language.Haskell.GhcMod.Cabal18
Language.Haskell.GhcMod.CaseSplit
Language.Haskell.GhcMod.Check
Language.Haskell.GhcMod.Cradle
Language.Haskell.GhcMod.Convert
Language.Haskell.GhcMod.Debug
Language.Haskell.GhcMod.Doc
Language.Haskell.GhcMod.FillSig
Language.Haskell.GhcMod.Find
Language.Haskell.GhcMod.Flag
Language.Haskell.GhcMod.GHCApi
@ -81,6 +83,7 @@ Library
Language.Haskell.GhcMod.Utils
Language.Haskell.GhcMod.Types
Language.Haskell.GhcMod.Read
Language.Haskell.GhcMod.SrcUtils
Build-Depends: base >= 4.0 && < 5
, containers
, deepseq
@ -100,6 +103,8 @@ Library
, mtl
, monad-control
, split
, haskell-src-exts
, text
if impl(ghc < 7.7)
Build-Depends: convertible
, Cabal >= 1.10 && < 1.17
@ -177,6 +182,8 @@ Test-Suite spec
, monad-control
, hspec >= 1.8.2
, split
, haskell-src-exts
, text
if impl(ghc < 7.7)
Build-Depends: convertible
, Cabal >= 1.10 && < 1.17

4
src/GHCMod.hs
View File

@ -38,6 +38,8 @@ usage = progVersion
++ "\t ghc-mod debug" ++ ghcOptHelp ++ "\n"
++ "\t ghc-mod info" ++ ghcOptHelp ++ "<HaskellFile> <module> <expression>\n"
++ "\t ghc-mod type" ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"
++ "\t ghc-mod split" ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"
++ "\t ghc-mod sig" ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"
++ "\t ghc-mod find <symbol>\n"
++ "\t ghc-mod lint [-h opt] <HaskellFile>\n"
++ "\t ghc-mod root\n"
@ -119,6 +121,8 @@ main = flip E.catches handlers $ do
"debug" -> debugInfo opt cradle
"info" -> nArgs 3 infoExpr opt cradle cmdArg1 cmdArg3
"type" -> nArgs 4 $ typeExpr opt cradle cmdArg1 (read cmdArg3) (read cmdArg4)
"split" -> nArgs 4 $ splitVar opt cradle cmdArg1 (read cmdArg3) (read cmdArg4)
"sig" -> nArgs 4 $ fillSig opt cradle cmdArg1 (read cmdArg3) (read cmdArg4)
"find" -> runGhcMod opt $ nArgs 1 $ findSymbol cmdArg1
"lint" -> nArgs 1 withFile (lintSyntax opt) cmdArg1
"root" -> rootInfo opt cradle

53
src/GHCModi.hs
View File

@ -31,7 +31,7 @@ import Data.Set (Set)
import qualified Data.Set as S
import Data.Typeable (Typeable)
import Data.Version (showVersion)
import GHC (Ghc)
import GHC (GhcMonad)
import qualified GHC as G
import Language.Haskell.GhcMod
import Language.Haskell.GhcMod.Ghc
@ -142,8 +142,10 @@ loop opt set mvar = do
"check" -> checkStx opt set arg
"find" -> findSym set arg mvar
"lint" -> toGhcMod $ lintStx opt set arg
"info" -> toGhcMod $ showInfo opt set arg
"type" -> toGhcMod $ showType opt set arg
"info" -> showInfo set arg
"type" -> showType set arg
"split" -> doSplit set arg
"sig" -> doSig set arg
"boot" -> bootIt set
"browse" -> browseIt set arg
"quit" -> return ("quit", False, set)
@ -171,7 +173,7 @@ checkStx _ set file = do
Right ret -> return (ret, True, set')
Left ret -> return (ret, True, set) -- fxime: set
newFileSet :: Set FilePath -> FilePath -> Ghc (Set FilePath)
newFileSet :: GhcMonad m => Set FilePath -> FilePath -> m (Set FilePath)
newFileSet set file = do
let set1
| S.member file set = set
@ -181,7 +183,7 @@ newFileSet set file = do
Nothing -> set1
Just mainfile -> S.delete mainfile set1
getModSummaryForMain :: Ghc (Maybe G.ModSummary)
getModSummaryForMain :: GhcMonad m => m (Maybe G.ModSummary)
getModSummaryForMain = find isMain <$> G.getModuleGraph
where
isMain m = G.moduleNameString (G.moduleName (G.ms_mod m)) == "Main"
@ -207,8 +209,9 @@ findSym set sym mvar = do
let ret = lookupSym' opt sym db
return (ret, True, set)
lintStx :: Options -> Set FilePath -> FilePath
-> Ghc (String, Bool, Set FilePath)
lintStx :: GhcMonad m
=> Options -> Set FilePath -> FilePath
-> m (String, Bool, Set FilePath)
lintStx opt set optFile = liftIO $ do
ret <-lintSyntax opt' file
return (ret, True, set)
@ -234,24 +237,40 @@ parseLintOptions optFile = case brk (== ']') (dropWhile (/= '[') optFile) of
----------------------------------------------------------------
showInfo :: Options
-> Set FilePath
showInfo :: Set FilePath
-> FilePath
-> Ghc (String, Bool, Set FilePath)
showInfo opt set fileArg = do
-> GhcMod (String, Bool, Set FilePath)
showInfo set fileArg = do
let [file, expr] = words fileArg
set' <- newFileSet set file
ret <- info opt file expr
ret <- info file expr
return (ret, True, set')
showType :: Options
-> Set FilePath
showType :: Set FilePath
-> FilePath
-> Ghc (String, Bool, Set FilePath)
showType opt set fileArg = do
-> GhcMod (String, Bool, Set FilePath)
showType set fileArg = do
let [file, line, column] = words fileArg
set' <- newFileSet set file
ret <- types opt file (read line) (read column)
ret <- types file (read line) (read column)
return (ret, True, set')
doSplit :: Set FilePath
-> FilePath
-> GhcMod (String, Bool, Set FilePath)
doSplit set fileArg = do
let [file, line, column] = words fileArg
set' <- newFileSet set file
ret <- splits file (read line) (read column)
return (ret, True, set')
doSig :: Set FilePath
-> FilePath
-> GhcMod (String, Bool, Set FilePath)
doSig set fileArg = do
let [file, line, column] = words fileArg
set' <- newFileSet set file
ret <- sig file (read line) (read column)
return (ret, True, set')
----------------------------------------------------------------