ghc-mod/Language/Haskell/GhcMod/FillSig.hs

551 lines
22 KiB
Haskell
Raw Normal View History

2014-09-16 03:33:01 +00:00
{-# LANGUAGE CPP, MultiParamTypeClasses, FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
module Language.Haskell.GhcMod.FillSig (
sig
2014-07-17 04:59:10 +00:00
, refine
2014-08-01 15:08:23 +00:00
, auto
) where
import Data.Char (isSymbol)
2014-07-20 11:33:36 +00:00
import Data.Function (on)
2014-08-02 07:52:36 +00:00
import Data.List (find, nub, sortBy)
2014-08-03 18:38:54 +00:00
import qualified Data.Map as M
2015-06-01 14:53:56 +00:00
import Data.Maybe (catMaybes)
import Text.PrettyPrint (($$), text, nest)
import Exception (ghandle, SomeException(..))
2014-09-16 03:33:01 +00:00
import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags,
SrcSpan, Type, GenLocated(L))
import qualified GHC as G
import qualified Name as G
import qualified Language.Haskell.GhcMod.Gap as Gap
import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.DynFlags
import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.SrcUtils
import Language.Haskell.GhcMod.Logging (gmLog)
import Language.Haskell.GhcMod.Pretty (showDoc)
import Language.Haskell.GhcMod.Doc
import Language.Haskell.GhcMod.Types
2015-07-03 19:31:52 +00:00
import Language.Haskell.GhcMod.FileMapping (fileModSummaryWithMapping)
2014-08-03 17:57:01 +00:00
import Outputable (PprStyle)
import qualified Type as Ty
import qualified HsBinds as Ty
import qualified Class as Ty
import qualified Var as Ty
import qualified HsPat as Ty
import qualified Language.Haskell.Exts.Annotated as HE
2014-08-01 15:08:23 +00:00
import Djinn.GHC
2015-01-16 14:47:56 +00:00
#if __GLASGOW_HASKELL__ >= 710
import GHC (unLoc)
#endif
----------------------------------------------------------------
-- INTIAL CODE FROM FUNCTION OR INSTANCE SIGNATURE
----------------------------------------------------------------
-- Possible signatures we can find: function or instance
2014-09-16 03:33:01 +00:00
data SigInfo
= Signature SrcSpan [G.RdrName] (G.HsType G.RdrName)
| InstanceDecl SrcSpan G.Class
| TyFamDecl SrcSpan G.RdrName TyFamType {- True if closed -} [G.RdrName]
-- Signature for fallback operation via haskell-src-exts
2014-09-16 03:33:01 +00:00
data HESigInfo
= HESignature HE.SrcSpan [HE.Name HE.SrcSpanInfo] (HE.Type HE.SrcSpanInfo)
| HEFamSignature
HE.SrcSpan
TyFamType
(HE.Name HE.SrcSpanInfo)
[HE.Name HE.SrcSpanInfo]
data TyFamType = Closed | Open | Data
initialTyFamString :: TyFamType -> (String, String)
initialTyFamString Closed = ("instance", "")
initialTyFamString Open = ("function", "type instance ")
initialTyFamString Data = ("function", "data instance ")
-- | Create a initial body from a signature.
sig :: IOish m
=> FilePath -- ^ A target file.
-> Int -- ^ Line number.
-> Int -- ^ Column number.
-> GhcModT m String
sig file lineNo colNo =
runGmlT' [Left file] deferErrors $ ghandle fallback $ do
opt <- options
style <- getStyle
dflag <- G.getSessionDynFlags
2015-07-03 19:31:52 +00:00
modSum <- fileModSummaryWithMapping file
whenFound opt (getSignature modSum lineNo colNo) $ \s ->
case s of
Signature loc names ty ->
("function", fourInts loc, map (initialBody dflag style ty) names)
2015-06-01 14:54:50 +00:00
InstanceDecl loc cls ->
let body x = initialBody dflag style (G.idType x) x
in ("instance", fourInts loc, body `map` Ty.classMethods cls)
TyFamDecl loc name flavour vars ->
let (rTy, initial) = initialTyFamString flavour
body = initialFamBody dflag style name vars
2015-06-01 14:54:50 +00:00
in (rTy, fourInts loc, [initial ++ body])
where
fallback (SomeException _) = do
opt <- options
-- Code cannot be parsed by ghc module
-- Fallback: try to get information via haskell-src-exts
whenFound opt (getSignatureFromHE file lineNo colNo) $ \x -> case x of
HESignature loc names ty ->
("function", fourIntsHE loc, map (initialBody undefined undefined ty) names)
HEFamSignature loc flavour name vars ->
let (rTy, initial) = initialTyFamString flavour
in (rTy, fourIntsHE loc, [initial ++ initialFamBody undefined undefined name vars])
----------------------------------------------------------------
-- a. Code for getting the information
-- Get signature from ghc parsing and typechecking
getSignature :: GhcMonad m => G.ModSummary -> Int -> Int -> m (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
2015-01-16 14:47:56 +00:00
#if __GLASGOW_HASKELL__ >= 710
[L loc (G.SigD (Ty.TypeSig names (L _ ty) _))] ->
#else
[L loc (G.SigD (Ty.TypeSig names (L _ ty)))] ->
2015-01-16 14:47:56 +00:00
#endif
-- 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
let lst = listifyRenamedSpans tcs (lineNo, colNo)
case Gap.getClass lst of
2014-07-15 05:44:02 +00:00
Just (clsName,loc) -> obtainClassInfo minfo clsName loc
_ -> return Nothing
#if __GLASGOW_HASKELL__ >= 708
[L loc (G.TyClD (G.FamDecl (G.FamilyDecl info (L _ name) (G.HsQTvs _ vars) _)))] -> do
#elif __GLASGOW_HASKELL__ >= 706
[L loc (G.TyClD (G.TyFamily info (L _ name) (G.HsQTvs _ vars) _))] -> do
#else
[L loc (G.TyClD (G.TyFamily info (L _ name) vars _))] -> do
#endif
#if __GLASGOW_HASKELL__ >= 708
let flavour = case info of
G.ClosedTypeFamily _ -> Closed
G.OpenTypeFamily -> Open
G.DataFamily -> Data
#else
let flavour = case info of -- Closed type families where introduced in GHC 7.8
G.TypeFamily -> Open
G.DataFamily -> Data
#endif
2015-01-29 08:43:31 +00:00
#if __GLASGOW_HASKELL__ >= 710
getTyFamVarName x = case x of
L _ (G.UserTyVar n) -> n
L _ (G.KindedTyVar (G.L _ n) _) -> n
#elif __GLASGOW_HASKELL__ >= 706
2014-08-14 02:11:02 +00:00
getTyFamVarName x = case x of
L _ (G.UserTyVar n) -> n
L _ (G.KindedTyVar n _) -> n
2014-07-27 12:11:54 +00:00
#else
2014-08-14 02:11:02 +00:00
getTyFamVarName x = case x of -- In GHC 7.4, HsTyVarBndr's have an extra arg
L _ (G.UserTyVar n _) -> n
L _ (G.KindedTyVar n _ _) -> n
2014-07-27 12:11:54 +00:00
#endif
in return $ Just (TyFamDecl loc name flavour $ map getTyFamVarName vars)
_ -> return Nothing
where obtainClassInfo :: GhcMonad m => G.ModuleInfo -> G.Name -> SrcSpan -> m (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
2015-04-02 23:15:12 +00:00
getSignatureFromHE :: (MonadIO m, GhcMonad m) =>
FilePath -> Int -> Int -> m (Maybe HESigInfo)
getSignatureFromHE file lineNo colNo = do
presult <- liftIO $ HE.parseFile file
return $ case presult of
HE.ParseOk (HE.Module _ _ _ _ mdecls) -> do
decl <- find (typeSigInRangeHE lineNo colNo) mdecls
2014-08-14 01:49:48 +00:00
case decl of
2014-09-16 03:34:00 +00:00
HE.TypeSig (HE.SrcSpanInfo s _) names ty ->
return $ HESignature s names ty
HE.TypeFamDecl (HE.SrcSpanInfo s _) declHead _ ->
let (name, tys) = dHeadTyVars declHead in
return $ HEFamSignature s Open name (map cleanTyVarBind tys)
2014-09-16 03:34:00 +00:00
HE.DataFamDecl (HE.SrcSpanInfo s _) _ declHead _ ->
let (name, tys) = dHeadTyVars declHead in
return $ HEFamSignature s Open name (map cleanTyVarBind tys)
2014-08-01 15:08:23 +00:00
_ -> fail ""
_ -> Nothing
where cleanTyVarBind (HE.KindedVar _ n _) = n
cleanTyVarBind (HE.UnkindedVar _ n) = n
2014-09-16 03:34:00 +00:00
#if MIN_VERSION_haskell_src_exts(1,16,0)
dHeadTyVars :: HE.DeclHead l -> (HE.Name l, [HE.TyVarBind l])
dHeadTyVars (HE.DHead _ name) = (name, [])
dHeadTyVars (HE.DHApp _ r ty) = (++[ty]) `fmap` (dHeadTyVars r)
dHeadTyVars (HE.DHInfix _ ty name) = (name, [ty])
dHeadTyVars (HE.DHParen _ r) = dHeadTyVars r
#else
dHeadTyVars :: HE.DeclHead l -> (HE.Name l, [HE.TyVarBind l])
dHeadTyVars (HE.DHead _ n tys) = (n, tys)
2014-09-16 03:34:00 +00:00
#endif
----------------------------------------------------------------
-- b. Code for generating initial code
2014-09-16 03:33:01 +00:00
-- 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 | FnExplicitName String
initialBody :: FnArgsInfo ty name => DynFlags -> PprStyle -> ty -> name -> String
2014-09-16 03:33:01 +00:00
initialBody dflag style ty name =
initialBody' (getFnName dflag style name) (getFnArgs ty)
initialBody' :: String -> [FnArg] -> String
2014-09-16 03:33:01 +00:00
initialBody' fname args =
initialHead fname args ++ " = " ++ n ++ "_body"
where n = if isSymbolName fname then "" else '_':fname
2014-07-19 10:11:34 +00:00
2014-09-16 03:33:01 +00:00
initialFamBody :: FnArgsInfo ty name
=> DynFlags -> PprStyle -> name -> [name] -> String
initialFamBody dflag style name args =
initialHead fnName fnArgs ++ " = ()"
where fnName = getFnName dflag style name
fnArgs = map (FnExplicitName . getFnName dflag style) args
2014-07-19 10:11:34 +00:00
initialHead :: String -> [FnArg] -> String
initialHead fname args =
case initialBodyArgs args infiniteVars infiniteFns of
[] -> fname
arglist -> if isSymbolName fname
2014-07-17 08:16:44 +00:00
then head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist)
else fname ++ " " ++ unwords arglist
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 (FnExplicitName n:xs) vs fs = n : initialBodyArgs xs vs fs
2014-09-16 03:33:01 +00:00
initialBodyArgs _ _ _ =
error "initialBodyArgs: This should never happen" -- Lists are infinite
2014-07-19 10:11:34 +00:00
initialHead1 :: String -> [FnArg] -> [String] -> String
initialHead1 fname args elts =
case initialBodyArgs1 args elts of
[] -> fname
2015-06-01 14:54:50 +00:00
arglist
| isSymbolName fname ->
head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist)
| otherwise ->
fname ++ " " ++ unwords arglist
2014-07-19 10:11:34 +00:00
initialBodyArgs1 :: [FnArg] -> [String] -> [String]
initialBodyArgs1 args elts = take (length args) elts
-- 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
2014-07-15 05:44:02 +00:00
getFnName dflag style name = showOccName dflag style $ Gap.occName name
2015-01-16 14:47:56 +00:00
#if __GLASGOW_HASKELL__ >= 710
getFnArgs (G.HsForAllTy _ _ _ _ (L _ iTy))
#else
getFnArgs (G.HsForAllTy _ _ _ (L _ iTy))
#endif
= getFnArgs iTy
getFnArgs (G.HsParTy (L _ iTy)) = getFnArgs iTy
2014-09-16 03:33:01 +00:00
getFnArgs (G.HsFunTy (L _ lTy) (L _ rTy)) =
(if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy
2014-07-17 08:16:44 +00:00
where fnarg ty = case ty of
2015-01-16 14:47:56 +00:00
#if __GLASGOW_HASKELL__ >= 710
(G.HsForAllTy _ _ _ _ (L _ iTy)) ->
#else
(G.HsForAllTy _ _ _ (L _ iTy)) ->
#endif
fnarg iTy
2014-07-17 08:16:44 +00:00
(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
2014-09-16 03:33:01 +00:00
getFnArgs (HE.TyFun _ lTy rTy) =
(if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy
2014-07-17 08:16:44 +00:00
where fnarg ty = case ty of
(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
2014-09-16 03:33:01 +00:00
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]
2014-09-16 03:33:01 +00:00
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"
2014-07-16 16:20:52 +00:00
----------------------------------------------------------------
-- REWRITE A HOLE / UNDEFINED VIA A FUNCTION
----------------------------------------------------------------
refine :: IOish m
=> FilePath -- ^ A target file.
2014-07-16 16:20:52 +00:00
-> Int -- ^ Line number.
-> Int -- ^ Column number.
-> Expression -- ^ A Haskell expression.
-> GhcModT m String
refine file lineNo colNo (Expression expr) =
2015-06-01 14:54:50 +00:00
ghandle handler $
runGmlT' [Left file] deferErrors $ do
opt <- options
style <- getStyle
dflag <- G.getSessionDynFlags
2015-07-03 19:31:52 +00:00
modSum <- fileModSummaryWithMapping file
2015-06-01 14:54:50 +00:00
p <- G.parseModule modSum
tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p
ety <- G.exprType expr
whenFound opt (findVar dflag style tcm tcs lineNo colNo) $
\(loc, name, rty, paren) ->
let eArgs = getFnArgs ety
rArgs = getFnArgs rty
diffArgs' = length eArgs - length rArgs
diffArgs = if diffArgs' < 0 then 0 else diffArgs'
iArgs = take diffArgs eArgs
2015-08-07 05:33:04 +00:00
txt = initialHead1 expr iArgs (infinitePrefixSupply name)
in (fourInts loc, doParen paren txt)
2015-06-01 14:54:50 +00:00
where
handler (SomeException ex) = do
gmLog GmDebug "refining" $
text "" $$ nest 4 (showDoc ex)
emptyResult =<< options
2014-07-16 16:20:52 +00:00
2014-07-18 15:09:02 +00:00
-- Look for the variable in the specified position
2015-06-01 14:54:50 +00:00
findVar
:: GhcMonad m
=> DynFlags
-> PprStyle
-> G.TypecheckedModule
-> G.TypecheckedSource
-> Int
-> Int
-> m (Maybe (SrcSpan, String, Type, Bool))
2014-07-19 10:11:34 +00:00
findVar dflag style tcm tcs lineNo colNo =
2015-06-01 14:53:56 +00:00
case lst of
e@(L _ (G.HsVar i)):others -> do
tyInfo <- Gap.getType tcm e
case tyInfo of
2015-06-01 14:54:50 +00:00
Just (s, typ)
2015-06-01 14:53:56 +00:00
| name == "undefined" || head name == '_' ->
2015-06-01 14:54:50 +00:00
return $ Just (s, name, typ, b)
2015-06-01 14:53:56 +00:00
where
name = getFnName dflag style i
-- If inside an App, we need parenthesis
b = case others of
L _ (G.HsApp (L _ a1) (L _ a2)):_ ->
isSearchedVar i a1 || isSearchedVar i a2
_ -> False
_ -> return Nothing
_ -> return Nothing
where
lst :: [G.LHsExpr Id]
lst = sortBy (cmp `on` G.getLoc) $ listifySpans tcs (lineNo, colNo)
2014-07-19 10:11:34 +00:00
infinitePrefixSupply :: String -> [String]
infinitePrefixSupply "undefined" = repeat "undefined"
infinitePrefixSupply p = map (\n -> p ++ "_" ++ show n) ([1 ..] :: [Integer])
2014-07-20 11:33:36 +00:00
doParen :: Bool -> String -> String
doParen False s = s
doParen True s = if ' ' `elem` s then '(':s ++ ")" else s
isSearchedVar :: Id -> G.HsExpr Id -> Bool
isSearchedVar i (G.HsVar i2) = i == i2
isSearchedVar _ _ = False
2014-08-01 15:08:23 +00:00
----------------------------------------------------------------
-- REFINE AUTOMATICALLY
----------------------------------------------------------------
auto :: IOish m
=> FilePath -- ^ A target file.
-> Int -- ^ Line number.
-> Int -- ^ Column number.
-> GhcModT m String
auto file lineNo colNo =
ghandle handler $ runGmlT' [Left file] deferErrors $ do
2014-08-01 15:08:23 +00:00
opt <- options
style <- getStyle
dflag <- G.getSessionDynFlags
2015-07-03 19:31:52 +00:00
modSum <- fileModSummaryWithMapping file
2014-08-01 15:08:23 +00:00
p <- G.parseModule modSum
2014-09-16 03:33:01 +00:00
tcm@TypecheckedModule {
tm_typechecked_source = tcs
, tm_checked_module_info = minfo
} <- G.typecheckModule p
2014-08-01 15:08:23 +00:00
whenFound' opt (findVar dflag style tcm tcs lineNo colNo) $ \(loc, _name, rty, paren) -> do
topLevel <- getEverythingInTopLevel minfo
let (f,pats) = getPatsForVariable tcs (lineNo,colNo)
2014-09-16 03:33:01 +00:00
-- Remove self function to prevent recursion, and id to trim
-- cases
2014-08-14 02:11:02 +00:00
filterFn (n,_) = let funName = G.getOccString n
recName = G.getOccString (G.getName f)
in funName `notElem` recName:notWantedFuns
-- Find without using other functions in top-level
2014-09-16 03:33:01 +00:00
localBnds = M.unions $
map (\(L _ pat) -> getBindingsForPat pat) pats
lbn = filter filterFn (M.toList localBnds)
djinnsEmpty <- djinn True (Just minfo) lbn rty (Max 10) 100000
let -- Find with the entire top-level
almostEnv = M.toList $ M.union localBnds topLevel
env = filter filterFn almostEnv
djinns <- djinn True (Just minfo) env rty (Max 10) 100000
2014-09-16 03:33:01 +00:00
return ( fourInts loc
, map (doParen paren) $ nub (djinnsEmpty ++ djinns))
where
handler (SomeException ex) = do
gmLog GmDebug "auto-refining" $
text "" $$ nest 4 (showDoc ex)
emptyResult =<< options
-- Functions we do not want in completions
notWantedFuns :: [String]
notWantedFuns = ["id", "asTypeOf", "const"]
-- Get all things defined in top-level
getEverythingInTopLevel :: GhcMonad m => G.ModuleInfo -> m (M.Map G.Name Type)
getEverythingInTopLevel m = do
let modInfo = tyThingsToInfo (G.modInfoTyThings m)
topNames = G.modInfoTopLevelScope m
case topNames of
Just topNames' -> do topThings <- mapM G.lookupGlobalName topNames'
let topThings' = catMaybes topThings
topInfo = tyThingsToInfo topThings'
return $ M.union modInfo topInfo
Nothing -> return modInfo
tyThingsToInfo :: [Ty.TyThing] -> M.Map G.Name Type
tyThingsToInfo [] = M.empty
2014-09-16 03:33:01 +00:00
tyThingsToInfo (G.AnId i : xs) =
M.insert (G.getName i) (Ty.varType i) (tyThingsToInfo xs)
-- Getting information about constructors is not needed
-- because they will be added by djinn-ghc when traversing types
-- #if __GLASGOW_HASKELL__ >= 708
-- tyThingToInfo (G.AConLike (G.RealDataCon con)) = return [(Ty.dataConName con, Ty.dataConUserType con)]
-- #else
-- tyThingToInfo (G.AConLike con) = return [(Ty.dataConName con, Ty.dataConUserType con)]
-- #endif
tyThingsToInfo (_:xs) = tyThingsToInfo xs
-- Find the Id of the function and the pattern where the hole is located
getPatsForVariable :: G.TypecheckedSource -> (Int,Int) -> (Id, [Ty.LPat Id])
getPatsForVariable tcs (lineNo, colNo) =
2014-09-16 03:33:01 +00:00
let (L _ bnd:_) = sortBy (cmp `on` G.getLoc) $
listifySpans tcs (lineNo, colNo) :: [G.LHsBind Id]
in case bnd of
G.PatBind { Ty.pat_lhs = L ploc pat } -> case pat of
Ty.ConPatIn (L _ i) _ -> (i, [L ploc pat])
2014-08-04 15:25:18 +00:00
_ -> (error "This should never happen", [])
G.FunBind { Ty.fun_id = L _ funId } ->
2014-08-04 15:25:18 +00:00
let m = sortBy (cmp `on` G.getLoc) $ listifySpans tcs (lineNo, colNo)
#if __GLASGOW_HASKELL__ >= 708
:: [G.LMatch Id (G.LHsExpr Id)]
#else
:: [G.LMatch Id]
#endif
2015-03-28 18:54:10 +00:00
#if __GLASGOW_HASKELL__ >= 710
2015-01-29 08:43:31 +00:00
(L _ (G.Match _ pats _ _):_) = m
2015-03-28 18:54:10 +00:00
#else
(L _ (G.Match pats _ _):_) = m
#endif
in (funId, pats)
_ -> (error "This should never happen", [])
getBindingsForPat :: Ty.Pat Id -> M.Map G.Name Type
getBindingsForPat (Ty.VarPat i) = M.singleton (G.getName i) (Ty.varType i)
getBindingsForPat (Ty.LazyPat (L _ l)) = getBindingsForPat l
getBindingsForPat (Ty.BangPat (L _ b)) = getBindingsForPat b
2014-09-16 03:33:01 +00:00
getBindingsForPat (Ty.AsPat (L _ a) (L _ i)) =
M.insert (G.getName a) (Ty.varType a) (getBindingsForPat i)
2014-08-04 15:25:18 +00:00
#if __GLASGOW_HASKELL__ >= 708
2014-09-16 03:33:01 +00:00
getBindingsForPat (Ty.ListPat l _ _) =
M.unions $ map (\(L _ i) -> getBindingsForPat i) l
2014-08-04 15:25:18 +00:00
#else
2014-09-16 03:33:01 +00:00
getBindingsForPat (Ty.ListPat l _) =
M.unions $ map (\(L _ i) -> getBindingsForPat i) l
2014-08-04 15:25:18 +00:00
#endif
2014-09-16 03:33:01 +00:00
getBindingsForPat (Ty.TuplePat l _ _) =
M.unions $ map (\(L _ i) -> getBindingsForPat i) l
getBindingsForPat (Ty.PArrPat l _) =
M.unions $ map (\(L _ i) -> getBindingsForPat i) l
getBindingsForPat (Ty.ViewPat _ (L _ i) _) = getBindingsForPat i
getBindingsForPat (Ty.SigPatIn (L _ i) _) = getBindingsForPat i
getBindingsForPat (Ty.SigPatOut (L _ i) _) = getBindingsForPat i
2014-09-16 03:33:01 +00:00
getBindingsForPat (Ty.ConPatIn (L _ i) d) =
M.insert (G.getName i) (Ty.varType i) (getBindingsForRecPat d)
getBindingsForPat (Ty.ConPatOut { Ty.pat_args = d }) = getBindingsForRecPat d
getBindingsForPat _ = M.empty
getBindingsForRecPat :: Ty.HsConPatDetails Id -> M.Map G.Name Type
2014-09-16 03:33:01 +00:00
getBindingsForRecPat (Ty.PrefixCon args) =
M.unions $ map (\(L _ i) -> getBindingsForPat i) args
getBindingsForRecPat (Ty.InfixCon (L _ a1) (L _ a2)) =
M.union (getBindingsForPat a1) (getBindingsForPat a2)
getBindingsForRecPat (Ty.RecCon (Ty.HsRecFields { Ty.rec_flds = fields })) =
2015-01-16 14:47:56 +00:00
getBindingsForRecFields (map unLoc' fields)
where
#if __GLASGOW_HASKELL__ >= 710
unLoc' = unLoc
#else
unLoc' = id
#endif
getBindingsForRecFields [] = M.empty
getBindingsForRecFields (Ty.HsRecField {Ty.hsRecFieldArg = (L _ a)}:fs) =
M.union (getBindingsForPat a) (getBindingsForRecFields fs)