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

Initial implementation of instance completion

Browse Source
This commit is contained in:
Alejandro Serrano 2014-06-11 22:01:43 +02:00
parent 4f8d30aa06
commit 585c28f928
1 changed files with 63 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -21,9 +21,9 @@ import Data.List (find, intercalate, sortBy)
import Data.Maybe (catMaybes, fromMaybe)
import Data.Ord as O
import Exception (ghandle, SomeException(..))
import GHC (Ghc, LHsBind, LHsExpr, LPat, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, Located, ParsedSource, TypecheckedSource, GenLocated(L))
import GHC (Ghc, LHsBind, LHsExpr, LPat, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, Located, ParsedSource, RenamedSource, TypecheckedSource, GenLocated(L))
import qualified GHC as G
import GHC.SYB.Utils (Stage(Parser,TypeChecker), everythingStaged)
import GHC.SYB.Utils (Stage(..), everythingStaged, showData)
import Language.Haskell.GhcMod.Doc (showPage, showOneLine, getStyle)
import Language.Haskell.GhcMod.GHCApi
import Language.Haskell.GhcMod.Gap (HasType(..), setWarnTypedHoles, setDeferTypeErrors)
@ -36,6 +36,7 @@ import qualified Type as Ty
import qualified TyCon as Ty
import qualified DataCon as Ty
import qualified HsBinds as Ty
import qualified Class as Ty
import OccName (OccName, occName)
----------------------------------------------------------------
@ -122,6 +123,11 @@ 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]))
@ -290,6 +296,9 @@ showFieldNames dflag style v (x:xs) = let fName = showName dflag style x
----------------------------------------------------------------
data SigInfo = Signature SrcSpan [G.RdrName] (G.HsType G.RdrName)
| InstanceDecl SrcSpan G.Class
-- | Create a initial body from a signature.
fillSig :: Options
-> Cradle
@ -314,19 +323,43 @@ sig opt file lineNo colNo = ghandle handler body
sigTy <- getSignature modSum lineNo colNo
case sigTy of
Nothing -> return ""
Just (loc, names, ty) -> do
Just (Signature loc names ty) -> do
return $ convert opt $ ( fourInts loc
, intercalate "\n" (map (initialBody dflag style ty) names)
, intercalate "\n"
(map (initialBody dflag style ty) names)
)
Just (InstanceDecl loc cls) -> do
return $ convert opt $ ( fourInts loc
, intercalate "\n"
(map (initialInstanceBody dflag style) (Ty.classMethods cls))
)
handler (SomeException _) = return ""
getSignature :: G.ModSummary -> Int -> Int -> Ghc (Maybe (SrcSpan, [G.RdrName], G.HsType G.RdrName))
getSignature :: G.ModSummary -> Int -> Int -> Ghc (Maybe SigInfo)
getSignature modSum lineNo colNo = do
ParsedModule{pm_parsed_source = ps} <- G.parseModule modSum
-- TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p
p@ParsedModule{pm_parsed_source = ps} <- G.parseModule modSum
-- Look into 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)))] -> return $ Just (loc, map G.unLoc names, ty)
[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
[L loc (G.ClsInstD (G.ClsInstDecl {G.cid_poly_ty =
(L _ (G.HsForAllTy _ _ _ (L _ (G.HsAppTy (L _ (G.HsTyVar clsName)) _))))}))] -> do
tyThing <- G.modInfoLookupName minfo clsName
case tyThing of
Just (Ty.ATyCon clsCon) ->
case G.tyConClass_maybe clsCon of
Just cls -> return $ Just $ InstanceDecl loc cls
Nothing -> return Nothing
_ -> return Nothing
_ -> return Nothing
_ ->return Nothing
initialBody :: DynFlags -> PprStyle -> G.HsType G.RdrName -> G.RdrName -> String
initialBody dflag style ty name =
@ -334,7 +367,7 @@ initialBody dflag style ty name =
args = initialArgs infiniteVars infiniteFns ty
in fName ++ " " ++ args ++ " = _" ++ fName ++ "_body"
initialArgs :: [String] -> [String] -> G.HsType G.RdrName -> String
initialArgs :: [String] -> [String] -> G.HsType a -> String
-- Contexts and foralls: continue inside
initialArgs vars fns (G.HsForAllTy _ _ _ (L _ ty)) =
initialArgs vars fns ty
@ -349,6 +382,26 @@ initialArgs (v:_) _ _ = v
-- Lists are infinite, so this should never happen
initialArgs _ _ _ = error "this should never happen"
initialInstanceBody :: DynFlags -> PprStyle -> Id -> String
initialInstanceBody dflag style method =
let fName = showOccName dflag style $ G.getOccName method -- get function name
args = initialInstanceArgs infiniteVars infiniteFns (G.idType method)
in fName ++ " " ++ args ++ " = _" ++ fName ++ "_body"
initialInstanceArgs :: [String] -> [String] -> G.Type -> String
-- Contexts and foralls: continue inside
initialInstanceArgs vars fns ty | Just (_,iTy) <- Ty.splitForAllTy_maybe ty =
initialInstanceArgs vars fns iTy
-- Function whose first argument is another function
initialInstanceArgs (v:vs) (f:fs) ty | Just (argTy,rTy) <- Ty.splitFunTy_maybe ty =
case Ty.splitFunTy_maybe argTy of
Just _ -> f ++ " " ++ initialInstanceArgs (v:vs) fs rTy
Nothing -> v ++ " " ++ initialInstanceArgs vs (f:fs) rTy
-- Rest of the cases: just write a variable
initialInstanceArgs (v:_) _ _ = v
-- Lists are infinite, so this should never happen
initialInstanceArgs _ _ _ = error "this should never happen"
infiniteVars, infiniteFns :: [String]
infiniteVars = infiniteSupply ["x","y","z","t","u","v","w"]
infiniteFns = infiniteSupply ["f","g","h"]