Initial support for adding body from signature

Language/Haskell/GhcMod.hs

@@ -20,6 +20,7 @@ module Language.Haskell.GhcMod (
   , expandTemplate
   , infoExpr
   , typeExpr
+  , fillSig
   , listModules
   , listLanguages
   , listFlags

Language/Haskell/GhcMod/Gap.hs

@@ -25,6 +25,7 @@ module Language.Haskell.GhcMod.Gap (
   , errorMsgSpan
   , typeForUser
   , nameForUser
+  , occNameForUser
   , deSugar
   , showDocWith
   , GapThing(..)
@@ -354,6 +355,13 @@ nameForUser = pprOccName . getOccName
 nameForUser = pprOccName False . getOccName
 #endif
 
+occNameForUser :: OccName -> SDoc
+#if __GLASGOW_HASKELL__ >= 708
+occNameForUser = pprOccName
+#else
+occNameForUser = pprOccName False
+#endif
+
 deSugar :: TypecheckedModule -> LHsExpr Id -> HscEnv
          -> IO (Maybe CoreExpr)
 #if __GLASGOW_HASKELL__ >= 708

Language/Haskell/GhcMod/Ghc.hs

@@ -9,6 +9,7 @@ module Language.Haskell.GhcMod.Ghc (
   , info
   , types
   , splits
+  , sig
   , modules
   -- * 'SymMdlDb'
   , Symbol

Language/Haskell/GhcMod/Info.hs

@@ -8,6 +8,8 @@ module Language.Haskell.GhcMod.Info (
   , types
   , splitVar
   , splits
+  , fillSig
+  , sig
   ) where
 
 import Control.Applicative ((<$>))
@@ -19,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, TypecheckedModule(..), DynFlags, SrcSpan, Type, Located, TypecheckedSource, GenLocated(L))
+import GHC (Ghc, LHsBind, LHsExpr, LPat, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, Located, ParsedSource, TypecheckedSource, GenLocated(L))
 import qualified GHC as G
-import GHC.SYB.Utils (Stage(TypeChecker), everythingStaged)
+import GHC.SYB.Utils (Stage(Parser,TypeChecker), everythingStaged)
 import Language.Haskell.GhcMod.Doc (showPage, showOneLine, getStyle)
 import Language.Haskell.GhcMod.GHCApi
 import Language.Haskell.GhcMod.Gap (HasType(..), setWarnTypedHoles, setDeferTypeErrors)
@@ -33,6 +35,8 @@ import TcHsSyn (hsPatType)
 import qualified Type as Ty
 import qualified TyCon as Ty
 import qualified DataCon as Ty
+import qualified HsBinds as Ty
+import OccName (OccName, occName)
 
 ----------------------------------------------------------------
 
@@ -113,6 +117,11 @@ listifySpans tcs lc = listifyStaged TypeChecker p tcs
   where
     p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc
 
+listifyParsedSpans :: Typeable a => ParsedSource -> (Int, Int) -> [Located a]
+listifyParsedSpans pcs lc = listifyStaged Parser 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]))
 
@@ -268,6 +277,9 @@ newVarsSpecialSingleton v start n = newVars v start n
 showName :: DynFlags -> PprStyle -> G.Name -> String
 showName dflag style name = showOneLine dflag style $ Gap.nameForUser name
 
+showOccName :: DynFlags -> PprStyle -> OccName -> String
+showOccName dflag style name = showOneLine dflag style $ Gap.occNameForUser name
+
 showFieldNames :: DynFlags -> PprStyle -> String -> [G.Name] -> String
 showFieldNames _     _     _ []      = "" -- This should never happen
 showFieldNames dflag style v (x:xs) = let fName = showName dflag style x
@@ -275,3 +287,70 @@ showFieldNames dflag style v (x:xs) = let fName = showName dflag style x
                                        in case xs of
                                             [] -> fAcc
                                             _  -> fAcc ++ ", " ++ showFieldNames dflag style v xs
