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

Merge pull request #296 from serras/master

Browse Source 
Add refinement and better support for typed holes in Emacs mode
This commit is contained in:
Kazu Yamamoto
2014-08-01 15:14:50 +09:00
parent e42c066035 e3853a49f1
commit d1daf6def9
12 changed files with 391 additions and 45 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
Language/Haskell/GhcMod.hs
View File

@@ -35,6 +35,7 @@ module Language.Haskell.GhcMod (
, types
, splits
, sig
, refine
, modules
, languages
, flags

44
Language/Haskell/GhcMod/CaseSplit.hs
View File

@@ -5,18 +5,20 @@ module Language.Haskell.GhcMod.CaseSplit (
) where
import CoreMonad (liftIO)
import Data.List (find, intercalate)
import Data.Function (on)
import Data.List (find, intercalate, sortBy)
import Data.Maybe (isJust)
import qualified Data.Text as T
import qualified Data.Text.IO as T (readFile)
import qualified DataCon as Ty
import Exception (ghandle, SomeException(..))
import GHC (GhcMonad, LHsBind, LPat, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L))
import GHC (GhcMonad, LPat, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L))
import qualified GHC as G
import Language.Haskell.GhcMod.Convert
import qualified Language.Haskell.GhcMod.Gap as Gap
import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.SrcUtils
import Outputable (PprStyle)
import Outputable (ppr, PprStyle)
import qualified TyCon as Ty
import qualified Type as Ty
@@ -24,7 +26,8 @@ import qualified Type as Ty
-- CASE SPLITTING
----------------------------------------------------------------
data SplitInfo = SplitInfo G.Name (SrcSpan,Type) (SrcSpan, Type) [SrcSpan]
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
@@ -42,8 +45,13 @@ splits file lineNo colNo = ghandle handler body
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
whenFound' opt (getSrcSpanTypeForSplit modSum lineNo colNo) $ \x -> case x of
(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)
(TySplitInfo varName bndLoc (varLoc,varT)) -> do
let varName' = showName dflag style varName -- Convert name to string
text <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $
getTyCons dflag style varName varT)
@@ -55,20 +63,26 @@ splits file lineNo colNo = ghandle handler body
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 bs:_ = listifySpans tcs (lineNo, colNo) :: [LHsBind Id]
varPat = find isPatternVar $ listifySpans tcs (lineNo, colNo) :: Maybe (LPat Id)
let varPat = find isPatternVar $ listifySpans tcs (lineNo, colNo) :: Maybe (LPat Id)
match:_ = listifyParsedSpans pms (lineNo, colNo) :: [Gap.GLMatch]
case varPat of
Nothing -> return Nothing
Just varPat' -> do
varT <- Gap.getType tcm varPat' -- Finally we get the type of the var
bsT <- Gap.getType tcm bs
case (varT, bsT) of
(Just varT', Just (_,bsT')) ->
case varT of
Just varT' ->
let (L matchL (G.Match _ _ (G.GRHSs rhsLs _))) = match
in return $ Just (SplitInfo (getPatternVarName varPat') (matchL,bsT') varT' (map G.getLoc rhsLs) )
in return $ Just (SplitInfo (getPatternVarName varPat') matchL varT' (map G.getLoc rhsLs) )
_ -> return Nothing
isPatternVar :: LPat Id -> Bool
@@ -77,7 +91,11 @@ isPatternVar _ = False
getPatternVarName :: LPat Id -> G.Name
getPatternVarName (L _ (G.VarPat vName)) = G.getName vName
getPatternVarName _ = error "This should never happend"
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

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

@@ -34,7 +34,9 @@ checkSyntax files = withErrorHandler sessionName $
check :: IOish m
=> [FilePath] -- ^ The target files.
-> GhcModT m (Either String String)
check fileNames = withLogger setAllWaringFlags $ setTargetFiles fileNames
check fileNames =
withLogger (setAllWaringFlags . setNoMaxRelevantBindings) $
setTargetFiles fileNames
----------------------------------------------------------------

10
Language/Haskell/GhcMod/DynFlags.hs
View File

@@ -1,3 +1,5 @@
{-# LANGUAGE CPP #-}
module Language.Haskell.GhcMod.DynFlags where
import Control.Applicative ((<$>))
@@ -109,3 +111,11 @@ allWarningFlags = unsafePerformIO $
return $ G.warningFlags df'
----------------------------------------------------------------
-- | Set 'DynFlags' equivalent to "-fno-max-relevant-bindings".
setNoMaxRelevantBindings :: DynFlags -> DynFlags
#if __GLASGOW_HASKELL__ >= 708
setNoMaxRelevantBindings df = df { maxRelevantBinds = Nothing }
#else
setNoMaxRelevantBindings = id
#endif

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

@@ -2,10 +2,13 @@
module Language.Haskell.GhcMod.FillSig (
sig
, refine
) where
import Data.Char (isSymbol)
import Data.List (find)
import Data.Function (on)
import Data.List (find, sortBy)
import Data.Maybe (isJust)
import Exception (ghandle, SomeException(..))
import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L))
import qualified GHC as G
@@ -13,6 +16,7 @@ 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 CoreMonad (liftIO)
import Outputable (PprStyle)
import qualified Type as Ty
@@ -27,9 +31,17 @@ import qualified Language.Haskell.Exts.Annotated as HE
-- 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
@@ -48,14 +60,20 @@ sig file lineNo colNo = ghandle handler body
InstanceDecl loc cls ->
("instance", fourInts loc, map (\x -> initialBody dflag style (G.idType x) x)
(Ty.classMethods cls))
TyFamDecl loc name flavour vars ->
let (rTy, initial) = initialTyFamString flavour
in (rTy, fourInts loc, [initial ++ initialFamBody dflag style name vars])
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)
whenFound opt (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
@@ -73,9 +91,37 @@ getSignature modSum lineNo colNo = do
-- We found an instance declaration
TypecheckedModule{tm_renamed_source = Just tcs
,tm_checked_module_info = minfo} <- G.typecheckModule p
case Gap.getClass $ listifyRenamedSpans tcs (lineNo, colNo) of
let lst = listifyRenamedSpans tcs (lineNo, colNo)
case Gap.getClass lst of
Just (clsName,loc) -> obtainClassInfo minfo clsName loc
Nothing -> return Nothing
_ -> return Nothing
#if __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__ >= 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
@@ -90,35 +136,62 @@ 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
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 _) (HE.DHead _ name tys) _ ->
return $ HEFamSignature s Open name (map cleanTyVarBind tys)
HE.DataFamDecl (HE.SrcSpanInfo s _) _ (HE.DHead _ name tys) _ ->
return $ HEFamSignature s Open name (map cleanTyVarBind tys)
_ -> Nothing
where cleanTyVarBind (HE.KindedVar _ n _) = n
cleanTyVarBind (HE.UnkindedVar _ n) = n
----------------------------------------------------------------
-- 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
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 =
initialBody' fname args = initialHead fname args ++ " = "
++ (if isSymbolName fname then "" else '_':fname) ++ "_body"
initialFamBody :: FnArgsInfo ty name => DynFlags -> PprStyle -> name -> [name] -> String
initialFamBody dflag style name args = initialHead (getFnName dflag style name)
(map (\arg -> FnExplicitName (getFnName dflag style arg)) 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
++ " = " ++ (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 (FnExplicitName n:xs) vs fs = n : initialBodyArgs xs vs fs
initialBodyArgs _ _ _ = error "This should never happen" -- Lists are infinite
initialHead1 :: String -> [FnArg] -> [String] -> String
initialHead1 fname args elts =
case initialBodyArgs1 args elts of
[] -> fname
arglist -> if isSymbolName fname
then head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist)
else fname ++ " " ++ unwords arglist
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)
@@ -174,3 +247,66 @@ infiniteSupply initialSupply = initialSupply ++ concatMap (\n -> map (\v -> v ++
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 expr = ghandle handler body
where
body = inModuleContext file $ \dflag style -> do
opt <- options
modSum <- Gap.fileModSummary file
p <- G.parseModule modSum
tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p
ety <- G.exprType expr
whenFound opt (findVar dflag style tcm tcs lineNo colNo) $ \(loc, name, rty, paren) ->
let eArgs = getFnArgs ety
rArgs = getFnArgs rty
diffArgs' = length eArgs - length rArgs
diffArgs = if diffArgs' < 0 then 0 else diffArgs'
iArgs = take diffArgs eArgs
text = initialHead1 expr iArgs (infinitePrefixSupply name)
in (fourInts loc, doParen paren text)
handler (SomeException _) = emptyResult =<< options
-- Look for the variable in the specified position
findVar :: GhcMonad m => DynFlags -> PprStyle
-> G.TypecheckedModule -> G.TypecheckedSource
-> Int -> Int -> m (Maybe (SrcSpan, String, Type, Bool))
findVar dflag style tcm tcs lineNo colNo =
let lst = sortBy (cmp `on` G.getLoc) $ listifySpans tcs (lineNo, colNo) :: [G.LHsExpr Id]
in case lst of
e@(L _ (G.HsVar i)):others ->
do tyInfo <- Gap.getType tcm e
let name = getFnName dflag style i
if (name == "undefined" || head name == '_') && isJust tyInfo
then let Just (s,t) = tyInfo
b = case others of -- If inside an App, we need parenthesis
[] -> False
(L _ (G.HsApp (L _ a1) (L _ a2))):_ ->
isSearchedVar i a1 || isSearchedVar i a2
_ -> False
in return $ Just (s, name, t, b)
else return Nothing
_ -> return Nothing
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
isSearchedVar i (G.HsVar i2) = i == i2
isSearchedVar _ _ = False

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

@@ -72,7 +72,11 @@ fourIntsHE loc = ( HE.srcSpanStartLine loc, HE.srcSpanStartColumn 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 _) _ _) =
typeSigInRangeHE lineNo colNo (HE.TypeSig (HE.SrcSpanInfo s _) _ _) =
HE.srcSpanStart s <= (lineNo, colNo) && HE.srcSpanEnd s >= (lineNo, colNo)
typeSigInRangeHE lineNo colNo (HE.TypeFamDecl (HE.SrcSpanInfo s _) _ _) =
HE.srcSpanStart s <= (lineNo, colNo) && HE.srcSpanEnd s >= (lineNo, colNo)
typeSigInRangeHE lineNo colNo (HE.DataFamDecl (HE.SrcSpanInfo s _) _ _ _) =
HE.srcSpanStart s <= (lineNo, colNo) && HE.srcSpanEnd s >= (lineNo, colNo)
typeSigInRangeHE _ _ _= False