module Language.PureScript.Backend.IR

( module Language.PureScript.Backend.IR

, module Language.PureScript.Backend.IR.Types

, module Language.PureScript.Backend.IR.Names

) where

import Control.Monad.Error.Class (MonadError (throwError))

import Control.Monad.Writer.Class (MonadWriter (..))

import Data.List qualified as List

import Data.List.NonEmpty ((<|))

import Data.List.NonEmpty qualified as NE

import Data.Map.Lazy qualified as Map

import Data.Tagged (Tagged (Tagged))

import Data.Text qualified as Text

import Data.Traversable (for)

import Language.PureScript.Backend.IR.Inliner (Annotation)

import Language.PureScript.Backend.IR.Inliner qualified as Inliner

import Language.PureScript.Backend.IR.Names

import Language.PureScript.Backend.IR.Types

import Language.PureScript.Backend.Lua.Fixture (runtimeLazyName)

import Language.PureScript.Backend.Lua.Name qualified as Name

import Language.PureScript.CoreFn qualified as Cfn

import Language.PureScript.CoreFn.Laziness (applyLazinessTransform)

import Language.PureScript.PSString

( PSString

, decodeString

, decodeStringEscaping

)

import Relude.Extra (toFst)

import Text.Megaparsec qualified as Megaparsec

import Text.Pretty.Simple (pShow)

import Text.Show (Show (..))

import Prelude hiding (identity, show)

data Context = Context

{ annotations

∷ Map Name Annotation

, contextModule

∷ Cfn.Module Cfn.Ann

, contextDataTypes

∷ Map (ModuleName, TyName) (AlgebraicType, Map CtorName [FieldName])

, lastGeneratedNameIndex

∷ Integer

, needsRuntimeLazy

∷ Any

}

type CfnExp = Cfn.Expr Cfn.Ann

newtype RepM a = RepM (StateT Context (Either CoreFnError) a)

deriving newtype

( Functor

, Applicative

, Monad

, MonadState Context

, MonadError CoreFnError

)

instance MonadWriter Any RepM where

writer (a, nrl) = a <$ modify \ctx → ctx {needsRuntimeLazy = nrl}

listen repM = (,) <$> repM <*> gets needsRuntimeLazy

pass repM = do

(a, f) ← repM

a <$ modify' \ctx → ctx {needsRuntimeLazy = f (needsRuntimeLazy ctx)}

runRepM

∷ Context

→ RepM a

→ Either CoreFnError (Tagged "needsRuntimeLazy" Bool, a)

runRepM ctx (RepM m) = do

