summaryrefslogtreecommitdiff
path: root/compiler/hieFile/HieAst.hs
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/hieFile/HieAst.hs')
-rw-r--r--compiler/hieFile/HieAst.hs1713
1 files changed, 1713 insertions, 0 deletions
diff --git a/compiler/hieFile/HieAst.hs b/compiler/hieFile/HieAst.hs
new file mode 100644
index 0000000000..6fcc9243f8
--- /dev/null
+++ b/compiler/hieFile/HieAst.hs
@@ -0,0 +1,1713 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+module HieAst ( mkHieFile ) where
+
+import GhcPrelude
+
+import Avail ( Avails )
+import Bag ( Bag, bagToList )
+import BasicTypes
+import BooleanFormula
+import Class ( FunDep )
+import CoreUtils ( exprType )
+import ConLike ( conLikeName )
+import Config ( cProjectVersion )
+import Desugar ( deSugarExpr )
+import FieldLabel
+import HsSyn
+import HscTypes
+import Module ( ModuleName, ml_hs_file )
+import MonadUtils ( concatMapM, liftIO )
+import Name ( Name, nameSrcSpan, setNameLoc )
+import SrcLoc
+import TcHsSyn ( hsPatType )
+import Type ( Type )
+import Var ( Id, Var, setVarName, varName, varType )
+
+import HieTypes
+import HieUtils
+
+import qualified Data.Array as A
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BSC
+import qualified Data.Map as M
+import qualified Data.Set as S
+import Data.Data ( Data, Typeable )
+import Data.List ( foldl1' )
+import Data.Maybe ( listToMaybe )
+import Control.Monad.Trans.Reader
+import Control.Monad.Trans.Class ( lift )
+
+-- These synonyms match those defined in main/GHC.hs
+type RenamedSource = ( HsGroup GhcRn, [LImportDecl GhcRn]
+ , Maybe [(LIE GhcRn, Avails)]
+ , Maybe LHsDocString )
+type TypecheckedSource = LHsBinds GhcTc
+
+
+{- Note [Name Remapping]
+The Typechecker introduces new names for mono names in AbsBinds.
+We don't care about the distinction between mono and poly bindings,
+so we replace all occurrences of the mono name with the poly name.
+-}
+newtype HieState = HieState
+ { name_remapping :: M.Map Name Id
+ }
+
+initState :: HieState
+initState = HieState M.empty
+
+class ModifyState a where -- See Note [Name Remapping]
+ addSubstitution :: a -> a -> HieState -> HieState
+
+instance ModifyState Name where
+ addSubstitution _ _ hs = hs
+
+instance ModifyState Id where
+ addSubstitution mono poly hs =
+ hs{name_remapping = M.insert (varName mono) poly (name_remapping hs)}
+
+modifyState :: ModifyState (IdP p) => [ABExport p] -> HieState -> HieState
+modifyState = foldr go id
+ where
+ go ABE{abe_poly=poly,abe_mono=mono} f = addSubstitution mono poly . f
+ go _ f = f
+
+type HieM = ReaderT HieState Hsc
+
+-- | Construct an 'HieFile' from the outputs of the typechecker.
+mkHieFile :: ModSummary -> TypecheckedSource -> RenamedSource -> Hsc HieFile
+mkHieFile ms ts rs = do
+ (asts', arr) <- getCompressedAsts ts rs
+ let Just src_file = ml_hs_file $ ms_location ms
+ src <- liftIO $ BS.readFile src_file
+ return $ HieFile
+ { hie_version = curHieVersion
+ , hie_ghc_version = BSC.pack cProjectVersion
+ , hie_hs_file = src_file
+ , hie_types = arr
+ , hie_asts = asts'
+ , hie_hs_src = src
+ }
+
+getCompressedAsts :: TypecheckedSource -> RenamedSource
+ -> Hsc (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)
+getCompressedAsts ts rs = do
+ asts <- enrichHie ts rs
+ return $ compressTypes asts
+
+enrichHie :: TypecheckedSource -> RenamedSource -> Hsc (HieASTs Type)
+enrichHie ts (hsGrp, imports, exports, _) = flip runReaderT initState $ do
+ tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts
+ rasts <- processGrp hsGrp
+ imps <- toHie $ filter (not . ideclImplicit . unLoc) imports
+ exps <- toHie $ fmap (map $ IEC Export . fst) exports
+ let spanFile children = case children of
+ [] -> mkRealSrcSpan (mkRealSrcLoc "" 1 1) (mkRealSrcLoc "" 1 1)
+ _ -> mkRealSrcSpan (realSrcSpanStart $ nodeSpan $ head children)
+ (realSrcSpanEnd $ nodeSpan $ last children)
+
+ modulify xs =
+ Node (simpleNodeInfo "Module" "Module") (spanFile xs) xs
+
+ asts = HieASTs
+ $ resolveTyVarScopes
+ $ M.map (modulify . mergeSortAsts)
+ $ M.fromListWith (++)
+ $ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts
+
+ flat_asts = concat
+ [ tasts
+ , rasts
+ , imps
+ , exps
+ ]
+ return asts
+ where
+ processGrp grp = concatM
+ [ toHie $ fmap (RS ModuleScope ) hs_valds grp
+ , toHie $ hs_splcds grp
+ , toHie $ hs_tyclds grp
+ , toHie $ hs_derivds grp
+ , toHie $ hs_fixds grp
+ , toHie $ hs_defds grp
+ , toHie $ hs_fords grp
+ , toHie $ hs_warnds grp
+ , toHie $ hs_annds grp
+ , toHie $ hs_ruleds grp
+ ]
+
+getRealSpan :: SrcSpan -> Maybe Span
+getRealSpan (RealSrcSpan sp) = Just sp
+getRealSpan _ = Nothing
+
+grhss_span :: GRHSs p body -> SrcSpan
+grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (getLoc bs) (map getLoc xs)
+grhss_span (XGRHSs _) = error "XGRHS has no span"
+
+bindingsOnly :: [Context Name] -> [HieAST a]
+bindingsOnly [] = []
+bindingsOnly (C c n : xs) = case nameSrcSpan n of
+ RealSrcSpan span -> Node nodeinfo span [] : bindingsOnly xs
+ where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info)
+ info = mempty{identInfo = S.singleton c}
+ _ -> bindingsOnly xs
+
+concatM :: Monad m => [m [a]] -> m [a]
+concatM xs = concat <$> sequence xs
+
+{- Note [Capturing Scopes and other non local information]
+toHie is a local tranformation, but scopes of bindings cannot be known locally,
+hence we have to push the relevant info down into the binding nodes.
+We use the following types (*Context and *Scoped) to wrap things and
+carry the required info
+(Maybe Span) always carries the span of the entire binding, including rhs
+-}
+data Context a = C ContextInfo a -- Used for names and bindings
+
+data RContext a = RC RecFieldContext a
+data RFContext a = RFC RecFieldContext (Maybe Span) a
+-- ^ context for record fields
+
+data IEContext a = IEC IEType a
+-- ^ context for imports/exports
+
+data BindContext a = BC BindType Scope a
+-- ^ context for imports/exports
+
+data PatSynFieldContext a = PSC (Maybe Span) a
+-- ^ context for pattern synonym fields.
+
+data SigContext a = SC SigInfo a
+-- ^ context for type signatures
+
+data SigInfo = SI SigType (Maybe Span)
+
+data SigType = BindSig | ClassSig | InstSig
+
+data RScoped a = RS Scope a
+-- ^ Scope spans over everything to the right of a, (mostly) not
+-- including a itself
+-- (Includes a in a few special cases like recursive do bindings) or
+-- let/where bindings
+
+-- | Pattern scope
+data PScoped a = PS (Maybe Span)
+ Scope -- ^ use site of the pattern
+ Scope -- ^ pattern to the right of a, not including a
+ a
+ deriving (Typeable, Data) -- Pattern Scope
+
+{- Note [TyVar Scopes]
+Due to -XScopedTypeVariables, type variables can be in scope quite far from
+their original binding. We resolve the scope of these type variables
+in a seperate pass
+-}
+data TScoped a = TS TyVarScope a -- TyVarScope
+
+data TVScoped a = TVS TyVarScope Scope a -- TyVarScope
+-- ^ First scope remains constant
+-- Second scope is used to build up the scope of a tyvar over
+-- things to its right, ala RScoped
+
+-- | Each element scopes over the elements to the right
+listScopes :: Scope -> [Located a] -> [RScoped (Located a)]
+listScopes _ [] = []
+listScopes rhsScope [pat] = [RS rhsScope pat]
+listScopes rhsScope (pat : pats) = RS sc pat : pats'
+ where
+ pats'@((RS scope p):_) = listScopes rhsScope pats
+ sc = combineScopes scope $ mkScope $ getLoc p
+
+-- | 'listScopes' specialised to 'PScoped' things
+patScopes
+ :: Maybe Span
+ -> Scope
+ -> Scope
+ -> [LPat (GhcPass p)]
+ -> [PScoped (LPat (GhcPass p))]
+patScopes rsp useScope patScope xs =
+ map (\(RS sc a) -> PS rsp useScope sc (unLoc a)) $
+ listScopes patScope (map dL xs)
+
+-- | 'listScopes' specialised to 'TVScoped' things
+tvScopes
+ :: TyVarScope
+ -> Scope
+ -> [LHsTyVarBndr a]
+ -> [TVScoped (LHsTyVarBndr a)]
+tvScopes tvScope rhsScope xs =
+ map (\(RS sc a)-> TVS tvScope sc a) $ listScopes rhsScope xs
+
+{- Note [Scoping Rules for SigPat]
+Explicitly quantified variables in pattern type signatures are not
+brought into scope in the rhs, but implicitly quantified variables
+are (HsWC and HsIB).
+This is unlike other signatures, where explicitly quantified variables
+are brought into the RHS Scope
+For example
+foo :: forall a. ...;
+foo = ... -- a is in scope here
+
+bar (x :: forall a. a -> a) = ... -- a is not in scope here
+-- ^ a is in scope here (pattern body)
+
+bax (x :: a) = ... -- a is in scope here
+Because of HsWC and HsIB pass on their scope to their children
+we must wrap the LHsType in pattern signatures in a
+Shielded explictly, so that the HsWC/HsIB scope is not passed
+on the the LHsType
+-}
+
+data Shielded a = SH Scope a -- Ignores its TScope, uses its own scope instead
+
+type family ProtectedSig a where
+ ProtectedSig GhcRn = HsWildCardBndrs GhcRn (HsImplicitBndrs
+ GhcRn
+ (Shielded (LHsType GhcRn)))
+ ProtectedSig GhcTc = NoExt
+
+class ProtectSig a where
+ protectSig :: Scope -> LHsSigWcType (NoGhcTc a) -> ProtectedSig a
+
+instance (HasLoc a) => HasLoc (Shielded a) where
+ loc (SH _ a) = loc a
+
+instance (ToHie (TScoped a)) => ToHie (TScoped (Shielded a)) where
+ toHie (TS _ (SH sc a)) = toHie (TS (ResolvedScopes [sc]) a)
+
+instance ProtectSig GhcTc where
+ protectSig _ _ = NoExt
+
+instance ProtectSig GhcRn where
+ protectSig sc (HsWC a (HsIB b sig)) =
+ HsWC a (HsIB b (SH sc sig))
+ protectSig _ _ = error "protectSig not given HsWC (HsIB)"
+
+class HasLoc a where
+ -- ^ defined so that HsImplicitBndrs and HsWildCardBndrs can
+ -- know what their implicit bindings are scoping over
+ loc :: a -> SrcSpan
+
+instance HasLoc thing => HasLoc (TScoped thing) where
+ loc (TS _ a) = loc a
+
+instance HasLoc thing => HasLoc (PScoped thing) where
+ loc (PS _ _ _ a) = loc a
+
+instance HasLoc (LHsQTyVars GhcRn) where
+ loc (HsQTvs _ vs) = loc vs
+ loc _ = noSrcSpan
+
+instance HasLoc thing => HasLoc (HsImplicitBndrs a thing) where
+ loc (HsIB _ a) = loc a
+ loc _ = noSrcSpan
+
+instance HasLoc thing => HasLoc (HsWildCardBndrs a thing) where
+ loc (HsWC _ a) = loc a
+ loc _ = noSrcSpan
+
+instance HasLoc (Located a) where
+ loc (L l _) = l
+
+instance HasLoc a => HasLoc [a] where
+ loc [] = noSrcSpan
+ loc xs = foldl1' combineSrcSpans $ map loc xs
+
+instance (HasLoc a, HasLoc b) => HasLoc (FamEqn s a b) where
+ loc (FamEqn _ a Nothing b _ c) = foldl1' combineSrcSpans [loc a, loc b, loc c]
+ loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans
+ [loc a, loc tvs, loc b, loc c]
+ loc _ = noSrcSpan
+
+instance HasLoc (HsDataDefn GhcRn) where
+ loc def@(HsDataDefn{}) = loc $ dd_cons def
+ -- Only used for data family instances, so we only need rhs
+ -- Most probably the rest will be unhelpful anyway
+ loc _ = noSrcSpan
+
+instance HasLoc (Pat (GhcPass a)) where
+ loc (dL -> L l _) = l
+
+-- | The main worker class
+class ToHie a where
+ toHie :: a -> HieM [HieAST Type]
+
+-- | Used to collect type info
+class Data a => HasType a where
+ getTypeNode :: a -> HieM [HieAST Type]
+
+instance (ToHie a) => ToHie [a] where
+ toHie = concatMapM toHie
+
+instance (ToHie a) => ToHie (Bag a) where
+ toHie = toHie . bagToList
+
+instance (ToHie a) => ToHie (Maybe a) where
+ toHie = maybe (pure []) toHie
+
+instance ToHie (Context (Located NoExt)) where
+ toHie _ = pure []
+
+instance ToHie (TScoped NoExt) where
+ toHie _ = pure []
+
+instance ToHie (IEContext (Located ModuleName)) where
+ toHie (IEC c (L (RealSrcSpan span) mname)) =
+ pure $ [Node (NodeInfo S.empty [] idents) span []]
+ where details = mempty{identInfo = S.singleton (IEThing c)}
+ idents = M.singleton (Left mname) details
+ toHie _ = pure []
+
+instance ToHie (Context (Located Var)) where
+ toHie c = case c of
+ C context (L (RealSrcSpan span) name')
+ -> do
+ m <- asks name_remapping
+ let name = M.findWithDefault name' (varName name') m
+ pure
+ [Node
+ (NodeInfo S.empty [] $
+ M.singleton (Right $ varName name)
+ (IdentifierDetails (Just $ varType name')
+ (S.singleton context)))
+ span
+ []]
+ _ -> pure []
+
+instance ToHie (Context (Located Name)) where
+ toHie c = case c of
+ C context (L (RealSrcSpan span) name') -> do
+ m <- asks name_remapping
+ let name = case M.lookup name' m of
+ Just var -> varName var
+ Nothing -> name'
+ pure
+ [Node
+ (NodeInfo S.empty [] $
+ M.singleton (Right name)
+ (IdentifierDetails Nothing
+ (S.singleton context)))
+ span
+ []]
+ _ -> pure []
+
+-- | Dummy instances - never called
+instance ToHie (TScoped (LHsSigWcType GhcTc)) where
+ toHie _ = pure []
+instance ToHie (TScoped (LHsWcType GhcTc)) where
+ toHie _ = pure []
+instance ToHie (SigContext (LSig GhcTc)) where
+ toHie _ = pure []
+instance ToHie (TScoped Type) where
+ toHie _ = pure []
+
+instance HasType (LHsBind GhcRn) where
+ getTypeNode (L spn bind) = makeNode bind spn
+
+instance HasType (LHsBind GhcTc) where
+ getTypeNode (L spn bind) = case bind of
+ FunBind{fun_id = name} -> makeTypeNode bind spn (varType $ unLoc name)
+ _ -> makeNode bind spn
+
+instance HasType (LPat GhcRn) where
+ getTypeNode (dL -> L spn pat) = makeNode pat spn
+
+instance HasType (LPat GhcTc) where
+ getTypeNode (dL -> L spn opat) = makeTypeNode opat spn (hsPatType opat)
+
+instance HasType (LHsExpr GhcRn) where
+ getTypeNode (L spn e) = makeNode e spn
+
+instance HasType (LHsExpr GhcTc) where
+ getTypeNode e@(L spn e') = lift $ do
+ hs_env <- Hsc $ \e w -> return (e,w)
+ (_,mbe) <- liftIO $ deSugarExpr hs_env e
+ case mbe of
+ Just te -> makeTypeNode e' spn (exprType te)
+ Nothing -> makeNode e' spn
+
+instance ( ToHie (Context (Located (IdP a)))
+ , ToHie (MatchGroup a (LHsExpr a))
+ , ToHie (PScoped (LPat a))
+ , ToHie (GRHSs a (LHsExpr a))
+ , ToHie (LHsExpr a)
+ , ToHie (Located (PatSynBind a a))
+ , HasType (LHsBind a)
+ , ModifyState (IdP a)
+ , Data (HsBind a)
+ ) => ToHie (BindContext (LHsBind a)) where
+ toHie (BC context scope b@(L span bind)) =
+ concatM $ getTypeNode b : case bind of
+ FunBind{fun_id = name, fun_matches = matches} ->
+ [ toHie $ C (ValBind context scope $ getRealSpan span) name
+ , toHie matches
+ ]
+ PatBind{pat_lhs = lhs, pat_rhs = rhs} ->
+ [ toHie $ PS (getRealSpan span) scope NoScope lhs
+ , toHie rhs
+ ]
+ VarBind{var_rhs = expr} ->
+ [ toHie expr
+ ]
+ AbsBinds{abs_exports = xs, abs_binds = binds} ->
+ [ local (modifyState xs) $ -- Note [Name Remapping]
+ toHie $ fmap (BC context scope) binds
+ ]
+ PatSynBind _ psb ->
+ [ toHie $ L span psb -- PatSynBinds only occur at the top level
+ ]
+ XHsBindsLR _ -> []
+
+instance ( ToHie (LMatch a body)
+ ) => ToHie (MatchGroup a body) where
+ toHie mg = concatM $ case mg of
+ MG{ mg_alts = (L span alts) , mg_origin = FromSource } ->
+ [ pure $ locOnly span
+ , toHie alts
+ ]
+ MG{} -> []
+ XMatchGroup _ -> []
+
+instance ( ToHie (Context (Located (IdP a)))
+ , ToHie (PScoped (LPat a))
+ , ToHie (HsPatSynDir a)
+ ) => ToHie (Located (PatSynBind a a)) where
+ toHie (L sp psb) = concatM $ case psb of
+ PSB{psb_id=var, psb_args=dets, psb_def=pat, psb_dir=dir} ->
+ [ toHie $ C (Decl PatSynDec $ getRealSpan sp) var
+ , toHie $ toBind dets
+ , toHie $ PS Nothing lhsScope NoScope pat
+ , toHie dir
+ ]
+ where
+ lhsScope = combineScopes varScope detScope
+ varScope = mkLScope var
+ detScope = case dets of
+ (PrefixCon args) -> foldr combineScopes NoScope $ map mkLScope args
+ (InfixCon a b) -> combineScopes (mkLScope a) (mkLScope b)
+ (RecCon r) -> foldr go NoScope r
+ go (RecordPatSynField a b) c = combineScopes c
+ $ combineScopes (mkLScope a) (mkLScope b)
+ detSpan = case detScope of
+ LocalScope a -> Just a
+ _ -> Nothing
+ toBind (PrefixCon args) = PrefixCon $ map (C Use) args
+ toBind (InfixCon a b) = InfixCon (C Use a) (C Use b)
+ toBind (RecCon r) = RecCon $ map (PSC detSpan) r
+ XPatSynBind _ -> []
+
+instance ( ToHie (MatchGroup a (LHsExpr a))
+ ) => ToHie (HsPatSynDir a) where
+ toHie dir = case dir of
+ ExplicitBidirectional mg -> toHie mg
+ _ -> pure []
+
+instance ( a ~ GhcPass p
+ , ToHie body
+ , ToHie (HsMatchContext (NameOrRdrName (IdP a)))
+ , ToHie (PScoped (LPat a))
+ , ToHie (GRHSs a body)
+ , Data (Match a body)
+ ) => ToHie (LMatch (GhcPass p) body) where
+ toHie (L span m ) = concatM $ makeNode m span : case m of
+ Match{m_ctxt=mctx, m_pats = pats, m_grhss = grhss } ->
+ [ toHie mctx
+ , let rhsScope = mkScope $ grhss_span grhss
+ in toHie $ patScopes Nothing rhsScope NoScope pats
+ , toHie grhss
+ ]
+ XMatch _ -> []
+
+instance ( ToHie (Context (Located a))
+ ) => ToHie (HsMatchContext a) where
+ toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name
+ toHie (StmtCtxt a) = toHie a
+ toHie _ = pure []
+
+instance ( ToHie (HsMatchContext a)
+ ) => ToHie (HsStmtContext a) where
+ toHie (PatGuard a) = toHie a
+ toHie (ParStmtCtxt a) = toHie a
+ toHie (TransStmtCtxt a) = toHie a
+ toHie _ = pure []
+
+instance ( a ~ GhcPass p
+ , ToHie (Context (Located (IdP a)))
+ , ToHie (RContext (HsRecFields a (PScoped (LPat a))))
+ , ToHie (LHsExpr a)
+ , ToHie (TScoped (LHsSigWcType a))
+ , ProtectSig a
+ , ToHie (TScoped (ProtectedSig a))
+ , HasType (LPat a)
+ , Data (HsSplice a)
+ ) => ToHie (PScoped (LPat (GhcPass p))) where
+ toHie (PS rsp scope pscope lpat@(dL -> L ospan opat)) =
+ concatM $ getTypeNode lpat : case opat of
+ WildPat _ ->
+ []
+ VarPat _ lname ->
+ [ toHie $ C (PatternBind scope pscope rsp) lname
+ ]
+ LazyPat _ p ->
+ [ toHie $ PS rsp scope pscope p
+ ]
+ AsPat _ lname pat ->
+ [ toHie $ C (PatternBind scope
+ (combineScopes (mkLScope (dL pat)) pscope)
+ rsp)
+ lname
+ , toHie $ PS rsp scope pscope pat
+ ]
+ ParPat _ pat ->
+ [ toHie $ PS rsp scope pscope pat
+ ]
+ BangPat _ pat ->
+ [ toHie $ PS rsp scope pscope pat
+ ]
+ ListPat _ pats ->
+ [ toHie $ patScopes rsp scope pscope pats
+ ]
+ TuplePat _ pats _ ->
+ [ toHie $ patScopes rsp scope pscope pats
+ ]
+ SumPat _ pat _ _ ->
+ [ toHie $ PS rsp scope pscope pat
+ ]
+ ConPatIn c dets ->
+ [ toHie $ C Use c
+ , toHie $ contextify dets
+ ]
+ ConPatOut {pat_con = con, pat_args = dets}->
+ [ toHie $ C Use $ fmap conLikeName con
+ , toHie $ contextify dets
+ ]
+ ViewPat _ expr pat ->
+ [ toHie expr
+ , toHie $ PS rsp scope pscope pat
+ ]
+ SplicePat _ sp ->
+ [ toHie $ L ospan sp
+ ]
+ LitPat _ _ ->
+ []
+ NPat _ _ _ _ ->
+ []
+ NPlusKPat _ n _ _ _ _ ->
+ [ toHie $ C (PatternBind scope pscope rsp) n
+ ]
+ SigPat _ pat sig ->
+ [ toHie $ PS rsp scope pscope pat
+ , let cscope = mkLScope (dL pat) in
+ toHie $ TS (ResolvedScopes [cscope, scope, pscope])
+ (protectSig @a cscope sig)
+ -- See Note [Scoping Rules for SigPat]
+ ]
+ CoPat _ _ _ _ ->
+ []
+ XPat _ -> []
+ where
+ contextify (PrefixCon args) = PrefixCon $ patScopes rsp scope pscope args
+ contextify (InfixCon a b) = InfixCon a' b'
+ where [a', b'] = patScopes rsp scope pscope [a,b]
+ contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r
+ contextify_rec (HsRecFields fds a) = HsRecFields (map go scoped_fds) a
+ where
+ go (RS fscope (L spn (HsRecField lbl pat pun))) =
+ L spn $ HsRecField lbl (PS rsp scope fscope pat) pun
+ scoped_fds = listScopes pscope fds
+
+instance ( ToHie body
+ , ToHie (LGRHS a body)
+ , ToHie (RScoped (LHsLocalBinds a))
+ ) => ToHie (GRHSs a body) where
+ toHie grhs = concatM $ case grhs of
+ GRHSs _ grhss binds ->
+ [ toHie grhss
+ , toHie $ RS (mkScope $ grhss_span grhs) binds
+ ]
+ XGRHSs _ -> []
+
+instance ( ToHie (Located body)
+ , ToHie (RScoped (GuardLStmt a))
+ , Data (GRHS a (Located body))
+ ) => ToHie (LGRHS a (Located body)) where
+ toHie (L span g) = concatM $ makeNode g span : case g of
+ GRHS _ guards body ->
+ [ toHie $ listScopes (mkLScope body) guards
+ , toHie body
+ ]
+ XGRHS _ -> []
+
+instance ( a ~ GhcPass p
+ , ToHie (Context (Located (IdP a)))
+ , HasType (LHsExpr a)
+ , ToHie (PScoped (LPat a))
+ , ToHie (MatchGroup a (LHsExpr a))
+ , ToHie (LGRHS a (LHsExpr a))
+ , ToHie (RContext (HsRecordBinds a))
+ , ToHie (RFContext (Located (AmbiguousFieldOcc a)))
+ , ToHie (ArithSeqInfo a)
+ , ToHie (LHsCmdTop a)
+ , ToHie (RScoped (GuardLStmt a))
+ , ToHie (RScoped (LHsLocalBinds a))
+ , ToHie (TScoped (LHsWcType (NoGhcTc a)))
+ , ToHie (TScoped (LHsSigWcType (NoGhcTc a)))
+ , Data (HsExpr a)
+ , Data (HsSplice a)
+ , Data (HsTupArg a)
+ , Data (AmbiguousFieldOcc a)
+ ) => ToHie (LHsExpr (GhcPass p)) where
+ toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of
+ HsVar _ (L _ var) ->
+ [ toHie $ C Use (L mspan var)
+ -- Patch up var location since typechecker removes it
+ ]
+ HsUnboundVar _ _ ->
+ []
+ HsConLikeOut _ con ->
+ [ toHie $ C Use $ L mspan $ conLikeName con
+ ]
+ HsRecFld _ fld ->
+ [ toHie $ RFC RecFieldOcc Nothing (L mspan fld)
+ ]
+ HsOverLabel _ _ _ -> []
+ HsIPVar _ _ -> []
+ HsOverLit _ _ -> []
+ HsLit _ _ -> []
+ HsLam _ mg ->
+ [ toHie mg
+ ]
+ HsLamCase _ mg ->
+ [ toHie mg
+ ]
+ HsApp _ a b ->
+ [ toHie a
+ , toHie b
+ ]
+ HsAppType _ expr sig ->
+ [ toHie expr
+ , toHie $ TS (ResolvedScopes []) sig
+ ]
+ OpApp _ a b c ->
+ [ toHie a
+ , toHie b
+ , toHie c
+ ]
+ NegApp _ a _ ->
+ [ toHie a
+ ]
+ HsPar _ a ->
+ [ toHie a
+ ]
+ SectionL _ a b ->
+ [ toHie a
+ , toHie b
+ ]
+ SectionR _ a b ->
+ [ toHie a
+ , toHie b
+ ]
+ ExplicitTuple _ args _ ->
+ [ toHie args
+ ]
+ ExplicitSum _ _ _ expr ->
+ [ toHie expr
+ ]
+ HsCase _ expr matches ->
+ [ toHie expr
+ , toHie matches
+ ]
+ HsIf _ _ a b c ->
+ [ toHie a
+ , toHie b
+ , toHie c
+ ]
+ HsMultiIf _ grhss ->
+ [ toHie grhss
+ ]
+ HsLet _ binds expr ->
+ [ toHie $ RS (mkLScope expr) binds
+ , toHie expr
+ ]
+ HsDo _ _ (L ispan stmts) ->
+ [ pure $ locOnly ispan
+ , toHie $ listScopes NoScope stmts
+ ]
+ ExplicitList _ _ exprs ->
+ [ toHie exprs
+ ]
+ RecordCon {rcon_con_name = name, rcon_flds = binds}->
+ [ toHie $ C Use name
+ , toHie $ RC RecFieldAssign $ binds
+ ]
+ RecordUpd {rupd_expr = expr, rupd_flds = upds}->
+ [ toHie expr
+ , toHie $ map (RC RecFieldAssign) upds
+ ]
+ ExprWithTySig _ expr sig ->
+ [ toHie expr
+ , toHie $ TS (ResolvedScopes [mkLScope expr]) sig
+ ]
+ ArithSeq _ _ info ->
+ [ toHie info
+ ]
+ HsSCC _ _ _ expr ->
+ [ toHie expr
+ ]
+ HsCoreAnn _ _ _ expr ->
+ [ toHie expr
+ ]
+ HsProc _ pat cmdtop ->
+ [ toHie $ PS Nothing (mkLScope cmdtop) NoScope pat
+ , toHie cmdtop
+ ]
+ HsStatic _ expr ->
+ [ toHie expr
+ ]
+ HsArrApp _ a b _ _ ->
+ [ toHie a
+ , toHie b
+ ]
+ HsArrForm _ expr _ cmds ->
+ [ toHie expr
+ , toHie cmds
+ ]
+ HsTick _ _ expr ->
+ [ toHie expr
+ ]
+ HsBinTick _ _ _ expr ->
+ [ toHie expr
+ ]
+ HsTickPragma _ _ _ _ expr ->
+ [ toHie expr
+ ]
+ HsWrap _ _ a ->
+ [ toHie $ L mspan a
+ ]
+ HsBracket _ b ->
+ [ toHie b
+ ]
+ HsRnBracketOut _ b p ->
+ [ toHie b
+ , toHie p
+ ]
+ HsTcBracketOut _ b p ->
+ [ toHie b
+ , toHie p
+ ]
+ HsSpliceE _ x ->
+ [ toHie $ L mspan x
+ ]
+ EWildPat _ -> []
+ EAsPat _ a b ->
+ [ toHie $ C Use a
+ , toHie b
+ ]
+ EViewPat _ a b ->
+ [ toHie a
+ , toHie b
+ ]
+ ELazyPat _ a ->
+ [ toHie a
+ ]
+ XExpr _ -> []
+
+instance ( a ~ GhcPass p
+ , ToHie (LHsExpr a)
+ , Data (HsTupArg a)
+ ) => ToHie (LHsTupArg (GhcPass p)) where
+ toHie (L span arg) = concatM $ makeNode arg span : case arg of
+ Present _ expr ->
+ [ toHie expr
+ ]
+ Missing _ -> []
+ XTupArg _ -> []
+
+instance ( a ~ GhcPass p
+ , ToHie (PScoped (LPat a))
+ , ToHie (LHsExpr a)
+ , ToHie (SigContext (LSig a))
+ , ToHie (RScoped (LHsLocalBinds a))
+ , ToHie (RScoped (ApplicativeArg a))
+ , ToHie (Located body)
+ , Data (StmtLR a a (Located body))
+ , Data (StmtLR a a (Located (HsExpr a)))
+ ) => ToHie (RScoped (LStmt (GhcPass p) (Located body))) where
+ toHie (RS scope (L span stmt)) = concatM $ makeNode stmt span : case stmt of
+ LastStmt _ body _ _ ->
+ [ toHie body
+ ]
+ BindStmt _ pat body _ _ ->
+ [ toHie $ PS (getRealSpan $ getLoc body) scope NoScope pat
+ , toHie body
+ ]
+ ApplicativeStmt _ stmts _ ->
+ [ concatMapM (toHie . RS scope . snd) stmts
+ ]
+ BodyStmt _ body _ _ ->
+ [ toHie body
+ ]
+ LetStmt _ binds ->
+ [ toHie $ RS scope binds
+ ]
+ ParStmt _ parstmts _ _ ->
+ [ concatMapM (\(ParStmtBlock _ stmts _ _) ->
+ toHie $ listScopes NoScope stmts)
+ parstmts
+ ]
+ TransStmt {trS_stmts = stmts, trS_using = using, trS_by = by} ->
+ [ toHie $ listScopes scope stmts
+ , toHie using
+ , toHie by
+ ]
+ RecStmt {recS_stmts = stmts} ->
+ [ toHie $ map (RS $ combineScopes scope (mkScope span)) stmts
+ ]
+ XStmtLR _ -> []
+
+instance ( ToHie (LHsExpr a)
+ , ToHie (PScoped (LPat a))
+ , ToHie (BindContext (LHsBind a))
+ , ToHie (SigContext (LSig a))
+ , ToHie (RScoped (HsValBindsLR a a))
+ , Data (HsLocalBinds a)
+ ) => ToHie (RScoped (LHsLocalBinds a)) where
+ toHie (RS scope (L sp binds)) = concatM $ makeNode binds sp : case binds of
+ EmptyLocalBinds _ -> []
+ HsIPBinds _ _ -> []
+ HsValBinds _ valBinds ->
+ [ toHie $ RS (combineScopes scope $ mkScope sp)
+ valBinds
+ ]
+ XHsLocalBindsLR _ -> []
+
+instance ( ToHie (BindContext (LHsBind a))
+ , ToHie (SigContext (LSig a))
+ , ToHie (RScoped (XXValBindsLR a a))
+ ) => ToHie (RScoped (HsValBindsLR a a)) where
+ toHie (RS sc v) = concatM $ case v of
+ ValBinds _ binds sigs ->
+ [ toHie $ fmap (BC RegularBind sc) binds
+ , toHie $ fmap (SC (SI BindSig Nothing)) sigs
+ ]
+ XValBindsLR x -> [ toHie $ RS sc x ]
+
+instance ToHie (RScoped (NHsValBindsLR GhcTc)) where
+ toHie (RS sc (NValBinds binds sigs)) = concatM $
+ [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)
+ , toHie $ fmap (SC (SI BindSig Nothing)) sigs
+ ]
+instance ToHie (RScoped (NHsValBindsLR GhcRn)) where
+ toHie (RS sc (NValBinds binds sigs)) = concatM $
+ [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)
+ , toHie $ fmap (SC (SI BindSig Nothing)) sigs
+ ]
+
+instance ( ToHie (RContext (LHsRecField a arg))
+ ) => ToHie (RContext (HsRecFields a arg)) where
+ toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields
+
+instance ( ToHie (RFContext (Located label))
+ , ToHie arg
+ , HasLoc arg
+ , Data label
+ , Data arg
+ ) => ToHie (RContext (LHsRecField' label arg)) where
+ toHie (RC c (L span recfld)) = concatM $ makeNode recfld span : case recfld of
+ HsRecField label expr _ ->
+ [ toHie $ RFC c (getRealSpan $ loc expr) label
+ , toHie expr
+ ]
+
+removeDefSrcSpan :: Name -> Name
+removeDefSrcSpan n = setNameLoc n noSrcSpan
+
+instance ToHie (RFContext (LFieldOcc GhcRn)) where
+ toHie (RFC c rhs (L nspan f)) = concatM $ case f of
+ FieldOcc name _ ->
+ [ toHie $ C (RecField c rhs) (L nspan $ removeDefSrcSpan name)
+ ]
+ XFieldOcc _ -> []
+
+instance ToHie (RFContext (LFieldOcc GhcTc)) where
+ toHie (RFC c rhs (L nspan f)) = concatM $ case f of
+ FieldOcc var _ ->
+ let var' = setVarName var (removeDefSrcSpan $ varName var)
+ in [ toHie $ C (RecField c rhs) (L nspan var')
+ ]
+ XFieldOcc _ -> []
+
+instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where
+ toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of
+ Unambiguous name _ ->
+ [ toHie $ C (RecField c rhs) $ L nspan $ removeDefSrcSpan name
+ ]
+ Ambiguous _name _ ->
+ [ ]
+ XAmbiguousFieldOcc _ -> []
+
+instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where
+ toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of
+ Unambiguous var _ ->
+ let var' = setVarName var (removeDefSrcSpan $ varName var)
+ in [ toHie $ C (RecField c rhs) (L nspan var')
+ ]
+ Ambiguous var _ ->
+ let var' = setVarName var (removeDefSrcSpan $ varName var)
+ in [ toHie $ C (RecField c rhs) (L nspan var')
+ ]
+ XAmbiguousFieldOcc _ -> []
+
+instance ( a ~ GhcPass p
+ , ToHie (PScoped (LPat a))
+ , ToHie (BindContext (LHsBind a))
+ , ToHie (LHsExpr a)
+ , ToHie (SigContext (LSig a))
+ , ToHie (RScoped (HsValBindsLR a a))
+ , Data (StmtLR a a (Located (HsExpr a)))
+ , Data (HsLocalBinds a)
+ ) => ToHie (RScoped (ApplicativeArg (GhcPass p))) where
+ toHie (RS sc (ApplicativeArgOne _ pat expr _)) = concatM
+ [ toHie $ PS Nothing sc NoScope pat
+ , toHie expr
+ ]
+ toHie (RS sc (ApplicativeArgMany _ stmts _ pat)) = concatM
+ [ toHie $ listScopes NoScope stmts
+ , toHie $ PS Nothing sc NoScope pat
+ ]
+ toHie (RS _ (XApplicativeArg _)) = pure []
+
+instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where
+ toHie (PrefixCon args) = toHie args
+ toHie (RecCon rec) = toHie rec
+ toHie (InfixCon a b) = concatM [ toHie a, toHie b]
+
+instance ( ToHie (LHsCmd a)
+ , Data (HsCmdTop a)
+ ) => ToHie (LHsCmdTop a) where
+ toHie (L span top) = concatM $ makeNode top span : case top of
+ HsCmdTop _ cmd ->
+ [ toHie cmd
+ ]
+ XCmdTop _ -> []
+
+instance ( a ~ GhcPass p
+ , ToHie (PScoped (LPat a))
+ , ToHie (BindContext (LHsBind a))
+ , ToHie (LHsExpr a)
+ , ToHie (MatchGroup a (LHsCmd a))
+ , ToHie (SigContext (LSig a))
+ , ToHie (RScoped (HsValBindsLR a a))
+ , Data (HsCmd a)
+ , Data (HsCmdTop a)
+ , Data (StmtLR a a (Located (HsCmd a)))
+ , Data (HsLocalBinds a)
+ , Data (StmtLR a a (Located (HsExpr a)))
+ ) => ToHie (LHsCmd (GhcPass p)) where
+ toHie (L span cmd) = concatM $ makeNode cmd span : case cmd of
+ HsCmdArrApp _ a b _ _ ->
+ [ toHie a
+ , toHie b
+ ]
+ HsCmdArrForm _ a _ _ cmdtops ->
+ [ toHie a
+ , toHie cmdtops
+ ]
+ HsCmdApp _ a b ->
+ [ toHie a
+ , toHie b
+ ]
+ HsCmdLam _ mg ->
+ [ toHie mg
+ ]
+ HsCmdPar _ a ->
+ [ toHie a
+ ]
+ HsCmdCase _ expr alts ->
+ [ toHie expr
+ , toHie alts
+ ]
+ HsCmdIf _ _ a b c ->
+ [ toHie a
+ , toHie b
+ , toHie c
+ ]
+ HsCmdLet _ binds cmd' ->
+ [ toHie $ RS (mkLScope cmd') binds
+ , toHie cmd'
+ ]
+ HsCmdDo _ (L ispan stmts) ->
+ [ pure $ locOnly ispan
+ , toHie $ listScopes NoScope stmts
+ ]
+ HsCmdWrap _ _ _ -> []
+ XCmd _ -> []
+
+instance ToHie (TyClGroup GhcRn) where
+ toHie (TyClGroup _ classes roles instances) = concatM
+ [ toHie classes
+ , toHie roles
+ , toHie instances
+ ]
+ toHie (XTyClGroup _) = pure []
+
+instance ToHie (LTyClDecl GhcRn) where
+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
+ FamDecl {tcdFam = fdecl} ->
+ [ toHie (L span fdecl)
+ ]
+ SynDecl {tcdLName = name, tcdTyVars = vars, tcdRhs = typ} ->
+ [ toHie $ C (Decl SynDec $ getRealSpan span) name
+ , toHie $ TS (ResolvedScopes [mkScope $ getLoc typ]) vars
+ , toHie typ
+ ]
+ DataDecl {tcdLName = name, tcdTyVars = vars, tcdDataDefn = defn} ->
+ [ toHie $ C (Decl DataDec $ getRealSpan span) name
+ , toHie $ TS (ResolvedScopes [quant_scope, rhs_scope]) vars
+ , toHie defn
+ ]
+ where
+ quant_scope = mkLScope $ dd_ctxt defn
+ rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc
+ sig_sc = maybe NoScope mkLScope $ dd_kindSig defn
+ con_sc = foldr combineScopes NoScope $ map mkLScope $ dd_cons defn
+ deriv_sc = mkLScope $ dd_derivs defn
+ ClassDecl { tcdCtxt = context
+ , tcdLName = name
+ , tcdTyVars = vars
+ , tcdFDs = deps
+ , tcdSigs = sigs
+ , tcdMeths = meths
+ , tcdATs = typs
+ , tcdATDefs = deftyps
+ } ->
+ [ toHie $ C (Decl ClassDec $ getRealSpan span) name
+ , toHie context
+ , toHie $ TS (ResolvedScopes [context_scope, rhs_scope]) vars
+ , toHie deps
+ , toHie $ map (SC $ SI ClassSig $ getRealSpan span) sigs
+ , toHie $ fmap (BC InstanceBind ModuleScope) meths
+ , toHie typs
+ , concatMapM (pure . locOnly . getLoc) deftyps
+ , toHie $ map (go . unLoc) deftyps
+ ]
+ where
+ context_scope = mkLScope context
+ rhs_scope = foldl1' combineScopes $ map mkScope
+ [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps]
+
+ go :: TyFamDefltEqn GhcRn
+ -> FamEqn GhcRn (TScoped (LHsQTyVars GhcRn)) (LHsType GhcRn)
+ go (FamEqn a var bndrs pat b rhs) =
+ FamEqn a var bndrs (TS (ResolvedScopes [mkLScope rhs]) pat) b rhs
+ go (XFamEqn NoExt) = XFamEqn NoExt
+ XTyClDecl _ -> []
+
+instance ToHie (LFamilyDecl GhcRn) where
+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
+ FamilyDecl _ info name vars _ sig inj ->
+ [ toHie $ C (Decl FamDec $ getRealSpan span) name
+ , toHie $ TS (ResolvedScopes [rhsSpan]) vars
+ , toHie info
+ , toHie $ RS injSpan sig
+ , toHie inj
+ ]
+ where
+ rhsSpan = sigSpan `combineScopes` injSpan
+ sigSpan = mkScope $ getLoc sig
+ injSpan = maybe NoScope (mkScope . getLoc) inj
+ XFamilyDecl _ -> []
+
+instance ToHie (FamilyInfo GhcRn) where
+ toHie (ClosedTypeFamily (Just eqns)) = concatM $
+ [ concatMapM (pure . locOnly . getLoc) eqns
+ , toHie $ map go eqns
+ ]
+ where
+ go (L l ib) = TS (ResolvedScopes [mkScope l]) ib
+ toHie _ = pure []
+
+instance ToHie (RScoped (LFamilyResultSig GhcRn)) where
+ toHie (RS sc (L span sig)) = concatM $ makeNode sig span : case sig of
+ NoSig _ ->
+ []
+ KindSig _ k ->
+ [ toHie k
+ ]
+ TyVarSig _ bndr ->
+ [ toHie $ TVS (ResolvedScopes [sc]) NoScope bndr
+ ]
+ XFamilyResultSig _ -> []
+
+instance ToHie (Located (FunDep (Located Name))) where
+ toHie (L span fd@(lhs, rhs)) = concatM $
+ [ makeNode fd span
+ , toHie $ map (C Use) lhs
+ , toHie $ map (C Use) rhs
+ ]
+
+instance (ToHie pats, ToHie rhs, HasLoc pats, HasLoc rhs)
+ => ToHie (TScoped (FamEqn GhcRn pats rhs)) where
+ toHie (TS _ f) = toHie f
+
+instance ( ToHie pats
+ , ToHie rhs
+ , HasLoc pats
+ , HasLoc rhs
+ ) => ToHie (FamEqn GhcRn pats rhs) where
+ toHie fe@(FamEqn _ var tybndrs pats _ rhs) = concatM $
+ [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var
+ , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs
+ , toHie pats
+ , toHie rhs
+ ]
+ where scope = combineScopes patsScope rhsScope
+ patsScope = mkScope (loc pats)
+ rhsScope = mkScope (loc rhs)
+ toHie (XFamEqn _) = pure []
+
+instance ToHie (LInjectivityAnn GhcRn) where
+ toHie (L span ann) = concatM $ makeNode ann span : case ann of
+ InjectivityAnn lhs rhs ->
+ [ toHie $ C Use lhs
+ , toHie $ map (C Use) rhs
+ ]
+
+instance ToHie (HsDataDefn GhcRn) where
+ toHie (HsDataDefn _ _ ctx _ mkind cons derivs) = concatM
+ [ toHie ctx
+ , toHie mkind
+ , toHie cons
+ , toHie derivs
+ ]
+ toHie (XHsDataDefn _) = pure []
+
+instance ToHie (HsDeriving GhcRn) where
+ toHie (L span clauses) = concatM
+ [ pure $ locOnly span
+ , toHie clauses
+ ]
+
+instance ToHie (LHsDerivingClause GhcRn) where
+ toHie (L span cl) = concatM $ makeNode cl span : case cl of
+ HsDerivingClause _ strat (L ispan tys) ->
+ [ toHie strat
+ , pure $ locOnly ispan
+ , toHie $ map (TS (ResolvedScopes [])) tys
+ ]
+ XHsDerivingClause _ -> []
+
+instance ToHie (Located (DerivStrategy GhcRn)) where
+ toHie (L span strat) = concatM $ makeNode strat span : case strat of
+ StockStrategy -> []
+ AnyclassStrategy -> []
+ NewtypeStrategy -> []
+ ViaStrategy s -> [ toHie $ TS (ResolvedScopes []) s ]
+
+instance ToHie (Located OverlapMode) where
+ toHie (L span _) = pure $ locOnly span
+
+instance ToHie (LConDecl GhcRn) where
+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
+ ConDeclGADT { con_names = names, con_qvars = qvars
+ , con_mb_cxt = ctx, con_args = args, con_res_ty = typ } ->
+ [ toHie $ map (C (Decl ConDec $ getRealSpan span)) names
+ , toHie $ TS (ResolvedScopes [ctxScope, rhsScope]) qvars
+ , toHie ctx
+ , toHie args
+ , toHie typ
+ ]
+ where
+ rhsScope = combineScopes argsScope tyScope
+ ctxScope = maybe NoScope mkLScope ctx
+ argsScope = condecl_scope args
+ tyScope = mkLScope typ
+ ConDeclH98 { con_name = name, con_ex_tvs = qvars
+ , con_mb_cxt = ctx, con_args = dets } ->
+ [ toHie $ C (Decl ConDec $ getRealSpan span) name
+ , toHie $ tvScopes (ResolvedScopes []) rhsScope qvars
+ , toHie ctx
+ , toHie dets
+ ]
+ where
+ rhsScope = combineScopes ctxScope argsScope
+ ctxScope = maybe NoScope mkLScope ctx
+ argsScope = condecl_scope dets
+ XConDecl _ -> []
+ where condecl_scope args = case args of
+ PrefixCon xs -> foldr combineScopes NoScope $ map mkLScope xs
+ InfixCon a b -> combineScopes (mkLScope a) (mkLScope b)
+ RecCon x -> mkLScope x
+
+instance ToHie (Located [LConDeclField GhcRn]) where
+ toHie (L span decls) = concatM $
+ [ pure $ locOnly span
+ , toHie decls
+ ]
+
+instance ( HasLoc thing
+ , ToHie (TScoped thing)
+ ) => ToHie (TScoped (HsImplicitBndrs GhcRn thing)) where
+ toHie (TS sc (HsIB ibrn a)) = concatM $
+ [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) ibrn
+ , toHie $ TS sc a
+ ]
+ where span = loc a
+ toHie (TS _ (XHsImplicitBndrs _)) = pure []
+
+instance ( HasLoc thing
+ , ToHie (TScoped thing)
+ ) => ToHie (TScoped (HsWildCardBndrs GhcRn thing)) where
+ toHie (TS sc (HsWC names a)) = concatM $
+ [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names
+ , toHie $ TS sc a
+ ]
+ where span = loc a
+ toHie (TS _ (XHsWildCardBndrs _)) = pure []
+
+instance ToHie (SigContext (LSig GhcRn)) where
+ toHie (SC (SI styp msp) (L sp sig)) = concatM $ makeNode sig sp : case sig of
+ TypeSig _ names typ ->
+ [ toHie $ map (C TyDecl) names
+ , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ
+ ]
+ PatSynSig _ names typ ->
+ [ toHie $ map (C TyDecl) names
+ , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ
+ ]
+ ClassOpSig _ _ names typ ->
+ [ case styp of
+ ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpan sp) names
+ _ -> toHie $ map (C $ TyDecl) names
+ , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ
+ ]
+ IdSig _ _ -> []
+ FixSig _ fsig ->
+ [ toHie $ L sp fsig
+ ]
+ InlineSig _ name _ ->
+ [ toHie $ (C Use) name
+ ]
+ SpecSig _ name typs _ ->
+ [ toHie $ (C Use) name
+ , toHie $ map (TS (ResolvedScopes [])) typs
+ ]
+ SpecInstSig _ _ typ ->
+ [ toHie $ TS (ResolvedScopes []) typ
+ ]
+ MinimalSig _ _ form ->
+ [ toHie form
+ ]
+ SCCFunSig _ _ name mtxt ->
+ [ toHie $ (C Use) name
+ , pure $ maybe [] (locOnly . getLoc) mtxt
+ ]
+ CompleteMatchSig _ _ (L ispan names) typ ->
+ [ pure $ locOnly ispan
+ , toHie $ map (C Use) names
+ , toHie $ fmap (C Use) typ
+ ]
+ XSig _ -> []
+
+instance ToHie (LHsType GhcRn) where
+ toHie x = toHie $ TS (ResolvedScopes []) x
+
+instance ToHie (TScoped (LHsType GhcRn)) where
+ toHie (TS tsc (L span t)) = concatM $ makeNode t span : case t of
+ HsForAllTy _ bndrs body ->
+ [ toHie $ tvScopes tsc (mkScope $ getLoc body) bndrs
+ , toHie body
+ ]
+ HsQualTy _ ctx body ->
+ [ toHie ctx
+ , toHie body
+ ]
+ HsTyVar _ _ var ->
+ [ toHie $ C Use var
+ ]
+ HsAppTy _ a b ->
+ [ toHie a
+ , toHie b
+ ]
+ HsFunTy _ a b ->
+ [ toHie a
+ , toHie b
+ ]
+ HsListTy _ a ->
+ [ toHie a
+ ]
+ HsTupleTy _ _ tys ->
+ [ toHie tys
+ ]
+ HsSumTy _ tys ->
+ [ toHie tys
+ ]
+ HsOpTy _ a op b ->
+ [ toHie a
+ , toHie $ C Use op
+ , toHie b
+ ]
+ HsParTy _ a ->
+ [ toHie a
+ ]
+ HsIParamTy _ ip ty ->
+ [ toHie ip
+ , toHie ty
+ ]
+ HsKindSig _ a b ->
+ [ toHie a
+ , toHie b
+ ]
+ HsSpliceTy _ a ->
+ [ toHie $ L span a
+ ]
+ HsDocTy _ a _ ->
+ [ toHie a
+ ]
+ HsBangTy _ _ ty ->
+ [ toHie ty
+ ]
+ HsRecTy _ fields ->
+ [ toHie fields
+ ]
+ HsExplicitListTy _ _ tys ->
+ [ toHie tys
+ ]
+ HsExplicitTupleTy _ tys ->
+ [ toHie tys
+ ]
+ HsTyLit _ _ -> []
+ HsWildCardTy e ->
+ [ toHie e
+ ]
+ HsStarTy _ _ -> []
+ XHsType _ -> []
+
+instance ToHie HsWildCardInfo where
+ toHie (AnonWildCard name) = toHie $ C Use name
+
+instance ToHie (TVScoped (LHsTyVarBndr GhcRn)) where
+ toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of
+ UserTyVar _ var ->
+ [ toHie $ C (TyVarBind sc tsc) var
+ ]
+ KindedTyVar _ var kind ->
+ [ toHie $ C (TyVarBind sc tsc) var
+ , toHie kind
+ ]
+ XTyVarBndr _ -> []
+
+instance ToHie (TScoped (LHsQTyVars GhcRn)) where
+ toHie (TS sc (HsQTvs (HsQTvsRn implicits _) vars)) = concatM $
+ [ pure $ bindingsOnly bindings
+ , toHie $ tvScopes sc NoScope vars
+ ]
+ where
+ varLoc = loc vars
+ bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits
+ toHie (TS _ (XLHsQTyVars _)) = pure []
+
+instance ToHie (LHsContext GhcRn) where
+ toHie (L span tys) = concatM $
+ [ pure $ locOnly span
+ , toHie tys
+ ]
+
+instance ToHie (LConDeclField GhcRn) where
+ toHie (L span field) = concatM $ makeNode field span : case field of
+ ConDeclField _ fields typ _ ->
+ [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields
+ , toHie typ
+ ]
+ XConDeclField _ -> []
+
+instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where
+ toHie (From expr) = toHie expr
+ toHie (FromThen a b) = concatM $
+ [ toHie a
+ , toHie b
+ ]
+ toHie (FromTo a b) = concatM $
+ [ toHie a
+ , toHie b
+ ]
+ toHie (FromThenTo a b c) = concatM $
+ [ toHie a
+ , toHie b
+ , toHie c
+ ]
+
+instance ToHie (LSpliceDecl GhcRn) where
+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
+ SpliceDecl _ splice _ ->
+ [ toHie splice
+ ]
+ XSpliceDecl _ -> []
+
+instance ToHie (HsBracket a) where
+ toHie _ = pure []
+
+instance ToHie PendingRnSplice where
+ toHie _ = pure []
+
+instance ToHie PendingTcSplice where
+ toHie _ = pure []
+
+instance ToHie (LBooleanFormula (Located Name)) where
+ toHie (L span form) = concatM $ makeNode form span : case form of
+ Var a ->
+ [ toHie $ C Use a
+ ]
+ And forms ->
+ [ toHie forms
+ ]
+ Or forms ->
+ [ toHie forms
+ ]
+ Parens f ->
+ [ toHie f
+ ]
+
+instance ToHie (Located HsIPName) where
+ toHie (L span e) = makeNode e span
+
+instance ( ToHie (LHsExpr a)
+ , Data (HsSplice a)
+ ) => ToHie (Located (HsSplice a)) where
+ toHie (L span sp) = concatM $ makeNode sp span : case sp of
+ HsTypedSplice _ _ _ expr ->
+ [ toHie expr
+ ]
+ HsUntypedSplice _ _ _ expr ->
+ [ toHie expr
+ ]
+ HsQuasiQuote _ _ _ ispan _ ->
+ [ pure $ locOnly ispan
+ ]
+ HsSpliced _ _ _ ->
+ []
+ XSplice _ -> []
+
+instance ToHie (LRoleAnnotDecl GhcRn) where
+ toHie (L span annot) = concatM $ makeNode annot span : case annot of
+ RoleAnnotDecl _ var roles ->
+ [ toHie $ C Use var
+ , concatMapM (pure . locOnly . getLoc) roles
+ ]
+ XRoleAnnotDecl _ -> []
+
+instance ToHie (LInstDecl GhcRn) where
+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
+ ClsInstD _ d ->
+ [ toHie $ L span d
+ ]
+ DataFamInstD _ d ->
+ [ toHie $ L span d
+ ]
+ TyFamInstD _ d ->
+ [ toHie $ L span d
+ ]
+ XInstDecl _ -> []
+
+instance ToHie (LClsInstDecl GhcRn) where
+ toHie (L span decl) = concatM
+ [ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl
+ , toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl
+ , toHie $ map (SC $ SI InstSig $ getRealSpan span) $ cid_sigs decl
+ , pure $ concatMap (locOnly . getLoc) $ cid_tyfam_insts decl
+ , toHie $ cid_tyfam_insts decl
+ , pure $ concatMap (locOnly . getLoc) $ cid_datafam_insts decl
+ , toHie $ cid_datafam_insts decl
+ , toHie $ cid_overlap_mode decl
+ ]
+
+instance ToHie (LDataFamInstDecl GhcRn) where
+ toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d
+
+instance ToHie (LTyFamInstDecl GhcRn) where
+ toHie (L sp (TyFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d
+
+instance ToHie (Context a)
+ => ToHie (PatSynFieldContext (RecordPatSynField a)) where
+ toHie (PSC sp (RecordPatSynField a b)) = concatM $
+ [ toHie $ C (RecField RecFieldDecl sp) a
+ , toHie $ C Use b
+ ]
+
+instance ToHie (LDerivDecl GhcRn) where
+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
+ DerivDecl _ typ strat overlap ->
+ [ toHie $ TS (ResolvedScopes []) typ
+ , toHie strat
+ , toHie overlap
+ ]
+ XDerivDecl _ -> []
+
+instance ToHie (LFixitySig GhcRn) where
+ toHie (L span sig) = concatM $ makeNode sig span : case sig of
+ FixitySig _ vars _ ->
+ [ toHie $ map (C Use) vars
+ ]
+ XFixitySig _ -> []
+
+instance ToHie (LDefaultDecl GhcRn) where
+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
+ DefaultDecl _ typs ->
+ [ toHie typs
+ ]
+ XDefaultDecl _ -> []
+
+instance ToHie (LForeignDecl GhcRn) where
+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
+ ForeignImport {fd_name = name, fd_sig_ty = sig, fd_fi = fi} ->
+ [ toHie $ C (ValBind RegularBind ModuleScope $ getRealSpan span) name
+ , toHie $ TS (ResolvedScopes []) sig
+ , toHie fi
+ ]
+ ForeignExport {fd_name = name, fd_sig_ty = sig, fd_fe = fe} ->
+ [ toHie $ C Use name
+ , toHie $ TS (ResolvedScopes []) sig
+ , toHie fe
+ ]
+ XForeignDecl _ -> []
+
+instance ToHie ForeignImport where
+ toHie (CImport (L a _) (L b _) _ _ (L c _)) = pure $ concat $
+ [ locOnly a
+ , locOnly b
+ , locOnly c
+ ]
+
+instance ToHie ForeignExport where
+ toHie (CExport (L a _) (L b _)) = pure $ concat $
+ [ locOnly a
+ , locOnly b
+ ]
+
+instance ToHie (LWarnDecls GhcRn) where
+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
+ Warnings _ _ warnings ->
+ [ toHie warnings
+ ]
+ XWarnDecls _ -> []
+
+instance ToHie (LWarnDecl GhcRn) where
+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
+ Warning _ vars _ ->
+ [ toHie $ map (C Use) vars
+ ]
+ XWarnDecl _ -> []
+
+instance ToHie (LAnnDecl GhcRn) where
+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
+ HsAnnotation _ _ prov expr ->
+ [ toHie prov
+ , toHie expr
+ ]
+ XAnnDecl _ -> []
+
+instance ToHie (Context (Located a)) => ToHie (AnnProvenance a) where
+ toHie (ValueAnnProvenance a) = toHie $ C Use a
+ toHie (TypeAnnProvenance a) = toHie $ C Use a
+ toHie ModuleAnnProvenance = pure []
+
+instance ToHie (LRuleDecls GhcRn) where
+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
+ HsRules _ _ rules ->
+ [ toHie rules
+ ]
+ XRuleDecls _ -> []
+
+instance ToHie (LRuleDecl GhcRn) where
+ toHie (L _ (XRuleDecl _)) = pure []
+ toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM
+ [ makeNode r span
+ , pure $ locOnly $ getLoc rname
+ , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs
+ , toHie $ map (RS $ mkScope span) bndrs
+ , toHie exprA
+ , toHie exprB
+ ]
+ where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc
+ bndrs_sc = maybe NoScope mkLScope (listToMaybe bndrs)
+ exprA_sc = mkLScope exprA
+ exprB_sc = mkLScope exprB
+
+instance ToHie (RScoped (LRuleBndr GhcRn)) where
+ toHie (RS sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of
+ RuleBndr _ var ->
+ [ toHie $ C (ValBind RegularBind sc Nothing) var
+ ]
+ RuleBndrSig _ var typ ->
+ [ toHie $ C (ValBind RegularBind sc Nothing) var
+ , toHie $ TS (ResolvedScopes [sc]) typ
+ ]
+ XRuleBndr _ -> []
+
+instance ToHie (LImportDecl GhcRn) where
+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
+ ImportDecl { ideclName = name, ideclAs = as, ideclHiding = hidden } ->
+ [ toHie $ IEC Import name
+ , toHie $ fmap (IEC ImportAs) as
+ , maybe (pure []) goIE hidden
+ ]
+ XImportDecl _ -> []
+ where
+ goIE (hiding, (L sp liens)) = concatM $
+ [ pure $ locOnly sp
+ , toHie $ map (IEC c) liens
+ ]
+ where
+ c = if hiding then ImportHiding else Import
+
+instance ToHie (IEContext (LIE GhcRn)) where
+ toHie (IEC c (L span ie)) = concatM $ makeNode ie span : case ie of
+ IEVar _ n ->
+ [ toHie $ IEC c n
+ ]
+ IEThingAbs _ n ->
+ [ toHie $ IEC c n
+ ]
+ IEThingAll _ n ->
+ [ toHie $ IEC c n
+ ]
+ IEThingWith _ n _ ns flds ->
+ [ toHie $ IEC c n
+ , toHie $ map (IEC c) ns
+ , toHie $ map (IEC c) flds
+ ]
+ IEModuleContents _ n ->
+ [ toHie $ IEC c n
+ ]
+ IEGroup _ _ _ -> []
+ IEDoc _ _ -> []
+ IEDocNamed _ _ -> []
+ XIE _ -> []
+
+instance ToHie (IEContext (LIEWrappedName Name)) where
+ toHie (IEC c (L span iewn)) = concatM $ makeNode iewn span : case iewn of
+ IEName n ->
+ [ toHie $ C (IEThing c) n
+ ]
+ IEPattern p ->
+ [ toHie $ C (IEThing c) p
+ ]
+ IEType n ->
+ [ toHie $ C (IEThing c) n
+ ]
+
+instance ToHie (IEContext (Located (FieldLbl Name))) where
+ toHie (IEC c (L span lbl)) = concatM $ makeNode lbl span : case lbl of
+ FieldLabel _ _ n ->
+ [ toHie $ C (IEThing c) $ L span n
+ ]
View Lorry Controller Status