Initial code generation working
- Added fallback with haskell-src-exts
This commit is contained in:
Alejandro Serrano
parent
90abb89a98
commit
5fa536714f
@ -80,9 +80,9 @@ instance ToString ((Int,Int,Int,Int),String) where
|
||||
toLisp opt x = ('(' :) . tupToString opt x . (')' :)
|
||||
toPlain opt x = tupToString opt x
|
||||
|
||||
instance ToString ((Int,Int,Int,Int),[String]) where
|
||||
toLisp opt (x,y) = toSexp2 $ [('(' :) . fourIntsToString opt x . (')' :), toLisp opt y]
|
||||
toPlain opt (x,y) = inter '\n' [fourIntsToString opt x, toPlain opt y]
|
||||
instance ToString (String, (Int,Int,Int,Int),[String]) where
|
||||
toLisp opt (s,x,y) = toSexp2 $ [toLisp opt s, ('(' :) . fourIntsToString opt x . (')' :), toLisp opt y]
|
||||
toPlain opt (s,x,y) = inter '\n' [toPlain opt s, fourIntsToString opt x, toPlain opt y]
|
||||
|
||||
instance ToString [(Int,Int,Int,Int)] where
|
||||
toLisp opt = toSexp2 . map toS
|
||||
|
||||
@ -19,6 +19,7 @@ import qualified Language.Haskell.GhcMod.Gap as Gap
|
||||
import Language.Haskell.GhcMod.SrcUtils
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Language.Haskell.GhcMod.Convert
|
||||
import MonadUtils (liftIO)
|
||||
import Outputable (PprStyle)
|
||||
import qualified Type as Ty
|
||||
import qualified TyCon as Ty
|
||||
@ -26,6 +27,9 @@ import qualified DataCon as Ty
|
||||
import qualified HsBinds as Ty
|
||||
import qualified Class as Ty
|
||||
import OccName (OccName, occName)
|
||||
import qualified Language.Haskell.Exts.Annotated as HE
|
||||
|
||||
import Debug.Trace
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
@ -54,13 +58,13 @@ splits opt file lineNo colNo = ghandle handler body
|
||||
modSum <- Gap.fileModSummary file
|
||||
splitInfo <- getSrcSpanTypeForSplit modSum lineNo colNo
|
||||
case splitInfo of
|
||||
Nothing -> return ""
|
||||
Nothing -> return $ convert opt ([] :: [String])
|
||||
Just (SplitInfo varName binding var@(_,varT) matches) -> do
|
||||
return $ convert opt $ ( toTup dflag style binding
|
||||
, toTup dflag style var
|
||||
, (map fourInts matches)
|
||||
, getTyCons dflag style varName varT)
|
||||
handler (SomeException _) = return []
|
||||
handler (SomeException _) = return $ convert opt ([] :: [String])
|
||||
|
||||
getSrcSpanTypeForSplit :: G.ModSummary -> Int -> Int -> Ghc (Maybe SplitInfo)
|
||||
getSrcSpanTypeForSplit modSum lineNo colNo = do
|
||||
@ -174,6 +178,8 @@ 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
|
||||
|
||||
data HESigInfo = HESignature HE.SrcSpan [HE.Name HE.SrcSpanInfo] (HE.Type HE.SrcSpanInfo)
|
||||
|
||||
-- | Create a initial body from a signature.
|
||||
fillSig :: Options
|
||||
-> Cradle
|
||||
@ -199,15 +205,30 @@ sig opt file lineNo colNo = ghandle handler body
|
||||
case sigTy of
|
||||
Nothing -> return ""
|
||||
Just (Signature loc names ty) -> do
|
||||
return $ convert opt $ ( fourInts loc
|
||||
return $ convert opt $ ( "function"
|
||||
, fourInts loc
|
||||
, map (initialFnBody dflag style ty) names
|
||||
)
|
||||
|
||||
Just (InstanceDecl loc cls) -> do
|
||||
return $ convert opt $ ( fourInts loc
|
||||
return $ convert opt $ ( "instance"
|
||||
, fourInts loc
|
||||
, map (initialInstBody dflag style) (Ty.classMethods cls)
|
||||
)
|
||||
|
||||
handler (SomeException _) = return ""
|
||||
handler (SomeException _) = do
|
||||
-- Fallback: try to get information via haskell-src-exts
|
||||
sigTy <- getSignatureFromHE file lineNo colNo
|
||||
case sigTy of
|
||||
Just (HESignature loc names ty) -> do
|
||||
return $ convert opt $ ( "function"
|
||||
, (HE.srcSpanStartLine loc
|
||||
,HE.srcSpanStartColumn loc
|
||||
,HE.srcSpanEndLine loc
|
||||
,HE.srcSpanEndColumn loc)
|
||||
, map (initialHEFnBody ty) names
|
||||
)
|
||||
_ -> return $ convert opt ([] :: [String])
|
||||
|
||||
getSignature :: G.ModSummary -> Int -> Int -> Ghc (Maybe SigInfo)
|
||||
getSignature modSum lineNo colNo = do
|
||||
@ -232,7 +253,9 @@ getSignature modSum lineNo colNo = do
|
||||
obtainClassInfo minfo clsName loc
|
||||
_ -> return Nothing
|
||||
_ -> return Nothing
|
||||
where obtainClassInfo minfo clsName loc = do
|
||||
|
||||
obtainClassInfo :: G.ModuleInfo -> G.Name -> SrcSpan -> Ghc (Maybe SigInfo)
|
||||
obtainClassInfo minfo clsName loc = do
|
||||
tyThing <- G.modInfoLookupName minfo clsName
|
||||
case tyThing of
|
||||
Just (Ty.ATyCon clsCon) ->
|
||||
@ -241,6 +264,23 @@ getSignature modSum lineNo colNo = do
|
||||
Nothing -> return Nothing
|
||||
_ -> return Nothing
|
||||
|
||||
getSignatureFromHE :: FilePath -> Int -> Int -> Ghc (Maybe HESigInfo)
|
||||
getSignatureFromHE file lineNo colNo = do
|
||||
presult <- liftIO $ HE.parseFile file
|
||||
case presult of
|
||||
HE.ParseOk (HE.Module _ _ _ _ mdecls) -> do
|
||||
let tsig = find (typeSigInRange lineNo colNo) mdecls
|
||||
case tsig of
|
||||
Just (HE.TypeSig (HE.SrcSpanInfo s _) names ty) ->
|
||||
return $ Just (HESignature s names ty)
|
||||
_ -> return Nothing
|
||||
_ -> return Nothing
|
||||
|
||||
typeSigInRange :: Int -> Int -> HE.Decl HE.SrcSpanInfo -> Bool
|
||||
typeSigInRange lineNo colNo (HE.TypeSig (HE.SrcSpanInfo s _) _ _) =
|
||||
HE.srcSpanStart s <= (lineNo, colNo) && HE.srcSpanEnd s >= (lineNo, colNo)
|
||||
typeSigInRange _ _ _= False
|
||||
|
||||
-- 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
|
||||
@ -278,6 +318,21 @@ initialFnBody dflag style ty name =
|
||||
_ -> False
|
||||
in initialBody fname (args ty)
|
||||
|
||||
initialHEFnBody :: HE.Type HE.SrcSpanInfo -> HE.Name HE.SrcSpanInfo -> String
|
||||
initialHEFnBody ty name =
|
||||
let fname = case name of
|
||||
HE.Ident _ s -> s
|
||||
HE.Symbol _ s -> s
|
||||
args = \case (HE.TyForall _ _ _ iTy) -> args iTy
|
||||
(HE.TyParen _ iTy) -> args iTy
|
||||
(HE.TyFun _ lTy rTy) -> (if fnarg lTy then FnArgFunction else FnArgNormal):args rTy
|
||||
_ -> []
|
||||
fnarg = \case (HE.TyForall _ _ _ iTy) -> fnarg iTy
|
||||
(HE.TyParen _ iTy) -> fnarg iTy
|
||||
(HE.TyFun _ _ _) -> True
|
||||
_ -> False
|
||||
in initialBody fname (args ty)
|
||||
|
||||
initialInstBody :: DynFlags -> PprStyle -> Id -> String
|
||||
initialInstBody dflag style method =
|
||||
let fname = showOccName dflag style $ G.getOccName method -- get function name
|
||||
|
||||
@ -50,13 +50,16 @@
|
||||
(if (null info)
|
||||
(message "Cannot obtain initial code")
|
||||
(let* ((ln-current (line-number-at-pos))
|
||||
(pos (car info))
|
||||
(sort (car info))
|
||||
(pos (cadr info))
|
||||
(ln-end (ghc-sinfo-get-end-line pos))
|
||||
(ln-diff (+ 1 (- ln-end ln-current)))
|
||||
(fns-to-insert (cadr info)))
|
||||
(fns-to-insert (caddr info)))
|
||||
(goto-char (line-end-position ln-diff))
|
||||
(dolist (fn-to-insert fns-to-insert)
|
||||
(newline-and-indent)
|
||||
(if (equal sort "function")
|
||||
(newline)
|
||||
(newline-and-indent))
|
||||
(insert fn-to-insert))))))
|
||||
|
||||
(defun ghc-obtain-initial-code-from-signature ()
|
||||
|
||||
@ -102,6 +102,7 @@ Library
|
||||
, mtl
|
||||
, monad-control
|
||||
, split
|
||||
, haskell-src-exts
|
||||
if impl(ghc < 7.7)
|
||||
Build-Depends: convertible
|
||||
, Cabal >= 1.10 && < 1.17
|
||||
|
||||
Loading…
Reference in New Issue
Block a user