From 2ab6991d95ed720f0a90c4681405bacdd4071901 Mon Sep 17 00:00:00 2001 From: Alejandro Serrano Date: Fri, 27 Jun 2014 18:38:15 +0200 Subject: [PATCH] Move code to new FillSig module - Clean up a lot of code --- Language/Haskell/GhcMod.hs | 3 +- .../GhcMod/{Rewrite.hs => CaseSplit.hs} | 196 +----------------- Language/Haskell/GhcMod/Convert.hs | 10 +- Language/Haskell/GhcMod/FillSig.hs | 194 +++++++++++++++++ Language/Haskell/GhcMod/Ghc.hs | 3 +- Language/Haskell/GhcMod/SrcUtils.hs | 20 ++ ghc-mod.cabal | 3 +- 7 files changed, 234 insertions(+), 195 deletions(-) rename Language/Haskell/GhcMod/{Rewrite.hs => CaseSplit.hs} (53%) create mode 100644 Language/Haskell/GhcMod/FillSig.hs diff --git a/Language/Haskell/GhcMod.hs b/Language/Haskell/GhcMod.hs index 379bba7..4f081db 100644 --- a/Language/Haskell/GhcMod.hs +++ b/Language/Haskell/GhcMod.hs @@ -43,5 +43,6 @@ import Language.Haskell.GhcMod.Lang import Language.Haskell.GhcMod.Lint import Language.Haskell.GhcMod.List import Language.Haskell.GhcMod.PkgDoc -import Language.Haskell.GhcMod.Rewrite +import Language.Haskell.GhcMod.FillSig +import Language.Haskell.GhcMod.CaseSplit import Language.Haskell.GhcMod.Types diff --git a/Language/Haskell/GhcMod/Rewrite.hs b/Language/Haskell/GhcMod/CaseSplit.hs similarity index 53% rename from Language/Haskell/GhcMod/Rewrite.hs rename to Language/Haskell/GhcMod/CaseSplit.hs index 3b62783..3ebaab8 100644 --- a/Language/Haskell/GhcMod/Rewrite.hs +++ b/Language/Haskell/GhcMod/CaseSplit.hs @@ -1,10 +1,9 @@ -{-# LANGUAGE LambdaCase, RecordWildCards #-} +{-# LANGUAGE LambdaCase, RecordWildCards + , MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} -module Language.Haskell.GhcMod.Rewrite ( +module Language.Haskell.GhcMod.CaseSplit ( splitVar , splits - , fillSig - , sig ) where import Data.Char (isSymbol) @@ -31,6 +30,8 @@ import qualified Class as Ty import OccName (OccName, occName) import qualified Language.Haskell.Exts.Annotated as HE +---------------------------------------------------------------- +-- CASE SPLITTING ---------------------------------------------------------------- data SplitInfo = SplitInfo G.Name (SrcSpan,Type) (SrcSpan, Type) [SrcSpan] @@ -170,12 +171,6 @@ newVarsSpecialSingleton :: String -> Int -> Int -> String newVarsSpecialSingleton v _ 1 = v 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 @@ -227,184 +222,3 @@ replaceVarWithTyCon text (vsl,vsc,_,vec) varname tycon = then T.take vsc line `T.append` tycon'' `T.append` T.drop vec line else T.replicate spacesToAdd (T.pack " ") `T.append` line) [0 ..] text ----------------------------------------------------------------- - -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 - -> 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 $ convert opt ([] :: [String]) - Just (Signature loc names ty) -> do - return $ convert opt $ ( "function" - , fourInts loc - , map (initialFnBody dflag style ty) names - ) - - Just (InstanceDecl loc cls) -> do - return $ convert opt $ ( "instance" - , fourInts loc - , map (initialInstBody dflag style) (Ty.classMethods cls) - ) - - 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 - p@ParsedModule{pm_parsed_source = ps} <- G.parseModule modSum - -- Look into the parse tree to find the signature - case listifyParsedSpans ps (lineNo, colNo) :: [G.LHsDecl G.RdrName] of - [L loc (G.SigD (Ty.TypeSig names (L _ ty)))] -> - -- We found a type signature - return $ Just $ Signature loc (map G.unLoc names) ty - [L _ (G.InstD _)] -> do - -- We found an instance declaration - TypecheckedModule{tm_renamed_source = Just tcs - ,tm_checked_module_info = minfo} <- G.typecheckModule p - case listifyRenamedSpans tcs (lineNo, colNo) :: [G.LInstDecl G.Name] of - -- Instance declarations of sort 'instance F (G a)' - [L loc (G.ClsInstD (G.ClsInstDecl {G.cid_poly_ty = - (L _ (G.HsForAllTy _ _ _ (L _ (G.HsAppTy (L _ (G.HsTyVar clsName)) _))))}))] -> - obtainClassInfo minfo clsName loc - -- Instance declarations of sort 'instance F G' (no variables) - [L loc (G.ClsInstD (G.ClsInstDecl {G.cid_poly_ty = - (L _ (G.HsAppTy (L _ (G.HsTyVar clsName)) _))}))] -> - obtainClassInfo minfo clsName loc - _ -> 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 -data FnArg = FnArgFunction | FnArgNormal - -initialBody :: String -> [FnArg] -> String -initialBody fname args = - case initialBodyArgs args infiniteVars infiniteFns of - [] -> fname - arglist -> if isSymbolName fname - then (head arglist) ++ " " ++ fname ++ " " ++ (intercalate " " (tail arglist)) - else fname ++ " " ++ (intercalate " " arglist) - ++ " = " ++ (if isSymbolName fname then "" else '_':fname) ++ "_body" - -initialBodyArgs :: [FnArg] -> [String] -> [String] -> [String] -initialBodyArgs [] _ _ = [] -initialBodyArgs (FnArgFunction:xs) vs (f:fs) = f : initialBodyArgs xs vs fs -initialBodyArgs (FnArgNormal:xs) (v:vs) fs = v : initialBodyArgs xs vs fs -initialBodyArgs _ _ _ = error "This should never happen" -- Lists are infinite - --- Getting the initial body of function and instances differ --- This is because for functions we only use the parsed file --- (so the full file doesn't have to be type correct) --- but for instances we need to get information about the class - -initialFnBody :: DynFlags -> PprStyle -> G.HsType G.RdrName -> G.RdrName -> String -initialFnBody dflag style ty name = - let fname = showOccName dflag style $ occName name -- get function name - args = \case (G.HsForAllTy _ _ _ (L _ iTy)) -> args iTy - (G.HsParTy (L _ iTy)) -> args iTy - (G.HsFunTy (L _ lTy) (L _ rTy)) -> (if fnarg lTy then FnArgFunction else FnArgNormal):args rTy - _ -> [] - fnarg = \case (G.HsForAllTy _ _ _ (L _ iTy)) -> fnarg iTy - (G.HsParTy (L _ iTy)) -> fnarg iTy - (G.HsFunTy _ _) -> True - _ -> 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 - args = \case ty | Just (lTy,rTy) <- Ty.splitFunTy_maybe ty -> - case Ty.splitFunTy_maybe lTy of - Just _ -> FnArgFunction:args rTy - Nothing -> -- Drop the class predicates - if Ty.isPredTy lTy then args rTy else FnArgNormal:args rTy - ty | Just (_,iTy) <- Ty.splitForAllTy_maybe ty -> args iTy - _ -> [] - in initialBody fname (args (Ty.dropForAlls $ G.idType method)) - -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]) - -isSymbolName :: String -> Bool -isSymbolName (c:_) = c `elem` "!#$%&*+./<=>?@\\^|-~" || isSymbol c -isSymbolName [] = error "This should never happen" diff --git a/Language/Haskell/GhcMod/Convert.hs b/Language/Haskell/GhcMod/Convert.hs index 93b1257..6b0195e 100644 --- a/Language/Haskell/GhcMod/Convert.hs +++ b/Language/Haskell/GhcMod/Convert.hs @@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleInstances, FlexibleContexts, OverlappingInstances #-} -module Language.Haskell.GhcMod.Convert (convert, convert') where +module Language.Haskell.GhcMod.Convert (convert, convert', emptyResult, whenFound) where import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Types @@ -115,3 +115,11 @@ quote opt str = ("\"" ++) . (quote' str ++) . ("\"" ++) | otherwise = x : quote' xs ---------------------------------------------------------------- + +-- Empty result to be returned when no info can be gathered +emptyResult :: Monad m => Options -> m String +emptyResult opt = return $ convert opt ([] :: [String]) + +-- Return an emptyResult when Nothing +whenFound :: (Monad m, ToString b) => Options -> m (Maybe a) -> (a -> b) -> m String +whenFound opt from f = maybe (emptyResult opt) (return . convert opt . f) =<< from diff --git a/Language/Haskell/GhcMod/FillSig.hs b/Language/Haskell/GhcMod/FillSig.hs new file mode 100644 index 0000000..1676b19 --- /dev/null +++ b/Language/Haskell/GhcMod/FillSig.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE LambdaCase, RecordWildCards + , MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} + +module Language.Haskell.GhcMod.FillSig ( + fillSig + , sig + ) where + +import Data.Char (isSymbol) +import Data.List (find, intercalate) +import Exception (ghandle, SomeException(..)) +import GHC (Ghc, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L)) +import qualified GHC as G +import Language.Haskell.GhcMod.GHCApi +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 HsBinds as Ty +import qualified Class as Ty +import OccName (occName) +import qualified Language.Haskell.Exts.Annotated as HE + +---------------------------------------------------------------- +-- INTIAL CODE FROM FUNCTION OR INSTANCE SIGNATURE +---------------------------------------------------------------- + +-- Possible signatures we can find: function or instance +data SigInfo = Signature SrcSpan [G.RdrName] (G.HsType G.RdrName) + | InstanceDecl SrcSpan G.Class + +-- Signature for fallback operation via haskell-src-exts +data HESigInfo = HESignature HE.SrcSpan [HE.Name HE.SrcSpanInfo] (HE.Type HE.SrcSpanInfo) + +-- | 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 + +-- | Create a initial body from a signature. +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 + whenFound opt (getSignature modSum lineNo colNo) $ + \case Signature loc names ty -> + ("function", fourInts loc, map (initialBody dflag style ty) names) + InstanceDecl loc cls -> do + ("instance", fourInts loc, map (\x -> initialBody dflag style (G.idType x) x) + (Ty.classMethods cls)) + + handler (SomeException _) = do + -- Code cannot be parsed by ghc module + -- Fallback: try to get information via haskell-src-exts + whenFound opt (getSignatureFromHE file lineNo colNo) $ + \(HESignature loc names ty) -> + ("function", fourIntsHE loc, map (initialBody undefined undefined ty) names) + +---------------------------------------------------------------- +-- a. Code for getting the information + +-- Get signature from ghc parsing and typechecking +getSignature :: G.ModSummary -> Int -> Int -> Ghc (Maybe SigInfo) +getSignature modSum lineNo colNo = do + p@ParsedModule{pm_parsed_source = ps} <- G.parseModule modSum + -- Inspect the parse tree to find the signature + case listifyParsedSpans ps (lineNo, colNo) :: [G.LHsDecl G.RdrName] of + [L loc (G.SigD (Ty.TypeSig names (L _ ty)))] -> + -- We found a type signature + return $ Just $ Signature loc (map G.unLoc names) ty + [L _ (G.InstD _)] -> do + -- We found an instance declaration + TypecheckedModule{tm_renamed_source = Just tcs + ,tm_checked_module_info = minfo} <- G.typecheckModule p + case listifyRenamedSpans tcs (lineNo, colNo) :: [G.LInstDecl G.Name] of + -- Instance declarations of sort 'instance F (G a)' + [L loc (G.ClsInstD (G.ClsInstDecl {G.cid_poly_ty = + (L _ (G.HsForAllTy _ _ _ (L _ (G.HsAppTy (L _ (G.HsTyVar clsName)) _))))}))] -> + obtainClassInfo minfo clsName loc + -- Instance declarations of sort 'instance F G' (no variables) + [L loc (G.ClsInstD (G.ClsInstDecl {G.cid_poly_ty = + (L _ (G.HsAppTy (L _ (G.HsTyVar clsName)) _))}))] -> + obtainClassInfo minfo clsName loc + _ -> return Nothing + _ -> return Nothing + where obtainClassInfo :: G.ModuleInfo -> G.Name -> SrcSpan -> Ghc (Maybe SigInfo) + obtainClassInfo minfo clsName loc = do + tyThing <- G.modInfoLookupName minfo clsName + return $ do Ty.ATyCon clsCon <- tyThing -- In Maybe + cls <- G.tyConClass_maybe clsCon + return $ InstanceDecl loc cls + +-- Get signature from haskell-src-exts +getSignatureFromHE :: FilePath -> Int -> Int -> Ghc (Maybe HESigInfo) +getSignatureFromHE file lineNo colNo = do + presult <- liftIO $ HE.parseFile file + return $ case presult of + HE.ParseOk (HE.Module _ _ _ _ mdecls) -> do + HE.TypeSig (HE.SrcSpanInfo s _) names ty <- find (typeSigInRangeHE lineNo colNo) mdecls + return $ HESignature s names ty + _ -> Nothing + +---------------------------------------------------------------- +-- b. Code for generating initial code + +-- A list of function arguments, and whether they are functions or normal arguments +-- is built from either a function signature or an instance signature +data FnArg = FnArgFunction | FnArgNormal + +initialBody :: FnArgsInfo ty name => DynFlags -> PprStyle -> ty -> name -> String +initialBody dflag style ty name = initialBody' (getFnName dflag style name) (getFnArgs ty) + +initialBody' :: String -> [FnArg] -> String +initialBody' fname args = + case initialBodyArgs args infiniteVars infiniteFns of + [] -> fname + arglist -> if isSymbolName fname + then (head arglist) ++ " " ++ fname ++ " " ++ (intercalate " " (tail arglist)) + else fname ++ " " ++ (intercalate " " arglist) + ++ " = " ++ (if isSymbolName fname then "" else '_':fname) ++ "_body" + +initialBodyArgs :: [FnArg] -> [String] -> [String] -> [String] +initialBodyArgs [] _ _ = [] +initialBodyArgs (FnArgFunction:xs) vs (f:fs) = f : initialBodyArgs xs vs fs +initialBodyArgs (FnArgNormal:xs) (v:vs) fs = v : initialBodyArgs xs vs fs +initialBodyArgs _ _ _ = error "This should never happen" -- Lists are infinite + +-- Getting the initial body of function and instances differ +-- This is because for functions we only use the parsed file +-- (so the full file doesn't have to be type correct) +-- but for instances we need to get information about the class + +class FnArgsInfo ty name | ty -> name, name -> ty where + getFnName :: DynFlags -> PprStyle -> name -> String + getFnArgs :: ty -> [FnArg] + +instance FnArgsInfo (G.HsType G.RdrName) (G.RdrName) where + getFnName dflag style name = showOccName dflag style $ occName name + getFnArgs (G.HsForAllTy _ _ _ (L _ iTy)) = getFnArgs iTy + getFnArgs (G.HsParTy (L _ iTy)) = getFnArgs iTy + getFnArgs (G.HsFunTy (L _ lTy) (L _ rTy)) = (if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy + where fnarg = \case (G.HsForAllTy _ _ _ (L _ iTy)) -> fnarg iTy + (G.HsParTy (L _ iTy)) -> fnarg iTy + (G.HsFunTy _ _) -> True + _ -> False + getFnArgs _ = [] + +instance FnArgsInfo (HE.Type HE.SrcSpanInfo) (HE.Name HE.SrcSpanInfo) where + getFnName _ _ (HE.Ident _ s) = s + getFnName _ _ (HE.Symbol _ s) = s + getFnArgs (HE.TyForall _ _ _ iTy) = getFnArgs iTy + getFnArgs (HE.TyParen _ iTy) = getFnArgs iTy + getFnArgs (HE.TyFun _ lTy rTy) = (if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy + where fnarg = \case (HE.TyForall _ _ _ iTy) -> fnarg iTy + (HE.TyParen _ iTy) -> fnarg iTy + (HE.TyFun _ _ _) -> True + _ -> False + getFnArgs _ = [] + +instance FnArgsInfo Type Id where + getFnName dflag style method = showOccName dflag style $ G.getOccName method + getFnArgs = getFnArgs' . Ty.dropForAlls + where getFnArgs' ty | Just (lTy,rTy) <- Ty.splitFunTy_maybe ty = + maybe (if Ty.isPredTy lTy then getFnArgs' rTy else FnArgNormal:getFnArgs' rTy) + (\_ -> FnArgFunction:getFnArgs' rTy) + $ Ty.splitFunTy_maybe lTy + getFnArgs' ty | Just (_,iTy) <- Ty.splitForAllTy_maybe ty = getFnArgs' iTy + getFnArgs' _ = [] + +-- Infinite supply of variable and function variable names +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]) + +-- Check whether a String is a symbol name +isSymbolName :: String -> Bool +isSymbolName (c:_) = c `elem` "!#$%&*+./<=>?@\\^|-~" || isSymbol c +isSymbolName [] = error "This should never happen" diff --git a/Language/Haskell/GhcMod/Ghc.hs b/Language/Haskell/GhcMod/Ghc.hs index dd6caa8..112dfd1 100644 --- a/Language/Haskell/GhcMod/Ghc.hs +++ b/Language/Haskell/GhcMod/Ghc.hs @@ -26,4 +26,5 @@ import Language.Haskell.GhcMod.Find import Language.Haskell.GhcMod.GHCApi import Language.Haskell.GhcMod.Info import Language.Haskell.GhcMod.List -import Language.Haskell.GhcMod.Rewrite +import Language.Haskell.GhcMod.FillSig +import Language.Haskell.GhcMod.CaseSplit diff --git a/Language/Haskell/GhcMod/SrcUtils.hs b/Language/Haskell/GhcMod/SrcUtils.hs index c959500..0270dc9 100644 --- a/Language/Haskell/GhcMod/SrcUtils.hs +++ b/Language/Haskell/GhcMod/SrcUtils.hs @@ -18,6 +18,8 @@ import Language.Haskell.GhcMod.Gap (HasType(..), setWarnTypedHoles, setDeferType import qualified Language.Haskell.GhcMod.Gap as Gap import Outputable (PprStyle) import TcHsSyn (hsPatType) +import OccName (OccName) +import qualified Language.Haskell.Exts.Annotated as HE ---------------------------------------------------------------- @@ -62,6 +64,16 @@ toTup dflag style (spn, typ) = (fourInts spn, pretty dflag style typ) fourInts :: SrcSpan -> (Int,Int,Int,Int) fourInts = fromMaybe (0,0,0,0) . Gap.getSrcSpan +fourIntsHE :: HE.SrcSpan -> (Int,Int,Int,Int) +fourIntsHE loc = ( HE.srcSpanStartLine loc, HE.srcSpanStartColumn loc + , HE.srcSpanEndLine loc, HE.srcSpanEndColumn loc) + +-- Check whether (line,col) is inside a given SrcSpanInfo +typeSigInRangeHE :: Int -> Int -> HE.Decl HE.SrcSpanInfo -> Bool +typeSigInRangeHE lineNo colNo (HE.TypeSig (HE.SrcSpanInfo s _) _ _) = + HE.srcSpanStart s <= (lineNo, colNo) && HE.srcSpanEnd s >= (lineNo, colNo) +typeSigInRangeHE _ _ _= False + pretty :: DynFlags -> PprStyle -> Type -> String pretty dflag style = showOneLine dflag style . Gap.typeForUser @@ -75,3 +87,11 @@ inModuleContext file action = dflag <- G.getSessionDynFlags style <- getStyle action dflag style + +---------------------------------------------------------------- + +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 diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 9b1225b..c704868 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -61,11 +61,13 @@ Library Language.Haskell.GhcMod.CabalConfig Language.Haskell.GhcMod.Cabal16 Language.Haskell.GhcMod.Cabal18 + Language.Haskell.GhcMod.CaseSplit Language.Haskell.GhcMod.Check Language.Haskell.GhcMod.Cradle Language.Haskell.GhcMod.Convert Language.Haskell.GhcMod.Debug Language.Haskell.GhcMod.Doc + Language.Haskell.GhcMod.FillSig Language.Haskell.GhcMod.Find Language.Haskell.GhcMod.Flag Language.Haskell.GhcMod.GHCApi @@ -81,7 +83,6 @@ Library Language.Haskell.GhcMod.Utils Language.Haskell.GhcMod.Types Language.Haskell.GhcMod.Read - Language.Haskell.GhcMod.Rewrite Language.Haskell.GhcMod.SrcUtils Build-Depends: base >= 4.0 && < 5 , containers