+
+----------------------------------------------------------------
+
+-- | Create a initial body from a signature.
+fillSig :: Options
+        -> Cradle
+        -> FilePath     -- ^ A target file.
+        -> Int          -- ^ Line number.
+        -> Int          -- ^ Column number.
+        -> IO String
+fillSig opt cradle file lineNo colNo = withGHC' $ do
+    initializeFlagsWithCradle opt cradle
+    sig opt file lineNo colNo
+
+-- | Splitting a variable in a equation.
+sig :: Options
+       -> 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
+        modSum <- Gap.fileModSummary file
+        sigTy <- getSignature modSum lineNo colNo
+        case sigTy of
+          Nothing -> return ""
+          Just (loc, names, ty) -> do
+            return $ convert opt $ ( fourInts loc
+                                   , intercalate "\n" (map (initialBody dflag style ty) names)
+                                   )
+    handler (SomeException _) = return ""
+
+getSignature :: G.ModSummary -> Int -> Int -> Ghc (Maybe (SrcSpan, [G.RdrName], G.HsType G.RdrName))
+getSignature modSum lineNo colNo = do
+    ParsedModule{pm_parsed_source = ps} <- G.parseModule modSum
+    -- TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p
+    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
+
+initialBody :: DynFlags -> PprStyle -> G.HsType G.RdrName -> G.RdrName -> String
+initialBody dflag style ty name = 
+  let fName = showOccName dflag style $ occName name  -- get function name
+      args  = initialArgs infiniteVars infiniteFns ty
+  in fName ++ " " ++ args ++ " = _" ++ fName ++ "_body"
+
+initialArgs :: [String] -> [String] -> G.HsType G.RdrName -> String
+-- Contexts and foralls: continue inside
+initialArgs vars fns (G.HsForAllTy _ _ _ (L _ ty)) =
+  initialArgs vars fns ty
+-- Function whose first argument is another function
+initialArgs vars (f:fs) (G.HsFunTy (L _ (G.HsFunTy _ _)) (L _ rTy)) =
+  f ++ " " ++ initialArgs vars fs rTy
+-- Function whose first argument is not another function
+initialArgs (v:vs) fns (G.HsFunTy _ (L _ rTy)) =
+  v ++ " " ++ initialArgs vs fns rTy
+-- Rest of the cases: just write a variable
+initialArgs (v:_) _ _ = v
+-- Lists are infinite, so this should never happen
+initialArgs _ _ _ = error "this should never happen"
+
+infiniteVars, infiniteFns :: [String]
+infiniteVars = infiniteSupply ["x","y","z","t","u","v","w"]
+infiniteFns  = infiniteSupply ["f","g","h"]
+infiniteSupply :: [String] -> [String]
+infiniteSupply initialSupply = initialSupply ++ concatMap (\n -> map (\v -> v ++ show n) initialSupply) ([1 .. ] :: [Integer])

src/GHCMod.hs

@@ -39,6 +39,7 @@ usage =    progVersion
         ++ "\t ghc-mod info" ++ ghcOptHelp ++ "<HaskellFile> <module> <expression>\n"
         ++ "\t ghc-mod type" ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"
         ++ "\t ghc-mod split" ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"
+        ++ "\t ghc-mod sig" ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"
         ++ "\t ghc-mod find <symbol>\n"
         ++ "\t ghc-mod lint [-h opt] <HaskellFile>\n"
         ++ "\t ghc-mod root\n"
@@ -121,6 +122,7 @@ main = flip E.catches handlers $ do
       "info"    -> nArgs 3 infoExpr opt cradle cmdArg1 cmdArg3
       "type"    -> nArgs 4 $ typeExpr opt cradle cmdArg1 (read cmdArg3) (read cmdArg4)
       "split"   -> nArgs 4 $ splitVar opt cradle cmdArg1 (read cmdArg3) (read cmdArg4)
+      "sig"     -> nArgs 4 $ fillSig opt cradle cmdArg1 (read cmdArg3) (read cmdArg4)
       "find"    -> runGhcMod opt $ nArgs 1 $ findSymbol cmdArg1
       "lint"    -> nArgs 1 withFile (lintSyntax opt) cmdArg1
       "root"    -> rootInfo opt cradle

src/GHCModi.hs

@@ -145,6 +145,7 @@ loop opt set mvar = do
         "info"   -> toGhcMod $ showInfo opt set arg
         "type"   -> toGhcMod $ showType opt set arg
         "split"  -> toGhcMod $ doSplit  opt set arg
+        "sig"    -> toGhcMod $ doSig    opt set arg
         "boot"   -> bootIt set
         "browse" -> browseIt set arg
         "quit"   -> return ("quit", False, set)
@@ -265,6 +266,16 @@ doSplit opt set fileArg  = do
     ret <- splits opt file (read line) (read column)
     return (ret, True, set')
 
+doSig :: Options
+      -> Set FilePath
+      -> FilePath
+      -> Ghc (String, Bool, Set FilePath)
+doSig opt set fileArg  = do
+    let [file, line, column] = words fileArg
+    set' <- newFileSet set file
+    ret <- sig opt file (read line) (read column)
+    return (ret, True, set')
+
 ----------------------------------------------------------------
 
 bootIt :: Set FilePath