Initial implementation of instance completion
This commit is contained in:
Alejandro Serrano
parent
4f8d30aa06
commit
585c28f928
|
|
@ -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)
|
||||
_ -> return Nothing
|
||||
[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"]
|
||||
|
|
|
|||
Loading…
Reference in New Issue