(a, ctx') ← runStateT m ctx

let remainingAnnotations = annotations ctx'

unless (Map.null remainingAnnotations) do

Left . CoreFnError (Cfn.moduleName (contextModule ctx)) $

UnusedAnnotations remainingAnnotations

pure (Tagged . getAny $ needsRuntimeLazy ctx', a)

mkModule

∷ Cfn.Module Cfn.Ann

→ Map (ModuleName, TyName) (AlgebraicType, Map CtorName [FieldName])

→ Either CoreFnError (Tagged "needsRuntimeLazy" Bool, Module)

mkModule cfnModule contextDataTypes = do

annotations ← parseAnnotations cfnModule

runRepM

Context

{ annotations

, contextModule = cfnModule

, contextDataTypes

, lastGeneratedNameIndex = 0

, needsRuntimeLazy = Any False

}

do

moduleBindings ← mkBindings

moduleImports ← mkImports

moduleExports ← mkExports

moduleReExports ← mkReExports

moduleForeigns ← mkForeigns

pure

Module

{ moduleName = Cfn.moduleName cfnModule

, modulePath = Cfn.modulePath cfnModule

, moduleBindings

, moduleImports

, moduleExports

, moduleReExports

, moduleForeigns

}

parseAnnotations ∷ Cfn.Module Cfn.Ann → Either CoreFnError (Map Name Annotation)

parseAnnotations currentModule =

Cfn.moduleComments currentModule

& foldMapM \case

Cfn.LineComment line → pure <$> parsePragmaLine line

Cfn.BlockComment block → traverse parsePragmaLine (lines block)

& fmap (Map.fromList . catMaybes)

where

parsePragmaLine ∷ Text → Either CoreFnError (Maybe Inliner.Pragma)

parsePragmaLine ln = do

let parser = optional (Inliner.pragmaParser <* Megaparsec.eof)

Megaparsec.parse parser (Cfn.modulePath currentModule) (Text.strip ln)

& first

(CoreFnError (Cfn.moduleName currentModule) . AnnotationParsingError)

useAnnotation ∷ Name → RepM (Maybe Annotation)

useAnnotation name = do

ctx ← get

let (ann, annotations') =

-- delete the annotation from the map returning the value

Map.updateLookupWithKey (\_ _ → Nothing) name (annotations ctx)

put $ ctx {annotations = annotations'}

pure ann

mkImports ∷ RepM [ModuleName]

mkImports = do

Cfn.Module {moduleName, moduleImports} ← gets contextModule

pure $

-- it's ok to always add prim as an explicit import:

-- DCE removes it if it's not used.

Cfn.unsafeModuleNameFromText "Prim"

: [i | (_ann, i) ← moduleImports, isIncluded moduleName i]

where

isIncluded ∷ ModuleName → ModuleName → Bool

isIncluded currentModule modname = modname /= currentModule

mkExports ∷ RepM [Name]

mkExports = identToName <<$>> gets (contextModule >>> Cfn.moduleExports)

mkReExports ∷ RepM (Map ModuleName [Name])

mkReExports =

Map.fromAscList . fmap (identToName <<$>>) . Map.toAscList

<$> gets (contextModule >>> Cfn.moduleReExports)

mkForeigns ∷ RepM [(Ann, Name)]

mkForeigns = do

idents ← gets (contextModule >>> Cfn.moduleForeign)

forM idents \ident → do

let name = identToName ident

ann ← useAnnotation name

pure (ann, name)

collectDataDeclarations

∷ Map ModuleName (Cfn.Module Cfn.Ann)

→ Map (ModuleName, TyName) (AlgebraicType, Map CtorName [FieldName])

collectDataDeclarations cfnModules = Map.unions do

Map.toList cfnModules <&> \(modName, cfnModule) →

Map.fromList

[ ((modName, ty), (algebraicType, Map.fromList (snd <$> ctors)))

| ctors ←

List.groupBy

((==) `on` fst)

[ (mkTyName tyName, (mkCtorName ctorName, identToFieldName <$> fields))

| bind ← Cfn.moduleBindings cfnModule

, Cfn.Constructor _ann tyName ctorName fields ← boundExp bind

]

, let ty = fst (head (NE.fromList ctors)) -- groupBy never makes an empty group

, let algebraicType = if length ctors == 1 then ProductType else SumType

]

where

boundExp ∷ Cfn.Bind a → [Cfn.Expr a]

boundExp = \case

Cfn.Rec bindingGroup → snd <$> bindingGroup

Cfn.NonRec _ann _ident expr → [expr]

mkQualified ∷ (a → n) → Cfn.Qualified a → Qualified n

mkQualified f (Cfn.Qualified by a) =

case by of

Cfn.BySourcePos _sourcePos → Local (f a)

Cfn.ByModuleName mn → Imported mn (f a)

identToName ∷ Cfn.Ident → Name

identToName = Name . identToText

identToFieldName ∷ Cfn.Ident → FieldName

identToFieldName = FieldName . identToText

identToText ∷ Cfn.Ident → Text

identToText = \case

Cfn.Ident ident → ident

Cfn.GenIdent name n → maybe "$" ("$" <>) name <> toText (show n)

Cfn.UnusedIdent → "$__unused"

Cfn.InternalIdent Cfn.RuntimeLazyFactory → Name.toText runtimeLazyName

Cfn.InternalIdent (Cfn.Lazy t) → "Lazy_" <> t

mkBindings ∷ RepM [Binding]

mkBindings = do

psBindings ← gets $ contextModule >>> Cfn.moduleBindings

traverse mkBinding psBindings

mkBinding ∷ Cfn.Bind Cfn.Ann → RepM Binding

mkBinding = \case

Cfn.NonRec _ann ident cfnExpr → do

let name = identToName ident

ann ← useAnnotation name

expr ← makeExprAnnotated ann cfnExpr

pure $ Standalone (noAnn, name, expr)

Cfn.Rec bindingGroup → do

modname ← gets $ contextModule >>> Cfn.moduleName

bindings ← writer $ applyLazinessTransform modname bindingGroup

case NE.nonEmpty bindings of

Nothing → throwContextualError EmptyBindingGroup

Just bs →

RecursiveGroup <$> for bs \((_ann, ident), expr) →

(noAnn,identToName ident,) <$> makeExpr expr

makeExpr ∷ CfnExp → RepM Exp

makeExpr = makeExprAnnotated Nothing

makeExprAnnotated ∷ Ann → CfnExp → RepM Exp

makeExprAnnotated ann cfnExpr =

case cfnExpr of

Cfn.Literal _ann literal →

mkLiteral ann literal

Cfn.Constructor cfnAnn tyName ctorName ids →

mkConstructor cfnAnn ann tyName ctorName ids

Cfn.Accessor _ann str expr →

mkAccessor ann str expr

Cfn.ObjectUpdate _ann expr patches →

mkObjectUpdate expr patches

Cfn.Abs _ann ident expr →

mkAbstraction ann ident expr

Cfn.App _ann abstr arg →

mkApplication abstr arg

Cfn.Var _ann qualifiedIdent →

mkRef qualifiedIdent

Cfn.Case _ann exprs alternatives →

case NE.nonEmpty alternatives of

Just as → mkCase ann exprs as

Nothing → throwContextualError $ EmptyCase cfnExpr

Cfn.Let _ann binds exprs →

mkLet ann binds exprs

mkLiteral ∷ Ann → Cfn.Literal CfnExp → RepM Exp

mkLiteral ann = \case

Cfn.NumericLiteral (Left i) →

pure $ LiteralInt ann i

Cfn.NumericLiteral (Right d) →

pure $ LiteralFloat ann d

Cfn.StringLiteral s →

pure $ LiteralString ann $ decodeStringEscaping s

Cfn.CharLiteral c →

pure $ LiteralChar ann c

Cfn.BooleanLiteral b →

pure $ LiteralBool ann b

Cfn.ArrayLiteral exprs →

LiteralArray ann <$> traverse makeExpr exprs

Cfn.ObjectLiteral kvs →

LiteralObject ann <$> traverse (bitraverse mkPropName makeExpr) kvs

mkConstructor

∷ Cfn.Ann

→ Ann

→ Cfn.ProperName 'Cfn.TypeName

→ Cfn.ProperName 'Cfn.ConstructorName

→ [Cfn.Ident]

→ RepM Exp

mkConstructor cfnAnn ann properTyName properCtorName fields = do

let tyName = mkTyName properTyName

contextModuleName ← gets (Cfn.moduleName . contextModule)

algTy ← algebraicTy contextModuleName tyName

pure

if isNewtype cfnAnn

then identity

else

Ctor

ann

algTy

contextModuleName

tyName

(mkCtorName properCtorName)

(identToFieldName <$> fields)

mkTyName ∷ Cfn.ProperName 'Cfn.TypeName → TyName

mkTyName = TyName . Cfn.runProperName

mkCtorName ∷ Cfn.ProperName 'Cfn.ConstructorName → CtorName

mkCtorName = CtorName . Cfn.runProperName

mkPropName ∷ PSString → RepM PropName

mkPropName str = case decodeString str of

Left err → throwContextualError $ UnicodeDecodeError err

Right decodedString → pure $ PropName decodedString

mkAccessor ∷ Ann → PSString → CfnExp → RepM Exp

mkAccessor ann prop cfnExpr = do

propName ← mkPropName prop

makeExprAnnotated ann cfnExpr <&> \expr → ObjectProp noAnn expr propName

mkObjectUpdate ∷ CfnExp → [(PSString, CfnExp)] → RepM Exp

mkObjectUpdate cfnExp props = do

expr ← makeExpr cfnExp

patch ← traverse (bitraverse mkPropName makeExpr) props

case NE.nonEmpty patch of

Nothing → throwContextualError EmptyObjectUpdate

Just ps → pure $ ObjectUpdate noAnn expr ps

mkAbstraction ∷ Ann → Cfn.Ident → CfnExp → RepM Exp

mkAbstraction ann i e = Abs ann param <$> makeExpr e

where

param ∷ Parameter Ann =

case identToText i of

"$__unused" → paramUnused

n → paramNamed (Name n)

mkApplication ∷ CfnExp → CfnExp → RepM Exp

mkApplication e1 e2 =

if isNewtype (Cfn.extractAnn e1)

then makeExpr e2

else application <$> makeExpr e1 <*> makeExpr e2

mkQualifiedIdent ∷ Cfn.Qualified Cfn.Ident → RepM (Qualified Name)

mkQualifiedIdent (Cfn.Qualified by ident) =

gets (Cfn.moduleName . contextModule) <&> \contextModuleName →

case by of

Cfn.BySourcePos _sourcePos → Local $ identToName ident

Cfn.ByModuleName modName →

if modName == contextModuleName

then Local (identToName ident)

else Imported modName (identToName ident)

mkRef ∷ Cfn.Qualified Cfn.Ident → RepM Exp

mkRef = (\n → Ref noAnn n 0) <<$>> mkQualifiedIdent

mkLet ∷ Ann → [Cfn.Bind Cfn.Ann] → CfnExp → RepM Exp

mkLet ann binds expr = do

groupings ∷ NonEmpty Binding ←

NE.nonEmpty binds

& maybe (throwContextualError LetWithoutBinds) (traverse mkBinding)

Let ann groupings <$> makeExpr expr

--------------------------------------------------------------------------------

-- Case statements are compiled to a decision trees (nested if/else's) ---------

-- The algorithm is based on this document: ------------------------------------

-- https://julesjacobs.com/notes/patternmatching/patternmatching.pdf -----------

mkCase ∷ Ann → [CfnExp] → NonEmpty (Cfn.CaseAlternative Cfn.Ann) → RepM Exp

mkCase ann cfnExpressions alternatives = do

expressions ← traverse makeExpr cfnExpressions

-- Before making clauses, we need to prepare bindings

-- such that instead of repeating the same expression multiple times,

-- we can bind it to a name once and then repeat references.

(references, bindings) ← prepareBindings expressions

clauses ← traverse (alternativeToClauses references) alternatives

let addHeader = maybe id (Let ann) (NE.nonEmpty bindings)

addHeader <$> mkCaseClauses (NE.toList clauses)

-- Either an expression to inline, or a named expression reference.

data Scrutinee = Inlinable Exp | Referrable Ann Name Exp

{- | Separate expressions into two groups:

1. Expressions that can be inlined directly.

2. Expressions that need to be referenced.

-}

prepareBindings ∷ [Exp] → RepM ([Exp], [Binding])

prepareBindings expressions = do

scrutinees ← forM expressions \e → do

let inlinable = pure (Inlinable e)

case e of

LiteralInt {} → inlinable

LiteralFloat {} → inlinable

LiteralChar {} → inlinable

LiteralBool {} → inlinable

Ref {} → inlinable

_ → do

n ← generateName "e"

pure (Referrable noAnn n e)

pure

( scrutinees <&> \case

Inlinable expr → expr

Referrable ann name _expr → Ref ann (Local name) 0

, [Standalone (ann, name, expr) | Referrable ann name expr ← scrutinees]

)

mkCaseClauses ∷ [CaseClause] → RepM Exp

mkCaseClauses = mkClauses Map.empty

where

mkClauses ∷ MatchHistory → [CaseClause] → RepM Exp

mkClauses history = \case

[] → pure $ exception "No patterns matched"

clause : restClauses → do

mkClause

history

clause

(`matchChosenByHeuristic` restClauses)

(`mkClauses` restClauses)

mkClause

∷ MatchHistory

→ CaseClause

→ (CaseClause → Maybe (Match, CaseClause))

→ (MatchHistory → RepM Exp)

→ RepM Exp

mkClause history currentClause heuristic nextClause =

case heuristic currentClause of

Nothing →

-- All matches for this clause have passed

case NE.nonEmpty (usedClauseBinds currentClause) of

Nothing → do

next ← nextClause history

pure case clauseResult currentClause of

Right result → result

Left guardedResults →

foldr (uncurry ifThenElse) next guardedResults

Just binds → do

n ← generateName "n"

next ← nextClause history

pure case clauseResult currentClause of

Right result → lets binds result

Left guardedResults →

lets (Standalone (noAnn, n, next) <| binds) $

foldr (uncurry ifThenElse) (refLocal n 0) guardedResults

Just (Match {..}, clause) →

let expr = foldr applyStep matchExp stepsToFocus

clause' =

clause

{ clauseMatches = nestedMatches <> clauseMatches clause

, clauseBindings =

(Standalone . (noAnn,,expr) <$> matchBinds)

<> clauseBindings clause

}

in case matchPat of

PatAny →

nextMatch history clause'

PatArrayLength (fromIntegral → len) →

ifThenElse (literalInt len `eq` arrayLength expr)

<$> nextMatch history clause'

<*> nextClause history

PatInteger i →

ifThenElse (literalInt i `eq` expr)

<$> nextMatch history clause'

<*> nextClause history

PatFloating d →

ifThenElse (literalFloat d `eq` expr)

<$> nextMatch history clause'

<*> nextClause history

PatString s →

ifThenElse (literalString s `eq` expr)

<$> nextMatch history clause'

<*> nextClause history

PatChar c →

ifThenElse (literalChar c `eq` expr)

<$> nextMatch history clause'

<*> nextClause history

PatBoolean b →

ifThenElse (literalBool b `eq` expr)

<$> nextMatch history clause'

<*> nextClause history

PatCtor algTy mn ty ctr → case Map.lookup expr history of

Just (ctr', True) →

if ctr' == ctr

then -- This constructor matched positively before,

-- proceed matching nested constructors.

nextMatch history clause'

else -- Other constructor matched positively before,

-- this one can't match, proceed to next clause.

nextClause history

Just (ctr', False)

| ctr' == ctr →

-- This constructor matched negatively before,

-- proceed to the next clause.

nextClause history

_ →

case algTy of

ProductType → nextMatch (history' True) clause'

SumType →

-- Either this constructor is matched for the first time,

-- or other constructor didn't pass the match before.

ifThenElse

(literalString (ctorId mn ty ctr) `eq` reflectCtor expr)

<$> nextMatch (history' True) clause'

<*> nextClause (history' False)

where

history' b = Map.insert expr (ctr, b) history

where

nextMatch hist clause = mkClause hist clause heuristic nextClause

usedClauseBinds ∷ CaseClause → [Binding]

usedClauseBinds CaseClause {clauseBindings} = clauseBindings

matchChosenByHeuristic

∷ CaseClause → [CaseClause] → Maybe (Match, CaseClause)

matchChosenByHeuristic thisClause otherClauses =

case clauseMatches thisClause of

[] → Nothing

[match] → Just (match, thisClause {clauseMatches = []})

matches →

-- select a match that is present in the maximum number of other clauses

sortOn

(Down . fst)

(toFst (countAffectedClauses otherClauses) <$> matches)

& uncons

& fmap \(match, remainingMatches) →

(snd match, thisClause {clauseMatches = snd <$> remainingMatches})

where

countAffectedClauses ∷ [CaseClause] → Match → Int

countAffectedClauses clauses Match {matchExp = expr, stepsToFocus = steps} =

foldr count 0 clauses

where

count ∷ CaseClause → Int → Int

count clause counter =

maybe counter (\_ → counter + 1) $

allClauseMatches clause & find \case

Match {matchPat = PatAny} → False

Match {matchExp, stepsToFocus}

| matchExp == expr, stepsToFocus == steps → True

_ → False

allClauseMatches ∷ CaseClause → [Match]

allClauseMatches CaseClause {clauseMatches} = go [] clauseMatches

where

go acc = \case

[] → acc

ms → ms >>= \t → go (t : acc) (nestedMatches t)

data CaseClause = CaseClause

{ clauseMatches ∷ [Match]

, clauseResult ∷ Either [(Exp, Exp)] Exp

, clauseBindings ∷ [Binding]

}

deriving stock (Show)

data Pattern

= PatAny

| PatCtor AlgebraicType ModuleName TyName CtorName

| PatInteger Integer

| PatFloating Double

| PatString Text

| PatChar Char

| PatBoolean Bool

| PatArrayLength Int

deriving stock (Eq, Show)

data Step = TakeIndex Natural | TakeProp PropName

deriving stock (Eq, Show)

applyStep ∷ Step → Exp → Exp

applyStep step expr =

case step of

TakeIndex i → arrayIndex expr i

TakeProp p → objectProp expr p

data Match = Match

{ matchExp ∷ Exp

, matchPat ∷ Pattern

, matchBinds ∷ [Name]

, stepsToFocus ∷ [Step]

, nestedMatches ∷ [Match]

}

deriving stock (Show)

mkBinder ∷ Exp → Cfn.Binder Cfn.Ann → RepM Match

mkBinder matchExp = go mempty

where

go ∷ [Step] → Cfn.Binder Cfn.Ann → RepM Match

go stepsToFocus = \case

Cfn.NullBinder _ann →

pure $ matchWhole PatAny

Cfn.VarBinder _ann name →

pure

Match

{ matchExp

, matchPat = PatAny

, stepsToFocus

, matchBinds = [identToName name]

, nestedMatches = mempty

}

Cfn.ConstructorBinder ann qTypeName qCtorName binders →

if isNewtype ann

then case binders of

[binder] → go stepsToFocus binder

_ →

throwContextualError

NewtypeCtorBinderHasUnexpectedNumberOfNestedBinders

else do

nestedMatches ←

for (zip [0 ..] binders) \(index ∷ Int, binder) →

let prop = PropName ("value" <> toText (show index))

in go (TakeProp prop : stepsToFocus) binder

let qualifiedTypeName = mkQualified mkTyName qTypeName

Context {contextModule} ← get

let contextModuleName = Cfn.moduleName contextModule

(modName, tyName, algTy) ← case qualifiedTypeName of

Imported modName tyName →

(modName,tyName,) <$> algebraicTy modName tyName

Local tyName →

(contextModuleName,tyName,)

<$> algebraicTy contextModuleName tyName

let ctrName = mkCtorName (Cfn.disqualify qCtorName)

pure

Match

{ matchExp

, matchPat = PatCtor algTy modName tyName ctrName

, stepsToFocus

, matchBinds = mempty

, nestedMatches

}

Cfn.LiteralBinder _ann literal →

case literal of

Cfn.NumericLiteral (Left i) →

pure $ matchWhole $ PatInteger i

Cfn.NumericLiteral (Right d) →

pure $ matchWhole $ PatFloating d

Cfn.StringLiteral s →

pure $ matchWhole $ PatString (decodeStringEscaping s)

Cfn.CharLiteral c →

pure $ matchWhole $ PatChar c

Cfn.BooleanLiteral b →

pure $ matchWhole $ PatBoolean b

Cfn.ArrayLiteral binders → do

nestedMatches ←

for (zip [0 ..] binders) \(index, binder) →

go (TakeIndex index : stepsToFocus) binder

pure

Match

{ matchExp

, stepsToFocus

, matchPat = PatArrayLength (length binders)

, matchBinds = mempty

, nestedMatches

}

Cfn.ObjectLiteral kvs → do

nestedMatches ←

for kvs \(prop, binder) → do

propName ← mkPropName prop

go (TakeProp propName : stepsToFocus) binder

pure

Match

{ matchExp

, matchPat = PatAny

, stepsToFocus

, matchBinds = mempty

, nestedMatches

}

Cfn.NamedBinder _ann ident binder → do

match ← go stepsToFocus binder

let bind = identToName ident

pure case matchBinds match of

[] → match {matchBinds = [bind]}

bs → match {matchBinds = bind : bs}

where

matchWhole ∷ Pattern → Match

matchWhole pat =

Match

{ matchExp

, stepsToFocus

, matchPat = pat

, matchBinds = mempty

, nestedMatches = mempty

}

type MatchHistory = Map Exp (CtorName, Bool)

alternativeToClauses

∷ [Exp] → Cfn.CaseAlternative Cfn.Ann → RepM CaseClause

alternativeToClauses

localRefs

Cfn.CaseAlternative {caseAlternativeBinders, caseAlternativeResult} = do

unless (length localRefs == length caseAlternativeBinders) do

throwContextualError $

CaseBindersNumberMismatch

(Tagged $ length localRefs)

(Tagged $ length caseAlternativeBinders)

matches ← for (zip localRefs caseAlternativeBinders) do

uncurry mkBinder

clauseResult ←

bitraverse

(traverse (bitraverse makeExpr makeExpr))

makeExpr

caseAlternativeResult

pure

CaseClause

{ clauseResult

, clauseBindings = []

, clauseMatches = matches

}

--------------------------------------------------------------------------------

-- Helper functions ------------------------------------------------------------

generateName ∷ Text → RepM Name

generateName prefix =

Name <$> do

ctx@Context {lastGeneratedNameIndex} ← get

put $ ctx {lastGeneratedNameIndex = lastGeneratedNameIndex + 1}

pure $ prefix <> toText (show lastGeneratedNameIndex)

isNewtype ∷ Cfn.Ann → Bool

isNewtype = \case

Just Cfn.IsNewtype → True

_ → False

isForeign ∷ Cfn.Ann → Bool

isForeign = \case

Just Cfn.IsForeign → True

_ → False

algebraicTy ∷ ModuleName → TyName → RepM AlgebraicType

algebraicTy modName tyName = do

Context {contextDataTypes} ← get

case Map.lookup (modName, tyName) contextDataTypes of

Just (algTy, _ctorFields) → pure algTy

Nothing → throwContextualError $ TypeNotDeclared contextDataTypes tyName

--------------------------------------------------------------------------------

-- Errors ----------------------------------------------------------------------

throwContextualError

∷ (MonadState Context m, MonadError CoreFnError m)

⇒ CoreFnErrorReason

→ m a

throwContextualError e = do

currentModule ← gets (contextModule >>> Cfn.moduleName)

throwError $ CoreFnError currentModule e

data CoreFnError = CoreFnError

{ currentModule ∷ ModuleName

, reason ∷ CoreFnErrorReason

}

instance Show CoreFnError where

show CoreFnError {currentModule, reason} =

"in module "

<> toString (moduleNameToText currentModule)

<> ": "

<> show reason

data CoreFnErrorReason

= EmptyExportList

| EmptyObjectUpdate

| NoDeclarations

| LetWithoutBinds

| EmptyCase (Cfn.Expr Cfn.Ann)

| EmptyBindingGroup

| NewtypeCtorBinderHasUnexpectedNumberOfNestedBinders

| CaseBindersNumberMismatch (Tagged "expressions" Int) (Tagged "binders" Int)

| TypeNotDeclared

(Map (ModuleName, TyName) (AlgebraicType, Map CtorName [FieldName]))

TyName

| UnicodeDecodeError UnicodeException

| AnnotationParsingError (Megaparsec.ParseErrorBundle Text Void)

| UnusedAnnotations (Map Name Annotation)

instance Show CoreFnErrorReason where

show = \case

EmptyExportList →

"Empty export list"

EmptyObjectUpdate →

"Empty object update"

NoDeclarations →

"No declarations"

LetWithoutBinds →

"Let without binds"

EmptyCase _ →

"Empty case"

EmptyBindingGroup →

"Empty binding group"

NewtypeCtorBinderHasUnexpectedNumberOfNestedBinders →

"Newtype constructor binder has unexpected number of nested binders"

CaseBindersNumberMismatch (Tagged exprs) (Tagged binders) →

"Number of expressions ("

<> show exprs

<> ") and binders ("

<> show binders

<> ") in case alternative mismatch"

TypeNotDeclared decls tyName →

"Type not declared: "

<> show tyName

<> ".\n Known types: "

<> toString (pShow decls)

UnicodeDecodeError e →

"Unicode decode error: " <> displayException e

AnnotationParsingError bundle →

"Annotation parsing error: " <> Megaparsec.errorBundlePretty bundle

UnusedAnnotations anns →

"Unused annotations: " <> toString (pShow anns)