Initial code generation working

- Added fallback with haskell-src-exts

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
+instance ToString (String, (Int,Int,Int,Int),[String]) where
-    toLisp  opt (x,y) = toSexp2 $ [('(' :) . fourIntsToString opt x . (')' :), toLisp opt y]
+    toLisp  opt (s,x,y) = toSexp2 $ [toLisp opt s, ('(' :) . fourIntsToString opt x . (')' :), toLisp opt y]
-    toPlain opt (x,y) = inter '\n' [fourIntsToString opt x, toPlain 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

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.
+    -> FilePath     -- ^ A target file.
-       -> Int          -- ^ Line number.
+    -> Int          -- ^ Line number.
-       -> Int          -- ^ Column number.
+    -> Int          -- ^ Column number.
-       -> Ghc String
+    -> 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
+obtainClassInfo :: G.ModuleInfo -> G.Name -> SrcSpan -> Ghc (Maybe SigInfo)
-               case tyThing of
+obtainClassInfo minfo clsName loc = do
-                 Just (Ty.ATyCon clsCon) -> 
+  tyThing <- G.modInfoLookupName minfo clsName
-                   case G.tyConClass_maybe clsCon of
+  case tyThing of
-                     Just cls -> return $ Just $ InstanceDecl loc cls
+    Just (Ty.ATyCon clsCon) -> 
-                     Nothing  -> return Nothing
+      case G.tyConClass_maybe clsCon of
-                 _ -> return Nothing
+        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

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 ()

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