diff --git a/Language/Haskell/GhcMod/Convert.hs b/Language/Haskell/GhcMod/Convert.hs index 118981f..7e24217 100644 --- a/Language/Haskell/GhcMod/Convert.hs +++ b/Language/Haskell/GhcMod/Convert.hs @@ -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 diff --git a/Language/Haskell/GhcMod/Rewrite.hs b/Language/Haskell/GhcMod/Rewrite.hs index 488fd38..bdbc6ae 100644 --- a/Language/Haskell/GhcMod/Rewrite.hs +++ b/Language/Haskell/GhcMod/Rewrite.hs @@ -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 @@ -187,10 +193,10 @@ fillSig opt cradle file lineNo colNo = withGHC' $ do -- | Splitting a variable in a equation. sig :: Options - -> FilePath -- ^ A target file. - -> Int -- ^ Line number. - -> Int -- ^ Column number. - -> Ghc String + -> FilePath -- ^ A target file. + -> Int -- ^ Line number. + -> Int -- ^ Column number. + -> Ghc String sig opt file lineNo colNo = ghandle handler body where body = inModuleContext file $ \dflag style -> do @@ -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,14 +253,33 @@ getSignature modSum lineNo colNo = do obtainClassInfo minfo clsName loc _ -> return Nothing _ -> return Nothing - where obtainClassInfo minfo clsName loc = 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 + +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) -> + case G.tyConClass_maybe clsCon of + Just cls -> return $ Just $ InstanceDecl loc cls + 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 @@ -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 diff --git a/elisp/ghc-rewrite.el b/elisp/ghc-rewrite.el index 2354b4d..05384d6 100644 --- a/elisp/ghc-rewrite.el +++ b/elisp/ghc-rewrite.el @@ -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 () diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 685f521..e65f30d 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -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