diff --git a/Language/Haskell/GhcMod.hs b/Language/Haskell/GhcMod.hs index b536024..5f201bb 100644 --- a/Language/Haskell/GhcMod.hs +++ b/Language/Haskell/GhcMod.hs @@ -20,6 +20,7 @@ module Language.Haskell.GhcMod ( , expandTemplate , infoExpr , typeExpr + , fillSig , listModules , listLanguages , listFlags diff --git a/Language/Haskell/GhcMod/Gap.hs b/Language/Haskell/GhcMod/Gap.hs index c594161..ae5333a 100644 --- a/Language/Haskell/GhcMod/Gap.hs +++ b/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 diff --git a/Language/Haskell/GhcMod/Ghc.hs b/Language/Haskell/GhcMod/Ghc.hs index 476b95f..311053c 100644 --- a/Language/Haskell/GhcMod/Ghc.hs +++ b/Language/Haskell/GhcMod/Ghc.hs @@ -9,6 +9,7 @@ module Language.Haskell.GhcMod.Ghc ( , info , types , splits + , sig , modules -- * 'SymMdlDb' , Symbol diff --git a/Language/Haskell/GhcMod/Info.hs b/Language/Haskell/GhcMod/Info.hs index 9c27e7f..ca71f17 100644 --- a/Language/Haskell/GhcMod/Info.hs +++ b/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]) diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 8fda9b6..a2958e6 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -39,6 +39,7 @@ usage = progVersion ++ "\t ghc-mod info" ++ ghcOptHelp ++ " \n" ++ "\t ghc-mod type" ++ ghcOptHelp ++ " \n" ++ "\t ghc-mod split" ++ ghcOptHelp ++ " \n" + ++ "\t ghc-mod sig" ++ ghcOptHelp ++ " \n" ++ "\t ghc-mod find \n" ++ "\t ghc-mod lint [-h opt] \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 diff --git a/src/GHCModi.hs b/src/GHCModi.hs index 664c1b7..5c01108 100644 --- a/src/GHCModi.hs +++ b/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