Initial support for adding body from signature

This commit is contained in:
Alejandro Serrano 2014-06-10 21:34:05 +02:00
parent cedf59ace7
commit 323c1b5471
6 changed files with 104 additions and 2 deletions

View File

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

View File

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

View File

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

View File

@ -8,6 +8,8 @@ module Language.Haskell.GhcMod.Info (
, types , types
, splitVar , splitVar
, splits , splits
, fillSig
, sig
) where ) where
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
@ -19,9 +21,9 @@ import Data.List (find, intercalate, sortBy)
import Data.Maybe (catMaybes, fromMaybe) import Data.Maybe (catMaybes, fromMaybe)
import Data.Ord as O import Data.Ord as O
import Exception (ghandle, SomeException(..)) 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 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.Doc (showPage, showOneLine, getStyle)
import Language.Haskell.GhcMod.GHCApi import Language.Haskell.GhcMod.GHCApi
import Language.Haskell.GhcMod.Gap (HasType(..), setWarnTypedHoles, setDeferTypeErrors) import Language.Haskell.GhcMod.Gap (HasType(..), setWarnTypedHoles, setDeferTypeErrors)
@ -33,6 +35,8 @@ import TcHsSyn (hsPatType)
import qualified Type as Ty import qualified Type as Ty
import qualified TyCon as Ty import qualified TyCon as Ty
import qualified DataCon 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 where
p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc 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 :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r]
listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x])) 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 :: DynFlags -> PprStyle -> G.Name -> String
showName dflag style name = showOneLine dflag style $ Gap.nameForUser name 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 :: DynFlags -> PprStyle -> String -> [G.Name] -> String
showFieldNames _ _ _ [] = "" -- This should never happen showFieldNames _ _ _ [] = "" -- This should never happen
showFieldNames dflag style v (x:xs) = let fName = showName dflag style x 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 in case xs of
[] -> fAcc [] -> fAcc
_ -> fAcc ++ ", " ++ showFieldNames dflag style v xs _ -> 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])

View File

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

View File

@ -145,6 +145,7 @@ loop opt set mvar = do
"info" -> toGhcMod $ showInfo opt set arg "info" -> toGhcMod $ showInfo opt set arg
"type" -> toGhcMod $ showType opt set arg "type" -> toGhcMod $ showType opt set arg
"split" -> toGhcMod $ doSplit opt set arg "split" -> toGhcMod $ doSplit opt set arg
"sig" -> toGhcMod $ doSig opt set arg
"boot" -> bootIt set "boot" -> bootIt set
"browse" -> browseIt set arg "browse" -> browseIt set arg
"quit" -> return ("quit", False, set) "quit" -> return ("quit", False, set)
@ -265,6 +266,16 @@ doSplit opt set fileArg = do
ret <- splits opt file (read line) (read column) ret <- splits opt file (read line) (read column)
return (ret, True, set') 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 bootIt :: Set FilePath