Fix build on case-insensitive filesystems (#873)
This commit is contained in:
eatobin
29
GhcModExe/Boot.hs
Normal file
29
GhcModExe/Boot.hs
Normal file
@@ -0,0 +1,29 @@
|
||||
module GhcModExe.Boot where
|
||||
|
||||
import Control.Applicative
|
||||
import Prelude
|
||||
|
||||
import GhcModExe.Browse
|
||||
import GhcModExe.Flag
|
||||
import GhcModExe.Lang
|
||||
import GhcModExe.Modules
|
||||
import Language.Haskell.GhcMod.Monad
|
||||
import Language.Haskell.GhcMod.Types (defaultBrowseOpts)
|
||||
|
||||
-- | Printing necessary information for front-end booting.
|
||||
boot :: IOish m => GhcModT m String
|
||||
boot = concat <$> sequence ms
|
||||
where
|
||||
ms = [modules False, languages, flags, concat <$> mapM (browse defaultBrowseOpts) preBrowsedModules]
|
||||
|
||||
preBrowsedModules :: [String]
|
||||
preBrowsedModules = [
|
||||
"Prelude"
|
||||
, "Control.Applicative"
|
||||
, "Control.Exception"
|
||||
, "Control.Monad"
|
||||
, "Data.Char"
|
||||
, "Data.List"
|
||||
, "Data.Maybe"
|
||||
, "System.IO"
|
||||
]
|
||||
169
GhcModExe/Browse.hs
Normal file
169
GhcModExe/Browse.hs
Normal file
@@ -0,0 +1,169 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
module GhcModExe.Browse (
|
||||
browse,
|
||||
BrowseOpts(..)
|
||||
) where
|
||||
|
||||
import Safe
|
||||
import Control.Applicative
|
||||
import Control.Exception (SomeException(..))
|
||||
import Data.Char
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import FastString
|
||||
import GHC
|
||||
import HscTypes
|
||||
import qualified GHC as G
|
||||
import Language.Haskell.GhcMod.Convert
|
||||
import Language.Haskell.GhcMod.Doc (showPage, styleUnqualified)
|
||||
import Language.Haskell.GhcMod.Gap as Gap
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Language.Haskell.GhcMod.Monad
|
||||
import Language.Haskell.GhcMod.Logging
|
||||
import Name (getOccString)
|
||||
import Outputable
|
||||
import TyCon (isAlgTyCon)
|
||||
import Type (dropForAlls, splitFunTy_maybe, mkFunTy, isPredTy)
|
||||
import Exception (ExceptionMonad, ghandle)
|
||||
import Prelude
|
||||
#if __GLASGOW_HASKELL__ >= 800
|
||||
import PatSyn (pprPatSynType)
|
||||
#endif
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | Getting functions, classes, etc from a module.
|
||||
browse :: forall m. IOish m
|
||||
=> BrowseOpts -- ^ Configuration parameters
|
||||
-> String -- ^ A module name. (e.g. \"Data.List\", "base:Prelude")
|
||||
-> GhcModT m String
|
||||
browse opts pkgmdl = do
|
||||
convert' . sort =<< go
|
||||
where
|
||||
-- TODO: Add API to Gm.Target to check if module is home module without
|
||||
-- bringing up a GHC session as well then this can be made a lot cleaner
|
||||
go = ghandle (\ex@(SomeException _) -> logException ex >> return []) $ do
|
||||
goPkgModule `G.gcatch` (\(SomeException _) -> goHomeModule)
|
||||
|
||||
logException ex =
|
||||
gmLog GmException "browse" $ showToDoc ex
|
||||
|
||||
goPkgModule = do
|
||||
runGmPkgGhc $
|
||||
processExports opts =<< tryModuleInfo =<< G.findModule mdlname mpkgid
|
||||
|
||||
goHomeModule = runGmlT [Right mdlname] $ do
|
||||
processExports opts =<< tryModuleInfo =<< G.findModule mdlname Nothing
|
||||
|
||||
tryModuleInfo m = fromJustNote "browse, tryModuleInfo" <$> G.getModuleInfo m
|
||||
|
||||
(mpkg, mdl) = splitPkgMdl pkgmdl
|
||||
mdlname = G.mkModuleName mdl
|
||||
mpkgid = mkFastString <$> mpkg
|
||||
|
||||
-- |
|
||||
--
|
||||
-- >>> splitPkgMdl "base:Prelude"
|
||||
-- (Just "base","Prelude")
|
||||
-- >>> splitPkgMdl "Prelude"
|
||||
-- (Nothing,"Prelude")
|
||||
splitPkgMdl :: String -> (Maybe String,String)
|
||||
splitPkgMdl pkgmdl =
|
||||
case break (==':') pkgmdl of
|
||||
(mdl, "") -> (Nothing, mdl)
|
||||
(pkg, _:mdl) -> (Just pkg, mdl)
|
||||
|
||||
-- Haskell 2010:
|
||||
-- small -> ascSmall | uniSmall | _
|
||||
-- ascSmall -> a | b | ... | z
|
||||
-- uniSmall -> any Unicode lowercase letter
|
||||
-- varid -> (small {small | large | digit | ' })
|
||||
|
||||
isNotOp :: String -> Bool
|
||||
isNotOp (h:_) = isAlpha h || (h == '_')
|
||||
isNotOp _ = error "isNotOp"
|
||||
|
||||
processExports :: (G.GhcMonad m, MonadIO m, ExceptionMonad m)
|
||||
=> BrowseOpts -> ModuleInfo -> m [String]
|
||||
processExports opt minfo = do
|
||||
let
|
||||
removeOps
|
||||
| optBrowseOperators opt = id
|
||||
| otherwise = filter (isNotOp . getOccString)
|
||||
mapM (showExport opt minfo) $ removeOps $ G.modInfoExports minfo
|
||||
|
||||
showExport :: forall m. (G.GhcMonad m, MonadIO m, ExceptionMonad m)
|
||||
=> BrowseOpts -> ModuleInfo -> Name -> m String
|
||||
showExport opt minfo e = do
|
||||
mtype' <- mtype
|
||||
return $ concat $ catMaybes [mqualified, Just $ formatOp $ getOccString e, mtype']
|
||||
where
|
||||
mqualified = (G.moduleNameString (G.moduleName $ G.nameModule e) ++ ".") `justIf` optBrowseQualified opt
|
||||
mtype :: m (Maybe String)
|
||||
mtype
|
||||
| optBrowseDetailed opt || optBrowseParents opt = do
|
||||
tyInfo <- G.modInfoLookupName minfo e
|
||||
-- If nothing found, load dependent module and lookup global
|
||||
tyResult <- maybe (inOtherModule e) (return . Just) tyInfo
|
||||
dflag <- G.getSessionDynFlags
|
||||
let sig = do
|
||||
typeName <- tyResult >>= showThing dflag
|
||||
(" :: " ++ typeName) `justIf` optBrowseDetailed opt
|
||||
let parent = do
|
||||
thing <- fmap getOccString $ tyResult >>= tyThingParent_maybe
|
||||
(" -- from:" ++ thing) `justIf` optBrowseParents opt
|
||||
return $ case concat $ catMaybes [sig, parent] of
|
||||
[] -> Nothing
|
||||
x -> Just x
|
||||
| otherwise = return Nothing
|
||||
formatOp nm
|
||||
| null nm = error "formatOp"
|
||||
| isNotOp nm = nm
|
||||
| otherwise = "(" ++ nm ++ ")"
|
||||
inOtherModule :: Name -> m (Maybe TyThing)
|
||||
inOtherModule nm = do
|
||||
G.getModuleInfo (G.nameModule nm) >> G.lookupGlobalName nm
|
||||
justIf :: a -> Bool -> Maybe a
|
||||
justIf x True = Just x
|
||||
justIf _ False = Nothing
|
||||
|
||||
showThing :: DynFlags -> TyThing -> Maybe String
|
||||
showThing dflag tything = showThing' dflag (fromTyThing tything)
|
||||
|
||||
showThing' :: DynFlags -> GapThing -> Maybe String
|
||||
showThing' dflag (GtA a) = Just $ formatType dflag a
|
||||
showThing' _ (GtT t) = unwords . toList <$> tyType t
|
||||
where
|
||||
toList t' = t' : getOccString t : map getOccString (G.tyConTyVars t)
|
||||
#if __GLASGOW_HASKELL__ >= 800
|
||||
showThing' dflag (GtPatSyn p) = Just $ showSDoc dflag $ pprPatSynType p
|
||||
#endif
|
||||
showThing' _ _ = Nothing
|
||||
|
||||
formatType :: DynFlags -> Type -> String
|
||||
formatType dflag a = showOutputable dflag (removeForAlls a)
|
||||
|
||||
tyType :: TyCon -> Maybe String
|
||||
tyType typ
|
||||
| isAlgTyCon typ
|
||||
&& not (G.isNewTyCon typ)
|
||||
&& not (G.isClassTyCon typ) = Just "data"
|
||||
| G.isNewTyCon typ = Just "newtype"
|
||||
| G.isClassTyCon typ = Just "class"
|
||||
| Gap.isSynTyCon typ = Just "type"
|
||||
| otherwise = Nothing
|
||||
|
||||
removeForAlls :: Type -> Type
|
||||
removeForAlls ty = removeForAlls' ty' tty'
|
||||
where
|
||||
ty' = dropForAlls ty
|
||||
tty' = splitFunTy_maybe ty'
|
||||
|
||||
removeForAlls' :: Type -> Maybe (Type, Type) -> Type
|
||||
removeForAlls' ty Nothing = ty
|
||||
removeForAlls' ty (Just (pre, ftype))
|
||||
| isPredTy pre = mkFunTy pre (dropForAlls ftype)
|
||||
| otherwise = ty
|
||||
|
||||
showOutputable :: Outputable a => DynFlags -> a -> String
|
||||
showOutputable dflag = unwords . lines . showPage dflag styleUnqualified . ppr
|
||||
261
GhcModExe/CaseSplit.hs
Normal file
261
GhcModExe/CaseSplit.hs
Normal file
@@ -0,0 +1,261 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
module GhcModExe.CaseSplit (
|
||||
splits
|
||||
) where
|
||||
|
||||
import Data.List (find, intercalate)
|
||||
import Data.Maybe (isJust)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.IO as T (readFile)
|
||||
import System.FilePath
|
||||
import Prelude
|
||||
|
||||
import qualified DataCon as Ty
|
||||
import GHC (GhcMonad, LPat, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L))
|
||||
import qualified GHC as G
|
||||
import Outputable (PprStyle)
|
||||
import qualified TyCon as Ty
|
||||
import qualified Type as Ty
|
||||
import Exception
|
||||
|
||||
import Language.Haskell.GhcMod.Convert
|
||||
import Language.Haskell.GhcMod.DynFlags
|
||||
import qualified Language.Haskell.GhcMod.Gap as Gap
|
||||
import Language.Haskell.GhcMod.Monad
|
||||
import Language.Haskell.GhcMod.SrcUtils
|
||||
import Language.Haskell.GhcMod.Doc
|
||||
import Language.Haskell.GhcMod.Logging
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Language.Haskell.GhcMod.Utils (withMappedFile)
|
||||
import Language.Haskell.GhcMod.FileMapping (fileModSummaryWithMapping)
|
||||
import Control.DeepSeq
|
||||
|
||||
----------------------------------------------------------------
|
||||
-- CASE SPLITTING
|
||||
----------------------------------------------------------------
|
||||
|
||||
data SplitInfo = SplitInfo G.Name SrcSpan (SrcSpan, Type) [SrcSpan]
|
||||
| TySplitInfo G.Name SrcSpan (SrcSpan, Ty.Kind)
|
||||
data SplitToTextInfo = SplitToTextInfo { sVarName :: String
|
||||
, sBindingSpan :: SrcSpan
|
||||
, sVarSpan :: SrcSpan
|
||||
, sTycons :: [String]
|
||||
}
|
||||
|
||||
-- | Splitting a variable in a equation.
|
||||
splits :: IOish m
|
||||
=> FilePath -- ^ A target file.
|
||||
-> Int -- ^ Line number.
|
||||
-> Int -- ^ Column number.
|
||||
-> GhcModT m String
|
||||
splits file lineNo colNo =
|
||||
ghandle handler $ runGmlT' [Left file] deferErrors $ do
|
||||
oopts <- outputOpts
|
||||
crdl <- cradle
|
||||
style <- getStyle
|
||||
dflag <- G.getSessionDynFlags
|
||||
modSum <- fileModSummaryWithMapping (cradleCurrentDir crdl </> file)
|
||||
whenFound' oopts (getSrcSpanTypeForSplit modSum lineNo colNo) $ \x -> do
|
||||
let (varName, bndLoc, (varLoc,varT))
|
||||
| (SplitInfo vn bl vlvt _matches) <- x
|
||||
= (vn, bl, vlvt)
|
||||
| (TySplitInfo vn bl vlvt) <- x
|
||||
= (vn, bl, vlvt)
|
||||
varName' = showName dflag style varName -- Convert name to string
|
||||
t <- withMappedFile file $ \file' ->
|
||||
genCaseSplitTextFile file' (SplitToTextInfo varName' bndLoc varLoc $
|
||||
getTyCons dflag style varName varT)
|
||||
return $!! (fourInts bndLoc, t)
|
||||
where
|
||||
handler (SomeException ex) = do
|
||||
gmLog GmException "splits" $
|
||||
text "" $$ nest 4 (showToDoc ex)
|
||||
emptyResult =<< outputOpts
|
||||
|
||||
----------------------------------------------------------------
|
||||
-- a. Code for getting the information of the variable
|
||||
|
||||
getSrcSpanTypeForSplit :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SplitInfo)
|
||||
getSrcSpanTypeForSplit modSum lineNo colNo = do
|
||||
fn <- getSrcSpanTypeForFnSplit modSum lineNo colNo
|
||||
if isJust fn
|
||||
then return fn
|
||||
else getSrcSpanTypeForTypeSplit modSum lineNo colNo
|
||||
|
||||
-- Information for a function case split
|
||||
getSrcSpanTypeForFnSplit :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SplitInfo)
|
||||
getSrcSpanTypeForFnSplit modSum lineNo colNo = do
|
||||
p@ParsedModule{pm_parsed_source = _pms} <- G.parseModule modSum
|
||||
tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p
|
||||
let varPat = find isPatternVar $ listifySpans tcs (lineNo, colNo) :: Maybe (LPat Id)
|
||||
match = last $ listifySpans tcs (lineNo, colNo) :: Gap.GLMatchI
|
||||
case varPat of
|
||||
Nothing -> return Nothing
|
||||
Just varPat' -> do
|
||||
varT <- Gap.getType tcm varPat' -- Finally we get the type of the var
|
||||
case varT of
|
||||
Just varT' ->
|
||||
#if __GLASGOW_HASKELL__ >= 710
|
||||
let (L matchL (G.Match _ _ _ (G.GRHSs rhsLs _))) = match
|
||||
#else
|
||||
let (L matchL (G.Match _ _ (G.GRHSs rhsLs _))) = match
|
||||
#endif
|
||||
in return $ Just (SplitInfo (getPatternVarName varPat') matchL varT' (map G.getLoc rhsLs) )
|
||||
_ -> return Nothing
|
||||
|
||||
isPatternVar :: LPat Id -> Bool
|
||||
isPatternVar (L _ (G.VarPat _)) = True
|
||||
isPatternVar _ = False
|
||||
|
||||
getPatternVarName :: LPat Id -> G.Name
|
||||
#if __GLASGOW_HASKELL__ >= 800
|
||||
getPatternVarName (L _ (G.VarPat (L _ vName))) = G.getName vName
|
||||
#else
|
||||
getPatternVarName (L _ (G.VarPat vName)) = G.getName vName
|
||||
#endif
|
||||
getPatternVarName _ = error "This should never happened"
|
||||
|
||||
-- TODO: Information for a type family case split
|
||||
getSrcSpanTypeForTypeSplit :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SplitInfo)
|
||||
getSrcSpanTypeForTypeSplit _modSum _lineNo _colNo = return Nothing
|
||||
|
||||
----------------------------------------------------------------
|
||||
-- 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
|
||||
#if __GLASGOW_HASKELL__ >= 800
|
||||
flds = map Ty.flSelector $ Ty.dataConFieldLabels dcon
|
||||
#else
|
||||
flds = Ty.dataConFieldLabels dcon
|
||||
#endif
|
||||
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 :: (MonadIO m, GhcMonad m) =>
|
||||
FilePath -> SplitToTextInfo -> m String
|
||||
genCaseSplitTextFile file info = liftIO $ do
|
||||
t <- T.readFile file
|
||||
return $ getCaseSplitText (T.lines t) info
|
||||
|
||||
getCaseSplitText :: [T.Text] -> SplitToTextInfo -> String
|
||||
getCaseSplitText t SplitToTextInfo{ sVarName = sVN, sBindingSpan = sBS
|
||||
, sVarSpan = sVS, sTycons = sT } =
|
||||
let bindingText = getBindingText t sBS
|
||||
difference = srcSpanDifference sBS sVS
|
||||
replaced = map (replaceVarWithTyCon bindingText difference sVN) sT
|
||||
-- The newly generated bindings need to be indented to align with the
|
||||
-- original binding.
|
||||
replaced' = head replaced : map (indentBindingTo sBS) (tail replaced)
|
||||
in T.unpack $ T.intercalate (T.pack "\n") (concat replaced')
|
||||
|
||||
getBindingText :: [T.Text] -> SrcSpan -> [T.Text]
|
||||
getBindingText t srcSpan =
|
||||
let Just (sl,sc,el,ec) = Gap.getSrcSpan srcSpan
|
||||
lines_ = drop (sl - 1) $ take el t
|
||||
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 t (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 ..] t
|
||||
|
||||
indentBindingTo :: SrcSpan -> [T.Text] -> [T.Text]
|
||||
indentBindingTo bndLoc binds =
|
||||
let Just (_,sl,_,_) = Gap.getSrcSpan bndLoc
|
||||
indent = (T.replicate (sl - 1) (T.pack " ") `T.append`)
|
||||
in indent (head binds) : tail binds
|
||||
57
GhcModExe/Check.hs
Normal file
57
GhcModExe/Check.hs
Normal file
@@ -0,0 +1,57 @@
|
||||
module GhcModExe.Check (
|
||||
checkSyntax
|
||||
, check
|
||||
, expandTemplate
|
||||
, expand
|
||||
) where
|
||||
|
||||
import Control.Applicative
|
||||
import Prelude
|
||||
import Language.Haskell.GhcMod.DynFlags
|
||||
import qualified Language.Haskell.GhcMod.Gap as Gap
|
||||
import Language.Haskell.GhcMod.Logger
|
||||
import Language.Haskell.GhcMod.Monad
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | Checking syntax of a target file using GHC.
|
||||
-- Warnings and errors are returned.
|
||||
checkSyntax :: IOish m
|
||||
=> [FilePath] -- ^ The target files.
|
||||
-> GhcModT m String
|
||||
checkSyntax [] = return ""
|
||||
checkSyntax files = either id id <$> check files
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | Checking syntax of a target file using GHC.
|
||||
-- Warnings and errors are returned.
|
||||
check :: IOish m
|
||||
=> [FilePath] -- ^ The target files.
|
||||
-> GhcModT m (Either String String)
|
||||
check files =
|
||||
runGmlTWith
|
||||
(map Left files)
|
||||
return
|
||||
((fmap fst <$>) . withLogger Gap.setNoMaxRelevantBindings)
|
||||
(return ())
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | Expanding Haskell Template.
|
||||
expandTemplate :: IOish m
|
||||
=> [FilePath] -- ^ The target files.
|
||||
-> GhcModT m String
|
||||
expandTemplate [] = return ""
|
||||
expandTemplate files = either id id <$> expand files
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | Expanding Haskell Template.
|
||||
expand :: IOish m => [FilePath] -> GhcModT m (Either String String)
|
||||
expand files =
|
||||
runGmlTWith
|
||||
(map Left files)
|
||||
return
|
||||
((fmap fst <$>) . withLogger (Gap.setDumpSplices . setNoWarningFlags))
|
||||
(return ())
|
||||
182
GhcModExe/Debug.hs
Normal file
182
GhcModExe/Debug.hs
Normal file
@@ -0,0 +1,182 @@
|
||||
module GhcModExe.Debug (debugInfo, rootInfo, componentInfo) where
|
||||
|
||||
import Control.Arrow (first)
|
||||
import Control.Applicative
|
||||
import Control.Monad
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import Data.Char
|
||||
import Data.Maybe
|
||||
import Data.Version
|
||||
import Data.List.Split
|
||||
import System.Directory
|
||||
|
||||
import GhcModExe.Internal
|
||||
import Language.Haskell.GhcMod.Cradle
|
||||
import Language.Haskell.GhcMod.Monad
|
||||
import Language.Haskell.GhcMod.Output
|
||||
import Language.Haskell.GhcMod.Pretty
|
||||
import Language.Haskell.GhcMod.Stack
|
||||
import Language.Haskell.GhcMod.Target
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Language.Haskell.GhcMod.Utils
|
||||
|
||||
import Paths_ghc_mod (version)
|
||||
|
||||
import Config (cProjectVersion)
|
||||
import Pretty
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | Obtaining debug information.
|
||||
debugInfo :: IOish m => GhcModT m String
|
||||
debugInfo = do
|
||||
Options {..} <- options
|
||||
Cradle {..} <- cradle
|
||||
|
||||
[ghcPath, ghcPkgPath] <- liftIO $
|
||||
case cradleProject of
|
||||
StackProject se ->
|
||||
catMaybes <$> sequence [getStackGhcPath se, getStackGhcPkgPath se]
|
||||
_ ->
|
||||
return ["ghc", "ghc-pkg"]
|
||||
|
||||
cabal <-
|
||||
case cradleProject of
|
||||
CabalProject -> cabalDebug ghcPkgPath
|
||||
StackProject {} -> (++) <$> stackPaths <*> cabalDebug ghcPkgPath
|
||||
_ -> return []
|
||||
|
||||
pkgOpts <- packageGhcOptions
|
||||
|
||||
readProc <- gmReadProcess
|
||||
|
||||
ghcVersion <- liftIO $
|
||||
dropWhileEnd isSpace <$> readProc ghcPath ["--numeric-version"] ""
|
||||
|
||||
return $ unlines $
|
||||
[ "Version: ghc-mod-" ++ showVersion version
|
||||
, "Library GHC Version: " ++ cProjectVersion
|
||||
, "System GHC Version: " ++ ghcVersion
|
||||
, "Root directory: " ++ cradleRootDir
|
||||
, "Current directory: " ++ cradleCurrentDir
|
||||
, "GHC Package flags:\n" ++ render (nest 4 $
|
||||
fsep $ map text pkgOpts)
|
||||
, "GHC System libraries: " ++ ghcLibDir
|
||||
] ++ cabal
|
||||
|
||||
stackPaths :: IOish m => GhcModT m [String]
|
||||
stackPaths = do
|
||||
Cradle { cradleProject = StackProject senv } <- cradle
|
||||
ghc <- getStackGhcPath senv
|
||||
ghcPkg <- getStackGhcPkgPath senv
|
||||
return $
|
||||
[ "Stack ghc executable: " ++ show ghc
|
||||
, "Stack ghc-pkg executable:" ++ show ghcPkg
|
||||
]
|
||||
|
||||
cabalDebug :: IOish m => FilePath -> GhcModT m [String]
|
||||
cabalDebug ghcPkgPath = do
|
||||
Cradle {..} <- cradle
|
||||
mcs <- cabalResolvedComponents
|
||||
let entrypoints = Map.map gmcEntrypoints mcs
|
||||
graphs = Map.map gmcHomeModuleGraph mcs
|
||||
opts = Map.map gmcGhcOpts mcs
|
||||
srcOpts = Map.map gmcGhcSrcOpts mcs
|
||||
|
||||
readProc <- gmReadProcess
|
||||
cabalExists <- liftIO $ (/=Nothing) <$> findExecutable "cabal"
|
||||
|
||||
cabalInstVersion <-
|
||||
if cabalExists
|
||||
then liftIO $
|
||||
dropWhileEnd isSpace <$> readProc "cabal" ["--numeric-version"] ""
|
||||
else return ""
|
||||
|
||||
packages <- liftIO $ readProc ghcPkgPath ["list", "--simple-output"] ""
|
||||
let cabalPackages = filter ((== ["Cabal"]) . take 1 . splitOn "-") $ splitWhen isSpace packages
|
||||
|
||||
return $
|
||||
[ "cabal-install Version: " ++ cabalInstVersion
|
||||
, "Cabal Library Versions:\n" ++ render (nest 4 $
|
||||
fsep $ map text cabalPackages)
|
||||
, "Cabal file: " ++ show cradleCabalFile
|
||||
, "Project: " ++ show cradleProject
|
||||
, "Cabal entrypoints:\n" ++ render (nest 4 $
|
||||
mapDoc gmComponentNameDoc smpDoc entrypoints)
|
||||
, "Cabal components:\n" ++ render (nest 4 $
|
||||
mapDoc gmComponentNameDoc graphDoc graphs)
|
||||
, "GHC Cabal options:\n" ++ render (nest 4 $
|
||||
mapDoc gmComponentNameDoc (fsep . map text) opts)
|
||||
, "GHC search path options:\n" ++ render (nest 4 $
|
||||
mapDoc gmComponentNameDoc (fsep . map text) srcOpts)
|
||||
]
|
||||
|
||||
componentInfo :: IOish m => [String] -> GhcModT m String
|
||||
componentInfo ts = do
|
||||
-- TODO: most of this is copypasta of targetGhcOptions. Factor out more
|
||||
-- useful function from there.
|
||||
crdl <- cradle
|
||||
sefnmn <- Set.fromList `liftM` mapM guessModuleFile ts
|
||||
mcs <- cabalResolvedComponents
|
||||
let
|
||||
mdlcs = moduleComponents mcs `zipMap` Set.toList sefnmn
|
||||
candidates = findCandidates $ map snd mdlcs
|
||||
cn = pickComponent candidates
|
||||
opts <- targetGhcOptions crdl sefnmn
|
||||
|
||||
return $ unlines $
|
||||
[ "Matching Components:\n" ++ render (nest 4 $
|
||||
alistDoc (either text mnDoc) (setDoc gmComponentNameDoc) mdlcs)
|
||||
, "Picked Component:\n" ++ render (nest 4 $
|
||||
gmComponentNameDoc cn)
|
||||
, "GHC Cabal options:\n" ++ render (nest 4 $ fsep $ map text opts)
|
||||
]
|
||||
where
|
||||
zipMap f l = l `zip` (f `map` l)
|
||||
|
||||
guessModuleFile :: MonadIO m => String -> m (Either FilePath ModuleName)
|
||||
guessModuleFile m
|
||||
| (isUpper . head .&&. (all $ all $ isAlphaNum .||. (=='.')) . splitOn ".") m =
|
||||
return $ Right $ mkModuleName m
|
||||
where
|
||||
infixr 1 .||.
|
||||
infixr 2 .&&.
|
||||
(.||.) = liftA2 (||)
|
||||
(.&&.) = liftA2 (&&)
|
||||
|
||||
guessModuleFile str = Left `liftM` liftIO (canonFilePath str)
|
||||
|
||||
graphDoc :: GmModuleGraph -> Doc
|
||||
graphDoc GmModuleGraph{..} =
|
||||
mapDoc mpDoc smpDoc' gmgGraph
|
||||
where
|
||||
smpDoc' smp = vcat $ map mpDoc' $ Set.toList smp
|
||||
mpDoc' = text . moduleNameString . mpModule
|
||||
|
||||
setDoc :: (a -> Doc) -> Set.Set a -> Doc
|
||||
setDoc f s = vcat $ map f $ Set.toList s
|
||||
|
||||
smpDoc :: Set.Set ModulePath -> Doc
|
||||
smpDoc smp = setDoc mpDoc smp
|
||||
|
||||
mpDoc :: ModulePath -> Doc
|
||||
mpDoc (ModulePath mn fn) = text (moduleNameString mn) <+> parens (text fn)
|
||||
|
||||
mnDoc :: ModuleName -> Doc
|
||||
mnDoc mn = text (moduleNameString mn)
|
||||
|
||||
alistDoc :: Ord k => (k -> Doc) -> (a -> Doc) -> [(k, a)] -> Doc
|
||||
alistDoc fk fa alist = mapDoc fk fa (Map.fromList alist)
|
||||
|
||||
mapDoc :: (k -> Doc) -> (a -> Doc) -> Map.Map k a -> Doc
|
||||
mapDoc kd ad m = vcat $
|
||||
map (uncurry ($+$)) $ map (first kd) $ Map.toList $ Map.map (nest 4 . ad) m
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | Obtaining root information.
|
||||
rootInfo :: forall m. (IOish m, GmOut m, GmEnv m) => m String
|
||||
rootInfo = do
|
||||
crdl <- findCradleNoLog =<< (optPrograms <$> options)
|
||||
liftIO $ cleanupCradle crdl
|
||||
return $ cradleRootDir crdl ++ "\n"
|
||||
590
GhcModExe/FillSig.hs
Normal file
590
GhcModExe/FillSig.hs
Normal file
@@ -0,0 +1,590 @@
|
||||
{-# LANGUAGE CPP, MultiParamTypeClasses, FunctionalDependencies #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
|
||||
module GhcModExe.FillSig (
|
||||
sig
|
||||
, refine
|
||||
, auto
|
||||
) where
|
||||
|
||||
import Data.Char (isSymbol)
|
||||
import Data.Function (on)
|
||||
import Data.Functor
|
||||
import Data.List (find, nub, sortBy)
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe (catMaybes)
|
||||
import Prelude
|
||||
|
||||
import Exception (ghandle, SomeException(..))
|
||||
import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags,
|
||||
SrcSpan, Type, GenLocated(L))
|
||||
import Pretty (($$), text, nest)
|
||||
import qualified GHC as G
|
||||
import qualified Name as G
|
||||
import Outputable (PprStyle)
|
||||
import qualified Type as Ty
|
||||
import qualified HsBinds as Ty
|
||||
import qualified Class as Ty
|
||||
import qualified Var as Ty
|
||||
import qualified HsPat as Ty
|
||||
import qualified Language.Haskell.Exts as HE
|
||||
import Djinn.GHC
|
||||
|
||||
import qualified Language.Haskell.GhcMod.Gap as Gap
|
||||
import Language.Haskell.GhcMod.Convert
|
||||
import Language.Haskell.GhcMod.DynFlags
|
||||
import Language.Haskell.GhcMod.Monad
|
||||
import Language.Haskell.GhcMod.SrcUtils
|
||||
import Language.Haskell.GhcMod.Logging (gmLog)
|
||||
import Language.Haskell.GhcMod.Pretty (showToDoc)
|
||||
import Language.Haskell.GhcMod.Doc
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Language.Haskell.GhcMod.FileMapping (fileModSummaryWithMapping)
|
||||
|
||||
#if __GLASGOW_HASKELL__ >= 710
|
||||
import GHC (unLoc)
|
||||
#endif
|
||||
|
||||
----------------------------------------------------------------
|
||||
-- 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
|
||||
| TyFamDecl SrcSpan G.RdrName TyFamType {- True if closed -} [G.RdrName]
|
||||
|
||||
-- Signature for fallback operation via haskell-src-exts
|
||||
data HESigInfo
|
||||
= HESignature HE.SrcSpan [HE.Name HE.SrcSpanInfo] (HE.Type HE.SrcSpanInfo)
|
||||
| HEFamSignature
|
||||
HE.SrcSpan
|
||||
TyFamType
|
||||
(HE.Name HE.SrcSpanInfo)
|
||||
[HE.Name HE.SrcSpanInfo]
|
||||
|
||||
data TyFamType = Closed | Open | Data
|
||||
initialTyFamString :: TyFamType -> (String, String)
|
||||
initialTyFamString Closed = ("instance", "")
|
||||
initialTyFamString Open = ("function", "type instance ")
|
||||
initialTyFamString Data = ("function", "data instance ")
|
||||
|
||||
-- | Create a initial body from a signature.
|
||||
sig :: IOish m
|
||||
=> FilePath -- ^ A target file.
|
||||
-> Int -- ^ Line number.
|
||||
-> Int -- ^ Column number.
|
||||
-> GhcModT m String
|
||||
sig file lineNo colNo =
|
||||
runGmlT' [Left file] deferErrors $ ghandle fallback $ do
|
||||
oopts <- outputOpts
|
||||
style <- getStyle
|
||||
dflag <- G.getSessionDynFlags
|
||||
modSum <- fileModSummaryWithMapping file
|
||||
whenFound oopts (getSignature modSum lineNo colNo) $ \s ->
|
||||
case s of
|
||||
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)
|
||||
|
||||
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
|
||||
oopts <- outputOpts
|
||||
-- Code cannot be parsed by ghc module
|
||||
-- Fallback: try to get information via haskell-src-exts
|
||||
whenFound oopts (getSignatureFromHE file lineNo colNo) $ \x -> case x of
|
||||
HESignature loc names ty ->
|
||||
("function", fourIntsHE loc, map (initialBody undefined undefined ty) names)
|
||||
HEFamSignature loc flavour name vars ->
|
||||
let (rTy, initial) = initialTyFamString flavour
|
||||
in (rTy, fourIntsHE loc, [initial ++ initialFamBody undefined undefined name vars])
|
||||
|
||||
----------------------------------------------------------------
|
||||
-- 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
|
||||
#if __GLASGOW_HASKELL__ >= 800
|
||||
[L loc (G.SigD (Ty.TypeSig names (G.HsIB _ (G.HsWC _ _ (L _ ty)))))] ->
|
||||
#elif __GLASGOW_HASKELL__ >= 710
|
||||
[L loc (G.SigD (Ty.TypeSig names (L _ ty) _))] ->
|
||||
#else
|
||||
[L loc (G.SigD (Ty.TypeSig names (L _ ty)))] ->
|
||||
#endif
|
||||
-- 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
|
||||
let lst = listifyRenamedSpans tcs (lineNo, colNo)
|
||||
case Gap.getClass lst of
|
||||
Just (clsName,loc) -> obtainClassInfo minfo clsName loc
|
||||
_ -> return Nothing
|
||||
#if __GLASGOW_HASKELL__ >= 800
|
||||
[L loc (G.TyClD (G.FamDecl (G.FamilyDecl info (L _ name) (G.HsQTvs _ vars _) _ _)))] -> do
|
||||
#elif __GLASGOW_HASKELL__ >= 708
|
||||
[L loc (G.TyClD (G.FamDecl (G.FamilyDecl info (L _ name) (G.HsQTvs _ vars) _)))] -> do
|
||||
#elif __GLASGOW_HASKELL__ >= 706
|
||||
[L loc (G.TyClD (G.TyFamily info (L _ name) (G.HsQTvs _ vars) _))] -> do
|
||||
#else
|
||||
[L loc (G.TyClD (G.TyFamily info (L _ name) vars _))] -> do
|
||||
#endif
|
||||
#if __GLASGOW_HASKELL__ >= 708
|
||||
let flavour = case info of
|
||||
G.ClosedTypeFamily _ -> Closed
|
||||
G.OpenTypeFamily -> Open
|
||||
G.DataFamily -> Data
|
||||
#else
|
||||
let flavour = case info of -- Closed type families where introduced in GHC 7.8
|
||||
G.TypeFamily -> Open
|
||||
G.DataFamily -> Data
|
||||
#endif
|
||||
|
||||
#if __GLASGOW_HASKELL__ >= 800
|
||||
getTyFamVarName x = case x of
|
||||
L _ (G.UserTyVar (G.L _ n)) -> n
|
||||
L _ (G.KindedTyVar (G.L _ n) _) -> n
|
||||
#elif __GLASGOW_HASKELL__ >= 710
|
||||
getTyFamVarName x = case x of
|
||||
L _ (G.UserTyVar n) -> n
|
||||
L _ (G.KindedTyVar (G.L _ n) _) -> n
|
||||
#elif __GLASGOW_HASKELL__ >= 706
|
||||
getTyFamVarName x = case x of
|
||||
L _ (G.UserTyVar n) -> n
|
||||
L _ (G.KindedTyVar n _) -> n
|
||||
#else
|
||||
getTyFamVarName x = case x of -- In GHC 7.4, HsTyVarBndr's have an extra arg
|
||||
L _ (G.UserTyVar n _) -> n
|
||||
L _ (G.KindedTyVar n _ _) -> n
|
||||
#endif
|
||||
in return $ Just (TyFamDecl loc name flavour $ map getTyFamVarName vars)
|
||||
_ -> 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 :: (MonadIO m, 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
|
||||
decl <- find (typeSigInRangeHE lineNo colNo) mdecls
|
||||
case decl of
|
||||
HE.TypeSig (HE.SrcSpanInfo s _) names ty ->
|
||||
return $ HESignature s names ty
|
||||
|
||||
HE.TypeFamDecl (HE.SrcSpanInfo s _) declHead _ _ ->
|
||||
let (name, tys) = dHeadTyVars declHead in
|
||||
return $ HEFamSignature s Open name (map cleanTyVarBind tys)
|
||||
|
||||
HE.DataFamDecl (HE.SrcSpanInfo s _) _ declHead _ ->
|
||||
let (name, tys) = dHeadTyVars declHead in
|
||||
return $ HEFamSignature s Open name (map cleanTyVarBind tys)
|
||||
_ -> fail ""
|
||||
_ -> Nothing
|
||||
where cleanTyVarBind (HE.KindedVar _ n _) = n
|
||||
cleanTyVarBind (HE.UnkindedVar _ n) = n
|
||||
|
||||
#if MIN_VERSION_haskell_src_exts(1,16,0)
|
||||
dHeadTyVars :: HE.DeclHead l -> (HE.Name l, [HE.TyVarBind l])
|
||||
dHeadTyVars (HE.DHead _ name) = (name, [])
|
||||
dHeadTyVars (HE.DHApp _ r ty) = (++[ty]) `fmap` (dHeadTyVars r)
|
||||
dHeadTyVars (HE.DHInfix _ ty name) = (name, [ty])
|
||||
dHeadTyVars (HE.DHParen _ r) = dHeadTyVars r
|
||||
#else
|
||||
dHeadTyVars :: HE.DeclHead l -> (HE.Name l, [HE.TyVarBind l])
|
||||
dHeadTyVars (HE.DHead _ n tys) = (n, tys)
|
||||
#endif
|
||||
|
||||
----------------------------------------------------------------
|
||||
-- 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 | FnExplicitName String
|
||||
|
||||
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 =
|
||||
initialHead fname args ++ " = " ++ n ++ "_body"
|
||||
where n = if isSymbolName fname then "" else '_':fname
|
||||
|
||||
initialFamBody :: FnArgsInfo ty name
|
||||
=> DynFlags -> PprStyle -> name -> [name] -> String
|
||||
initialFamBody dflag style name args =
|
||||
initialHead fnName fnArgs ++ " = ()"
|
||||
where fnName = getFnName dflag style name
|
||||
fnArgs = map (FnExplicitName . getFnName dflag style) args
|
||||
|
||||
initialHead :: String -> [FnArg] -> String
|
||||
initialHead fname args =
|
||||
case initialBodyArgs args infiniteVars infiniteFns of
|
||||
[] -> fname
|
||||
arglist -> if isSymbolName fname
|
||||
then head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist)
|
||||
else fname ++ " " ++ unwords arglist
|
||||
|
||||
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 (FnExplicitName n:xs) vs fs = n : initialBodyArgs xs vs fs
|
||||
initialBodyArgs _ _ _ =
|
||||
error "initialBodyArgs: This should never happen" -- Lists are infinite
|
||||
|
||||
initialHead1 :: String -> [FnArg] -> [String] -> String
|
||||
initialHead1 fname args elts =
|
||||
case initialBodyArgs1 args elts of
|
||||
[] -> fname
|
||||
arglist
|
||||
| isSymbolName fname ->
|
||||
head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist)
|
||||
| otherwise ->
|
||||
fname ++ " " ++ unwords arglist
|
||||
|
||||
initialBodyArgs1 :: [FnArg] -> [String] -> [String]
|
||||
initialBodyArgs1 args elts = take (length args) elts
|
||||
|
||||
-- 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 $ Gap.occName name
|
||||
#if __GLASGOW_HASKELL__ >= 800
|
||||
getFnArgs (G.HsForAllTy _ (L _ iTy))
|
||||
#elif __GLASGOW_HASKELL__ >= 710
|
||||
getFnArgs (G.HsForAllTy _ _ _ _ (L _ iTy))
|
||||
#else
|
||||
getFnArgs (G.HsForAllTy _ _ _ (L _ iTy))
|
||||
#endif
|
||||
= 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
|
||||
#if __GLASGOW_HASKELL__ >= 800
|
||||
(G.HsForAllTy _ (L _ iTy)) ->
|
||||
#elif __GLASGOW_HASKELL__ >= 710
|
||||
(G.HsForAllTy _ _ _ _ (L _ iTy)) ->
|
||||
#else
|
||||
(G.HsForAllTy _ _ _ (L _ iTy)) ->
|
||||
#endif
|
||||
fnarg iTy
|
||||
|
||||
(G.HsParTy (L _ iTy)) -> fnarg iTy
|
||||
(G.HsFunTy _ _) -> True
|
||||
_ -> False
|
||||
getFnArgs _ = []
|
||||
|
||||
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"
|
||||
|
||||
|
||||
----------------------------------------------------------------
|
||||
-- REWRITE A HOLE / UNDEFINED VIA A FUNCTION
|
||||
----------------------------------------------------------------
|
||||
|
||||
refine :: IOish m
|
||||
=> FilePath -- ^ A target file.
|
||||
-> Int -- ^ Line number.
|
||||
-> Int -- ^ Column number.
|
||||
-> Expression -- ^ A Haskell expression.
|
||||
-> GhcModT m String
|
||||
refine file lineNo colNo (Expression expr) =
|
||||
ghandle handler $
|
||||
runGmlT' [Left file] deferErrors $ do
|
||||
oopts <- outputOpts
|
||||
style <- getStyle
|
||||
dflag <- G.getSessionDynFlags
|
||||
modSum <- fileModSummaryWithMapping file
|
||||
p <- G.parseModule modSum
|
||||
tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p
|
||||
ety <- G.exprType expr
|
||||
whenFound oopts (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
|
||||
txt = initialHead1 expr iArgs (infinitePrefixSupply name)
|
||||
in (fourInts loc, doParen paren txt)
|
||||
where
|
||||
handler (SomeException ex) = do
|
||||
gmLog GmException "refining" $
|
||||
text "" $$ nest 4 (showToDoc ex)
|
||||
emptyResult =<< outputOpts
|
||||
|
||||
-- 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 dflag style tcm tcs lineNo colNo =
|
||||
case lst of
|
||||
#if __GLASGOW_HASKELL__ >= 800
|
||||
e@(L _ (G.HsVar (L _ i))):others -> do
|
||||
#else
|
||||
e@(L _ (G.HsVar i)):others -> do
|
||||
#endif
|
||||
tyInfo <- Gap.getType tcm e
|
||||
case tyInfo of
|
||||
Just (s, typ)
|
||||
| name == "undefined" || head name == '_' ->
|
||||
return $ Just (s, name, typ, b)
|
||||
where
|
||||
name = getFnName dflag style i
|
||||
-- If inside an App, we need parenthesis
|
||||
b = case others of
|
||||
L _ (G.HsApp (L _ a1) (L _ a2)):_ ->
|
||||
isSearchedVar i a1 || isSearchedVar i a2
|
||||
_ -> False
|
||||
_ -> return Nothing
|
||||
_ -> return Nothing
|
||||
where
|
||||
lst :: [G.LHsExpr Id]
|
||||
lst = sortBy (cmp `on` G.getLoc) $ listifySpans tcs (lineNo, colNo)
|
||||
|
||||
infinitePrefixSupply :: String -> [String]
|
||||
infinitePrefixSupply "undefined" = repeat "undefined"
|
||||
infinitePrefixSupply p = map (\n -> p ++ "_" ++ show n) ([1 ..] :: [Integer])
|
||||
|
||||
doParen :: Bool -> String -> String
|
||||
doParen False s = s
|
||||
doParen True s = if ' ' `elem` s then '(':s ++ ")" else s
|
||||
|
||||
isSearchedVar :: Id -> G.HsExpr Id -> Bool
|
||||
#if __GLASGOW_HASKELL__ >= 800
|
||||
isSearchedVar i (G.HsVar (L _ i2)) = i == i2
|
||||
#else
|
||||
isSearchedVar i (G.HsVar i2) = i == i2
|
||||
#endif
|
||||
isSearchedVar _ _ = False
|
||||
|
||||
|
||||
----------------------------------------------------------------
|
||||
-- REFINE AUTOMATICALLY
|
||||
----------------------------------------------------------------
|
||||
|
||||
auto :: IOish m
|
||||
=> FilePath -- ^ A target file.
|
||||
-> Int -- ^ Line number.
|
||||
-> Int -- ^ Column number.
|
||||
-> GhcModT m String
|
||||
auto file lineNo colNo =
|
||||
ghandle handler $ runGmlT' [Left file] deferErrors $ do
|
||||
oopts <- outputOpts
|
||||
style <- getStyle
|
||||
dflag <- G.getSessionDynFlags
|
||||
modSum <- fileModSummaryWithMapping file
|
||||
p <- G.parseModule modSum
|
||||
tcm@TypecheckedModule {
|
||||
tm_typechecked_source = tcs
|
||||
, tm_checked_module_info = minfo
|
||||
} <- G.typecheckModule p
|
||||
whenFound' oopts (findVar dflag style tcm tcs lineNo colNo) $ \(loc, _name, rty, paren) -> do
|
||||
topLevel <- getEverythingInTopLevel minfo
|
||||
let (f,pats) = getPatsForVariable tcs (lineNo,colNo)
|
||||
-- Remove self function to prevent recursion, and id to trim
|
||||
-- cases
|
||||
filterFn (n,_) = let funName = G.getOccString n
|
||||
recName = G.getOccString (G.getName f)
|
||||
in funName `notElem` recName:notWantedFuns
|
||||
-- Find without using other functions in top-level
|
||||
localBnds = M.unions $
|
||||
map (\(L _ pat) -> getBindingsForPat pat) pats
|
||||
lbn = filter filterFn (M.toList localBnds)
|
||||
djinnsEmpty <- djinn True (Just minfo) lbn rty (Max 10) 100000
|
||||
let -- Find with the entire top-level
|
||||
almostEnv = M.toList $ M.union localBnds topLevel
|
||||
env = filter filterFn almostEnv
|
||||
djinns <- djinn True (Just minfo) env rty (Max 10) 100000
|
||||
return ( fourInts loc
|
||||
, map (doParen paren) $ nub (djinnsEmpty ++ djinns))
|
||||
where
|
||||
handler (SomeException ex) = do
|
||||
gmLog GmException "auto-refining" $
|
||||
text "" $$ nest 4 (showToDoc ex)
|
||||
emptyResult =<< outputOpts
|
||||
|
||||
-- Functions we do not want in completions
|
||||
notWantedFuns :: [String]
|
||||
notWantedFuns = ["id", "asTypeOf", "const"]
|
||||
|
||||
-- Get all things defined in top-level
|
||||
getEverythingInTopLevel :: GhcMonad m => G.ModuleInfo -> m (M.Map G.Name Type)
|
||||
getEverythingInTopLevel m = do
|
||||
let modInfo = tyThingsToInfo (G.modInfoTyThings m)
|
||||
topNames = G.modInfoTopLevelScope m
|
||||
case topNames of
|
||||
Just topNames' -> do topThings <- mapM G.lookupGlobalName topNames'
|
||||
let topThings' = catMaybes topThings
|
||||
topInfo = tyThingsToInfo topThings'
|
||||
return $ M.union modInfo topInfo
|
||||
Nothing -> return modInfo
|
||||
|
||||
tyThingsToInfo :: [Ty.TyThing] -> M.Map G.Name Type
|
||||
tyThingsToInfo [] = M.empty
|
||||
tyThingsToInfo (G.AnId i : xs) =
|
||||
M.insert (G.getName i) (Ty.varType i) (tyThingsToInfo xs)
|
||||
-- Getting information about constructors is not needed
|
||||
-- because they will be added by djinn-ghc when traversing types
|
||||
-- #if __GLASGOW_HASKELL__ >= 708
|
||||
-- tyThingToInfo (G.AConLike (G.RealDataCon con)) = return [(Ty.dataConName con, Ty.dataConUserType con)]
|
||||
-- #else
|
||||
-- tyThingToInfo (G.AConLike con) = return [(Ty.dataConName con, Ty.dataConUserType con)]
|
||||
-- #endif
|
||||
tyThingsToInfo (_:xs) = tyThingsToInfo xs
|
||||
|
||||
-- Find the Id of the function and the pattern where the hole is located
|
||||
getPatsForVariable :: G.TypecheckedSource -> (Int,Int) -> (Id, [Ty.LPat Id])
|
||||
getPatsForVariable tcs (lineNo, colNo) =
|
||||
let (L _ bnd:_) = sortBy (cmp `on` G.getLoc) $
|
||||
listifySpans tcs (lineNo, colNo) :: [G.LHsBind Id]
|
||||
in case bnd of
|
||||
G.PatBind { Ty.pat_lhs = L ploc pat } -> case pat of
|
||||
Ty.ConPatIn (L _ i) _ -> (i, [L ploc pat])
|
||||
_ -> (error "This should never happen", [])
|
||||
G.FunBind { Ty.fun_id = L _ funId } ->
|
||||
let m = sortBy (cmp `on` G.getLoc) $ listifySpans tcs (lineNo, colNo)
|
||||
#if __GLASGOW_HASKELL__ >= 708
|
||||
:: [G.LMatch Id (G.LHsExpr Id)]
|
||||
#else
|
||||
:: [G.LMatch Id]
|
||||
#endif
|
||||
#if __GLASGOW_HASKELL__ >= 710
|
||||
(L _ (G.Match _ pats _ _):_) = m
|
||||
#else
|
||||
(L _ (G.Match pats _ _):_) = m
|
||||
#endif
|
||||
in (funId, pats)
|
||||
_ -> (error "This should never happen", [])
|
||||
|
||||
getBindingsForPat :: Ty.Pat Id -> M.Map G.Name Type
|
||||
#if __GLASGOW_HASKELL__ >= 800
|
||||
getBindingsForPat (Ty.VarPat (L _ i)) = M.singleton (G.getName i) (Ty.varType i)
|
||||
#else
|
||||
getBindingsForPat (Ty.VarPat i) = M.singleton (G.getName i) (Ty.varType i)
|
||||
#endif
|
||||
getBindingsForPat (Ty.LazyPat (L _ l)) = getBindingsForPat l
|
||||
getBindingsForPat (Ty.BangPat (L _ b)) = getBindingsForPat b
|
||||
getBindingsForPat (Ty.AsPat (L _ a) (L _ i)) =
|
||||
M.insert (G.getName a) (Ty.varType a) (getBindingsForPat i)
|
||||
#if __GLASGOW_HASKELL__ >= 708
|
||||
getBindingsForPat (Ty.ListPat l _ _) =
|
||||
M.unions $ map (\(L _ i) -> getBindingsForPat i) l
|
||||
#else
|
||||
getBindingsForPat (Ty.ListPat l _) =
|
||||
M.unions $ map (\(L _ i) -> getBindingsForPat i) l
|
||||
#endif
|
||||
getBindingsForPat (Ty.TuplePat l _ _) =
|
||||
M.unions $ map (\(L _ i) -> getBindingsForPat i) l
|
||||
getBindingsForPat (Ty.PArrPat l _) =
|
||||
M.unions $ map (\(L _ i) -> getBindingsForPat i) l
|
||||
getBindingsForPat (Ty.ViewPat _ (L _ i) _) = getBindingsForPat i
|
||||
getBindingsForPat (Ty.SigPatIn (L _ i) _) = getBindingsForPat i
|
||||
getBindingsForPat (Ty.SigPatOut (L _ i) _) = getBindingsForPat i
|
||||
getBindingsForPat (Ty.ConPatIn (L _ i) d) =
|
||||
M.insert (G.getName i) (Ty.varType i) (getBindingsForRecPat d)
|
||||
getBindingsForPat (Ty.ConPatOut { Ty.pat_args = d }) = getBindingsForRecPat d
|
||||
getBindingsForPat _ = M.empty
|
||||
|
||||
getBindingsForRecPat :: Ty.HsConPatDetails Id -> M.Map G.Name Type
|
||||
#if __GLASGOW_HASKELL__ >= 800
|
||||
getBindingsForRecPat (G.PrefixCon args) =
|
||||
#else
|
||||
getBindingsForRecPat (Ty.PrefixCon args) =
|
||||
#endif
|
||||
M.unions $ map (\(L _ i) -> getBindingsForPat i) args
|
||||
#if __GLASGOW_HASKELL__ >= 800
|
||||
getBindingsForRecPat (G.InfixCon (L _ a1) (L _ a2)) =
|
||||
#else
|
||||
getBindingsForRecPat (Ty.InfixCon (L _ a1) (L _ a2)) =
|
||||
#endif
|
||||
M.union (getBindingsForPat a1) (getBindingsForPat a2)
|
||||
#if __GLASGOW_HASKELL__ >= 800
|
||||
getBindingsForRecPat (G.RecCon (Ty.HsRecFields { Ty.rec_flds = fields })) =
|
||||
#else
|
||||
getBindingsForRecPat (Ty.RecCon (Ty.HsRecFields { Ty.rec_flds = fields })) =
|
||||
#endif
|
||||
getBindingsForRecFields (map unLoc' fields)
|
||||
where
|
||||
#if __GLASGOW_HASKELL__ >= 710
|
||||
unLoc' = unLoc
|
||||
#else
|
||||
unLoc' = id
|
||||
#endif
|
||||
getBindingsForRecFields [] = M.empty
|
||||
getBindingsForRecFields (Ty.HsRecField {Ty.hsRecFieldArg = (L _ a)}:fs) =
|
||||
M.union (getBindingsForPat a) (getBindingsForRecFields fs)
|
||||
222
GhcModExe/Find.hs
Normal file
222
GhcModExe/Find.hs
Normal file
@@ -0,0 +1,222 @@
|
||||
{-# LANGUAGE CPP, BangPatterns, TupleSections, DeriveGeneric #-}
|
||||
|
||||
module GhcModExe.Find
|
||||
#ifndef SPEC
|
||||
( Symbol
|
||||
, SymbolDb
|
||||
, loadSymbolDb
|
||||
, lookupSymbol
|
||||
, dumpSymbol
|
||||
, findSymbol
|
||||
, lookupSym
|
||||
, isOutdated
|
||||
-- * Load 'SymbolDb' asynchronously
|
||||
, AsyncSymbolDb
|
||||
, newAsyncSymbolDb
|
||||
, getAsyncSymbolDb
|
||||
)
|
||||
#endif
|
||||
where
|
||||
|
||||
import qualified GHC as G
|
||||
import FastString
|
||||
import Module
|
||||
import OccName
|
||||
import HscTypes
|
||||
import Exception
|
||||
|
||||
import Language.Haskell.GhcMod.Convert
|
||||
import Language.Haskell.GhcMod.Gap
|
||||
import Language.Haskell.GhcMod.Monad
|
||||
import Language.Haskell.GhcMod.Output
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Language.Haskell.GhcMod.Utils
|
||||
import Language.Haskell.GhcMod.World
|
||||
import Language.Haskell.GhcMod.LightGhc
|
||||
|
||||
import Control.Applicative
|
||||
import Control.DeepSeq
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans.Control
|
||||
import Control.Concurrent
|
||||
|
||||
import Data.List
|
||||
import Data.Binary
|
||||
import Data.Function
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import Data.IORef
|
||||
|
||||
import System.Directory.ModTime
|
||||
import System.IO.Unsafe
|
||||
|
||||
import GHC.Generics (Generic)
|
||||
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as M
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as S
|
||||
import Language.Haskell.GhcMod.PathsAndFiles
|
||||
import System.Directory
|
||||
import Prelude
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | Type of function and operation names.
|
||||
type Symbol = BS.ByteString
|
||||
type ModuleNameBS = BS.ByteString
|
||||
|
||||
-- | Database from 'Symbol' to \['ModuleString'\].
|
||||
data SymbolDb = SymbolDb
|
||||
{ sdTable :: Map Symbol (Set ModuleNameBS)
|
||||
, sdTimestamp :: ModTime
|
||||
} deriving (Generic)
|
||||
|
||||
#if __GLASGOW_HASKELL__ >= 708
|
||||
instance Binary SymbolDb
|
||||
#else
|
||||
instance Binary SymbolDb where
|
||||
put (SymbolDb a b) = put a >> put b
|
||||
get = do
|
||||
a <- get
|
||||
b <- get
|
||||
return (SymbolDb a b)
|
||||
#endif
|
||||
instance NFData SymbolDb
|
||||
|
||||
isOutdated :: IOish m => SymbolDb -> GhcModT m Bool
|
||||
isOutdated db =
|
||||
isOlderThan (sdTimestamp db) <$> timedPackageCaches
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\]
|
||||
-- which will be concatenated. 'loadSymbolDb' is called internally.
|
||||
findSymbol :: IOish m => String -> GhcModT m String
|
||||
findSymbol sym = loadSymbolDb' >>= lookupSymbol sym
|
||||
|
||||
-- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\]
|
||||
-- which will be concatenated.
|
||||
lookupSymbol :: IOish m => String -> SymbolDb -> GhcModT m String
|
||||
lookupSymbol sym db = convert' $ lookupSym (fastStringToByteString $ mkFastString sym) db
|
||||
|
||||
lookupSym :: Symbol -> SymbolDb -> [ModuleString]
|
||||
lookupSym sym db = map (ModuleString . unpackFS . mkFastStringByteString') $ S.toList $ M.findWithDefault S.empty sym $ sdTable db
|
||||
|
||||
---------------------------------------------------------------
|
||||
|
||||
loadSymbolDb' :: IOish m => GhcModT m SymbolDb
|
||||
loadSymbolDb' = do
|
||||
cache <- symbolCache <$> cradle
|
||||
let doLoad True = do
|
||||
db <- decode <$> liftIO (LBS.readFile cache)
|
||||
outdated <- isOutdated db
|
||||
if outdated
|
||||
then doLoad False
|
||||
else return db
|
||||
doLoad False = do
|
||||
db <- loadSymbolDb
|
||||
liftIO $ LBS.writeFile cache $ encode db
|
||||
return db
|
||||
doLoad =<< liftIO (doesFileExist cache)
|
||||
|
||||
-- | Loading a file and creates 'SymbolDb'.
|
||||
loadSymbolDb :: IOish m => GhcModT m SymbolDb
|
||||
loadSymbolDb = do
|
||||
ghcMod <- liftIO ghcModExecutable
|
||||
readProc <- gmReadProcess'
|
||||
out <- liftIO $ readProc ghcMod ["--verbose", "error", "dumpsym"] ""
|
||||
return $!! decode out
|
||||
|
||||
----------------------------------------------------------------
|
||||
-- used 'ghc-mod dumpsym'
|
||||
|
||||
-- | Dumps a 'Binary' representation of 'SymbolDb' to stdout
|
||||
dumpSymbol :: IOish m => GhcModT m ()
|
||||
dumpSymbol = do
|
||||
ts <- liftIO getCurrentModTime
|
||||
st <- runGmPkgGhc $ getGlobalSymbolTable
|
||||
liftIO . LBS.putStr $ encode SymbolDb {
|
||||
sdTable = st
|
||||
, sdTimestamp = ts
|
||||
}
|
||||
|
||||
-- | Check whether given file is older than any file from the given set.
|
||||
-- Returns True if given file does not exist.
|
||||
isOlderThan :: ModTime -> [TimedFile] -> Bool
|
||||
isOlderThan tCache files =
|
||||
any (tCache <=) $ map tfTime files -- including equal just in case
|
||||
|
||||
-- | Browsing all functions in all system modules.
|
||||
getGlobalSymbolTable :: (G.GhcMonad m, MonadIO m)
|
||||
=> m (Map Symbol (Set ModuleNameBS))
|
||||
getGlobalSymbolTable =
|
||||
foldM extend M.empty =<< (listVisibleModules <$> G.getSessionDynFlags)
|
||||
|
||||
extend :: (G.GhcMonad m, MonadIO m)
|
||||
=> Map Symbol (Set ModuleNameBS)
|
||||
-> Module
|
||||
-> m (Map Symbol (Set ModuleNameBS))
|
||||
extend mm mdl = do
|
||||
hsc_env <- G.getSession
|
||||
eps <- liftIO $ readIORef $ hsc_EPS hsc_env
|
||||
modinfo <- liftIO $ unsafeInterleaveIO $ runLightGhc hsc_env $ do
|
||||
G.getModuleInfo mdl <* liftIO (writeIORef (hsc_EPS hsc_env) eps)
|
||||
return $ M.unionWith S.union mm $ extractBindings modinfo mdl
|
||||
|
||||
extractBindings :: Maybe G.ModuleInfo
|
||||
-> G.Module
|
||||
-> Map Symbol (Set ModuleNameBS)
|
||||
extractBindings Nothing _ = M.empty
|
||||
extractBindings (Just inf) mdl = M.fromList $ do
|
||||
name <- G.modInfoExports inf
|
||||
let sym = fastStringToByteString $ occNameFS $ G.getOccName name
|
||||
mdls = S.singleton $ fastStringToByteString $ moduleNameFS $ moduleName mdl
|
||||
return (sym, mdls)
|
||||
|
||||
mkFastStringByteString' :: BS.ByteString -> FastString
|
||||
#if !MIN_VERSION_ghc(7,8,0)
|
||||
fastStringToByteString :: FastString -> BS.ByteString
|
||||
fastStringToByteString = BS.pack . bytesFS
|
||||
|
||||
mkFastStringByteString' = mkFastStringByteList . BS.unpack
|
||||
#elif __GLASGOW_HASKELL__ == 708
|
||||
mkFastStringByteString' = unsafePerformIO . mkFastStringByteString
|
||||
#else
|
||||
mkFastStringByteString' = mkFastStringByteString
|
||||
#endif
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
data AsyncSymbolDb = AsyncSymbolDb (MVar (Either SomeException SymbolDb))
|
||||
|
||||
asyncLoadSymbolDb :: IOish m
|
||||
=> MVar (Either SomeException SymbolDb)
|
||||
-> GhcModT m ()
|
||||
asyncLoadSymbolDb mv = void $
|
||||
liftBaseWith $ \run -> forkIO $ void $ run $ do
|
||||
edb <- gtry loadSymbolDb
|
||||
liftIO $ putMVar mv edb
|
||||
|
||||
newAsyncSymbolDb :: IOish m => GhcModT m AsyncSymbolDb
|
||||
newAsyncSymbolDb = do
|
||||
mv <- liftIO newEmptyMVar
|
||||
asyncLoadSymbolDb mv
|
||||
return $ AsyncSymbolDb mv
|
||||
|
||||
getAsyncSymbolDb :: forall m. IOish m => AsyncSymbolDb -> GhcModT m SymbolDb
|
||||
getAsyncSymbolDb (AsyncSymbolDb mv) = do
|
||||
db <- liftIO $ handleEx <$> takeMVar mv
|
||||
outdated <- isOutdated db
|
||||
if outdated
|
||||
then do
|
||||
asyncLoadSymbolDb mv
|
||||
liftIO $ handleEx <$> readMVar mv
|
||||
else do
|
||||
liftIO $ putMVar mv $ Right db
|
||||
return db
|
||||
where
|
||||
handleEx edb =
|
||||
case edb of
|
||||
Left ex -> throw ex
|
||||
Right db -> db
|
||||
9
GhcModExe/Flag.hs
Normal file
9
GhcModExe/Flag.hs
Normal file
@@ -0,0 +1,9 @@
|
||||
module GhcModExe.Flag where
|
||||
|
||||
import qualified Language.Haskell.GhcMod.Gap as Gap
|
||||
import Language.Haskell.GhcMod.Convert
|
||||
import Language.Haskell.GhcMod.Monad
|
||||
|
||||
-- | Listing of GHC flags, same as @ghc@\'s @--show-options@ with @ghc >= 7.10@.
|
||||
flags :: IOish m => GhcModT m String
|
||||
flags = convert' Gap.ghcCmdOptions
|
||||
79
GhcModExe/Info.hs
Normal file
79
GhcModExe/Info.hs
Normal file
@@ -0,0 +1,79 @@
|
||||
module GhcModExe.Info (
|
||||
info
|
||||
, types
|
||||
) where
|
||||
|
||||
import Data.Function (on)
|
||||
import Data.List (sortBy)
|
||||
import System.FilePath
|
||||
import Exception (ghandle, SomeException(..))
|
||||
import GHC (GhcMonad, SrcSpan)
|
||||
import Prelude
|
||||
import qualified GHC as G
|
||||
|
||||
import qualified Language.Haskell.GhcMod.Gap as Gap
|
||||
import Language.Haskell.GhcMod.Convert
|
||||
import Language.Haskell.GhcMod.Doc
|
||||
import Language.Haskell.GhcMod.DynFlags
|
||||
import Language.Haskell.GhcMod.Gap
|
||||
import Language.Haskell.GhcMod.Logging
|
||||
import Language.Haskell.GhcMod.Monad
|
||||
import Language.Haskell.GhcMod.SrcUtils
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Language.Haskell.GhcMod.Utils (mkRevRedirMapFunc)
|
||||
import Language.Haskell.GhcMod.FileMapping (fileModSummaryWithMapping)
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | Obtaining information of a target expression. (GHCi's info:)
|
||||
info :: IOish m
|
||||
=> FilePath -- ^ A target file.
|
||||
-> Expression -- ^ A Haskell expression.
|
||||
-> GhcModT m String
|
||||
info file expr =
|
||||
ghandle handler $
|
||||
runGmlT' [Left file] deferErrors $
|
||||
withInteractiveContext $ do
|
||||
convert' =<< body
|
||||
where
|
||||
handler (SomeException ex) = do
|
||||
gmLog GmException "info" $ text "" $$ nest 4 (showToDoc ex)
|
||||
convert' "Cannot show info"
|
||||
|
||||
body :: (GhcMonad m, GmState m, GmEnv m) => m String
|
||||
body = do
|
||||
m <- mkRevRedirMapFunc
|
||||
sdoc <- Gap.infoThing m expr
|
||||
st <- getStyle
|
||||
dflag <- G.getSessionDynFlags
|
||||
return $ showPage dflag st sdoc
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | Obtaining type of a target expression. (GHCi's type:)
|
||||
types :: IOish m
|
||||
=> Bool -- ^ Include constraints into type signature
|
||||
-> FilePath -- ^ A target file.
|
||||
-> Int -- ^ Line number.
|
||||
-> Int -- ^ Column number.
|
||||
-> GhcModT m String
|
||||
types withConstraints file lineNo colNo =
|
||||
ghandle handler $
|
||||
runGmlT' [Left file] deferErrors $
|
||||
withInteractiveContext $ do
|
||||
crdl <- cradle
|
||||
modSum <- fileModSummaryWithMapping (cradleCurrentDir crdl </> file)
|
||||
srcSpanTypes <- getSrcSpanType withConstraints modSum lineNo colNo
|
||||
dflag <- G.getSessionDynFlags
|
||||
st <- getStyle
|
||||
convert' $ map (toTup dflag st) $ sortBy (cmp `on` fst) srcSpanTypes
|
||||
where
|
||||
handler (SomeException ex) = do
|
||||
gmLog GmException "types" $ showToDoc ex
|
||||
return []
|
||||
|
||||
getSrcSpanType :: (GhcMonad m) => Bool -> G.ModSummary -> Int -> Int -> m [(SrcSpan, G.Type)]
|
||||
getSrcSpanType withConstraints modSum lineNo colNo =
|
||||
G.parseModule modSum
|
||||
>>= G.typecheckModule
|
||||
>>= flip (collectSpansTypes withConstraints) (lineNo, colNo)
|
||||
73
GhcModExe/Internal.hs
Normal file
73
GhcModExe/Internal.hs
Normal file
@@ -0,0 +1,73 @@
|
||||
-- | Low level access to the ghc-mod library.
|
||||
|
||||
module GhcModExe.Internal (
|
||||
-- * Types
|
||||
GHCOption
|
||||
, IncludeDir
|
||||
, GmlT(..)
|
||||
, MonadIO(..)
|
||||
, GmEnv(..)
|
||||
-- * Various Paths
|
||||
, ghcLibDir
|
||||
, ghcModExecutable
|
||||
-- * Logging
|
||||
, withLogger
|
||||
, setNoWarningFlags
|
||||
, setAllWarningFlags
|
||||
-- * Environment, state and logging
|
||||
, GhcModEnv(..)
|
||||
, GhcModState
|
||||
, GhcModLog
|
||||
, GmLog(..)
|
||||
, GmLogLevel(..)
|
||||
, gmSetLogLevel
|
||||
-- * Monad utilities
|
||||
, runGhcModT'
|
||||
, hoistGhcModT
|
||||
, runGmlT
|
||||
, runGmlT'
|
||||
, gmlGetSession
|
||||
, gmlSetSession
|
||||
, loadTargets
|
||||
, cabalResolvedComponents
|
||||
-- ** Accessing 'GhcModEnv' and 'GhcModState'
|
||||
, options
|
||||
, cradle
|
||||
, targetGhcOptions
|
||||
, withOptions
|
||||
-- * 'GhcModError'
|
||||
, gmeDoc
|
||||
-- * World
|
||||
, World
|
||||
, getCurrentWorld
|
||||
, didWorldChange
|
||||
-- * Cabal Helper
|
||||
, ModulePath(..)
|
||||
, GmComponent(..)
|
||||
, GmComponentType(..)
|
||||
, GmModuleGraph(..)
|
||||
, prepareCabalHelper
|
||||
-- * Misc stuff
|
||||
, GHandler(..)
|
||||
, gcatches
|
||||
-- * FileMapping
|
||||
, module Language.Haskell.GhcMod.FileMapping
|
||||
) where
|
||||
|
||||
import GHC.Paths (libdir)
|
||||
|
||||
import Language.Haskell.GhcMod.Target
|
||||
import Language.Haskell.GhcMod.DynFlags
|
||||
import Language.Haskell.GhcMod.Error
|
||||
import Language.Haskell.GhcMod.Logger
|
||||
import Language.Haskell.GhcMod.Logging
|
||||
import Language.Haskell.GhcMod.Monad
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Language.Haskell.GhcMod.Utils
|
||||
import Language.Haskell.GhcMod.World
|
||||
import Language.Haskell.GhcMod.CabalHelper
|
||||
import Language.Haskell.GhcMod.FileMapping
|
||||
|
||||
-- | Obtaining the directory for ghc system libraries.
|
||||
ghcLibDir :: FilePath
|
||||
ghcLibDir = libdir
|
||||
10
GhcModExe/Lang.hs
Normal file
10
GhcModExe/Lang.hs
Normal file
@@ -0,0 +1,10 @@
|
||||
module GhcModExe.Lang where
|
||||
|
||||
import DynFlags (supportedLanguagesAndExtensions)
|
||||
import Language.Haskell.GhcMod.Convert
|
||||
import Language.Haskell.GhcMod.Monad
|
||||
|
||||
-- | Listing language extensions.
|
||||
|
||||
languages :: IOish m => GhcModT m String
|
||||
languages = convert' supportedLanguagesAndExtensions
|
||||
30
GhcModExe/Lint.hs
Normal file
30
GhcModExe/Lint.hs
Normal file
@@ -0,0 +1,30 @@
|
||||
module GhcModExe.Lint where
|
||||
|
||||
import Exception (ghandle)
|
||||
import Control.Exception (SomeException(..))
|
||||
import Language.Haskell.GhcMod.Logger (checkErrorPrefix)
|
||||
import Language.Haskell.GhcMod.Convert
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Language.Haskell.GhcMod.Monad
|
||||
import Language.Haskell.HLint3
|
||||
|
||||
import Language.Haskell.GhcMod.Utils (withMappedFile)
|
||||
import Language.Haskell.Exts.SrcLoc (SrcSpan(..))
|
||||
|
||||
-- | Checking syntax of a target file using hlint.
|
||||
-- Warnings and errors are returned.
|
||||
lint :: IOish m
|
||||
=> LintOpts -- ^ Configuration parameters
|
||||
-> FilePath -- ^ A target file.
|
||||
-> GhcModT m String
|
||||
lint opt file = ghandle handler $
|
||||
withMappedFile file $ \tempfile -> do
|
||||
res <- liftIO $ hlint $ "--quiet" : tempfile : optLintHlintOpts opt
|
||||
pack . map (show . substFile file tempfile) $ res
|
||||
where
|
||||
pack = convert' . map init -- init drops the last \n.
|
||||
handler (SomeException e) = return $ checkErrorPrefix ++ show e ++ "\n"
|
||||
substFile orig temp idea
|
||||
| srcSpanFilename (ideaSpan idea) == temp
|
||||
= idea{ideaSpan=(ideaSpan idea){srcSpanFilename = orig}}
|
||||
substFile _ _ idea = idea
|
||||
27
GhcModExe/Modules.hs
Normal file
27
GhcModExe/Modules.hs
Normal file
@@ -0,0 +1,27 @@
|
||||
module GhcModExe.Modules (modules) where
|
||||
|
||||
import Control.Arrow
|
||||
import Data.List
|
||||
import Language.Haskell.GhcMod.Convert
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Language.Haskell.GhcMod.Monad
|
||||
import Language.Haskell.GhcMod.Gap ( listVisibleModuleNames
|
||||
, lookupModulePackageInAllPackages
|
||||
)
|
||||
|
||||
import qualified GHC as G
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | Listing installed modules.
|
||||
modules :: (IOish m, Gm m)
|
||||
=> Bool -- ^ 'detailed', if 'True', also prints packages that modules belong to.
|
||||
-> m String
|
||||
modules detailed = do
|
||||
df <- runGmPkgGhc G.getSessionDynFlags
|
||||
let mns = listVisibleModuleNames df
|
||||
pmnss = map (first moduleNameString) $ zip mns (modulePkg df `map` mns)
|
||||
convert' $ nub [ if detailed then pkg ++ " " ++ mn else mn
|
||||
| (mn, pkgs) <- pmnss, pkg <- pkgs ]
|
||||
where
|
||||
modulePkg df = lookupModulePackageInAllPackages df
|
||||
29
GhcModExe/PkgDoc.hs
Normal file
29
GhcModExe/PkgDoc.hs
Normal file
@@ -0,0 +1,29 @@
|
||||
module GhcModExe.PkgDoc (pkgDoc) where
|
||||
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Language.Haskell.GhcMod.GhcPkg
|
||||
import Language.Haskell.GhcMod.Monad
|
||||
import Language.Haskell.GhcMod.Output
|
||||
|
||||
import Control.Applicative
|
||||
import Prelude
|
||||
|
||||
-- | Obtaining the package name and the doc path of a module.
|
||||
pkgDoc :: IOish m => String -> GhcModT m String
|
||||
pkgDoc mdl = do
|
||||
ghcPkg <- getGhcPkgProgram
|
||||
readProc <- gmReadProcess
|
||||
pkgDbStack <- getPackageDbStack
|
||||
pkg <- liftIO $ trim <$> readProc ghcPkg (toModuleOpts pkgDbStack) ""
|
||||
if pkg == "" then
|
||||
return "\n"
|
||||
else do
|
||||
htmlpath <- liftIO $ readProc ghcPkg (toDocDirOpts pkg pkgDbStack) ""
|
||||
let ret = pkg ++ " " ++ drop 14 htmlpath
|
||||
return ret
|
||||
where
|
||||
toModuleOpts dbs = ["find-module", mdl, "--simple-output"]
|
||||
++ ghcPkgDbStackOpts dbs
|
||||
toDocDirOpts pkg dbs = ["field", pkg, "haddock-html"]
|
||||
++ ghcPkgDbStackOpts dbs
|
||||
trim = takeWhile (`notElem` " \n")
|
||||
45
GhcModExe/Test.hs
Normal file
45
GhcModExe/Test.hs
Normal file
@@ -0,0 +1,45 @@
|
||||
module GhcModExe.Test where
|
||||
|
||||
import Control.Applicative
|
||||
import Data.List
|
||||
import System.FilePath
|
||||
import System.Directory
|
||||
import Prelude
|
||||
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Language.Haskell.GhcMod.Monad
|
||||
import Language.Haskell.GhcMod.DynFlags
|
||||
|
||||
import GHC
|
||||
import GHC.Exception
|
||||
import OccName
|
||||
|
||||
test :: IOish m
|
||||
=> FilePath -> GhcModT m String
|
||||
test f = runGmlT' [Left f] (fmap setHscInterpreted . deferErrors) $ do
|
||||
mg <- getModuleGraph
|
||||
root <- cradleRootDir <$> cradle
|
||||
f' <- makeRelative root <$> liftIO (canonicalizePath f)
|
||||
let Just ms = find ((==Just f') . ml_hs_file . ms_location) mg
|
||||
mdl = ms_mod ms
|
||||
mn = moduleName mdl
|
||||
|
||||
Just mi <- getModuleInfo mdl
|
||||
let exs = map (occNameString . getOccName) $ modInfoExports mi
|
||||
cqs = filter ("prop_" `isPrefixOf`) exs
|
||||
|
||||
setContext [ IIDecl $ simpleImportDecl mn
|
||||
, IIDecl $ simpleImportDecl $ mkModuleName "Test.QuickCheck"
|
||||
]
|
||||
|
||||
_res <- mapM runTest cqs
|
||||
|
||||
return ""
|
||||
|
||||
runTest :: GhcMonad m => String -> m (Maybe SomeException)
|
||||
runTest fn = do
|
||||
res <- runStmt ("quickCheck " ++ fn) RunToCompletion
|
||||
return $ case res of
|
||||
RunOk [] -> Nothing
|
||||
RunException se -> Just se
|
||||
_ -> error "runTest"
|
||||
Reference in New Issue
Block a user