{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}

#if __GLASGOW_HASKELL__ >= 914
{-# OPTIONS_GHC -Wno-pattern-namespace-specifier #-}
#endif

-- | Source plugin for @polytropos@.
--
-- Desugars ergonomic syntax for row-polymorphic records, open variants,
-- and declaration forms into standard @Polytropos@ runtime combinators
-- before renaming and typechecking:
--
-- 1. __Record Construction:__
--    @REC { x = 1, y = True }@ (bare) and @REC_F { x = Just 1 }@ (HKD)
--    with field punning support.
-- 2. __Variant Injection:__
--    @VAR { Ok = 200 }@ or @VARIANT { Err = "fail" }@.
-- 3. __Record Updates:__
--    @REC_UPD r { x = 42 }@ into 'Polytropos.setField' chains.
-- 4. __Pattern Matching:__
--    @REC { x, y }@ into record view patterns, and
--    @VAR { Tag = pat }@ into variant projection view patterns.
-- 5. __Open Declarations:__
--    @data Person = Person { name :: String, age :: Int } deriving OpenRecord@
--    and @data Status = Active | Inactive String deriving OpenVariant@.
module Polytropos.Plugin.Source
  ( sourcePlugin
  ) where

import Prelude

import Data.Data
  ( Data
  , gmapT
  , Typeable
  , cast
  )
import Data.List
  ( nub
  )
import Data.List.NonEmpty
  ( NonEmpty(..)
  )

import GHC.Plugins
  ( CommandLineOption
  , FastString
  , fsLit
  , Hsc
  , GenLocated(..)
  , unLoc
  , mkRdrQual
  , mkRdrUnqual
  , mkVarOcc
  , mkDataOcc
  , mkModuleName
  , rdrNameOcc
  , occNameString
  , occNameFS
  , moduleNameString
  )

import GHC.Hs.Extension
  ( GhcPs
  )

import GHC.Hs
  ( HsParsedModule(..)
  , HsModule(..)
  , HsExpr(..)
  , Pat(..)
  , HsRecFields(..)
  , HsFieldBind(..)
  , FieldOcc(..)
  , LHsExpr
  , LHsRecField
  , LPat
  , LHsDecl
  , noLocA
  , HsConDetails(..)
  , LImportDecl
  , ImportDecl(..)
  , noAnn
  , noExtField
  , HsDecl(..)
  , TyClDecl(..)
  , HsDataDefn(..)
  , ConDecl(..)
  , DataDefnCons(..)
  , HsDerivingClause(..)
  , DerivClauseTys(..)
  , HsSigType(..)
  , HsType(..)
  )

import Language.Haskell.Syntax.Basic
  ( Boxity(..)
  )

import GHC.Driver.Plugins
  ( ParsedResult(..)
  )

import Polytropos.Plugin.Compat
  ( CompatRecUpdField
  , matchRecordUpd
  , extractRecUpdField
  , pattern PrefixConPat
  , stripHsPar
  , polyLabel
  , mkPolytroposImportDecl
  , mkHsApp
  , mkTupArg
  , mkLambda
  )

{-------------------------------------------------------------------------------
  GHC Notes: Source Plugin Architecture and Rewriting Mechanics
-------------------------------------------------------------------------------

Note [Source Plugin Desugaring Architecture: Syntactic Sugar Before Typechecking]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
[tag:note-source-plugin-arch]
GHC's source plugin hook ('parsedResultAction') operates directly on the untyped,
unrenamed abstract syntax tree ('HsParsedModule') immediately after the parser completes,
prior to the Renamer ('rnExpr') and Typechecker ('tcExpr').

Why desugar at the parsed AST level:
1. Native Syntax Feel:
   Developers write natural record syntax:
     @REC { name = "Alice", age = 30 }@
     @VAR { Ok = 200 }@
     @(REC_UPD user) { age = 31 }@
   without requiring language extensions that modify the lexical grammar or external
   preprocessors (like CPP or Template Haskell quotes).
2. Elimination of Downstream Complexity:
   By lowering syntactic forms to standard Polytropos combinators ('emptyRecord',
   'insertField', 'setField', 'injectVariant', 'projectVariant', 'recordField') before
   renaming, the GHC Typechecker receives standard Haskell function applications
   and view patterns. The typechecker plugin ('Polytropos.Plugin') can then solve
   the resulting 'FieldIndex', 'ConstructorIndex', and 'SubRow' constraints with
   exact literal evidence.
3. Import Injection:
   Source transformation automatically injects 'import qualified Polytropos as Polytropos'
   into the module's import list ('ensurePolytroposImport'), guaranteeing that all
   generated combinators and types resolve without requiring manual boilerplate imports
   by the user.
4. Source Span Preservation:
   Whenever AST nodes are transformed, annotations and source spans are maintained
   where possible, ensuring that compiler diagnostics and IDE hovers pinpoint the exact
   source locations written by the author.

Note [Open Declarations: Lowering Nominal Declarations to Open Rows]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
[tag:note-open-declarations]
Haskell developers frequently want the ergonomic benefits of declaring a named type
with field names or constructors, but want the resulting values to participate in open,
row-polymorphic operations without boilerplate conversion:

  @data Person = Person { name :: String, age :: Int } deriving OpenRecord@
  @data Status = Active | Inactive String deriving OpenVariant@

GHC's built-in deriving engine would reject 'OpenRecord' and 'OpenVariant' because they
are not built-in deriving strategies. The source plugin solves this via a two-stage process:

Stage 1 (Declaration Harvesting & Scrubbing):
- Scans 'hsmodDecls' for 'DataDecl's containing deriving clauses referencing 'OpenRecord'
  or 'OpenVariant'.
- Extracts the type name and constructor names into 'knownRecs' and 'knownVars'.
- Scrubs (filters out) the 'OpenRecord' and 'OpenVariant' deriving clauses from the AST,
  so GHC's stock deriving engine never sees them.

Stage 2 (Expression and Pattern Interception):
- Expressions:
  * Application of a known record constructor:
    @Person { name = "Alice", age = 30 }@
    is lowered into an open record construction chain:
    @insertField #name "Alice" (insertField #age 30 emptyRecord)@
  * Application of a known variant constructor:
    @Active@ or @Inactive "timeout"@
    is lowered into an open variant injection:
    @injectVariant #Active emptyRecord@
    @injectVariant #Inactive (insertField #_1 "timeout" emptyRecord)@
- Patterns:
  * Pattern matching on @Person { name, age }@ is lowered into a record view pattern.
  * Pattern matching on @Active@ or @Inactive err@ is lowered into a variant view pattern.

Note [Record Update and View Pattern Translation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
[tag:note-view-patterns]
1. Record Updates:
   Haskell's standard record update syntax @r { x = 42 }@ is notoriously problematic:
   it requires nominal field ownership and cannot change field types.
   Polytropos provides @REC_UPD r { x = 42, y = True }@.
   The plugin intercepts 'RecordUpd' (and its compat variants across GHC versions)
   and folds the updates right-to-left:
     @setField #x 42 (setField #y True r)@
   For HKD records, @REC_UPD_F@ desugars into 'setFieldF' chains.

2. Record Patterns & View Pattern Bundling:
   A pattern like @REC { name = p1, age = p2 }@ cannot be matched with standard data constructors
   because 'Record' is backed by a flat 'SmallArray'.
   The plugin desugars this into GHC View Patterns ('ViewPat'):
   - Single-field match:
     @REC { name = p1 }@  ==>  @(recordField #name -> p1)@
   - Multi-field match:
     Naively creating nested view patterns would inspect the record multiple times.
     The plugin bundles multi-field matches into a single tuple projection lambda:
     @REC { name = p1, age = p2 }@  ==>
     @(\_r -> (recordField #name _r, recordField #age _r)) -> (p1, p2)@
     This projects all requested fields in a single step matching against an unboxed tuple.

3. Variant Patterns:
   @VAR { Ok = p }@ is desugared into:
     @(projectVariant #Ok -> Just p)@
   If the variant's active tag matches '#Ok', 'projectVariant' yields 'Just payload' and
   matching proceeds against 'p'. If the tag does not match, 'projectVariant' yields
   'Nothing', causing GHC to fall through to the next pattern match branch.
-}

{-------------------------------------------------------------------------------
  Top-Level Source Plugin Entry Point
-------------------------------------------------------------------------------}

-- | Top-level entry point for GHC's @parsedResultAction@.
-- Invoked immediately after GHC's parser completes on each source file.
-- See Note [Source Plugin Desugaring Architecture: Syntactic Sugar Before Typechecking] [ref:note-source-plugin-arch]
sourcePlugin :: [CommandLineOption] -> ParsedResult -> Hsc ParsedResult
sourcePlugin :: [String] -> ParsedResult -> Hsc ParsedResult
sourcePlugin [String]
_opts ParsedResult
res = do
  let pm :: HsParsedModule
pm = ParsedResult -> HsParsedModule
parsedResultModule ParsedResult
res
  let pm' :: HsParsedModule
pm' = HsParsedModule -> HsParsedModule
transformParsedModule HsParsedModule
pm
  ParsedResult -> Hsc ParsedResult
forall a. a -> Hsc a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ParsedResult
res { parsedResultModule = pm' }

-- | Transforms a parsed module AST through three sequential compiler passes:
-- 1. Declaration Harvesting & Scrubbing: discovers 'OpenRecord' and 'OpenVariant' deriving
--    clauses, registers their nominal constructors, and strips the clauses.
--    See Note [Open Declarations: Lowering Nominal Declarations to Open Rows] [ref:note-open-declarations]
-- 2. Expression Transformation: rewrites 'REC', 'VAR', 'REC_UPD', and nominal constructors
--    into Polytropos runtime function application chains.
-- 3. Pattern Transformation: rewrites 'REC' and 'VAR' patterns into view patterns.
--    See Note [Record Update and View Pattern Translation] [ref:note-view-patterns]
-- 4. Import Management: ensures 'import qualified Polytropos as Polytropos' is present.
transformParsedModule :: HsParsedModule -> HsParsedModule
transformParsedModule :: HsParsedModule -> HsParsedModule
transformParsedModule pm :: HsParsedModule
pm@HsParsedModule{ hpm_module :: HsParsedModule -> Located (HsModule GhcPs)
hpm_module = L SrcSpan
modLoc HsModule GhcPs
hsmod } =
  let decls0 :: [LHsDecl GhcPs]
decls0 = HsModule GhcPs -> [LHsDecl GhcPs]
forall p. HsModule p -> [LHsDecl p]
hsmodDecls HsModule GhcPs
hsmod
      ([String]
knownRecs, [String]
knownVars, [LHsDecl GhcPs]
decls1) = [LHsDecl GhcPs] -> ([String], [String], [LHsDecl GhcPs])
extractAndCleanDeclarations [LHsDecl GhcPs]
decls0
      decls2 :: [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
decls2 = (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere ((HsExpr GhcPs -> HsExpr GhcPs) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT ([String] -> [String] -> HsExpr GhcPs -> HsExpr GhcPs
transformExpr [String]
knownRecs [String]
knownVars)) [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
[LHsDecl GhcPs]
decls1
      decls3 :: [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
decls3 = (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere ((Pat GhcPs -> Pat GhcPs) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT ([String] -> [String] -> Pat GhcPs -> Pat GhcPs
transformPat [String]
knownRecs [String]
knownVars)) [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
decls2
      hsmod' :: HsModule GhcPs
hsmod' = HsModule GhcPs
hsmod
        { hsmodDecls   = decls3
        , hsmodImports = ensurePolytroposImport (hsmodImports hsmod)
        }
  in HsParsedModule
pm { hpm_module = L modLoc hsmod' }

{-------------------------------------------------------------------------------
  SYB Combinators (Self-contained Data.Data helpers)
-------------------------------------------------------------------------------}

-- | Casts a transformation function 'b -> b' over any type 'a' satisfying 'Typeable'.
-- Provides lightweight Scrap Your Boilerplate traversal without external library dependencies.
mkT :: (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT :: forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT b -> b
f a
x = case a -> Maybe b
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x of
  Just b
y -> case b -> Maybe a
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast (b -> b
f b
y) of
    Just a
x' -> a
x'
    Maybe a
Nothing -> a
x
  Maybe b
Nothing -> a
x

-- | Bottom-up traversal over all subtrees of a data term.
everywhere :: (forall a. Data a => a -> a) -> (forall a. Data a => a -> a)
everywhere :: (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere forall a. Data a => a -> a
f a
x = a -> a
forall a. Data a => a -> a
f ((forall a. Data a => a -> a) -> a -> a
forall a. Data a => (forall a. Data a => a -> a) -> a -> a
gmapT ((forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere a -> a
forall a. Data a => a -> a
f) a
x)

{-------------------------------------------------------------------------------
  Declaration Analysis (OpenRecord & OpenVariant discovery)
-------------------------------------------------------------------------------}

-- | Scans top-level declarations for @OpenRecord@ and @OpenVariant@ deriving clauses,
-- records their names, and strips the clauses so GHC's stock deriving engine does
-- not halt with "Cannot derive OpenRecord" errors.
--
-- See Note [Open Declarations: Lowering Nominal Declarations to Open Rows] [ref:note-open-declarations]
extractAndCleanDeclarations :: [LHsDecl GhcPs] -> ([String], [String], [LHsDecl GhcPs])
extractAndCleanDeclarations :: [LHsDecl GhcPs] -> ([String], [String], [LHsDecl GhcPs])
extractAndCleanDeclarations [LHsDecl GhcPs]
decls =
  let ([String]
recs, [String]
vars, [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
cleanedDecls) = (GenLocated SrcSpanAnnA (HsDecl GhcPs)
 -> ([String], [String], [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
 -> ([String], [String], [GenLocated SrcSpanAnnA (HsDecl GhcPs)]))
-> ([String], [String], [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> ([String], [String], [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> ([String], [String], [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
-> ([String], [String], [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
forall {pass} {l} {l} {l} {l} {l} {l} {l}.
(IdP pass ~ RdrName, IdOccP pass ~ RdrName,
 XRec pass (ConDecl pass) ~ GenLocated l (ConDecl pass),
 XRec pass (HsSigType pass) ~ GenLocated l (HsSigType pass),
 XRec pass (HsType pass) ~ GenLocated l (HsType pass),
 XRec pass (HsDerivingClause pass)
 ~ GenLocated l (HsDerivingClause pass),
 XRec pass (DerivClauseTys pass)
 ~ GenLocated l (DerivClauseTys pass),
 XRec pass RdrName ~ GenLocated l RdrName, HasAnnotation l) =>
GenLocated l (HsDecl pass)
-> ([String], [String], [GenLocated l (HsDecl pass)])
-> ([String], [String], [GenLocated l (HsDecl pass)])
step ([], [], []) [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
[LHsDecl GhcPs]
decls
  in ([String] -> [String]
forall a. Eq a => [a] -> [a]
nub [String]
recs, [String] -> [String]
forall a. Eq a => [a] -> [a]
nub [String]
vars, [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
[LHsDecl GhcPs]
cleanedDecls)
  where
    step :: GenLocated l (HsDecl pass)
-> ([String], [String], [GenLocated l (HsDecl pass)])
-> ([String], [String], [GenLocated l (HsDecl pass)])
step (L l
loc (TyClD XTyClD pass
x TyClDecl pass
decl)) ([String]
rAcc, [String]
vAcc, [GenLocated l (HsDecl pass)]
dAcc)
      | DataDecl XDataDecl pass
ext (L l
_ RdrName
name) LHsQTyVars pass
tyvars LexicalFixity
fixity (HsDataDefn XCHsDataDefn pass
defnExt Maybe (LHsContext pass)
ctxt Maybe (XRec pass CType)
mtype Maybe (XRec pass (HsType pass))
mkind DataDefnCons (XRec pass (ConDecl pass))
cons HsDeriving pass
derivs) <- TyClDecl pass
decl
      , let hasOpenRec :: Bool
hasOpenRec = (GenLocated l (HsDerivingClause pass) -> Bool)
-> [GenLocated l (HsDerivingClause pass)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any GenLocated l (HsDerivingClause pass) -> Bool
forall {pass} {l} {l} {l} {l} {l}.
(IdOccP pass ~ RdrName,
 XRec pass (HsType pass) ~ GenLocated l (HsType pass),
 XRec pass (HsSigType pass) ~ GenLocated l (HsSigType pass),
 XRec pass (DerivClauseTys pass)
 ~ GenLocated l (DerivClauseTys pass),
 XRec pass RdrName ~ GenLocated l RdrName) =>
GenLocated l (HsDerivingClause pass) -> Bool
isDerivingOpenRecord [GenLocated l (HsDerivingClause pass)]
HsDeriving pass
derivs
      , let hasOpenVar :: Bool
hasOpenVar = (GenLocated l (HsDerivingClause pass) -> Bool)
-> [GenLocated l (HsDerivingClause pass)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any GenLocated l (HsDerivingClause pass) -> Bool
forall {pass} {l} {l} {l} {l} {l}.
(IdOccP pass ~ RdrName,
 XRec pass (HsType pass) ~ GenLocated l (HsType pass),
 XRec pass (HsSigType pass) ~ GenLocated l (HsSigType pass),
 XRec pass (DerivClauseTys pass)
 ~ GenLocated l (DerivClauseTys pass),
 XRec pass RdrName ~ GenLocated l RdrName) =>
GenLocated l (HsDerivingClause pass) -> Bool
isDerivingOpenVariant [GenLocated l (HsDerivingClause pass)]
HsDeriving pass
derivs
      = let typeNameStr :: String
typeNameStr = OccName -> String
occNameString (RdrName -> OccName
rdrNameOcc RdrName
name)
            rAcc' :: [String]
rAcc' = if Bool
hasOpenRec then String
typeNameStr String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
rAcc else [String]
rAcc
            vCons :: [String]
vCons = if Bool
hasOpenVar then DataDefnCons (GenLocated l (ConDecl pass)) -> [String]
forall {pass} {l} {l}.
(IdP pass ~ RdrName, XRec pass RdrName ~ GenLocated l RdrName,
 HasAnnotation l) =>
DataDefnCons (GenLocated l (ConDecl pass)) -> [String]
extractConNames DataDefnCons (GenLocated l (ConDecl pass))
DataDefnCons (XRec pass (ConDecl pass))
cons else []
            vAcc' :: [String]
vAcc' = if Bool
hasOpenVar then [String]
vCons [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
vAcc else [String]
vAcc
            cleanedDerivs :: [GenLocated l (HsDerivingClause pass)]
cleanedDerivs = (GenLocated l (HsDerivingClause pass) -> Bool)
-> [GenLocated l (HsDerivingClause pass)]
-> [GenLocated l (HsDerivingClause pass)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\GenLocated l (HsDerivingClause pass)
c -> Bool -> Bool
not (GenLocated l (HsDerivingClause pass) -> Bool
forall {pass} {l} {l} {l} {l} {l}.
(IdOccP pass ~ RdrName,
 XRec pass (HsType pass) ~ GenLocated l (HsType pass),
 XRec pass (HsSigType pass) ~ GenLocated l (HsSigType pass),
 XRec pass (DerivClauseTys pass)
 ~ GenLocated l (DerivClauseTys pass),
 XRec pass RdrName ~ GenLocated l RdrName) =>
GenLocated l (HsDerivingClause pass) -> Bool
isDerivingOpenRecord GenLocated l (HsDerivingClause pass)
c Bool -> Bool -> Bool
|| GenLocated l (HsDerivingClause pass) -> Bool
forall {pass} {l} {l} {l} {l} {l}.
(IdOccP pass ~ RdrName,
 XRec pass (HsType pass) ~ GenLocated l (HsType pass),
 XRec pass (HsSigType pass) ~ GenLocated l (HsSigType pass),
 XRec pass (DerivClauseTys pass)
 ~ GenLocated l (DerivClauseTys pass),
 XRec pass RdrName ~ GenLocated l RdrName) =>
GenLocated l (HsDerivingClause pass) -> Bool
isDerivingOpenVariant GenLocated l (HsDerivingClause pass)
c)) [GenLocated l (HsDerivingClause pass)]
HsDeriving pass
derivs
            defn' :: HsDataDefn pass
defn' = XCHsDataDefn pass
-> Maybe (LHsContext pass)
-> Maybe (XRec pass CType)
-> Maybe (XRec pass (HsType pass))
-> DataDefnCons (XRec pass (ConDecl pass))
-> HsDeriving pass
-> HsDataDefn pass
forall pass.
XCHsDataDefn pass
-> Maybe (LHsContext pass)
-> Maybe (XRec pass CType)
-> Maybe (LHsKind pass)
-> DataDefnCons (LConDecl pass)
-> HsDeriving pass
-> HsDataDefn pass
HsDataDefn XCHsDataDefn pass
defnExt Maybe (LHsContext pass)
ctxt Maybe (XRec pass CType)
mtype Maybe (XRec pass (HsType pass))
mkind DataDefnCons (XRec pass (ConDecl pass))
cons [GenLocated l (HsDerivingClause pass)]
HsDeriving pass
cleanedDerivs
            decl' :: TyClDecl pass
decl' = XDataDecl pass
-> LIdP pass
-> LHsQTyVars pass
-> LexicalFixity
-> HsDataDefn pass
-> TyClDecl pass
forall pass.
XDataDecl pass
-> LIdP pass
-> LHsQTyVars pass
-> LexicalFixity
-> HsDataDefn pass
-> TyClDecl pass
DataDecl XDataDecl pass
ext (RdrName -> GenLocated l RdrName
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA RdrName
name) LHsQTyVars pass
tyvars LexicalFixity
fixity HsDataDefn pass
defn'
        in ([String]
rAcc', [String]
vAcc', l -> HsDecl pass -> GenLocated l (HsDecl pass)
forall l e. l -> e -> GenLocated l e
L l
loc (XTyClD pass -> TyClDecl pass -> HsDecl pass
forall p. XTyClD p -> TyClDecl p -> HsDecl p
TyClD XTyClD pass
x TyClDecl pass
decl') GenLocated l (HsDecl pass)
-> [GenLocated l (HsDecl pass)] -> [GenLocated l (HsDecl pass)]
forall a. a -> [a] -> [a]
: [GenLocated l (HsDecl pass)]
dAcc)
    step GenLocated l (HsDecl pass)
d ([String]
rAcc, [String]
vAcc, [GenLocated l (HsDecl pass)]
dAcc) =
      ([String]
rAcc, [String]
vAcc, GenLocated l (HsDecl pass)
d GenLocated l (HsDecl pass)
-> [GenLocated l (HsDecl pass)] -> [GenLocated l (HsDecl pass)]
forall a. a -> [a] -> [a]
: [GenLocated l (HsDecl pass)]
dAcc)

    -- Detects 'deriving OpenRecord' or 'deriving (..., OpenRecord, ...)'
    isDerivingOpenRecord :: GenLocated l (HsDerivingClause pass) -> Bool
isDerivingOpenRecord (L l
_ (HsDerivingClause XCHsDerivingClause pass
_ Maybe (LDerivStrategy pass)
_ (L l
_ DerivClauseTys pass
dtys))) =
      String -> DerivClauseTys pass -> Bool
forall {pass} {l} {l} {l}.
(IdOccP pass ~ RdrName,
 XRec pass (HsType pass) ~ GenLocated l (HsType pass),
 XRec pass (HsSigType pass) ~ GenLocated l (HsSigType pass),
 XRec pass RdrName ~ GenLocated l RdrName) =>
String -> DerivClauseTys pass -> Bool
hasSigNamed String
"OpenRecord" DerivClauseTys pass
dtys
    isDerivingOpenRecord GenLocated l (HsDerivingClause pass)
_ = Bool
False

    -- Detects 'deriving OpenVariant' or 'deriving (..., OpenVariant, ...)'
    isDerivingOpenVariant :: GenLocated l (HsDerivingClause pass) -> Bool
isDerivingOpenVariant (L l
_ (HsDerivingClause XCHsDerivingClause pass
_ Maybe (LDerivStrategy pass)
_ (L l
_ DerivClauseTys pass
dtys))) =
      String -> DerivClauseTys pass -> Bool
forall {pass} {l} {l} {l}.
(IdOccP pass ~ RdrName,
 XRec pass (HsType pass) ~ GenLocated l (HsType pass),
 XRec pass (HsSigType pass) ~ GenLocated l (HsSigType pass),
 XRec pass RdrName ~ GenLocated l RdrName) =>
String -> DerivClauseTys pass -> Bool
hasSigNamed String
"OpenVariant" DerivClauseTys pass
dtys
    isDerivingOpenVariant GenLocated l (HsDerivingClause pass)
_ = Bool
False

    hasSigNamed :: String -> DerivClauseTys pass -> Bool
hasSigNamed String
target (DctSingle XDctSingle pass
_ XRec pass (HsSigType pass)
sig) = String -> GenLocated l (HsSigType pass) -> Bool
forall {pass} {l} {l} {l}.
(IdOccP pass ~ RdrName,
 XRec pass (HsType pass) ~ GenLocated l (HsType pass),
 XRec pass RdrName ~ GenLocated l RdrName) =>
String -> GenLocated l (HsSigType pass) -> Bool
sigMatches String
target GenLocated l (HsSigType pass)
XRec pass (HsSigType pass)
sig
    hasSigNamed String
target (DctMulti XDctMulti pass
_ [XRec pass (HsSigType pass)]
sigs) = (GenLocated l (HsSigType pass) -> Bool)
-> [GenLocated l (HsSigType pass)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> GenLocated l (HsSigType pass) -> Bool
forall {pass} {l} {l} {l}.
(IdOccP pass ~ RdrName,
 XRec pass (HsType pass) ~ GenLocated l (HsType pass),
 XRec pass RdrName ~ GenLocated l RdrName) =>
String -> GenLocated l (HsSigType pass) -> Bool
sigMatches String
target) [GenLocated l (HsSigType pass)]
[XRec pass (HsSigType pass)]
sigs
    hasSigNamed String
_ DerivClauseTys pass
_ = Bool
False

    sigMatches :: String -> GenLocated l (HsSigType pass) -> Bool
sigMatches String
target (L l
_ (HsSig XHsSig pass
_ HsOuterSigTyVarBndrs pass
_ (L l
_ HsType pass
hty))) =
      case HsType pass
hty of
        HsTyVar XTyVar pass
_ PromotionFlag
_ (L l
_ RdrName
rdr) -> OccName -> String
occNameString (RdrName -> OccName
rdrNameOcc RdrName
rdr) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
target
        HsAppTy XAppTy pass
_ (L l
_ (HsTyVar XTyVar pass
_ PromotionFlag
_ (L l
_ RdrName
rdr))) XRec pass (HsType pass)
_ -> OccName -> String
occNameString (RdrName -> OccName
rdrNameOcc RdrName
rdr) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
target
        HsType pass
_ -> Bool
False
    sigMatches String
_ GenLocated l (HsSigType pass)
_ = Bool
False

    -- Extract constructor names from data definition
    extractConNames :: DataDefnCons (GenLocated l (ConDecl pass)) -> [String]
extractConNames DataDefnCons (GenLocated l (ConDecl pass))
cons =
      [ OccName -> String
occNameString (RdrName -> OccName
rdrNameOcc (GenLocated l RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc GenLocated l RdrName
LIdP pass
conName))
      | L l
_ ConDecl pass
cdecl <- case DataDefnCons (GenLocated l (ConDecl pass))
cons of
          DataTypeCons Bool
_ [GenLocated l (ConDecl pass)]
cs -> [GenLocated l (ConDecl pass)]
cs
          NewTypeCon GenLocated l (ConDecl pass)
c      -> [GenLocated l (ConDecl pass)
c]
      , let conName :: LIdP pass
conName = case ConDecl pass
cdecl of
              ConDeclH98 { con_name :: forall pass. ConDecl pass -> LIdP pass
con_name = LIdP pass
n } -> LIdP pass
n
              ConDeclGADT { con_names :: forall pass. ConDecl pass -> NonEmpty (LIdP pass)
con_names = (LIdP pass
n :| [LIdP pass]
_) } -> LIdP pass
n
              ConDecl pass
_ -> RdrName -> GenLocated l RdrName
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (OccName -> RdrName
mkRdrUnqual (String -> OccName
mkDataOcc String
"Unknown"))
      ]

{-------------------------------------------------------------------------------
  Expression Rewriting
-------------------------------------------------------------------------------}

-- | Rewrites expressions matching syntactic sugar markers ('REC', 'VAR', 'REC_UPD',
-- 'REC_UPD_F', and nominal constructors deriving 'OpenRecord' / 'OpenVariant') into
-- standard Polytropos library combinator expressions.
--
-- Supported Syntactic Forms:
-- 1. Bare Record Construction:
--    @REC { x = 1, y = True }@ or @Person { name = "Alice", age = 30 }@
--    Lowered into a chain of 'insertField' calls ending in 'emptyRecord'.
-- 2. HKD Record Construction:
--    @REC_F { x = Just 1 }@
--    Lowered into a chain of 'insertFieldF' calls ending in 'emptyRecordF'.
-- 3. Variant Injection:
--    @VAR { Ok = 200 }@ or @VARIANT { Err = "msg" }@
--    Lowered into @injectVariant #Tag val@.
-- 4. Functional Record Update:
--    @(REC_UPD r) { x = 42 }@ or @REC_UPD (r { x = 42 })@
--    Lowered into chained @setField #x 42 r@ calls.
-- 5. Open Variant Constructor Application:
--    - Record payload: @Success { val = 200 }@ ==> @injectVariant #Success (REC { val = 200 })@
--    - Prefix payload: @Success val@           ==> @injectVariant #Success val@
--    - Nullary:        @Loading@               ==> @injectVariant #Loading emptyRecord@
transformExpr :: [String] -> [String] -> HsExpr GhcPs -> HsExpr GhcPs
transformExpr :: [String] -> [String] -> HsExpr GhcPs -> HsExpr GhcPs
transformExpr [String]
knownRecs [String]
knownVars HsExpr GhcPs
expr = case HsExpr GhcPs
expr of
  -- 1. Record Construction: REC { x = 1, y = True } or Person { x = 1, y = True }
  RecordCon XRecordCon GhcPs
_ext (L SrcSpanAnnN
_ RdrName
nm) HsRecFields{ rec_flds :: forall p arg. HsRecFields p arg -> [LHsRecField p arg]
rec_flds = [LHsRecField GhcPs (LHsExpr GhcPs)]
flds }
    | let conStr :: String
conStr = OccName -> String
occNameString (RdrName -> OccName
rdrNameOcc RdrName
nm)
    , String
conStr String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"REC" Bool -> Bool -> Bool
|| String
conStr String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
knownRecs
    -> Bool -> [LHsRecField GhcPs (LHsExpr GhcPs)] -> HsExpr GhcPs
desugarRecordCon Bool
False [LHsRecField GhcPs (LHsExpr GhcPs)]
flds

  -- 2. HKD Record Construction: REC_F { x = Just 1 }
  RecordCon XRecordCon GhcPs
_ext (L SrcSpanAnnN
_ RdrName
nm) HsRecFields{ rec_flds :: forall p arg. HsRecFields p arg -> [LHsRecField p arg]
rec_flds = [LHsRecField GhcPs (LHsExpr GhcPs)]
flds }
    | OccName -> String
occNameString (RdrName -> OccName
rdrNameOcc RdrName
nm) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"REC_F"
    -> Bool -> [LHsRecField GhcPs (LHsExpr GhcPs)] -> HsExpr GhcPs
desugarRecordCon Bool
True [LHsRecField GhcPs (LHsExpr GhcPs)]
flds

  -- 3. Variant Injection: VAR { Ok = 200 } or VARIANT { Err = "msg" }
  RecordCon XRecordCon GhcPs
_ext (L SrcSpanAnnN
_ RdrName
nm) HsRecFields{ rec_flds :: forall p arg. HsRecFields p arg -> [LHsRecField p arg]
rec_flds = [LHsRecField GhcPs (LHsExpr GhcPs)]
flds }
    | let conStr :: String
conStr = OccName -> String
occNameString (RdrName -> OccName
rdrNameOcc RdrName
nm)
    , String
conStr String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"VAR" Bool -> Bool -> Bool
|| String
conStr String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"VARIANT"
    -> [LHsRecField GhcPs (LHsExpr GhcPs)] -> HsExpr GhcPs
desugarVariantCon [LHsRecField GhcPs (LHsExpr GhcPs)]
flds

  -- 4. Record Update: (REC_UPD r) { x = 42 } or REC_UPD (r { x = 42 }) or REC_UPD_F
  (HsExpr GhcPs
-> Maybe (LHsExpr GhcPs, [LHsRecField GhcPs (LHsExpr GhcPs)])
matchRecordUpd -> Just (LHsExpr GhcPs -> LHsExpr GhcPs
stripHsPar -> L SrcSpanAnnA
_ (HsApp XApp GhcPs
_ (LHsExpr GhcPs -> LHsExpr GhcPs
stripHsPar -> L SrcSpanAnnA
_ (HsVar XVar GhcPs
_ (L SrcSpanAnnN
_ RdrName
nm))) LHsExpr GhcPs
r), [LHsRecField GhcPs (LHsExpr GhcPs)]
flds))
    | let nmStr :: String
nmStr = OccName -> String
occNameString (RdrName -> OccName
rdrNameOcc RdrName
nm)
    , String
nmStr String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"REC_UPD" Bool -> Bool -> Bool
|| String
nmStr String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"REC_UPD_F"
    -> Bool
-> LHsExpr GhcPs
-> [LHsRecField GhcPs (LHsExpr GhcPs)]
-> HsExpr GhcPs
desugarRecordUpd (String
nmStr String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"REC_UPD_F") LHsExpr GhcPs
r [LHsRecField GhcPs (LHsExpr GhcPs)]
flds

  HsApp XApp GhcPs
_ (LHsExpr GhcPs -> LHsExpr GhcPs
stripHsPar -> L SrcSpanAnnA
_ (HsVar XVar GhcPs
_ (L SrcSpanAnnN
_ RdrName
nm))) (LHsExpr GhcPs -> LHsExpr GhcPs
stripHsPar -> L SrcSpanAnnA
_ (HsExpr GhcPs
-> Maybe (LHsExpr GhcPs, [LHsRecField GhcPs (LHsExpr GhcPs)])
matchRecordUpd -> Just (LHsExpr GhcPs
r, [LHsRecField GhcPs (LHsExpr GhcPs)]
flds)))
    | let nmStr :: String
nmStr = OccName -> String
occNameString (RdrName -> OccName
rdrNameOcc RdrName
nm)
    , String
nmStr String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"REC_UPD" Bool -> Bool -> Bool
|| String
nmStr String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"REC_UPD_F"
    -> Bool
-> LHsExpr GhcPs
-> [LHsRecField GhcPs (LHsExpr GhcPs)]
-> HsExpr GhcPs
desugarRecordUpd (String
nmStr String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"REC_UPD_F") LHsExpr GhcPs
r [LHsRecField GhcPs (LHsExpr GhcPs)]
flds

  -- 5. Open Variant Constructor Application (Lowering nominal forms to Variant)
  -- 5a. Record syntax payload: Success { val = 200 }
  RecordCon XRecordCon GhcPs
_ext (L SrcSpanAnnN
_ RdrName
nm) HsRecFields{ rec_flds :: forall p arg. HsRecFields p arg -> [LHsRecField p arg]
rec_flds = [LHsRecField GhcPs (LHsExpr GhcPs)]
flds }
    | let conStr :: String
conStr = OccName -> String
occNameString (RdrName -> OccName
rdrNameOcc RdrName
nm)
    , String
conStr String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
knownVars
    -> let injFn :: LHsExpr GhcPs
injFn = String -> LHsExpr GhcPs
polyVar String
"injectVariant"
           lblExpr :: LHsExpr GhcPs
lblExpr = FastString -> LHsExpr GhcPs
polyLabel (String -> FastString
fsLit String
conStr)
           recPayload :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
recPayload = HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (Bool -> [LHsRecField GhcPs (LHsExpr GhcPs)] -> HsExpr GhcPs
desugarRecordCon Bool
False [LHsRecField GhcPs (LHsExpr GhcPs)]
flds)
       in GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsExpr GhcPs
forall l e. GenLocated l e -> e
unLoc (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
mkHsApp (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
mkHsApp GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
injFn LHsExpr GhcPs
lblExpr) GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
recPayload)

  -- 5b. Prefix payload application: Success r
  HsApp XApp GhcPs
appExt (L SrcSpanAnnA
_ (HsVar XVar GhcPs
_ (L SrcSpanAnnN
_ RdrName
nm))) LHsExpr GhcPs
arg
    | let conStr :: String
conStr = OccName -> String
occNameString (RdrName -> OccName
rdrNameOcc RdrName
nm)
    , String
conStr String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
knownVars
    -> let injFn :: LHsExpr GhcPs
injFn = String -> LHsExpr GhcPs
polyVar String
"injectVariant"
           lblExpr :: LHsExpr GhcPs
lblExpr = FastString -> LHsExpr GhcPs
polyLabel (String -> FastString
fsLit String
conStr)
       in XApp GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcPs
appExt (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
mkHsApp GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
injFn LHsExpr GhcPs
lblExpr) LHsExpr GhcPs
arg

  -- 5c. Nullary constructor: Loading (payload is emptyRecord)
  HsVar XVar GhcPs
_ (L SrcSpanAnnN
_ RdrName
nm)
    | let conStr :: String
conStr = OccName -> String
occNameString (RdrName -> OccName
rdrNameOcc RdrName
nm)
    , String
conStr String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
knownVars
    -> let injFn :: LHsExpr GhcPs
injFn = String -> LHsExpr GhcPs
polyVar String
"injectVariant"
           lblExpr :: LHsExpr GhcPs
lblExpr = FastString -> LHsExpr GhcPs
polyLabel (String -> FastString
fsLit String
conStr)
           emptyFn :: LHsExpr GhcPs
emptyFn = String -> LHsExpr GhcPs
polyVar String
"emptyRecord"
       in GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsExpr GhcPs
forall l e. GenLocated l e -> e
unLoc (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
mkHsApp (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
mkHsApp GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
injFn LHsExpr GhcPs
lblExpr) GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
emptyFn)

  HsExpr GhcPs
other -> HsExpr GhcPs
other

-- | Desugars record construction into a nested fold of 'insertField' calls:
-- @REC { x = 1, y = True }@ ==> @insertField #x 1 (insertField #y True emptyRecord)@
--
-- When 'isHKD' is true, emits 'insertFieldF' and 'emptyRecordF' instead.
-- Supports field punning: @REC { x }@ extracts local variable 'x' as argument.
desugarRecordCon :: Bool -> [LHsRecField GhcPs (LHsExpr GhcPs)] -> HsExpr GhcPs
desugarRecordCon :: Bool -> [LHsRecField GhcPs (LHsExpr GhcPs)] -> HsExpr GhcPs
desugarRecordCon Bool
isHKD [LHsRecField GhcPs (LHsExpr GhcPs)]
flds =
  let emptyFn :: LHsExpr GhcPs
emptyFn = String -> LHsExpr GhcPs
polyVar (if Bool
isHKD then String
"emptyRecordF" else String
"emptyRecord")
      insertFnName :: String
insertFnName = if Bool
isHKD then String
"insertFieldF" else String
"insertField"
      foldStep :: LHsRecField GhcPs (LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
      foldStep :: LHsRecField GhcPs (LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
foldStep LHsRecField GhcPs (LHsExpr GhcPs)
fld LHsExpr GhcPs
acc =
        let (FastString
lbl, LHsExpr GhcPs
arg) = LHsRecField GhcPs (LHsExpr GhcPs) -> (FastString, LHsExpr GhcPs)
extractRecField LHsRecField GhcPs (LHsExpr GhcPs)
fld
            insFn :: LHsExpr GhcPs
insFn = String -> LHsExpr GhcPs
polyVar String
insertFnName
            lblExpr :: LHsExpr GhcPs
lblExpr = FastString -> LHsExpr GhcPs
polyLabel FastString
lbl
        in LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
mkHsApp (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
mkHsApp (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
mkHsApp LHsExpr GhcPs
insFn LHsExpr GhcPs
lblExpr) LHsExpr GhcPs
arg) LHsExpr GhcPs
acc
  in GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsExpr GhcPs
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ (GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated SrcSpanAnnA (FieldOcc GhcPs))
      (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
 -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> [GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated SrcSpanAnnA (FieldOcc GhcPs))
         (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr GenLocated
  SrcSpanAnnA
  (HsFieldBind
     (GenLocated SrcSpanAnnA (FieldOcc GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsRecField GhcPs (LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
foldStep GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
emptyFn [GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated SrcSpanAnnA (FieldOcc GhcPs))
      (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
[LHsRecField GhcPs (LHsExpr GhcPs)]
flds

-- | Desugars variant injection into @injectVariant #Tag val@:
-- @VAR { Ok = 200 }@ ==> @injectVariant #Ok 200@
desugarVariantCon :: [LHsRecField GhcPs (LHsExpr GhcPs)] -> HsExpr GhcPs
desugarVariantCon :: [LHsRecField GhcPs (LHsExpr GhcPs)] -> HsExpr GhcPs
desugarVariantCon [] =
  String -> HsExpr GhcPs
forall a. HasCallStack => String -> a
error String
"Polytropos.Plugin.Source: VAR {} requires a constructor tag (e.g. VAR { Ok = 200 })"
desugarVariantCon (LHsRecField GhcPs (LHsExpr GhcPs)
fld : [LHsRecField GhcPs (LHsExpr GhcPs)]
_) =
  let (FastString
lbl, LHsExpr GhcPs
arg) = LHsRecField GhcPs (LHsExpr GhcPs) -> (FastString, LHsExpr GhcPs)
extractRecField LHsRecField GhcPs (LHsExpr GhcPs)
fld
      injFn :: LHsExpr GhcPs
injFn = String -> LHsExpr GhcPs
polyVar String
"injectVariant"
      lblExpr :: LHsExpr GhcPs
lblExpr = FastString -> LHsExpr GhcPs
polyLabel FastString
lbl
  in GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsExpr GhcPs
forall l e. GenLocated l e -> e
unLoc (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
mkHsApp (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
mkHsApp GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
injFn LHsExpr GhcPs
lblExpr) LHsExpr GhcPs
arg)

-- | Desugars functional record update into a fold of 'setField' calls:
-- @REC_UPD r { x = 42, y = False }@ ==> @setField #x 42 (setField #y False r)@
--
-- When 'isHKD' is true, emits 'setFieldF' instead.
desugarRecordUpd :: Bool -> LHsExpr GhcPs -> [CompatRecUpdField] -> HsExpr GhcPs
desugarRecordUpd :: Bool
-> LHsExpr GhcPs
-> [LHsRecField GhcPs (LHsExpr GhcPs)]
-> HsExpr GhcPs
desugarRecordUpd Bool
isHKD LHsExpr GhcPs
r [LHsRecField GhcPs (LHsExpr GhcPs)]
flds =
  let setFnName :: String
setFnName = if Bool
isHKD then String
"setFieldF" else String
"setField"
      foldStep :: CompatRecUpdField -> LHsExpr GhcPs -> LHsExpr GhcPs
      foldStep :: LHsRecField GhcPs (LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
foldStep LHsRecField GhcPs (LHsExpr GhcPs)
fld LHsExpr GhcPs
acc =
        let (FastString
fs, LHsExpr GhcPs
arg) = LHsRecField GhcPs (LHsExpr GhcPs) -> (FastString, LHsExpr GhcPs)
extractRecUpdField LHsRecField GhcPs (LHsExpr GhcPs)
fld
            setFn :: LHsExpr GhcPs
setFn = String -> LHsExpr GhcPs
polyVar String
setFnName
            lblExpr :: LHsExpr GhcPs
lblExpr = FastString -> LHsExpr GhcPs
polyLabel FastString
fs
        in LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
mkHsApp (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
mkHsApp (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
mkHsApp LHsExpr GhcPs
setFn LHsExpr GhcPs
lblExpr) LHsExpr GhcPs
arg) LHsExpr GhcPs
acc
  in GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsExpr GhcPs
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ (GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated SrcSpanAnnA (FieldOcc GhcPs))
      (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
 -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> [GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated SrcSpanAnnA (FieldOcc GhcPs))
         (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr GenLocated
  SrcSpanAnnA
  (HsFieldBind
     (GenLocated SrcSpanAnnA (FieldOcc GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsRecField GhcPs (LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
foldStep GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
r [GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated SrcSpanAnnA (FieldOcc GhcPs))
      (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
[LHsRecField GhcPs (LHsExpr GhcPs)]
flds

-- | Extracts the field label and value expression from a record field node.
-- Handles GHC field punning: if @pun@ flag is set, synthesizes a variable
-- expression referencing the field identifier in local scope.
extractRecField :: LHsRecField GhcPs (LHsExpr GhcPs) -> (FastString, LHsExpr GhcPs)
extractRecField :: LHsRecField GhcPs (LHsExpr GhcPs) -> (FastString, LHsExpr GhcPs)
extractRecField (L SrcSpanAnnA
_ (HsFieldBind XHsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcPs))
_ (L SrcSpanAnnA
_ (FieldOcc XCFieldOcc GhcPs
_ (L SrcSpanAnnN
_ RdrName
lbl))) GenLocated SrcSpanAnnA (HsExpr GhcPs)
arg Bool
pun)) =
  let fs :: FastString
fs = OccName -> FastString
occNameFS (RdrName -> OccName
rdrNameOcc RdrName
lbl)
      arg' :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
arg' = if Bool
pun then HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (XVar GhcPs -> LIdOccP GhcPs -> HsExpr GhcPs
forall p. XVar p -> LIdOccP p -> HsExpr p
HsVar NoExtField
XVar GhcPs
noExtField (RdrName -> GenLocated SrcSpanAnnN RdrName
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA RdrName
lbl)) else GenLocated SrcSpanAnnA (HsExpr GhcPs)
arg
  in (FastString
fs, GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
arg')

{-------------------------------------------------------------------------------
  Pattern Rewriting
-------------------------------------------------------------------------------}

-- | Rewrites pattern matches on @REC@, @VAR@, and open nominal constructors into
-- GHC View Patterns ('ViewPat').
--
-- See Note [Record Update and View Pattern Translation] [ref:note-view-patterns]
--
-- Desugared Patterns:
-- 1. Record Pattern:
--    @REC { x, y }@ or @Person { name, age }@
--    Lowered into tuple-bundled view patterns via 'desugarRecordPat'.
-- 2. Variant Pattern:
--    @VAR { Ok = p }@
--    Lowered into @(projectVariant #Ok -> Just p)@.
-- 3. Open Variant Constructor Pattern:
--    - Record payload: @Success { val }@ ==> @(projectVariant #Success -> Just (val view pattern))@
--    - Prefix payload: @Success p@      ==> @(projectVariant #Success -> Just p)@
--    - Nullary:        @Loading@        ==> @(projectVariant #Loading -> Just _)@
transformPat :: [String] -> [String] -> Pat GhcPs -> Pat GhcPs
transformPat :: [String] -> [String] -> Pat GhcPs -> Pat GhcPs
transformPat [String]
knownRecs [String]
knownVars Pat GhcPs
pat = case Pat GhcPs
pat of
  -- 1. Record Pattern: REC { x, y } or Person { x, y }
  ConPat XConPat GhcPs
_ext (L SrcSpanAnnN
_ RdrName
nm) (RecCon HsRecFields{ rec_flds :: forall p arg. HsRecFields p arg -> [LHsRecField p arg]
rec_flds = [LHsRecField GhcPs (LPat GhcPs)]
flds })
    | let conStr :: String
conStr = OccName -> String
occNameString (RdrName -> OccName
rdrNameOcc RdrName
nm)
    , String
conStr String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"REC" Bool -> Bool -> Bool
|| String
conStr String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
knownRecs
    -> [LHsRecField GhcPs (LPat GhcPs)] -> Pat GhcPs
desugarRecordPat [LHsRecField GhcPs (LPat GhcPs)]
flds

  -- 2. Variant Pattern: VAR { Ok = p } or VARIANT { Err = p }
  ConPat XConPat GhcPs
_ext (L SrcSpanAnnN
_ RdrName
nm) (RecCon HsRecFields{ rec_flds :: forall p arg. HsRecFields p arg -> [LHsRecField p arg]
rec_flds = [LHsRecField GhcPs (LPat GhcPs)]
flds })
    | let conStr :: String
conStr = OccName -> String
occNameString (RdrName -> OccName
rdrNameOcc RdrName
nm)
    , String
conStr String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"VAR" Bool -> Bool -> Bool
|| String
conStr String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"VARIANT"
    -> [LHsRecField GhcPs (LPat GhcPs)] -> Pat GhcPs
desugarVariantPat [LHsRecField GhcPs (LPat GhcPs)]
flds

  -- 3. Open Variant Constructor Pattern (Lowering nominal constructor patterns)
  -- 3a. Record syntax payload: Success { val }
  ConPat XConPat GhcPs
_ext (L SrcSpanAnnN
_ RdrName
nm) (RecCon HsRecFields{ rec_flds :: forall p arg. HsRecFields p arg -> [LHsRecField p arg]
rec_flds = [LHsRecField GhcPs (LPat GhcPs)]
flds })
    | let conStr :: String
conStr = OccName -> String
occNameString (RdrName -> OccName
rdrNameOcc RdrName
nm)
    , String
conStr String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
knownVars
    -> let viewExpr :: LHsExpr GhcPs
viewExpr = LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
mkHsApp (String -> LHsExpr GhcPs
polyVar String
"projectVariant") (FastString -> LHsExpr GhcPs
polyLabel (String -> FastString
fsLit String
conStr))
           justCon :: GenLocated SrcSpanAnnN RdrName
justCon  = RdrName -> GenLocated SrcSpanAnnN RdrName
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (OccName -> RdrName
mkRdrUnqual (String -> OccName
mkDataOcc String
"Just"))
           innerPat :: GenLocated SrcSpanAnnA (Pat GhcPs)
innerPat = Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA ([LHsRecField GhcPs (LPat GhcPs)] -> Pat GhcPs
desugarRecordPat [LHsRecField GhcPs (LPat GhcPs)]
flds)
           justPat :: GenLocated SrcSpanAnnA (Pat GhcPs)
justPat  = Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs))
-> Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall a b. (a -> b) -> a -> b
$ XConPat GhcPs
-> XRec GhcPs (ConLikeP GhcPs)
-> HsConDetails (LPat GhcPs) (HsRecFields GhcPs (LPat GhcPs))
-> Pat GhcPs
forall p.
XConPat p -> XRec p (ConLikeP p) -> HsConPatDetails p -> Pat p
ConPat XConPat GhcPs
forall a. NoAnn a => a
noAnn GenLocated SrcSpanAnnN RdrName
XRec GhcPs (ConLikeP GhcPs)
justCon ([GenLocated SrcSpanAnnA (Pat GhcPs)]
-> HsConDetails
     (GenLocated SrcSpanAnnA (Pat GhcPs))
     (HsRecFields GhcPs (GenLocated SrcSpanAnnA (Pat GhcPs)))
forall arg rec. [arg] -> HsConDetails arg rec
PrefixConPat [GenLocated SrcSpanAnnA (Pat GhcPs)
innerPat])
       in XViewPat GhcPs -> LHsExpr GhcPs -> LPat GhcPs -> Pat GhcPs
forall p. XViewPat p -> LHsExpr p -> LPat p -> Pat p
ViewPat TokRarrow
XViewPat GhcPs
forall a. NoAnn a => a
noAnn LHsExpr GhcPs
viewExpr GenLocated SrcSpanAnnA (Pat GhcPs)
LPat GhcPs
justPat

  -- 3b. 1-arg prefix pattern: Success r
  ConPat XConPat GhcPs
_ext (L SrcSpanAnnN
_ RdrName
nm) (PrefixConPat [GenLocated SrcSpanAnnA (Pat GhcPs)
argPat])
    | let conStr :: String
conStr = OccName -> String
occNameString (RdrName -> OccName
rdrNameOcc RdrName
nm)
    , String
conStr String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
knownVars
    -> let viewExpr :: LHsExpr GhcPs
viewExpr = LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
mkHsApp (String -> LHsExpr GhcPs
polyVar String
"projectVariant") (FastString -> LHsExpr GhcPs
polyLabel (String -> FastString
fsLit String
conStr))
           justCon :: GenLocated SrcSpanAnnN RdrName
justCon  = RdrName -> GenLocated SrcSpanAnnN RdrName
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (OccName -> RdrName
mkRdrUnqual (String -> OccName
mkDataOcc String
"Just"))
           justPat :: GenLocated SrcSpanAnnA (Pat GhcPs)
justPat  = Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs))
-> Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall a b. (a -> b) -> a -> b
$ XConPat GhcPs
-> XRec GhcPs (ConLikeP GhcPs)
-> HsConDetails (LPat GhcPs) (HsRecFields GhcPs (LPat GhcPs))
-> Pat GhcPs
forall p.
XConPat p -> XRec p (ConLikeP p) -> HsConPatDetails p -> Pat p
ConPat XConPat GhcPs
forall a. NoAnn a => a
noAnn GenLocated SrcSpanAnnN RdrName
XRec GhcPs (ConLikeP GhcPs)
justCon ([GenLocated SrcSpanAnnA (Pat GhcPs)]
-> HsConDetails
     (GenLocated SrcSpanAnnA (Pat GhcPs))
     (HsRecFields GhcPs (GenLocated SrcSpanAnnA (Pat GhcPs)))
forall arg rec. [arg] -> HsConDetails arg rec
PrefixConPat [GenLocated SrcSpanAnnA (Pat GhcPs)
argPat])
       in XViewPat GhcPs -> LHsExpr GhcPs -> LPat GhcPs -> Pat GhcPs
forall p. XViewPat p -> LHsExpr p -> LPat p -> Pat p
ViewPat TokRarrow
XViewPat GhcPs
forall a. NoAnn a => a
noAnn LHsExpr GhcPs
viewExpr GenLocated SrcSpanAnnA (Pat GhcPs)
LPat GhcPs
justPat

  -- 3c. Nullary prefix pattern: Loading
  ConPat XConPat GhcPs
_ext (L SrcSpanAnnN
_ RdrName
nm) (PrefixConPat [])
    | let conStr :: String
conStr = OccName -> String
occNameString (RdrName -> OccName
rdrNameOcc RdrName
nm)
    , String
conStr String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
knownVars
    -> let viewExpr :: LHsExpr GhcPs
viewExpr = LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
mkHsApp (String -> LHsExpr GhcPs
polyVar String
"projectVariant") (FastString -> LHsExpr GhcPs
polyLabel (String -> FastString
fsLit String
conStr))
           justCon :: GenLocated SrcSpanAnnN RdrName
justCon  = RdrName -> GenLocated SrcSpanAnnN RdrName
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (OccName -> RdrName
mkRdrUnqual (String -> OccName
mkDataOcc String
"Just"))
           wildPat :: GenLocated SrcSpanAnnA (Pat GhcPs)
wildPat  = Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (XWildPat GhcPs -> Pat GhcPs
forall p. XWildPat p -> Pat p
WildPat NoExtField
XWildPat GhcPs
noExtField)
           justPat :: GenLocated SrcSpanAnnA (Pat GhcPs)
justPat  = Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs))
-> Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall a b. (a -> b) -> a -> b
$ XConPat GhcPs
-> XRec GhcPs (ConLikeP GhcPs)
-> HsConDetails (LPat GhcPs) (HsRecFields GhcPs (LPat GhcPs))
-> Pat GhcPs
forall p.
XConPat p -> XRec p (ConLikeP p) -> HsConPatDetails p -> Pat p
ConPat XConPat GhcPs
forall a. NoAnn a => a
noAnn GenLocated SrcSpanAnnN RdrName
XRec GhcPs (ConLikeP GhcPs)
justCon ([GenLocated SrcSpanAnnA (Pat GhcPs)]
-> HsConDetails
     (GenLocated SrcSpanAnnA (Pat GhcPs))
     (HsRecFields GhcPs (GenLocated SrcSpanAnnA (Pat GhcPs)))
forall arg rec. [arg] -> HsConDetails arg rec
PrefixConPat [GenLocated SrcSpanAnnA (Pat GhcPs)
wildPat])
       in XViewPat GhcPs -> LHsExpr GhcPs -> LPat GhcPs -> Pat GhcPs
forall p. XViewPat p -> LHsExpr p -> LPat p -> Pat p
ViewPat TokRarrow
XViewPat GhcPs
forall a. NoAnn a => a
noAnn LHsExpr GhcPs
viewExpr GenLocated SrcSpanAnnA (Pat GhcPs)
LPat GhcPs
justPat

  Pat GhcPs
other -> Pat GhcPs
other

-- | Desugars record pattern matching into GHC View Patterns ('ViewPat').
--
-- Optimization:
-- - Empty pattern @REC {}@ desugars to wildcard ('WildPat').
-- - Single field @REC { x = p }@ desugars to @(recordField #x -> p)@.
-- - Multi-field @REC { x = p1, y = p2 }@ bundles projections into a single tuple lambda:
--   @(\_r -> (recordField #x _r, recordField #y _r)) -> (p1, p2)@
--   This projects all fields in one evaluation pass rather than cascading multiple view patterns.
desugarRecordPat :: [LHsRecField GhcPs (LPat GhcPs)] -> Pat GhcPs
desugarRecordPat :: [LHsRecField GhcPs (LPat GhcPs)] -> Pat GhcPs
desugarRecordPat [] =
  XWildPat GhcPs -> Pat GhcPs
forall p. XWildPat p -> Pat p
WildPat NoExtField
XWildPat GhcPs
noExtField
desugarRecordPat [LHsRecField GhcPs (LPat GhcPs)
fld] =
  let (FastString
lbl, LPat GhcPs
p) = LHsRecField GhcPs (LPat GhcPs) -> (FastString, LPat GhcPs)
extractRecPatField LHsRecField GhcPs (LPat GhcPs)
fld
      viewExpr :: LHsExpr GhcPs
viewExpr = LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
mkHsApp (String -> LHsExpr GhcPs
polyVar String
"recordField") (FastString -> LHsExpr GhcPs
polyLabel FastString
lbl)
  in XViewPat GhcPs -> LHsExpr GhcPs -> LPat GhcPs -> Pat GhcPs
forall p. XViewPat p -> LHsExpr p -> LPat p -> Pat p
ViewPat TokRarrow
XViewPat GhcPs
forall a. NoAnn a => a
noAnn LHsExpr GhcPs
viewExpr LPat GhcPs
p
desugarRecordPat [LHsRecField GhcPs (LPat GhcPs)]
flds =
  let ([FastString]
lbls, [GenLocated SrcSpanAnnA (Pat GhcPs)]
pats) = [(FastString, GenLocated SrcSpanAnnA (Pat GhcPs))]
-> ([FastString], [GenLocated SrcSpanAnnA (Pat GhcPs)])
forall a b. [(a, b)] -> ([a], [b])
unzip ((GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated SrcSpanAnnA (FieldOcc GhcPs))
      (GenLocated SrcSpanAnnA (Pat GhcPs)))
 -> (FastString, GenLocated SrcSpanAnnA (Pat GhcPs)))
-> [GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated SrcSpanAnnA (FieldOcc GhcPs))
         (GenLocated SrcSpanAnnA (Pat GhcPs)))]
-> [(FastString, GenLocated SrcSpanAnnA (Pat GhcPs))]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated
  SrcSpanAnnA
  (HsFieldBind
     (GenLocated SrcSpanAnnA (FieldOcc GhcPs))
     (GenLocated SrcSpanAnnA (Pat GhcPs)))
-> (FastString, GenLocated SrcSpanAnnA (Pat GhcPs))
LHsRecField GhcPs (LPat GhcPs) -> (FastString, LPat GhcPs)
extractRecPatField [GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated SrcSpanAnnA (FieldOcc GhcPs))
      (GenLocated SrcSpanAnnA (Pat GhcPs)))]
[LHsRecField GhcPs (LPat GhcPs)]
flds)
      rVar :: RdrName
rVar         = OccName -> RdrName
mkRdrUnqual (String -> OccName
mkVarOcc String
"_r")
      rExpr :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
rExpr        = HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (XVar GhcPs -> LIdOccP GhcPs -> HsExpr GhcPs
forall p. XVar p -> LIdOccP p -> HsExpr p
HsVar NoExtField
XVar GhcPs
noExtField (RdrName -> GenLocated SrcSpanAnnN RdrName
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA RdrName
rVar))
      mkProj :: FastString -> LHsExpr GhcPs
mkProj FastString
lbl   = LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
mkHsApp (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
mkHsApp (String -> LHsExpr GhcPs
polyVar String
"recordField") (FastString -> LHsExpr GhcPs
polyLabel FastString
lbl)) GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
rExpr
      tupExpr :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
tupExpr      = HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XExplicitTuple GhcPs -> [HsTupArg GhcPs] -> Boxity -> HsExpr GhcPs
forall p. XExplicitTuple p -> [HsTupArg p] -> Boxity -> HsExpr p
ExplicitTuple (EpaLocation, EpaLocation)
XExplicitTuple GhcPs
forall a. NoAnn a => a
noAnn ((FastString -> HsTupArg GhcPs) -> [FastString] -> [HsTupArg GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsTupArg GhcPs
LHsExpr GhcPs -> HsTupArg GhcPs
mkTupArg (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsTupArg GhcPs)
-> (FastString -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> FastString
-> HsTupArg GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
FastString -> LHsExpr GhcPs
mkProj) [FastString]
lbls) Boxity
Boxed
      rPat :: GenLocated SrcSpanAnnA (Pat GhcPs)
rPat         = Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (XVarPat GhcPs -> LIdP GhcPs -> Pat GhcPs
forall p. XVarPat p -> LIdP p -> Pat p
VarPat NoExtField
XVarPat GhcPs
noExtField (RdrName -> GenLocated SrcSpanAnnN RdrName
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA RdrName
rVar))
      lamExpr :: LHsExpr GhcPs
lamExpr      = [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
mkLambda [GenLocated SrcSpanAnnA (Pat GhcPs)
LPat GhcPs
rPat] GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
tupExpr
      tupPat :: GenLocated SrcSpanAnnA (Pat GhcPs)
tupPat       = Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs))
-> Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall a b. (a -> b) -> a -> b
$ XTuplePat GhcPs -> [LPat GhcPs] -> Boxity -> Pat GhcPs
forall p. XTuplePat p -> [LPat p] -> Boxity -> Pat p
TuplePat XTuplePat GhcPs
forall a. NoAnn a => a
noAnn [GenLocated SrcSpanAnnA (Pat GhcPs)]
[LPat GhcPs]
pats Boxity
Boxed
  in XViewPat GhcPs -> LHsExpr GhcPs -> LPat GhcPs -> Pat GhcPs
forall p. XViewPat p -> LHsExpr p -> LPat p -> Pat p
ViewPat TokRarrow
XViewPat GhcPs
forall a. NoAnn a => a
noAnn LHsExpr GhcPs
lamExpr GenLocated SrcSpanAnnA (Pat GhcPs)
LPat GhcPs
tupPat

-- | Desugars variant pattern matching into @(projectVariant #Tag -> Just p)@:
-- @VAR { Ok = p }@ ==> @(projectVariant #Ok -> Just p)@
--
-- If the runtime tag matches '#Ok', 'projectVariant' returns 'Just payload' and
-- succeeds; otherwise it returns 'Nothing' and pattern matching falls through.
desugarVariantPat :: [LHsRecField GhcPs (LPat GhcPs)] -> Pat GhcPs
desugarVariantPat :: [LHsRecField GhcPs (LPat GhcPs)] -> Pat GhcPs
desugarVariantPat [] =
  String -> Pat GhcPs
forall a. HasCallStack => String -> a
error String
"Polytropos.Plugin.Source: VAR {} pattern requires a constructor tag"
desugarVariantPat (LHsRecField GhcPs (LPat GhcPs)
fld : [LHsRecField GhcPs (LPat GhcPs)]
_) =
  let (FastString
lbl, LPat GhcPs
p)   = LHsRecField GhcPs (LPat GhcPs) -> (FastString, LPat GhcPs)
extractRecPatField LHsRecField GhcPs (LPat GhcPs)
fld
      viewExpr :: LHsExpr GhcPs
viewExpr   = LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
mkHsApp (String -> LHsExpr GhcPs
polyVar String
"projectVariant") (FastString -> LHsExpr GhcPs
polyLabel FastString
lbl)
      justCon :: GenLocated SrcSpanAnnN RdrName
justCon    = RdrName -> GenLocated SrcSpanAnnN RdrName
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (OccName -> RdrName
mkRdrUnqual (String -> OccName
mkDataOcc String
"Just"))
      justPat :: GenLocated SrcSpanAnnA (Pat GhcPs)
justPat    = Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs))
-> Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall a b. (a -> b) -> a -> b
$ XConPat GhcPs
-> XRec GhcPs (ConLikeP GhcPs)
-> HsConDetails (LPat GhcPs) (HsRecFields GhcPs (LPat GhcPs))
-> Pat GhcPs
forall p.
XConPat p -> XRec p (ConLikeP p) -> HsConPatDetails p -> Pat p
ConPat XConPat GhcPs
forall a. NoAnn a => a
noAnn GenLocated SrcSpanAnnN RdrName
XRec GhcPs (ConLikeP GhcPs)
justCon ([LPat GhcPs]
-> HsConDetails (LPat GhcPs) (HsRecFields GhcPs (LPat GhcPs))
forall arg rec. [arg] -> HsConDetails arg rec
PrefixConPat [LPat GhcPs
p])
  in XViewPat GhcPs -> LHsExpr GhcPs -> LPat GhcPs -> Pat GhcPs
forall p. XViewPat p -> LHsExpr p -> LPat p -> Pat p
ViewPat TokRarrow
XViewPat GhcPs
forall a. NoAnn a => a
noAnn LHsExpr GhcPs
viewExpr GenLocated SrcSpanAnnA (Pat GhcPs)
LPat GhcPs
justPat

-- | Extracts the field label and sub-pattern from a record pattern field node.
-- Supports field punning: @REC { x }@ binds to pattern variable 'x'.
extractRecPatField :: LHsRecField GhcPs (LPat GhcPs) -> (FastString, LPat GhcPs)
extractRecPatField :: LHsRecField GhcPs (LPat GhcPs) -> (FastString, LPat GhcPs)
extractRecPatField (L SrcSpanAnnA
_ (HsFieldBind XHsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcPs))
_ (L SrcSpanAnnA
_ (FieldOcc XCFieldOcc GhcPs
_ (L SrcSpanAnnN
_ RdrName
lbl))) GenLocated SrcSpanAnnA (Pat GhcPs)
p Bool
pun)) =
  let fs :: FastString
fs = OccName -> FastString
occNameFS (RdrName -> OccName
rdrNameOcc RdrName
lbl)
      p' :: GenLocated SrcSpanAnnA (Pat GhcPs)
p' = if Bool
pun then Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (XVarPat GhcPs -> LIdP GhcPs -> Pat GhcPs
forall p. XVarPat p -> LIdP p -> Pat p
VarPat NoExtField
XVarPat GhcPs
noExtField (RdrName -> GenLocated SrcSpanAnnN RdrName
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA RdrName
lbl)) else GenLocated SrcSpanAnnA (Pat GhcPs)
p
  in (FastString
fs, GenLocated SrcSpanAnnA (Pat GhcPs)
LPat GhcPs
p')

{-------------------------------------------------------------------------------
  Helper Functions
-------------------------------------------------------------------------------}

-- | Synthesizes a qualified RdrName expression: @Polytropos.<identifier>@.
-- Ensures that transformed expressions reference canonical Polytropos symbols
-- regardless of userland import shadowing.
polyVar :: String -> LHsExpr GhcPs
polyVar :: String -> LHsExpr GhcPs
polyVar String
occ = HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (XVar GhcPs -> LIdOccP GhcPs -> HsExpr GhcPs
forall p. XVar p -> LIdOccP p -> HsExpr p
HsVar NoExtField
XVar GhcPs
noExtField (RdrName -> GenLocated SrcSpanAnnN RdrName
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (ModuleName -> OccName -> RdrName
mkRdrQual (String -> ModuleName
mkModuleName String
"Polytropos") (String -> OccName
mkVarOcc String
occ))))

-- | Ensures that @import qualified Polytropos as Polytropos@ is present in the module's imports.
-- Injected automatically during 'transformParsedModule' so generated combinators resolve cleanly.
ensurePolytroposImport :: [LImportDecl GhcPs] -> [LImportDecl GhcPs]
ensurePolytroposImport :: [LImportDecl GhcPs] -> [LImportDecl GhcPs]
ensurePolytroposImport [LImportDecl GhcPs]
imps =
  if (GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> Bool)
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> Bool
forall {pass} {l} {l}.
(XRec pass ModuleName ~ GenLocated l ModuleName) =>
GenLocated l (ImportDecl pass) -> Bool
isPolytroposImport [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
[LImportDecl GhcPs]
imps
    then [LImportDecl GhcPs]
imps
    else GenLocated SrcSpanAnnA (ImportDecl GhcPs)
LImportDecl GhcPs
mkPolytroposImportDecl GenLocated SrcSpanAnnA (ImportDecl GhcPs)
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
forall a. a -> [a] -> [a]
: [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
[LImportDecl GhcPs]
imps
  where
    isPolytroposImport :: GenLocated l (ImportDecl pass) -> Bool
isPolytroposImport (L l
_ ImportDecl{ ideclName :: forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName = L l
_ ModuleName
modNm }) =
      ModuleName -> String
moduleNameString ModuleName
modNm String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Polytropos"
    isPolytroposImport GenLocated l (ImportDecl pass)
_ = Bool
False