ychr-0.1.0.0: src/YCHR/Internal/Backend/Scheme.hs
{-# LANGUAGE OverloadedStrings #-}
-- | Scheme code generation backend for CHR VM programs.
--
-- Translates a 'VMProgram' into R7RS Scheme source code that uses the
-- YCHR Scheme runtime libraries (@(ychr var)@, @(ychr store)@,
-- @(ychr history)@, @(ychr reactivation)@).
--
-- Control flow ('Return', 'Break', 'Continue') is implemented via
-- @call\/cc@ escape continuations. Internal names use a @%@ prefix
-- to avoid collisions with user-defined identifiers.
module YCHR.Internal.Backend.Scheme
( generateScheme,
compileSymbol,
isValidSchemeIdentifier,
qualifiedAliasIdentifier,
)
where
import Data.Char (isAlpha, isAlphaNum, ord)
import Data.Map.Strict qualified as Map
import Data.Maybe (maybeToList)
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text qualified as T
import Numeric (showHex)
import YCHR.Internal.Compile (tellProcName)
import YCHR.Internal.Compile.Names (encodeIdentifier, isIdInitialSafe)
import YCHR.Internal.SExpr (SExpr (..), printSExpr)
import YCHR.Internal.Types qualified as Types
import YCHR.Internal.VM.SExpr (VMProgram (..))
import YCHR.Internal.VM.Types
-- ---------------------------------------------------------------------------
-- Public API
-- ---------------------------------------------------------------------------
-- | Generate Scheme source code from a VM program, wrapped in an R6RS
-- @(library ...)@ form.
--
-- The library name components are given as a list of 'Text' values,
-- e.g. @["ychr", "generated", "order"]@ produces @(ychr generated order)@.
-- A program-info binding named after the last segment is exported
-- (see 'programInfoBindingName'); it is a zero-argument thunk that
-- creates and returns a fresh session.
--
-- For every exported constraint with a generated @tell_*@, two
-- user-facing identifiers may be exported:
--
-- * Qualified: @MOD:NAME\/ARITY@ — always emitted when the resulting
-- string is a valid Scheme identifier.
-- * Short: @NAME\/ARITY@ — emitted only when the short form is unique
-- across all exported constraints in this library, and valid as an
-- identifier.
--
-- The mangled @tell_MOD__NAME_ARITY@ procedures remain defined inside
-- the library (the aliases are bound to them) but are not exported.
generateScheme :: [Text] -> VMProgram -> Text
generateScheme libName vmp =
let procs = vmp.program.procedures
infoName = programInfoBindingName libName
aliases = collectAliases vmp
in T.unlines $
[ ";; Generated by YCHR",
"(library " <> renderSExpr (SList (map SAtom libName)),
" " <> renderSExpr (exportClause infoName vmp aliases),
" " <> renderSExpr importClause,
""
]
++ map renderSExpr (concatMap compileProcedure procs)
++ map renderSExpr (aliasDefines aliases)
++ [renderSExpr (programInfoSExpr infoName vmp)]
++ [") ;; end library"]
-- ---------------------------------------------------------------------------
-- Library wrapper
-- ---------------------------------------------------------------------------
-- | Build the @(export ...)@ clause. Exports the friendly tell-procedure
-- aliases, all @func_*@ procedures (so drivers can evaluate function
-- calls in goal-argument position — see 'YCHR.Internal.Desugared.BodyTell'),
-- and the program-info binding.
exportClause :: Text -> VMProgram -> [AliasEntry] -> SExpr
exportClause infoName vmp aliases =
let procNames = Set.fromList [n.unName | p <- vmp.program.procedures, let n = p.name]
aliasNames = concatMap aliasEntryExports aliases
funcNames =
[ n | n <- Set.toList procNames, "func_" `T.isPrefixOf` n
]
in SList
( SAtom "export"
: SAtom infoName
: map SAtom (aliasNames ++ funcNames)
)
-- | Import clause for the runtime.
importClause :: SExpr
importClause =
SList
[ SAtom "import",
SList [SAtom "rnrs"],
SList [SAtom "ychr", SAtom "runtime"]
]
-- ---------------------------------------------------------------------------
-- Tell-procedure aliases
-- ---------------------------------------------------------------------------
-- | One row per exported constraint with a generated @tell_*@. Records
-- the friendly identifiers that should bind to the underlying mangled
-- procedure. The qualified alias is always emitted; the short alias is
-- 'Nothing' when another exported constraint shares the same encoded
-- short name (intra-library collision).
data AliasEntry = AliasEntry
{ aliasQualified :: Text,
aliasShort :: Maybe Text,
aliasTarget :: Text
}
aliasEntryExports :: AliasEntry -> [Text]
aliasEntryExports (AliasEntry q s _) = q : maybeToList s
-- | Render the qualified alias identifier (@mod:name/arity@) for a
-- constraint. The function is total: any input is encoded into a
-- well-formed identifier via 'encodeIdentifier' (plus an
-- initial-character guard via 'encodeAliasComponent' for the leading
-- module segment).
--
-- Shared with 'YCHR.Internal.Backend.SchemeDriver' so the driver script always
-- targets the same identifier the generated library exports.
qualifiedAliasIdentifier :: Types.Name -> Int -> Text
qualifiedAliasIdentifier name arity = case name of
Types.Qualified m n ->
encodeAliasComponent m
<> ":"
<> encodeIdentifier n
<> "/"
<> T.pack (show arity)
Types.Unqualified n -> shortAliasName n arity
-- | Render the short alias identifier (@name/arity@).
-- 'encodeAliasComponent' ensures the first character is a valid
-- identifier @<initial>@; the rest of the name uses
-- 'encodeIdentifier'.
shortAliasName :: Text -> Int -> Text
shortAliasName n a = encodeAliasComponent n <> "/" <> T.pack (show a)
-- | Like 'encodeIdentifier', but additionally escapes the first
-- character when it isn't a valid identifier @<initial>@ — digits
-- pass 'encodeIdentifier' (they're valid /subsequent/ chars) but are
-- illegal as the first character of an identifier. Used by the alias
-- builders, where the encoded component sits at the start of the
-- identifier; not needed by 'procNameFor', whose @tell_@ prefix
-- already supplies a safe initial.
encodeAliasComponent :: Text -> Text
encodeAliasComponent t = case T.uncons t of
Nothing -> T.empty
Just (c, rest)
| isIdInitialSafe c -> T.singleton c <> encodeIdentifier rest
| otherwise ->
"__u" <> T.pack (showHex (ord c) "") <> "__" <> encodeIdentifier rest
-- | Walk the program's exported tell procedures and compute the alias
-- table. Short-name uniqueness is determined within this library only;
-- cross-library collisions are left for the importing R6RS runtime to
-- surface via @(rename ...)@ / @(only ...)@ import sub-forms.
collectAliases :: VMProgram -> [AliasEntry]
collectAliases vmp =
let procNames = Set.fromList [n.unName | p <- vmp.program.procedures, let n = p.name]
tells =
[ (m, n, a, mangleName tn)
| Types.QualifiedIdentifier m n a <- Set.toList vmp.exportedSet,
let tn = tellProcName (Types.Qualified m n) a,
Set.member tn.unName procNames
]
shortCounts =
Map.fromListWith (+) [(shortAliasName n a, 1 :: Int) | (_, n, a, _) <- tells]
in [ AliasEntry
{ aliasQualified = qualifiedAliasIdentifier (Types.Qualified m n) a,
aliasShort =
let s = shortAliasName n a
in if Map.findWithDefault 0 s shortCounts == 1
then Just s
else Nothing,
aliasTarget = target
}
| (m, n, a, target) <- tells
]
-- | Emit the @(define ALIAS tell_*)@ forms paired with each alias.
aliasDefines :: [AliasEntry] -> [SExpr]
aliasDefines entries =
[ SList [SAtom "define", SAtom name, SAtom entry.aliasTarget]
| entry <- entries,
name <- aliasEntryExports entry
]
-- ---------------------------------------------------------------------------
-- Program-info binding
-- ---------------------------------------------------------------------------
-- | Identifier under which the per-program info is exported. Equals the
-- library's final segment, so a library compiled with @-n fib@ (giving
-- @(ychr generated fib)@) exports a binding named @fib@. Users then
-- call @(open-session fib)@ after importing @(ychr generated fib)@.
--
-- Callers must pass a non-empty 'libName'; the CLI always synthesizes
-- @["ychr","generated",NAME]@. The @NAME@ component is validated as a
-- Scheme identifier upstream (see 'isValidSchemeIdentifier' in
-- 'YCHR.Internal.Backend.Scheme', applied by @app/Main.hs@'s @runCompile@).
programInfoBindingName :: [Text] -> Text
programInfoBindingName libName = case reverse libName of
(x : _) -> x
[] -> error "programInfoBindingName: empty library name"
-- | Build the program-info binding: a zero-argument thunk that
-- allocates a fresh runtime session. The session's deep-eval
-- dispatch table is populated immediately so @is@ can reach every
-- user-defined function in the library.
--
-- > (define (NAME)
-- > (let ((%s (%make-session N)))
-- > (register-evaluable! %s 'functor1 arity1 proc1)
-- > ...
-- > %s))
--
-- @(open-session NAME)@ in the REPL library simply invokes this thunk;
-- the dispatcher-style @(NAME 'init)@ / @(NAME 'tells)@ protocol is
-- gone since tell procedures are now reached statically through the
-- exported alias identifiers.
programInfoSExpr :: Text -> VMProgram -> SExpr
programInfoSExpr infoName vmp =
let bindings =
[ SList
[ SAtom "%s",
SList [SAtom "%make-session", SInt (fromIntegral vmp.program.numTypes)]
]
]
registrations = map evaluableRegistration vmp.program.evaluables
-- The let body is the session itself, returned to the caller.
letBody = SAtom "%s"
in SList
[ SAtom "define",
SList [SAtom infoName],
SList ([SAtom "let", SList bindings] ++ registrations ++ [letBody])
]
-- | Emit @(register-evaluable! %s 'functor arity procedure)@ for a
-- single entry of the program's evaluables table. The procedure
-- identifier is the same mangled name bound by 'compileProcedure', so
-- direct identifier reference resolves it in the library's scope.
evaluableRegistration :: (EvaluableKey, Name) -> SExpr
evaluableRegistration (key, procName) =
SList
[ SAtom "register-evaluable!",
SAtom "%s",
compileSymbol key.functor.unName,
SInt (fromIntegral key.arity),
SAtom procName.unName
]
-- ---------------------------------------------------------------------------
-- Rendering
-- ---------------------------------------------------------------------------
renderSExpr :: SExpr -> Text
renderSExpr = printSExpr
-- ---------------------------------------------------------------------------
-- Procedure compilation
-- ---------------------------------------------------------------------------
compileProcedure :: Procedure -> [SExpr]
compileProcedure proc =
[ SList
( SAtom "define"
: SList
( SAtom (mangleName proc.name)
: SAtom "%s"
: map
(SAtom . mangleName)
proc.params
)
: [wrapReturn (compileStmts proc.body)]
)
]
-- | Wrap a procedure body in a call/cc for %return.
wrapReturn :: SExpr -> SExpr
wrapReturn body =
SList
[ SAtom "call/cc",
SList [SAtom "lambda", SList [SAtom "%return"], body, SAtom "#f"]
]
-- ---------------------------------------------------------------------------
-- Statement compilation
-- ---------------------------------------------------------------------------
-- | Compile a list of statements into a single SExpr.
-- Let statements thread as nested let bindings wrapping the rest.
compileStmts :: [Stmt] -> SExpr
compileStmts [] = SAtom "#f"
compileStmts [s] = compileStmtTail s []
compileStmts (s : rest) = compileStmtTail s rest
-- | Compile a statement with its continuation (remaining statements).
-- Let creates a nested let wrapping the rest; other statements emit
-- themselves followed by the rest in a begin.
compileStmtTail :: Stmt -> [Stmt] -> SExpr
compileStmtTail (LetVal n e) rest =
SList
[ SAtom "let",
SList [SList [SAtom (mangleName n), compileValExpr e]],
compileStmts rest
]
compileStmtTail (LetId n e) rest =
SList
[ SAtom "let",
SList [SList [SAtom (mangleName n), compileIdExpr e]],
compileStmts rest
]
compileStmtTail s [] = compileStmt s
compileStmtTail s rest =
SList (SAtom "begin" : compileStmt s : [compileStmts rest])
-- | Compile a single statement (no continuation context).
compileStmt :: Stmt -> SExpr
compileStmt (LetVal n e) =
SList [SAtom "let", SList [SList [SAtom (mangleName n), compileValExpr e]], SAtom "#f"]
compileStmt (LetId n e) =
SList [SAtom "let", SList [SList [SAtom (mangleName n), compileIdExpr e]], SAtom "#f"]
compileStmt (AssignVal n e) =
SList [SAtom "set!", SAtom (mangleName n), compileValExpr e]
compileStmt (AssignId n e) =
SList [SAtom "set!", SAtom (mangleName n), compileIdExpr e]
compileStmt (If cond thenBranch elseBranch) =
SList
[ SAtom "if",
compileBoolExpr cond,
compileBody thenBranch,
compileBody elseBranch
]
compileStmt (Foreach lbl (ConstraintType ct) sv conds body) =
compileForeach lbl ct sv conds body
compileStmt (Continue (Label lbl)) =
SList [SAtom (continueName lbl), SAtom "#f"]
compileStmt (Break (Label lbl)) =
SList [SAtom (breakName lbl), SAtom "#f"]
compileStmt (Return e) =
SList [SAtom "%return", compileValExpr e]
compileStmt (ExprStmt e) =
compileValExpr e
compileStmt (BoolExprStmt e) =
compileBoolExpr e
compileStmt (Store e) =
SList [SAtom "store-constraint", SAtom "%s", compileIdExpr e]
compileStmt (Kill e) =
SList [SAtom "kill-constraint", compileIdExpr e]
compileStmt (AddHistory (RuleId rid) es) =
SList
[ SAtom "add-history!",
SAtom "%s",
SInt (fromIntegral rid),
SList
( SAtom "list"
: map (\e -> SList [SAtom "constraint-id", compileIdExpr e]) es
)
]
compileStmt (PushFrame _) =
SList [SAtom "values"]
compileStmt (DrainReactivationQueue (Name sv) body) =
SList
[ SAtom "drain-queue!",
SAtom "%s",
SList
[ SAtom "lambda",
SList [SAtom sv],
SList
[ SAtom "when",
SList [SAtom "alive-constraint?", SAtom sv],
compileBody body
]
]
]
-- | Compile a statement list as a body (begin-wrapped if multiple).
compileBody :: [Stmt] -> SExpr
compileBody [] = SAtom "#f"
compileBody [s] = compileStmt s
compileBody stmts = compileStmts stmts
-- ---------------------------------------------------------------------------
-- Foreach compilation
-- ---------------------------------------------------------------------------
compileForeach :: Label -> Int -> Name -> [(ArgIndex, ValExpr)] -> [Stmt] -> SExpr
compileForeach (Label lbl) ct (Name sv) conds body =
SList
[ SAtom "call/cc",
SList
[ SAtom "lambda",
SList [SAtom (breakName lbl)],
SList
[ SAtom "let-values",
SList
[ SList
[ SList [SAtom "%vec", SAtom "%count"],
SList [SAtom "store-snapshot", SAtom "%s", SInt (fromIntegral ct)]
]
],
SList
[ SAtom "let",
SAtom (foreachName lbl),
SList [SList [SAtom "%i", SInt 0]],
SList
[ SAtom "when",
SList [SAtom "<", SAtom "%i", SAtom "%count"],
SList
[ SAtom "let",
SList
[ SList
[ SAtom sv,
SList
[ SAtom "vector-ref",
SAtom "%vec",
SAtom "%i"
]
]
],
foreachInner lbl sv conds body
],
SList [SAtom (foreachName lbl), SList [SAtom "+", SAtom "%i", SInt 1]]
]
]
]
]
]
foreachInner :: Text -> Text -> [(ArgIndex, ValExpr)] -> [Stmt] -> SExpr
foreachInner lbl sv conds body =
let aliveCheck = SList [SAtom "suspension-alive?", SAtom sv]
condChecks = map compileCondition conds
allChecks = aliveCheck : condChecks
guard = case allChecks of
[c] -> c
cs -> SList (SAtom "and" : cs)
innerBody =
SList
[ SAtom "call/cc",
SList
[ SAtom "lambda",
SList [SAtom (continueName lbl)],
compileBody body
]
]
in SList [SAtom "when", guard, innerBody]
where
compileCondition (ArgIndex i, e) =
SList
[ SAtom "equal?/chr",
SList [SAtom "constraint-arg", SAtom sv, SInt (fromIntegral i)],
compileValExpr e
]
-- ---------------------------------------------------------------------------
-- Expression compilation
-- ---------------------------------------------------------------------------
compileValExpr :: ValExpr -> SExpr
compileValExpr (Var n) = SAtom (mangleName n)
compileValExpr (Lit l) = compileLiteral l
compileValExpr (CallExpr n args) =
SList (SAtom (mangleName n) : SAtom "%s" : map compileCallArg args)
compileValExpr (HostCall n args) =
compileHostCall n args
compileValExpr (EvalDeep e) =
compileEvalDeep e
compileValExpr (EvalIs e) =
-- @is@-with-variable-RHS marker. The inner expression is always a
-- 'Var' (the compiler only emits this form for that case): we
-- evaluate it with deep-deref and then walk the dereferenced value
-- through 'deep-eval-value' so a bound compound whose functor is a
-- declared evaluable gets actually evaluated. Mirrors
-- 'evalValExpr (EvalIs _)' in the Haskell interpreter.
SList
[ SAtom "deep-eval-value",
SAtom "%s",
compileEvalDeep e
]
compileValExpr NewVar =
SList [SAtom "make-var", SAtom "%s"]
compileValExpr (MakeTerm (Name f) args) =
SList
[ SAtom "make-term",
compileSymbol f,
SList (SAtom "vector" : map compileValExpr args)
]
compileValExpr (GetArg e i) =
SList [SAtom "get-arg", compileValExpr e, SInt (fromIntegral i)]
compileValExpr (FieldArg e (ArgIndex i)) =
SList [SAtom "constraint-arg", compileIdExpr e, SInt (fromIntegral i)]
compileValExpr (FieldType e) =
SList [SAtom "constraint-type", compileIdExpr e]
-- | Compile a 'BoolExpr' to a Scheme boolean expression. Scheme is
-- dynamically typed, so 'BFromVal' is identical to compiling the
-- wrapped 'ValExpr' — the runtime accepts whatever truthy value the
-- underlying value produces.
compileBoolExpr :: BoolExpr -> SExpr
compileBoolExpr (BLit True) = SAtom "#t"
compileBoolExpr (BLit False) = SAtom "#f"
compileBoolExpr (BNot e) = SList [SAtom "not", compileBoolExpr e]
compileBoolExpr (BAnd a b) = SList [SAtom "and", compileBoolExpr a, compileBoolExpr b]
compileBoolExpr (BOr a b) = SList [SAtom "or", compileBoolExpr a, compileBoolExpr b]
compileBoolExpr (BMatchTerm e (Name f) arity) =
SList [SAtom "match-term", compileValExpr e, compileSymbol f, SInt (fromIntegral arity)]
compileBoolExpr (BEqual a b) =
SList [SAtom "equal?/chr", compileValExpr a, compileValExpr b]
compileBoolExpr (BIdEqual a b) =
SList [SAtom "id-equal?", compileIdExpr a, compileIdExpr b]
compileBoolExpr (BAlive e) =
SList [SAtom "alive-constraint?", compileIdExpr e]
compileBoolExpr (BIsConstraintType e (ConstraintType ct)) =
SList [SAtom "is-constraint-type?", compileIdExpr e, SInt (fromIntegral ct)]
compileBoolExpr (BNotInHistory (RuleId rid) es) =
SList
[ SAtom "not-in-history?",
SAtom "%s",
SInt (fromIntegral rid),
SList
( SAtom "list"
: map (\e -> SList [SAtom "constraint-id", compileIdExpr e]) es
)
]
compileBoolExpr (BUnify a b) =
SList [SAtom "%unify", SAtom "%s", compileValExpr a, compileValExpr b]
compileBoolExpr (BFromVal e) = compileValExpr e
compileBoolExpr (BEvalDeep e) = compileBoolEvalDeep e
compileIdExpr :: IdExpr -> SExpr
compileIdExpr (IdVar n) = SAtom (mangleName n)
compileIdExpr (CreateConstraint (ConstraintType ct) args) =
SList
[ SAtom "create-constraint",
SAtom "%s",
SInt (fromIntegral ct),
SList (SAtom "vector" : map compileValExpr args)
]
compileCallArg :: CallArg -> SExpr
compileCallArg (AVal e) = compileValExpr e
compileCallArg (AId e) = compileIdExpr e
-- ---------------------------------------------------------------------------
-- Literal compilation
-- ---------------------------------------------------------------------------
compileLiteral :: Literal -> SExpr
compileLiteral (IntLit n) = SInt n
compileLiteral (FloatLit n) = SFloat n
compileLiteral (AtomLit s) = compileSymbol s
compileLiteral (TextLit s) = SString s
compileLiteral (BoolLit True) = SAtom "#t"
compileLiteral (BoolLit False) = SAtom "#f"
compileLiteral WildcardLit = SAtom "*wildcard*"
-- | Compile a text to a Scheme symbol expression.
-- Uses @(quote sym)@ for valid identifiers, @(string->symbol "...")@ otherwise.
compileSymbol :: Text -> SExpr
compileSymbol s
| isValidSchemeIdentifier s = SList [SAtom "quote", SAtom s]
| otherwise = SList [SAtom "string->symbol", SString s]
-- ---------------------------------------------------------------------------
-- Host calls
-- ---------------------------------------------------------------------------
-- | Known host call name mapping.
hostCallMap :: Map.Map Text Text
hostCallMap =
Map.fromList
[ ("div", "%idiv"),
("mod", "%imod"),
("rem", "%irem"),
("=<", "<="),
("==", "equal?/chr"),
-- Must map: bare 'not' would bind to R6RS 'not', which treats every
-- non-#f value as true and so disagrees with the Haskell runtime on
-- untyped arguments. '%not' rejects non-booleans.
("not", "%not"),
("float", "flonum?"),
("int_to_float", "%int-to-float"),
("float_to_int", "%float-to-int"),
("write", "display"),
("writeln", "%writeln"),
("print", "%print"),
("string_concat", "string-append"),
("string_length", "string-length"),
("string_upper", "string-upcase"),
("string_lower", "string-downcase"),
("__chr_error", "%chr-error"),
("integer", "integer?"),
("atom", "symbol?"),
("boolean", "boolean?"),
("string", "string?"),
("var", "var?"),
("nonvar", "%nonvar?"),
("unifiable", "%unifiable?"),
("ground", "%ground?"),
("term_variables", "%term-variables"),
("compound_to_list", "%compound-to-list"),
("list_to_compound", "%list-to-compound"),
("read_term_from_string", "%read-term-from-string"),
("copy_term", "%copy-term")
]
-- | Host calls that need the session threaded as their first argument.
sessionHostCalls :: Set.Set Text
sessionHostCalls = Set.fromList ["copy_term"]
-- | Compile a host call. Arguments are dereferenced before calling.
-- Calls listed in 'sessionHostCalls' get the session @%s@ threaded as
-- their first argument (before the user-visible arguments).
compileHostCall :: Name -> [ValExpr] -> SExpr
compileHostCall = compileHostCallWith compileValExpr
-- | Worker for 'compileHostCall' parameterized by how arguments are
-- compiled. 'compileEvalDeep' reuses this with itself as the inner
-- compiler so deep-deref propagates into host-call arguments.
--
-- Names in 'hostCallMap' are rewritten to the corresponding runtime
-- procedure (e.g. @rem@ → @%irem@). Names not in the map are emitted
-- verbatim and resolve to whatever procedure is in scope in the
-- generated library's import environment — the YCHR runtime, R6RS
-- builtins, or anything the user has wired in. Guile R6RS resolves
-- top-level identifiers lazily at call time, so an unknown host name
-- only errors if it is actually invoked at runtime.
compileHostCallWith :: (ValExpr -> SExpr) -> Name -> [ValExpr] -> SExpr
compileHostCallWith compile (Name n) args =
let fn = Map.findWithDefault n n hostCallMap
derefedArgs = map (\a -> SList [SAtom "deref", compile a]) args
allArgs
| Set.member n sessionHostCalls = SAtom "%s" : derefedArgs
| otherwise = derefedArgs
in SList (SAtom fn : allArgs)
-- | Compile an EvalDeep expression. Like the standard expression
-- compiler, but Var references are dereferenced (following binding
-- chains) and the transformation propagates recursively into
-- sub-expressions ('call-expr' arguments, 'make-term' arguments,
-- 'host-call' arguments).
compileEvalDeep :: ValExpr -> SExpr
compileEvalDeep (Lit l) = compileLiteral l
compileEvalDeep (Var n) = SList [SAtom "deref", SAtom (mangleName n)]
compileEvalDeep (HostCall n args) = compileHostCallWith compileEvalDeep n args
compileEvalDeep (CallExpr n args) =
SList (SAtom (mangleName n) : SAtom "%s" : map compileCallArgDeep args)
compileEvalDeep (MakeTerm (Name f) args) =
SList
[ SAtom "make-term",
compileSymbol f,
SList (SAtom "vector" : map compileEvalDeep args)
]
compileEvalDeep e = compileValExpr e -- GetArg, FieldArg, FieldType, NewVar
compileCallArgDeep :: CallArg -> SExpr
compileCallArgDeep (AVal e) = compileEvalDeep e
compileCallArgDeep (AId e) = compileIdExpr e
-- | Like 'compileBoolExpr', but propagates deep-deref into 'ValExpr'
-- and 'IdExpr' payloads. Mirrors 'compileEvalDeep' for booleans.
compileBoolEvalDeep :: BoolExpr -> SExpr
compileBoolEvalDeep (BNot e) = SList [SAtom "not", compileBoolEvalDeep e]
compileBoolEvalDeep (BAnd a b) =
SList [SAtom "and", compileBoolEvalDeep a, compileBoolEvalDeep b]
compileBoolEvalDeep (BOr a b) =
SList [SAtom "or", compileBoolEvalDeep a, compileBoolEvalDeep b]
compileBoolEvalDeep (BMatchTerm e (Name f) arity) =
SList [SAtom "match-term", compileEvalDeep e, compileSymbol f, SInt (fromIntegral arity)]
compileBoolEvalDeep (BEqual a b) =
SList [SAtom "equal?/chr", compileEvalDeep a, compileEvalDeep b]
compileBoolEvalDeep (BUnify a b) =
SList [SAtom "%unify", SAtom "%s", compileEvalDeep a, compileEvalDeep b]
compileBoolEvalDeep (BFromVal e) = compileEvalDeep e
compileBoolEvalDeep (BEvalDeep e) = compileBoolEvalDeep e
compileBoolEvalDeep e = compileBoolExpr e
-- ---------------------------------------------------------------------------
-- Name mangling
-- ---------------------------------------------------------------------------
mangleName :: Name -> Text
mangleName (Name n) = n
-- | Continuation name for a foreach break.
breakName :: Text -> Text
breakName lbl = "%break-" <> lbl
-- | Continuation name for a foreach continue.
continueName :: Text -> Text
continueName lbl = "%continue-" <> lbl
-- | Named let for foreach loop.
foreachName :: Text -> Text
foreachName lbl = "%foreach-" <> lbl
-- | Check whether a text is a valid R7RS Scheme identifier.
-- Conservative: allows alphanumeric, underscore, hyphen, and common
-- Scheme "extended" identifier characters.
isValidSchemeIdentifier :: Text -> Bool
isValidSchemeIdentifier t = case T.uncons t of
Nothing -> False
Just (c, rest) ->
isSchemeInitial c && T.all isSchemeSubsequent rest
where
isSchemeInitial c = isAlpha c || c `elem` ("!$%&*/:<=>?^_~" :: [Char])
isSchemeSubsequent c = isSchemeInitial c || isAlphaNum c || c `elem` ("+-.@" :: [Char])