{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeFamilies #-}
module Language.Haskell.Tools.BackendGHC.Decls where
import ApiAnnotation as GHC (AnnKeywordId(..))
import Bag as GHC (bagToList)
import BasicTypes as GHC
import BooleanFormula as GHC (BooleanFormula(..))
import Class as GHC (FunDep)
import ForeignCall as GHC (Safety(..), CExportSpec(..), CCallConv(..))
import qualified GHC
import HsSyn as GHC
import Name as GHC (Name, occNameString, nameOccName, isSymOcc)
import Outputable as GHC (Outputable(..), showSDocUnsafe)
import RdrName as GHC (RdrName, rdrNameOcc)
import SrcLoc as GHC
import TyCon as GHC (Role(..))
import HsExtension (GhcPass, NoExt(..))
import Control.Monad.Reader
import Control.Reference
import Data.Generics.Uniplate.Data ()
import Data.List
import Data.Maybe (Maybe(..), fromMaybe)
import GHC.Stack (HasCallStack)
import Language.Haskell.Tools.BackendGHC.Binds
import Language.Haskell.Tools.BackendGHC.Exprs (trfExpr)
import Language.Haskell.Tools.BackendGHC.GHCUtils
import Language.Haskell.Tools.BackendGHC.Kinds (trfKindSig, trfKindSig')
import Language.Haskell.Tools.BackendGHC.Monad
import Language.Haskell.Tools.BackendGHC.Names
import Language.Haskell.Tools.BackendGHC.Patterns (trfPattern)
import {-# SOURCE #-} Language.Haskell.Tools.BackendGHC.TH (trfSplice)
import Language.Haskell.Tools.BackendGHC.Types
import Language.Haskell.Tools.BackendGHC.Utils
import Language.Haskell.Tools.AST (Ann, AnnMaybeG, AnnListG, getRange, Dom, RangeStage)
import qualified Language.Haskell.Tools.AST as AST
import Language.Haskell.Tools.AST.SemaInfoTypes as AST (nameInfo, mkNoSemanticInfo, trfImportInfo)
trfDecls :: (TransformName n r, n ~ GhcPass p, HasCallStack) => [LHsDecl n] -> Trf (AnnListG AST.UDecl (Dom r) RangeStage)
trfDecls decls = addToCurrentScope decls $ makeIndentedListNewlineBefore atTheEnd (mapM trfDecl decls)
trfDeclsGroup :: forall n r p . (TransformName n r, n ~ GhcPass p, HasCallStack) => HsGroup n -> Trf (AnnListG AST.UDecl (Dom r) RangeStage)
trfDeclsGroup g@(HsGroup _ vals splices tycls derivs fixities defaults foreigns warns anns rules _)
= do rdrSpls <- asks declSplices
let (sigs, bagToList -> binds) = getBindsAndSigs vals
alldecls :: [Located (HsDecl n)]
alldecls = (map (fmap (SpliceD NoExt)) splices)
++ (map (fmap (ValD NoExt)) binds)
++ (map (fmap (SigD NoExt)) sigs)
++ (map (fmap (TyClD NoExt)) (concat $ map group_tyclds tycls))
++ (map (fmap (DerivD NoExt)) derivs)
++ (map (fmap (SigD NoExt . FixSig NoExt)) (mergeFixityDefs fixities))
++ (map (fmap (DefD NoExt)) defaults)
++ (map (fmap (ForD NoExt)) foreigns)
++ (map (fmap (WarningD NoExt)) warns)
++ (map (fmap (AnnD NoExt)) anns)
++ (map (fmap (RuleD NoExt)) rules)
++ (map (fmap (InstD NoExt)) (hsGroupInstDecls g))
let (genNames, sourceNames) = partition (\d -> any (\spl -> getLoc spl `containsRealSpan` getLoc d) rdrSpls) alldecls
addToCurrentScope sourceNames $ do
spls <- asks declSplices >>= mapM (\(L l e) -> let namesGeneratedBefore = filter ((srcSpanStart l >) . srcSpanEnd . getLoc) genNames
in addToCurrentScope namesGeneratedBefore ((L l) <$> transformSplice e))
let actualDefinitions = removeContained $ orderElems $ replaceSpliceDecls spls alldecls
in makeIndentedListNewlineBefore atTheEnd
(orderDefs <$> ((++) <$> getDeclsToInsert <*> (mapM (trfDeclsWithScope genNames) actualDefinitions)))
where
trfDeclsWithScope genNames d = local (\s -> s {declSplices = []})
$ addToCurrentScope namesGeneratedBefore (trfDecl @n @r @p d)
where namesGeneratedBefore = filter ((srcSpanStart (getLoc d) >) . srcSpanEnd . getLoc) genNames
replaceSpliceDecls :: [Located (HsSplice n)] -> [Located (HsDecl n)] -> [Located (HsDecl n)]
replaceSpliceDecls splices decls = foldl mergeSplice decls splices
orderElems :: [Located a] -> [Located a]
orderElems = sortOn (srcSpanStart . getLoc)
removeContained :: [Located (HsDecl n)] -> [Located (HsDecl n)]
removeContained (fst:snd:rest) | getLoc fst `containsRealSpan` getLoc snd
= removeContained (fst:rest)
removeContained (fst:rest) = fst : removeContained rest
removeContained [] = []
(RealSrcSpan sp1) `containsRealSpan` (RealSrcSpan sp2) = sp1 `containsSpan` sp2
_ `containsRealSpan` _ = False
mergeSplice :: [Located (HsDecl n)] -> Located (HsSplice n) -> [Located (HsDecl n)]
mergeSplice decls spl@(L spLoc@(RealSrcSpan rss) _)
= L spLoc (SpliceD NoExt (SpliceDecl NoExt spl ExplicitSplice)) : filter (\(L (RealSrcSpan rdsp) _) -> not (rss `containsSpan` rdsp)) decls
mergeSplice _ (L (UnhelpfulSpan {}) _) = convProblem "mergeSplice: no real span"
getDeclsToInsert :: Trf [Ann AST.UDecl (Dom r) RangeStage]
getDeclsToInsert = do decls <- asks declsToInsert
allLocals <- asks localsInScope
case allLocals of locals:_ -> liftGhc $ mapM (replaceNamesInDecls (map (^. _1) locals)) decls
[] -> convertionProblem "getDeclsToInsert: empty scope"
where replaceNamesInDecls :: [GHC.Name] -> Ann AST.UDecl (Dom GhcPs) RangeStage -> GHC.Ghc (Ann AST.UDecl (Dom r) RangeStage)
replaceNamesInDecls locals = AST.semaTraverse $
AST.SemaTrf (pure . (AST.nameInfo .- findName)) pure pure
(pure . trfImportInfo findName) pure pure pure
where findName :: RdrName -> IdP r
findName rdr = fromGHCName $ fromMaybe (convProblem $ "Data definition name not found: " ++ showSDocUnsafe (ppr rdr)
++ ", locals: " ++ (concat $ intersperse ", " $ map (showSDocUnsafe . ppr) locals))
$ find ((occNameString (rdrNameOcc rdr) ==) . occNameString . nameOccName) locals
trfDecl :: forall n r p . (TransformName n r, n ~ GhcPass p, HasCallStack) => Located (HsDecl n) -> Trf (Ann AST.UDecl (Dom r) RangeStage)
trfDecl = trfLocNoSema $ \case
TyClD _ (FamDecl _ (FamilyDecl _ (ClosedTypeFamily typeEqs) name tyVars _ kindSig inj))
-> AST.UClosedTypeFamilyDecl <$> focusAfter AnnType (createDeclHead name tyVars)
<*> trfFamilyResultSig kindSig inj
<*> trfTypeEqs typeEqs
TyClD _ (FamDecl _ fd) -> AST.UTypeFamilyDecl <$> annContNoSema (trfTypeFam' fd)
TyClD _ (SynDecl _ name vars _ rhs)
-> AST.UTypeDecl <$> between AnnType AnnEqual (createDeclHead name vars) <*> trfType rhs
TyClD _ (DataDecl _ name vars _ (HsDataDefn _ nd ctx _ kind cons derivs))
-> do let ctxTok = case nd of DataType -> AnnData
NewType -> AnnNewtype
consLoc = focusBeforeIfPresent AnnDeriving atTheEnd
whereLoc <- tokenLoc AnnWhere
if isGoodSrcSpan whereLoc then trfGADT nd name vars ctx kind cons derivs ctxTok consLoc
else trfDataDef nd name vars ctx cons derivs ctxTok consLoc
TyClD _ (ClassDecl _ ctx name vars _ funDeps sigs defs typeFuns typeFunDefs _)
-> AST.UClassDecl <$> trfCtx (after AnnClass) ctx
<*> betweenIfPresent AnnClass AnnWhere (createDeclHead name vars)
<*> trfFunDeps @n funDeps
<*> createClassBody sigs defs typeFuns typeFunDefs
InstD _ (ClsInstD _ (ClsInstDecl _ typ binds sigs typefam datafam overlap))
-> AST.UInstDecl <$> trfMaybeDefault " " "" trfOverlap (after AnnInstance) overlap
<*> trfInstanceRule (hsib_body typ)
<*> trfInstBody binds sigs typefam datafam
InstD _ (DataFamInstD _ (DataFamInstDecl (hsib_body -> FamEqn _ con pats _ (HsDataDefn _ nd _ _ _ cons derivs))))
| all ((\case ConDeclH98{} -> True; _ -> False) . unLoc) cons
-> AST.UDataInstDecl <$> trfDataKeyword nd
<*> (focusAfter AnnInstance . focusBeforeIfPresent AnnEqual . focusBeforeIfPresent AnnDeriving)
(makeInstanceRuleTyVars con pats)
<*> makeListBefore " = " " | " (pure $ srcSpanStart $ foldLocs $ getLoc con : map getLoc pats) (mapM trfConDecl cons)
<*> makeIndentedList atTheEnd (mapM trfDerivings (unLoc derivs))
InstD _ (DataFamInstD _ (DataFamInstDecl (hsib_body -> FamEqn _ con pats _ (HsDataDefn _ nd _ _ kind cons _))))
-> AST.UGDataInstDecl <$> trfDataKeyword nd
<*> (focusAfter AnnInstance . focusBeforeIfPresent AnnWhere)
(makeInstanceRuleTyVars con pats)
<*> focusBefore AnnWhere (trfKindSig kind)
<*> makeIndentedListBefore " where " atTheEnd (mapM trfGADTConDecl cons)
InstD _ (TyFamInstD _ (TyFamInstDecl (hsib_body -> FamEqn _ con pats _ rhs)))
-> AST.UTypeInstDecl <$> between AnnInstance AnnEqual (makeInstanceRuleTyVars con pats) <*> trfType rhs
ValD _ bind -> trfVal bind
SigD _ sig -> trfSig sig
DerivD _ (DerivDecl _ t strat overlap) -> AST.UDerivDecl <$> trfDerivingStrategy strat <*> trfMaybeDefault " " "" trfOverlap (after AnnInstance) overlap <*> trfInstanceRule (hsib_body $ hswc_body t)
RuleD _ (HsRules _ _ rules) -> AST.UPragmaDecl <$> annContNoSema (AST.URulePragma <$> makeIndentedList (before AnnClose) (mapM trfRewriteRule rules))
RoleAnnotD _ (RoleAnnotDecl _ name roles) -> AST.URoleDecl <$> trfQualifiedName @n False name <*> makeList " " atTheEnd (mapM trfRole roles)
DefD _ (DefaultDecl _ types) -> AST.UDefaultDecl <$> makeList "," (after AnnOpenP) (mapM trfType types)
ForD _ (ForeignImport _ name typ (CImport ccall safe _ _ _))
-> AST.UForeignImport <$> trfCallConv ccall <*> trfSafety (getLoc ccall) safe <*> define (trfName @n name) <*> trfType (hsib_body typ)
ForD _ (ForeignExport _ name typ (CExport (L l (CExportStatic _ _ ccall)) _))
-> AST.UForeignExport <$> annLocNoSema (pure l) (trfCallConv' ccall) <*> trfName @n name <*> trfType (hsib_body typ)
SpliceD _ (SpliceDecl _ (unLoc -> spl) _) -> AST.USpliceDecl <$> trfSplice spl
WarningD _ (Warnings _ _ [])
-> AST.UPragmaDecl <$> annContNoSema (AST.UDeprPragma <$> (makeList " " (after AnnOpen) (pure []))
<*> makeList ", " (before AnnClose) (pure []))
WarningD _ (Warnings _ _ [L _ (Warning _ names (DeprecatedTxt _ stringLits))])
-> AST.UPragmaDecl <$> annContNoSema (AST.UDeprPragma <$> (makeList " " (after AnnOpen) $ mapM (trfName @n) names)
<*> makeList ", " (before AnnClose) (mapM (\(L l (StringLiteral _ fs)) -> trfFastString (L l fs)) stringLits))
WarningD _ (Warnings _ _ [L _ (Warning _ names (WarningTxt _ stringLits))])
-> AST.UPragmaDecl <$> annContNoSema (AST.UWarningPragma <$> (makeNonemptyList " " $ mapM (trfName @n) names)
<*> makeList ", " (before AnnClose) (mapM (\(L l (StringLiteral _ fs)) -> trfFastString (L l fs)) stringLits))
AnnD _ (HsAnnotation _ stxt subject expr)
-> AST.UPragmaDecl <$> annContNoSema (AST.UAnnPragma <$> trfAnnotationSubject @n stxt subject (srcSpanStart $ getLoc expr) <*> trfExpr expr)
d -> unhandledElement "declaration" d
trfGADT :: (TransformName n r, n ~ GhcPass p, HasCallStack) => NewOrData -> Located (IdP n) -> LHsQTyVars n -> Located (HsContext n)
-> Maybe (Located (HsKind n)) -> [Located (ConDecl n)]
-> Located [LHsDerivingClause n] -> AnnKeywordId -> Trf SrcLoc -> Trf (AST.UDecl (Dom r) RangeStage)
trfGADT nd name vars ctx kind cons derivs ctxTok consLoc
= AST.UGDataDecl <$> trfDataKeyword nd
<*> trfCtx (after ctxTok) ctx
<*> betweenIfPresent ctxTok AnnEqual (createDeclHead name vars)
<*> focusBefore AnnWhere (trfKindSig kind)
<*> makeIndentedListBefore " where " consLoc (mapM trfGADTConDecl cons)
<*> makeIndentedList atTheEnd (mapM trfDerivings (unLoc derivs))
trfDataDef :: (TransformName n r, n ~ GhcPass p, HasCallStack) => NewOrData -> Located (IdP n) -> LHsQTyVars n -> Located (HsContext n)
-> [Located (ConDecl n)] -> Located [LHsDerivingClause n]
-> AnnKeywordId -> Trf SrcLoc -> Trf (AST.UDecl (Dom r) RangeStage)
trfDataDef nd name vars ctx cons derivs ctxTok consLoc
= AST.UDataDecl <$> trfDataKeyword nd
<*> trfCtx (after ctxTok) ctx
<*> betweenIfPresent ctxTok AnnEqual (createDeclHead name vars)
<*> makeListBefore "=" " | " consLoc (mapM trfConDecl cons)
<*> makeIndentedList atTheEnd (mapM trfDerivings (unLoc derivs))
trfVal :: (TransformName n r, n ~ GhcPass p, HasCallStack) => HsBindLR n n -> Trf (AST.UDecl (Dom r) RangeStage)
trfVal (PatSynBind _ psb) = AST.UPatternSynonymDecl <$> annContNoSema (trfPatternSynonym psb)
trfVal bind = AST.UValueBinding <$> (annContNoSema $ trfBind' bind)
trfSig :: forall n r p . (TransformName n r, n ~ GhcPass p, HasCallStack) => Sig n -> Trf (AST.UDecl (Dom r) RangeStage)
trfSig (ts@TypeSig {}) = AST.UTypeSigDecl <$> defineTypeVars (annContNoSema $ trfTypeSig' ts)
trfSig (FixSig _ fs) = AST.UFixityDecl <$> (annContNoSema $ trfFixitySig fs)
trfSig (PatSynSig _ ids typ)
= AST.UPatTypeSigDecl <$> annContNoSema (AST.UPatternTypeSignature <$> trfAnnList ", " (trfName' @n) ids <*> trfType (hsib_body typ))
trfSig (InlineSig _ name prag)
= AST.UPragmaDecl <$> annContNoSema (AST.UInlinePragmaDecl <$> trfInlinePragma @n name prag)
trfSig (SpecSig _ name (map hsib_body -> types) (inl_act -> phase))
= AST.UPragmaDecl <$> annContNoSema (AST.USpecializeDecl <$> trfSpecializePragma name types phase)
trfSig (CompleteMatchSig _ _ names typeConstraint)
= AST.UPragmaDecl <$> annContNoSema (AST.UCompletePragma <$> trfAnnList ", " (trfName' @n) (unLoc names)
<*> trfMaybe " :: " "" (trfName @n) typeConstraint)
trfSig s = unhandledElement "signature" s
trfSpecializePragma :: forall n r p . (TransformName n r, n ~ GhcPass p, HasCallStack)
=> Located (IdP n) -> [Located (HsType n)] -> Activation -> Trf (Ann AST.USpecializePragma (Dom r) RangeStage)
trfSpecializePragma name types phase
= annContNoSema $ AST.USpecializePragma <$> trfPhase (pure $ srcSpanStart (getLoc name)) phase
<*> trfName @n name
<*> (orderAnnList <$> trfAnnList ", " trfType' types)
trfConDecl :: (TransformName n r, n ~ GhcPass p, HasCallStack) => Located (ConDecl n) -> Trf (Ann AST.UConDecl (Dom r) RangeStage)
trfConDecl = trfLocNoSema trfConDecl'
trfConDecl' :: forall n r p . (TransformName n r, n ~ GhcPass p, HasCallStack) => ConDecl n -> Trf (AST.UConDecl (Dom r) RangeStage)
trfConDecl' (ConDeclH98 { con_name = name, con_ex_tvs = tyVars, con_mb_cxt = ctx, con_args = PrefixCon args })
= AST.UConDecl <$> trfBindings tyVars <*> trfConCtx ctx <*> define (trfName @n name) <*> makeList " " atTheEnd (mapM trfType args)
trfConDecl' (ConDeclH98 { con_name = name, con_ex_tvs = tyVars, con_mb_cxt = ctx, con_args = RecCon (unLoc -> flds) })
= AST.URecordDecl <$> trfBindings tyVars <*> trfConCtx ctx <*> define (trfName @n name) <*> (between AnnOpenC AnnCloseC $ trfAnnList ", " trfFieldDecl' flds)
trfConDecl' (ConDeclH98 { con_name = name, con_ex_tvs = tyVars, con_mb_cxt = ctx, con_args = InfixCon t1 t2 })
= AST.UInfixConDecl <$> trfBindings tyVars <*> trfConCtx ctx <*> trfType t1 <*> define (trfOperator @n name) <*> trfType t2
trfConDecl' gadt@(ConDeclGADT {}) = unhandledElement "normal constructor declaration" gadt
trfConCtx :: (TransformName n r, n ~ GhcPass p, HasCallStack) => Maybe (LHsContext n) -> Trf (AnnMaybeG AST.UContext (Dom r) RangeStage)
trfConCtx Nothing = nothing "" " => " atTheStart
trfConCtx (Just ctx) = trfCtx atTheStart ctx
trfGADTConDecl :: (TransformName n r, n ~ GhcPass p, HasCallStack) => Located (ConDecl n) -> Trf (Ann AST.UGadtConDecl (Dom r) RangeStage)
trfGADTConDecl = trfLocNoSema trfGADTConDecl'
trfGADTConDecl' :: forall n r p . (TransformName n r, n ~ GhcPass p, HasCallStack) => ConDecl n -> Trf (AST.UGadtConDecl (Dom r) RangeStage)
trfGADTConDecl' (ConDeclGADT { con_names = names, con_res_ty = t, con_mb_cxt = ctx, con_qvars = vars })
= AST.UGadtConDecl <$> define (trfAnnList ", " (trfName' @n) names)
<*> focusOn (mkSrcSpan (srcSpanEnd nameLoc) (srcSpanStart (getLoc t))) (trfBindings (hsq_explicit vars))
<*> updateFocus (return . updateEnd (\_ -> srcSpanStart (getLoc t))) (focusAfterIfPresent AnnDot (trfCtx atTheStart (fromMaybe (L noSrcSpan []) ctx)))
<*> trfGadtConType t
where nameLoc = last (map getLoc names ++ map getLoc (hsq_explicit vars))
trfGadtConType :: (TransformName n r, n ~ GhcPass p, HasCallStack) => Located (HsType n) -> Trf (Ann AST.UGadtConType (Dom r) RangeStage)
trfGadtConType = trfLocNoSema $ \case
HsFunTy _ (unLoc -> HsRecTy _ flds) resType
-> AST.UGadtRecordType <$> between AnnOpenC AnnCloseC (trfAnnList ", " trfFieldDecl' flds)
<*> trfType resType
typ -> AST.UGadtNormalType <$> annContNoSema (trfType' typ)
trfFieldDecl :: (TransformName n r, n ~ GhcPass p, HasCallStack) => Located (ConDeclField n) -> Trf (Ann AST.UFieldDecl (Dom r) RangeStage)
trfFieldDecl = trfLocNoSema trfFieldDecl'
trfFieldDecl' :: forall n r p . (TransformName n r, n ~ GhcPass p, HasCallStack) => ConDeclField n -> Trf (AST.UFieldDecl (Dom r) RangeStage)
trfFieldDecl' (ConDeclField _ names typ _) = AST.UFieldDecl <$> (define $ nonemptyAnnList <$> mapM (trfName @n . getFieldOccName) names) <*> trfType typ
trfDerivings :: (TransformName n r, n ~ GhcPass p, HasCallStack) => Located (HsDerivingClause n) -> Trf (Ann AST.UDeriving (Dom r) RangeStage)
trfDerivings = trfLocNoSema $ \case
HsDerivingClause _ strat (unLoc->[hsib_body -> typ@(unLoc -> HsTyVar {})])
-> AST.UDerivingOne <$> trfDerivingStrategy strat <*> trfInstanceHead typ
HsDerivingClause _ strat derivs
-> AST.UDerivings <$> trfDerivingStrategy strat <*> focusOn (getLoc derivs) (trfAnnList ", " trfInstanceHead' (map hsib_body (unLoc derivs)))
trfDerivingStrategy :: (TransformName n r, HasCallStack) => Maybe (Located (DerivStrategy n)) -> Trf (AnnMaybeG AST.UDeriveStrategy (Dom r) RangeStage)
trfDerivingStrategy = trfMaybeDefault " " ""
(trfLocNoSema $ \case StockStrategy -> return AST.UStockStrategy
AnyclassStrategy -> return AST.UAnyClassStrategy
NewtypeStrategy -> return AST.UNewtypeStrategy)
atTheStart
trfInstanceRule :: (TransformName n r, n ~ GhcPass p, HasCallStack) => Located (HsType n) -> Trf (Ann AST.UInstanceRule (Dom r) RangeStage)
trfInstanceRule = trfLocNoSema trfInstanceRule'
trfInstanceRule' :: forall n r p . (TransformName n r, n ~ GhcPass p, HasCallStack) => HsType n -> Trf (AST.UInstanceRule (Dom r) RangeStage)
trfInstanceRule' (HsForAllTy _ bndrs (unLoc -> HsQualTy _ ctx typ))
= AST.UInstanceRule <$> (makeJust <$> annLocNoSema (pure $ collectLocs bndrs) (trfBindings bndrs))
<*> trfCtx (after AnnDot) ctx
<*> trfInstanceHead typ
trfInstanceRule' (HsQualTy _ ctx typ) = AST.UInstanceRule <$> nothing "" " . " atTheStart
<*> trfCtx atTheStart ctx
<*> trfInstanceHead typ
trfInstanceRule' (HsParTy _ typ) = instanceHead $ annContNoSema (AST.UInstanceHeadParen <$> trfInstanceHead typ)
trfInstanceRule' (HsTyVar _ _ tv) = instanceHead $ annContNoSema (AST.UInstanceHeadCon <$> trfName @n tv)
trfInstanceRule' (HsAppTy _ t1 t2) = instanceHead $ annContNoSema (AST.UInstanceHeadApp <$> trfInstanceHead t1 <*> trfType t2)
trfInstanceRule' (HsOpTy _ t1 op t2) = instanceHead $ annContNoSema (AST.UInstanceHeadApp <$> annLocNoSema (pure $ getLoc t1 `combineSrcSpans` getLoc op) (AST.UInstanceHeadInfix <$> trfType t1 <*> trfOperator @n op) <*> trfType t2)
trfInstanceRule' t = unhandledElement "instance rule" t
instanceHead :: HasCallStack => Trf (Ann AST.UInstanceHead (Dom r) RangeStage) -> Trf (AST.UInstanceRule (Dom r) RangeStage)
instanceHead hd = AST.UInstanceRule <$> (nothing "" " . " atTheStart) <*> (nothing " " "" atTheStart) <*> hd
makeInstanceRuleTyVars :: forall n r p . (TransformName n r, n ~ GhcPass p, HasCallStack) => Located (IdP n) -> [LHsType n] -> Trf (Ann AST.UInstanceRule (Dom r) RangeStage)
makeInstanceRuleTyVars n vars
| isSymOcc (occName @n (unLoc n))
, leftOp:rest <- vars
, srcSpanStart (getLoc n) > srcSpanEnd (getLoc leftOp)
= annContNoSema
$ AST.UInstanceRule <$> nothing "" " . " atTheStart
<*> nothing " " "" atTheStart
<*> foldl foldTypeArgs
(annLocNoSema (pure $ combineSrcSpans (getLoc leftOp) (getLoc n))
(AST.UInstanceHeadInfix <$> trfType leftOp <*> trfOperator @n n)) rest
| otherwise
= annContNoSema
$ AST.UInstanceRule <$> nothing "" " . " atTheStart
<*> nothing " " "" atTheStart
<*> foldl foldTypeArgs (copyAnnot AST.UInstanceHeadCon (trfName @n n)) vars
where foldTypeArgs base typ = annLocNoSema (pure $ combineSrcSpans (getLoc n) (getLoc typ)) $ AST.UInstanceHeadApp <$> base <*> (trfType typ)
trfInstanceHead :: forall n r p . (TransformName n r, n ~ GhcPass p, HasCallStack) => Located (HsType n) -> Trf (Ann AST.UInstanceHead (Dom r) RangeStage)
trfInstanceHead = trfLocNoSema trfInstanceHead'
trfInstanceHead' :: forall n r p . (TransformName n r, n ~ GhcPass p, HasCallStack) => HsType n -> Trf (AST.UInstanceHead (Dom r) RangeStage)
trfInstanceHead' = trfInstanceHead'' where
trfInstanceHead'' (HsForAllTy _ [] (unLoc -> t)) = trfInstanceHead' t
trfInstanceHead'' (HsTyVar _ _ tv) = AST.UInstanceHeadCon <$> trfName @n tv
trfInstanceHead'' (HsAppTy _ t1 t2) = AST.UInstanceHeadApp <$> trfInstanceHead t1 <*> trfType t2
trfInstanceHead'' (HsParTy _ typ) = AST.UInstanceHeadParen <$> trfInstanceHead typ
trfInstanceHead'' (HsOpTy _ t1 op t2)
= AST.UInstanceHeadApp <$> (annLocNoSema (pure $ combineSrcSpans (getLoc t1) (getLoc op))
(AST.UInstanceHeadInfix <$> trfType t1 <*> trfOperator @n op))
<*> trfType t2
trfInstanceHead'' t = unhandledElement "instance head" t
trfTypeEqs :: (TransformName n r, n ~ GhcPass p, HasCallStack) => Maybe [Located (TyFamInstEqn n)] -> Trf (AnnListG AST.UTypeEqn (Dom r) RangeStage)
trfTypeEqs eqs =
do toks <- tokensAfter AnnWhere
case toks of [] -> convertionProblem "trfTypeEqs: no where found after closed type family"
loc:_ -> makeList "\n" (pure $ srcSpanStart loc) (mapM (trfTypeEq . fmap hsib_body) (fromMaybe [] eqs))
trfTypeEq :: forall n r p . (TransformName n r, n ~ GhcPass p, HasCallStack) => Located (FamEqn n (HsTyPats n) (LHsType n)) -> Trf (Ann AST.UTypeEqn (Dom r) RangeStage)
trfTypeEq = trfLocNoSema $ \(FamEqn _ name pats _ rhs)
-> AST.UTypeEqn <$> defineTypeVars (focusBefore AnnEqual (combineTypes name pats)) <*> trfType rhs
where combineTypes :: Located (IdP n) -> [LHsType n] -> Trf (Ann AST.UType (Dom r) RangeStage)
combineTypes name [lhs, rhs] | srcSpanStart (getLoc name) > srcSpanEnd (getLoc lhs)
= annContNoSema $ AST.UTyInfix <$> trfType lhs <*> trfOperator @n name <*> trfType rhs
combineTypes name pats = wrapTypes (annLocNoSema (pure $ getLoc name) (AST.UTyVar <$> trfName @n name)) pats
wrapTypes :: Trf (Ann AST.UType (Dom r) RangeStage) -> [LHsType n] -> Trf (Ann AST.UType (Dom r) RangeStage)
wrapTypes base pats
= foldl (\t p -> do typ <- t
annLocNoSema (pure $ combineSrcSpans (getRange typ) (getLoc p))
(AST.UTyApp <$> pure typ <*> trfType p)) base pats
trfFunDeps :: forall n r . (TransformName n r, HasCallStack)
=> [Located (FunDep (Located (IdP n)))] -> Trf (AnnMaybeG AST.UFunDeps (Dom r) RangeStage)
trfFunDeps [] = do whereToken <- tokenLoc AnnWhere
nothing "| " "" (if isGoodSrcSpan whereToken then pure $ srcSpanStart whereToken else atTheEnd)
trfFunDeps fundeps = makeJust <$> annLocNoSema (combineSrcSpans (collectLocs fundeps) <$> tokenLoc AnnVbar)
(AST.UFunDeps <$> trfAnnList ", " (trfFunDep' @n) fundeps)
trfFunDep' :: forall n r . (TransformName n r, HasCallStack) => FunDep (Located (IdP n)) -> Trf (AST.UFunDep (Dom r) RangeStage)
trfFunDep' (lhs, rhs) = AST.UFunDep <$> trfAnnList ", " (trfName' @n) lhs <*> trfAnnList ", " (trfName' @n) rhs
createDeclHead :: forall n r p . (TransformName n r, n ~ GhcPass p, HasCallStack) => Located (IdP n) -> LHsQTyVars n -> Trf (Ann AST.UDeclHead (Dom r) RangeStage)
createDeclHead name (hsq_explicit -> lhs : rhs : rest)
| srcSpanStart (getLoc name) > srcSpanEnd (getLoc lhs)
= wrapDeclHead rest
$ annLocNoSema (addParenLocs $ getLoc lhs `combineSrcSpans` getLoc rhs)
(AST.UDHInfix <$> defineTypeVars (trfTyVar lhs) <*> define (trfOperator @n name) <*> defineTypeVars (trfTyVar rhs))
createDeclHead name vars = defineTypeVars $ wrapDeclHead (hsq_explicit vars) (define $ copyAnnot AST.UDeclHead (trfName @n name))
wrapDeclHead :: (TransformName n r, n ~ GhcPass p, HasCallStack) => [LHsTyVarBndr n] -> Trf (Ann AST.UDeclHead (Dom r) RangeStage) -> Trf (Ann AST.UDeclHead (Dom r) RangeStage)
wrapDeclHead vars base
= foldl (\t p -> do typ <- t
annLocNoSema (addParenLocs $ combineSrcSpans (getRange typ) (getLoc p))
(AST.UDHApp typ <$> trfTyVar p)
) base vars
addParenLocs :: SrcSpan -> Trf SrcSpan
addParenLocs sp
= let possibleSpan = mkSrcSpan (updateCol (subtract 1) (srcSpanStart sp)) (updateCol (+1) (srcSpanEnd sp))
in local (\s -> s { contRange = possibleSpan })
(combineSrcSpans <$> (combineSrcSpans sp <$> tokenLoc AnnOpenP) <*> tokenLocBack AnnCloseP)
createClassBody :: (TransformName n r, n ~ GhcPass p, HasCallStack) => [LSig n] -> LHsBinds n -> [LFamilyDecl n]
-> [LTyFamDefltEqn n] -> Trf (AnnMaybeG AST.UClassBody (Dom r) RangeStage)
createClassBody sigs binds typeFams typeFamDefs
= do isThereWhere <- isGoodSrcSpan <$> (tokenLoc AnnWhere)
if isThereWhere
then makeJust <$> annLocNoSema (combinedLoc <$> tokenLoc AnnWhere)
(AST.UClassBody <$> makeList "" (after AnnWhere)
(orderDefs . concat <$> sequenceA allDefs))
else nothing " where " "" atTheEnd
where combinedLoc wh = foldl combineSrcSpans wh allLocs
allLocs = map getLoc sigs ++ map getLoc (bagToList binds) ++ map getLoc typeFams ++ map getLoc typeFamDefs
allDefs = [getSigs, getBinds, getFams, getFamDefs]
getSigs = mapM trfClassElemSig sigs
getBinds = mapM (copyAnnot AST.UClsDef . trfBind) (bagToList binds)
getFams = mapM (copyAnnot AST.UClsTypeFam . trfTypeFam) typeFams
getFamDefs = mapM trfTypeFamDef typeFamDefs
trfClassElemSig :: forall n r p . (TransformName n r, n ~ GhcPass p, HasCallStack) => Located (Sig n) -> Trf (Ann AST.UClassElement (Dom r) RangeStage)
trfClassElemSig = trfLocNoSema $ \case
TypeSig _ names typ -> AST.UClsSig <$> (annContNoSema $ AST.UTypeSignature <$> define (makeNonemptyList ", " (mapM (trfName @n) names))
<*> trfType (hsib_body $ hswc_body typ))
ClassOpSig _ True [name] typ -> AST.UClsDefSig <$> trfName @n name <*> trfType (hsib_body typ)
ClassOpSig _ False names typ -> AST.UClsSig <$> (annContNoSema $ AST.UTypeSignature <$> define (makeNonemptyList ", " (mapM (trfName @n) names))
<*> trfType (hsib_body typ))
MinimalSig _ _ formula -> AST.UClsMinimal <$> trfMinimalFormula @n formula
InlineSig _ name prag -> AST.UClsInline <$> trfInlinePragma @n name prag
FixSig _ fixity -> AST.UClsFixity <$> annContNoSema (trfFixitySig fixity)
s -> unhandledElement "signature in class" s
trfTypeFam :: (TransformName n r, n ~ GhcPass p, HasCallStack) => Located (FamilyDecl n) -> Trf (Ann AST.UTypeFamily (Dom r) RangeStage)
trfTypeFam = trfLocNoSema trfTypeFam'
trfTypeFam' :: (TransformName n r, n ~ GhcPass p, HasCallStack) => FamilyDecl n -> Trf (AST.UTypeFamily (Dom r) RangeStage)
trfTypeFam' (FamilyDecl _ DataFamily name tyVars _ kindSig _)
= AST.UDataFamily <$> (case unLoc kindSig of KindSig _ _ -> between AnnData AnnDcolon; _ -> id) (createDeclHead name tyVars)
<*> trfFamilyKind kindSig
trfTypeFam' (FamilyDecl _ OpenTypeFamily name tyVars _ kindSig injectivity)
= AST.UTypeFamily <$> (case unLoc kindSig of KindSig _ _ -> between AnnType AnnDcolon; _ -> id) (createDeclHead name tyVars)
<*> trfFamilyResultSig kindSig injectivity
trfTypeFam' (FamilyDecl _ (ClosedTypeFamily {}) _ _ _ _ _) = convertionProblem "trfTypeFam': closed type family received"
trfTypeFamDef :: (TransformName n r, n ~ GhcPass p, HasCallStack) => Located (TyFamDefltEqn n) -> Trf (Ann AST.UClassElement (Dom r) RangeStage)
trfTypeFamDef = trfLocNoSema $ \(FamEqn _ con pats _ rhs)
-> AST.UClsTypeDef <$> between AnnType AnnEqual (createDeclHead con pats) <*> trfType rhs
trfInstBody :: (TransformName n r, n ~ GhcPass p, HasCallStack) => LHsBinds n -> [LSig n] -> [LTyFamInstDecl n] -> [LDataFamInstDecl n] -> Trf (AnnMaybeG AST.UInstBody (Dom r) RangeStage)
trfInstBody binds sigs fams dats = do
wh <- tokenLoc AnnWhere
if isGoodSrcSpan wh then
makeJust <$> annLocNoSema (combinedLoc <$> tokenLoc AnnWhere)
(AST.UInstBody <$> (makeList "" (after AnnWhere)
(orderDefs . concat <$> sequenceA allDefs)))
else nothing " where " "" atTheEnd
where combinedLoc wh = foldl combineSrcSpans wh allLocs
allLocs = map getLoc sigs ++ map getLoc (bagToList binds) ++ map getLoc fams ++ map getLoc dats
allDefs = [getSigs, getBinds, getFams, getDats]
getSigs = mapM trfClassInstSig sigs
getBinds = mapM (copyAnnot AST.UInstBodyNormalDecl . trfBind) (bagToList binds)
getFams = mapM trfInstTypeFam fams
getDats = mapM trfInstDataFam dats
trfClassInstSig :: forall n r p . (TransformName n r, n ~ GhcPass p, HasCallStack) => Located (Sig n) -> Trf (Ann AST.UInstBodyDecl (Dom r) RangeStage)
trfClassInstSig = trfLocNoSema $ \case
TypeSig _ names typ -> AST.UInstBodyTypeSig <$> (annContNoSema $ AST.UTypeSignature <$> makeNonemptyList ", " (mapM (trfName @n) names)
<*> trfType (hsib_body $ hswc_body typ))
ClassOpSig _ _ names typ -> AST.UInstBodyTypeSig <$> (annContNoSema $ AST.UTypeSignature <$> define (makeNonemptyList ", " (mapM (trfName @n) names))
<*> trfType (hsib_body typ))
SpecInstSig _ _ typ -> AST.USpecializeInstance <$> trfType (hsib_body typ)
SpecSig _ name (map hsib_body -> tys) (inl_act -> phase) -> AST.UInstanceSpecialize <$> trfSpecializePragma name tys phase
InlineSig _ name prag -> AST.UInlineInstance <$> trfInlinePragma @n name prag
s -> unhandledElement "class instance signature" s
trfInstTypeFam :: (TransformName n r, n ~ GhcPass p, HasCallStack) => Located (TyFamInstDecl n) -> Trf (Ann AST.UInstBodyDecl (Dom r) RangeStage)
trfInstTypeFam (L l (TyFamInstDecl (hsib_body -> eqn))) = copyAnnot AST.UInstBodyTypeDecl (trfTypeEq (L l eqn))
trfInstDataFam :: forall n r p . (TransformName n r, n ~ GhcPass p, HasCallStack) => Located (DataFamInstDecl n) -> Trf (Ann AST.UInstBodyDecl (Dom r) RangeStage)
trfInstDataFam = trfLocNoSema $ \case
(DataFamInstDecl (hsib_body -> FamEqn _ tc pats _ (HsDataDefn _ dn ctx _ ks cons derivs)))
| all ((\case ConDeclH98{} -> True; _ -> False) . unLoc) cons
-> AST.UInstBodyDataDecl
<$> trfDataKeyword dn
<*> annLocNoSema (pure $ collectLocs pats `combineSrcSpans` getLoc tc `combineSrcSpans` getLoc ctx)
(AST.UInstanceRule <$> nothing "" " . " atTheStart
<*> trfCtx atTheStart ctx
<*> transformNameAndPats tc pats)
<*> trfAnnList "" trfConDecl' cons
<*> makeIndentedList atTheEnd (mapM trfDerivings (unLoc derivs))
| otherwise
-> AST.UInstBodyGadtDataDecl
<$> trfDataKeyword dn
<*> annLocNoSema (pure $ collectLocs pats `combineSrcSpans` getLoc tc `combineSrcSpans` getLoc ctx)
(AST.UInstanceRule <$> nothing "" " . " atTheStart
<*> trfCtx atTheStart ctx
<*> transformNameAndPats tc pats)
<*> trfKindSig ks
<*> trfAnnList "" trfGADTConDecl' cons
<*> makeIndentedList atTheEnd (mapM trfDerivings (unLoc derivs))
where transformNameAndPats :: Located (IdP n) -> [LHsType n] -> Trf (Ann AST.UInstanceHead (Dom r) RangeStage)
transformNameAndPats tc pats
| all (\p -> srcSpanEnd (getLoc tc) < srcSpanStart (getLoc p)) pats
= foldl (\r t -> annLocNoSema (combineSrcSpans (getLoc t) . getRange <$> r)
(AST.UInstanceHeadApp <$> r <*> (trfType t)))
(copyAnnot AST.UInstanceHeadCon (trfName @n tc)) pats
transformNameAndPats tc (p:rest)
| otherwise
= foldl (\r t -> annLocNoSema (combineSrcSpans (getLoc t) . getRange <$> r)
(AST.UInstanceHeadApp <$> r <*> (trfType t)))
(annLocNoSema (pure $ getLoc p `combineSrcSpans` getLoc tc)
(AST.UInstanceHeadInfix <$> trfType p <*> trfOperator @n tc)) rest
trfPatternSynonym :: forall n r p . (TransformName n r, n ~ GhcPass p, HasCallStack) => PatSynBind n n -> Trf (AST.UPatternSynonym (Dom r) RangeStage)
trfPatternSynonym (PSB _ id lhs def dir)
= let sep = case dir of ImplicitBidirectional -> AnnEqual
_ -> AnnLarrow
rhsLoc = combineSrcSpans (getLoc def) <$> tokenLoc sep
rewrites = case lhs of RecCon flds -> map (\r -> (unLoc (recordPatSynPatVar r), unLoc (recordPatSynSelectorId r))) flds
_ -> []
changedRhs = biplateRef .- (\n -> case lookup n rewrites of Just x -> x; Nothing -> n) $ def
in AST.UPatternSynonym <$> trfPatSynLhs id lhs sep
<*> annLocNoSema rhsLoc (trfPatSynRhs dir changedRhs)
where trfPatSynLhs :: Located (IdP n) -> HsPatSynDetails (Located (IdP n)) -> AnnKeywordId -> Trf (Ann AST.UPatSynLhs (Dom r) RangeStage)
trfPatSynLhs id (PrefixCon args) _
= annLocNoSema (pure $ foldLocs (getLoc id : map getLoc args)) $ AST.UNormalPatSyn <$> define (trfName @n id) <*> trfAnnList " " (trfName' @n) args
trfPatSynLhs op (InfixCon lhs rhs) _
= annLocNoSema (pure $ getLoc lhs `combineSrcSpans` getLoc rhs) $ AST.UInfixPatSyn <$> define (trfName @n lhs) <*> trfOperator @n op <*> trfName @n rhs
trfPatSynLhs id (RecCon flds) kw
= annLocNoSema (mkSrcSpan (srcSpanStart (getLoc id)) <$> before kw)
$ AST.URecordPatSyn <$> define (trfName @n id) <*> trfAnnList ", " (trfName' @n) (map recordPatSynSelectorId flds)
trfPatSynRhs :: HsPatSynDir n -> Located (Pat n) -> Trf (AST.UPatSynRhs (Dom r) RangeStage)
trfPatSynRhs ImplicitBidirectional pat = AST.UBidirectionalPatSyn <$> trfPattern pat <*> nothing " where " "" atTheEnd
trfPatSynRhs (ExplicitBidirectional mg) pat = AST.UBidirectionalPatSyn <$> trfPattern pat <*> (makeJust <$> trfPatSynWhere mg)
trfPatSynRhs Unidirectional pat = AST.UOneDirectionalPatSyn <$> trfPattern pat
trfPatSynWhere :: MatchGroup n (LHsExpr n) -> Trf (Ann AST.UPatSynWhere (Dom r) RangeStage)
trfPatSynWhere (MG { mg_alts = alts }) = annLocNoSema (pure $ getLoc alts) (AST.UPatSynWhere <$> makeIndentedList (after AnnWhere) (mapM (trfMatch (unLoc id)) (unLoc alts)))
trfFamilyKind :: (TransformName n r, n ~ GhcPass p, HasCallStack) => Located (FamilyResultSig n) -> Trf (AnnMaybeG AST.UKindConstraint (Dom r) RangeStage)
trfFamilyKind (unLoc -> fr) = case fr of
NoSig _ -> nothing "" " " atTheEnd
KindSig _ k -> trfKindSig (Just k)
TyVarSig _ _ -> convertionProblem "trfFamilyKind: TyVarSig not supported"
trfFamilyResultSig :: forall n r p . (TransformName n r, n ~ GhcPass p, HasCallStack) => Located (FamilyResultSig n) -> Maybe (LInjectivityAnn n) -> Trf (AnnMaybeG AST.UTypeFamilySpec (Dom r) RangeStage)
trfFamilyResultSig (L l fr) Nothing = case fr of
NoSig _ -> nothing "" " " atTheEnd
KindSig _ k -> makeJust <$> (annLocNoSema (pure l) $ AST.UTypeFamilyKind <$> trfKindSig' k)
TyVarSig _ tv -> makeJust <$> (annLocNoSema (pure l) $ AST.UTypeFamilyTyVar <$> trfTyVar tv)
trfFamilyResultSig (L _ sig) (Just (L l (InjectivityAnn n deps)))
= makeJust <$> (annLocNoSema (pure l) $ AST.UTypeFamilyInjectivity <$> (annContNoSema $ AST.UInjectivityAnn <$> tv <*> trfAnnList ", " (trfName' @n) deps))
where tv = case sig of TyVarSig _ tv -> trfTyVar tv
_ -> annLocNoSema (pure $ getLoc n) (AST.UTyVarDecl <$> trfName @n n <*> nothing "" "" (pure $ srcSpanEnd (getLoc n)))
trfAnnotationSubject :: forall n r . (TransformName n r, HasCallStack) => SourceText -> AnnProvenance (IdP n) -> SrcLoc -> Trf (Ann AST.UAnnotationSubject (Dom r) RangeStage)
trfAnnotationSubject (fromSrcText -> stxt) subject payloadEnd
= do payloadStart <- advanceStr stxt <$> atTheStart
case subject of ValueAnnProvenance name@(L l _) -> annLocNoSema (pure l) (AST.UNameAnnotation <$> trfName @n name)
TypeAnnProvenance name@(L l _) -> annLocNoSema (pure $ mkSrcSpan payloadStart (srcSpanEnd l))
(AST.UTypeAnnotation <$> trfName @n name)
ModuleAnnProvenance -> annLocNoSema (pure $ mkSrcSpan payloadStart payloadEnd) (pure AST.UModuleAnnotation)
trfDataKeyword :: NewOrData -> Trf (Ann AST.UDataOrNewtypeKeyword (Dom r) RangeStage)
trfDataKeyword NewType = annLocNoSema (tokenLoc AnnNewtype) (pure AST.UNewtypeKeyword)
trfDataKeyword DataType = annLocNoSema (tokenLoc AnnData) (pure AST.UDataKeyword)
trfCallConv :: Located CCallConv -> Trf (Ann AST.UCallConv (Dom r) RangeStage)
trfCallConv = trfLocNoSema trfCallConv'
trfCallConv' :: CCallConv -> Trf (AST.UCallConv (Dom r) RangeStage)
trfCallConv' CCallConv = pure AST.UCCall
trfCallConv' CApiConv = pure AST.UCApi
trfCallConv' StdCallConv = pure AST.UStdCall
trfCallConv' JavaScriptCallConv = pure AST.UJavaScript
trfCallConv' PrimCallConv = convertionProblem "trfCallConv: PrimCallConv not supported"
trfSafety :: SrcSpan -> Located Safety -> Trf (AnnMaybeG AST.USafety (Dom r) RangeStage)
trfSafety ccLoc lsaf@(L l _) | isGoodSrcSpan l
= makeJust <$> trfLocNoSema (pure . \case
PlaySafe -> AST.USafe
PlayInterruptible -> AST.UInterruptible
PlayRisky -> AST.UUnsafe) lsaf
| otherwise = nothing " " "" (pure $ srcSpanEnd ccLoc)
trfOverlap :: Located OverlapMode -> Trf (Ann AST.UOverlapPragma (Dom r) RangeStage)
trfOverlap = trfLocNoSema $ pure . \case
NoOverlap _ -> AST.UDisableOverlap
Overlappable _ -> AST.UOverlappable
Overlapping _ -> AST.UOverlapping
Overlaps _ -> AST.UOverlaps
Incoherent _ -> AST.UIncoherentOverlap
trfRole :: Located (Maybe Role) -> Trf (Ann AST.URole (Dom r) RangeStage)
trfRole = trfLocNoSema $ \case Just Nominal -> pure AST.UNominal
Just Representational -> pure AST.URepresentational
Just GHC.Phantom -> pure AST.UPhantom
Nothing -> convertionProblem "trfRole: no role"
trfRewriteRule :: (TransformName n r, n ~ GhcPass p) => Located (RuleDecl n) -> Trf (Ann AST.URule (Dom r) RangeStage)
trfRewriteRule = trfLocNoSema $ \(HsRule _ (L nameLoc (_, ruleName)) act bndrs left right) ->
AST.URule <$> trfFastString (L nameLoc ruleName)
<*> trfPhase (pure $ srcSpanEnd nameLoc) act
<*> makeListAfter " " " " (pure $ srcSpanStart $ getLoc left) (mapM trfRuleBndr bndrs)
<*> trfExpr left
<*> trfExpr right
trfRuleBndr :: forall n r p . (TransformName n r, n ~ GhcPass p, HasCallStack) => Located (RuleBndr n) -> Trf (Ann AST.URuleVar (Dom r) RangeStage)
trfRuleBndr = trfLocNoSema $ \case (RuleBndr _ n) -> AST.URuleVar <$> trfName @n n
(RuleBndrSig _ n k) -> AST.USigRuleVar <$> trfName @n n <*> trfType (hsib_body $ hswc_body k)
trfMinimalFormula :: forall n r . (TransformName n r, HasCallStack) => Located (BooleanFormula (Located (IdP n))) -> Trf (Ann AST.UMinimalFormula (Dom r) RangeStage)
trfMinimalFormula = trfLocCorrect (pure mkNoSemanticInfo)
(\sp -> if isGoodSrcSpan sp then pure sp else srcLocSpan <$> before AnnClose) (trfMinimalFormula' @n)
trfMinimalFormula' :: forall n r . (TransformName n r, HasCallStack) => BooleanFormula (Located (IdP n)) -> Trf (AST.UMinimalFormula (Dom r) RangeStage)
trfMinimalFormula' (Var name) = AST.UMinimalName <$> trfName @n name
trfMinimalFormula' (And formulas)
= AST.UMinimalAnd <$> makeListBefore " " " , " atTheEnd (mapM (trfLocNoSema (trfMinimalFormula' @n)) formulas)
trfMinimalFormula' (Or formulas) = AST.UMinimalOr <$> trfAnnList " | " (trfMinimalFormula' @n) formulas
trfMinimalFormula' (Parens formula) = AST.UMinimalParen <$> (trfMinimalFormula @n) formula