-- SPDX-License-Identifier: MPL-2.0

{- | A pure, bounded real expression language shared with "HMath.Symbolic".

Grammar: @let name = expression in expression@; left-associative @+ - * /@;
right-associative @^@; unary @+ -@ binds below powers (@-2^2 = -(2^2)@).
Calls use commas; literals are integers, exact decimal/scientific notation, or
@numerator//denominator@. Constants are @pi@, @e@ and @tau@. Identifiers contain
letters, digits and underscores and start with a letter or underscore.

Values select exact Rational or finite Double arithmetic. Exact mode rejects
transcendental functions and irrational square roots rather than rounding them.
There is no IO, reflection, dynamically supplied Haskell function or code execution.
The registry maps allowed names to a closed set of builtins. Let is strict and
lexically scoped. Expression identity ignores source locations, otherwise it is
structural; algebraic equality is a separate symbolic operation.

Limits cover input characters, AST/payload units, recursion, arithmetic steps and
integer bits. They are conservative work/allocation limits, not operating-system
byte or wall-clock quotas. Intermediate rational sizes are checked before large
arithmetic. Compilation/CSE and cache insertion use the same bounded validator.
Compiler traversal and evaluation have separate fresh budgets; cache hits still
revalidate limits, registry and bindings when evaluated. Only trusted callers
should construct an AST directly; validation rejects malformed names and shapes.
-}
module HMath.Expression (
    SourcePos (..),
    unknownPosition,
    Expr (..),
    ExprNode (..),
    UnaryOp (..),
    BinaryOp (..),
    NamedConstant (..),
    literal,
    variable,
    constant,
    unary,
    binary,
    call,
    letIn,
    Limits (..),
    defaultLimits,
    ExprError (..),
    ErrorKind (..),
    validateLimits,
    validateExpression,
    parseExpression,
    prettyExpression,
    freeVariables,
    Precision (..),
    Value (..),
    Bindings,
    Builtin (..),
    Registry,
    defaultRegistry,
    emptyRegistry,
    registerFunction,
    allowedFunctions,
    typeCheckExpression,
    evaluateExpression,
    evaluateText,
    Compiled,
    compileExpression,
    compiledNodeCount,
    evaluateCompiled,
    optimizeExpression,
    ExpressionCache,
    emptyExpressionCache,
    cachedExpression,
    cacheSize,
    formatScientific,
    formatRadix,
    serializeExpression,
    deserializeExpression,
    expressionHash,
) where

import Control.Monad (foldM)
import Data.Bits (xor)
import Data.Char (isAlpha, isAlphaNum, isDigit, isSpace, ord)
import Data.List (intercalate)
import qualified Data.Map.Strict as Map
import Data.Ratio (denominator, numerator, (%))
import qualified Data.Set as Set
import Data.Word (Word64)
import Numeric (showEFloat, showIntAtBase)

-- | Zero-based offset and one-based line/column. Generated expressions use 0/0/0.
data SourcePos = SourcePos
    { SourcePos -> Int
sourceOffset :: Int
    -- ^ Zero-based source character offset; generated nodes use zero.
    , SourcePos -> Int
sourceLine :: Int
    -- ^ One-based source line, or zero for generated unknown positions.
    , SourcePos -> Int
sourceColumn :: Int
    -- ^ One-based source column, or zero for generated unknown positions.
    }
    deriving (SourcePos -> SourcePos -> Bool
(SourcePos -> SourcePos -> Bool)
-> (SourcePos -> SourcePos -> Bool) -> Eq SourcePos
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SourcePos -> SourcePos -> Bool
== :: SourcePos -> SourcePos -> Bool
$c/= :: SourcePos -> SourcePos -> Bool
/= :: SourcePos -> SourcePos -> Bool
Eq, Eq SourcePos
Eq SourcePos =>
(SourcePos -> SourcePos -> Ordering)
-> (SourcePos -> SourcePos -> Bool)
-> (SourcePos -> SourcePos -> Bool)
-> (SourcePos -> SourcePos -> Bool)
-> (SourcePos -> SourcePos -> Bool)
-> (SourcePos -> SourcePos -> SourcePos)
-> (SourcePos -> SourcePos -> SourcePos)
-> Ord SourcePos
SourcePos -> SourcePos -> Bool
SourcePos -> SourcePos -> Ordering
SourcePos -> SourcePos -> SourcePos
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SourcePos -> SourcePos -> Ordering
compare :: SourcePos -> SourcePos -> Ordering
$c< :: SourcePos -> SourcePos -> Bool
< :: SourcePos -> SourcePos -> Bool
$c<= :: SourcePos -> SourcePos -> Bool
<= :: SourcePos -> SourcePos -> Bool
$c> :: SourcePos -> SourcePos -> Bool
> :: SourcePos -> SourcePos -> Bool
$c>= :: SourcePos -> SourcePos -> Bool
>= :: SourcePos -> SourcePos -> Bool
$cmax :: SourcePos -> SourcePos -> SourcePos
max :: SourcePos -> SourcePos -> SourcePos
$cmin :: SourcePos -> SourcePos -> SourcePos
min :: SourcePos -> SourcePos -> SourcePos
Ord, Int -> SourcePos -> ShowS
[SourcePos] -> ShowS
SourcePos -> String
(Int -> SourcePos -> ShowS)
-> (SourcePos -> String)
-> ([SourcePos] -> ShowS)
-> Show SourcePos
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SourcePos -> ShowS
showsPrec :: Int -> SourcePos -> ShowS
$cshow :: SourcePos -> String
show :: SourcePos -> String
$cshowList :: [SourcePos] -> ShowS
showList :: [SourcePos] -> ShowS
Show)

{- | Source position sentinel (offset,line,column)=(0,0,0), used by programmatically
constructed nodes rather than parsed source positions.
-}
unknownPosition :: SourcePos
unknownPosition :: SourcePos
unknownPosition = Int -> Int -> Int -> SourcePos
SourcePos Int
0 Int
0 Int
0

-- | Unary expression operator; Negate changes the operand sign.
data UnaryOp = Negate deriving (UnaryOp -> UnaryOp -> Bool
(UnaryOp -> UnaryOp -> Bool)
-> (UnaryOp -> UnaryOp -> Bool) -> Eq UnaryOp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UnaryOp -> UnaryOp -> Bool
== :: UnaryOp -> UnaryOp -> Bool
$c/= :: UnaryOp -> UnaryOp -> Bool
/= :: UnaryOp -> UnaryOp -> Bool
Eq, Eq UnaryOp
Eq UnaryOp =>
(UnaryOp -> UnaryOp -> Ordering)
-> (UnaryOp -> UnaryOp -> Bool)
-> (UnaryOp -> UnaryOp -> Bool)
-> (UnaryOp -> UnaryOp -> Bool)
-> (UnaryOp -> UnaryOp -> Bool)
-> (UnaryOp -> UnaryOp -> UnaryOp)
-> (UnaryOp -> UnaryOp -> UnaryOp)
-> Ord UnaryOp
UnaryOp -> UnaryOp -> Bool
UnaryOp -> UnaryOp -> Ordering
UnaryOp -> UnaryOp -> UnaryOp
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: UnaryOp -> UnaryOp -> Ordering
compare :: UnaryOp -> UnaryOp -> Ordering
$c< :: UnaryOp -> UnaryOp -> Bool
< :: UnaryOp -> UnaryOp -> Bool
$c<= :: UnaryOp -> UnaryOp -> Bool
<= :: UnaryOp -> UnaryOp -> Bool
$c> :: UnaryOp -> UnaryOp -> Bool
> :: UnaryOp -> UnaryOp -> Bool
$c>= :: UnaryOp -> UnaryOp -> Bool
>= :: UnaryOp -> UnaryOp -> Bool
$cmax :: UnaryOp -> UnaryOp -> UnaryOp
max :: UnaryOp -> UnaryOp -> UnaryOp
$cmin :: UnaryOp -> UnaryOp -> UnaryOp
min :: UnaryOp -> UnaryOp -> UnaryOp
Ord, Int -> UnaryOp -> ShowS
[UnaryOp] -> ShowS
UnaryOp -> String
(Int -> UnaryOp -> ShowS)
-> (UnaryOp -> String) -> ([UnaryOp] -> ShowS) -> Show UnaryOp
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UnaryOp -> ShowS
showsPrec :: Int -> UnaryOp -> ShowS
$cshow :: UnaryOp -> String
show :: UnaryOp -> String
$cshowList :: [UnaryOp] -> ShowS
showList :: [UnaryOp] -> ShowS
Show)

{- | Arithmetic expression operator: addition,subtraction,multiplication,division,or
exponentiation. Evaluation enforces the selected numeric/domain limits.
-}
data BinaryOp = Add | Subtract | Multiply | Divide | Power deriving (BinaryOp -> BinaryOp -> Bool
(BinaryOp -> BinaryOp -> Bool)
-> (BinaryOp -> BinaryOp -> Bool) -> Eq BinaryOp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BinaryOp -> BinaryOp -> Bool
== :: BinaryOp -> BinaryOp -> Bool
$c/= :: BinaryOp -> BinaryOp -> Bool
/= :: BinaryOp -> BinaryOp -> Bool
Eq, Eq BinaryOp
Eq BinaryOp =>
(BinaryOp -> BinaryOp -> Ordering)
-> (BinaryOp -> BinaryOp -> Bool)
-> (BinaryOp -> BinaryOp -> Bool)
-> (BinaryOp -> BinaryOp -> Bool)
-> (BinaryOp -> BinaryOp -> Bool)
-> (BinaryOp -> BinaryOp -> BinaryOp)
-> (BinaryOp -> BinaryOp -> BinaryOp)
-> Ord BinaryOp
BinaryOp -> BinaryOp -> Bool
BinaryOp -> BinaryOp -> Ordering
BinaryOp -> BinaryOp -> BinaryOp
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: BinaryOp -> BinaryOp -> Ordering
compare :: BinaryOp -> BinaryOp -> Ordering
$c< :: BinaryOp -> BinaryOp -> Bool
< :: BinaryOp -> BinaryOp -> Bool
$c<= :: BinaryOp -> BinaryOp -> Bool
<= :: BinaryOp -> BinaryOp -> Bool
$c> :: BinaryOp -> BinaryOp -> Bool
> :: BinaryOp -> BinaryOp -> Bool
$c>= :: BinaryOp -> BinaryOp -> Bool
>= :: BinaryOp -> BinaryOp -> Bool
$cmax :: BinaryOp -> BinaryOp -> BinaryOp
max :: BinaryOp -> BinaryOp -> BinaryOp
$cmin :: BinaryOp -> BinaryOp -> BinaryOp
min :: BinaryOp -> BinaryOp -> BinaryOp
Ord, Int -> BinaryOp -> ShowS
[BinaryOp] -> ShowS
BinaryOp -> String
(Int -> BinaryOp -> ShowS)
-> (BinaryOp -> String) -> ([BinaryOp] -> ShowS) -> Show BinaryOp
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BinaryOp -> ShowS
showsPrec :: Int -> BinaryOp -> ShowS
$cshow :: BinaryOp -> String
show :: BinaryOp -> String
$cshowList :: [BinaryOp] -> ShowS
showList :: [BinaryOp] -> ShowS
Show)

{- | Symbolic pi,Euler number e,or tau=2*pi. Precision mode determines how a constant is
evaluated.
-}
data NamedConstant = Pi | Euler | Tau deriving (NamedConstant -> NamedConstant -> Bool
(NamedConstant -> NamedConstant -> Bool)
-> (NamedConstant -> NamedConstant -> Bool) -> Eq NamedConstant
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NamedConstant -> NamedConstant -> Bool
== :: NamedConstant -> NamedConstant -> Bool
$c/= :: NamedConstant -> NamedConstant -> Bool
/= :: NamedConstant -> NamedConstant -> Bool
Eq, Eq NamedConstant
Eq NamedConstant =>
(NamedConstant -> NamedConstant -> Ordering)
-> (NamedConstant -> NamedConstant -> Bool)
-> (NamedConstant -> NamedConstant -> Bool)
-> (NamedConstant -> NamedConstant -> Bool)
-> (NamedConstant -> NamedConstant -> Bool)
-> (NamedConstant -> NamedConstant -> NamedConstant)
-> (NamedConstant -> NamedConstant -> NamedConstant)
-> Ord NamedConstant
NamedConstant -> NamedConstant -> Bool
NamedConstant -> NamedConstant -> Ordering
NamedConstant -> NamedConstant -> NamedConstant
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: NamedConstant -> NamedConstant -> Ordering
compare :: NamedConstant -> NamedConstant -> Ordering
$c< :: NamedConstant -> NamedConstant -> Bool
< :: NamedConstant -> NamedConstant -> Bool
$c<= :: NamedConstant -> NamedConstant -> Bool
<= :: NamedConstant -> NamedConstant -> Bool
$c> :: NamedConstant -> NamedConstant -> Bool
> :: NamedConstant -> NamedConstant -> Bool
$c>= :: NamedConstant -> NamedConstant -> Bool
>= :: NamedConstant -> NamedConstant -> Bool
$cmax :: NamedConstant -> NamedConstant -> NamedConstant
max :: NamedConstant -> NamedConstant -> NamedConstant
$cmin :: NamedConstant -> NamedConstant -> NamedConstant
min :: NamedConstant -> NamedConstant -> NamedConstant
Ord, Int -> NamedConstant -> ShowS
[NamedConstant] -> ShowS
NamedConstant -> String
(Int -> NamedConstant -> ShowS)
-> (NamedConstant -> String)
-> ([NamedConstant] -> ShowS)
-> Show NamedConstant
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NamedConstant -> ShowS
showsPrec :: Int -> NamedConstant -> ShowS
$cshow :: NamedConstant -> String
show :: NamedConstant -> String
$cshowList :: [NamedConstant] -> ShowS
showList :: [NamedConstant] -> ShowS
Show)

{- | Positioned expression syntax tree. Smart builders use unknownPosition; parsed nodes
retain source locations. Validation/evaluation returns structured ExprError rather than
executing host code.
-}
data Expr = Expr
    { Expr -> SourcePos
expressionPosition :: SourcePos
    -- ^ Source location carried by this Expr for positioned errors.
    , Expr -> ExprNode
expressionNode :: ExprNode
    -- ^ Literal/variable/operator/call/let structure of this expression.
    }
    deriving (Int -> Expr -> ShowS
[Expr] -> ShowS
Expr -> String
(Int -> Expr -> ShowS)
-> (Expr -> String) -> ([Expr] -> ShowS) -> Show Expr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Expr -> ShowS
showsPrec :: Int -> Expr -> ShowS
$cshow :: Expr -> String
show :: Expr -> String
$cshowList :: [Expr] -> ShowS
showList :: [Expr] -> ShowS
Show)

{- | Expression syntax: exact literal,named variable/constant,unary/binary
operation,registered call,or lexically scoped let binding.
-}
data ExprNode
    = Literal Rational
    | Variable String
    | Constant NamedConstant
    | Unary UnaryOp Expr
    | Binary BinaryOp Expr Expr
    | Call String [Expr]
    | Let String Expr Expr
    deriving (ExprNode -> ExprNode -> Bool
(ExprNode -> ExprNode -> Bool)
-> (ExprNode -> ExprNode -> Bool) -> Eq ExprNode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ExprNode -> ExprNode -> Bool
== :: ExprNode -> ExprNode -> Bool
$c/= :: ExprNode -> ExprNode -> Bool
/= :: ExprNode -> ExprNode -> Bool
Eq, Eq ExprNode
Eq ExprNode =>
(ExprNode -> ExprNode -> Ordering)
-> (ExprNode -> ExprNode -> Bool)
-> (ExprNode -> ExprNode -> Bool)
-> (ExprNode -> ExprNode -> Bool)
-> (ExprNode -> ExprNode -> Bool)
-> (ExprNode -> ExprNode -> ExprNode)
-> (ExprNode -> ExprNode -> ExprNode)
-> Ord ExprNode
ExprNode -> ExprNode -> Bool
ExprNode -> ExprNode -> Ordering
ExprNode -> ExprNode -> ExprNode
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ExprNode -> ExprNode -> Ordering
compare :: ExprNode -> ExprNode -> Ordering
$c< :: ExprNode -> ExprNode -> Bool
< :: ExprNode -> ExprNode -> Bool
$c<= :: ExprNode -> ExprNode -> Bool
<= :: ExprNode -> ExprNode -> Bool
$c> :: ExprNode -> ExprNode -> Bool
> :: ExprNode -> ExprNode -> Bool
$c>= :: ExprNode -> ExprNode -> Bool
>= :: ExprNode -> ExprNode -> Bool
$cmax :: ExprNode -> ExprNode -> ExprNode
max :: ExprNode -> ExprNode -> ExprNode
$cmin :: ExprNode -> ExprNode -> ExprNode
min :: ExprNode -> ExprNode -> ExprNode
Ord, Int -> ExprNode -> ShowS
[ExprNode] -> ShowS
ExprNode -> String
(Int -> ExprNode -> ShowS)
-> (ExprNode -> String) -> ([ExprNode] -> ShowS) -> Show ExprNode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ExprNode -> ShowS
showsPrec :: Int -> ExprNode -> ShowS
$cshow :: ExprNode -> String
show :: ExprNode -> String
$cshowList :: [ExprNode] -> ShowS
showList :: [ExprNode] -> ShowS
Show)

instance Eq Expr where Expr SourcePos
_ ExprNode
a == :: Expr -> Expr -> Bool
== Expr SourcePos
_ ExprNode
b = ExprNode
a ExprNode -> ExprNode -> Bool
forall a. Eq a => a -> a -> Bool
== ExprNode
b
instance Ord Expr where compare :: Expr -> Expr -> Ordering
compare (Expr SourcePos
_ ExprNode
a) (Expr SourcePos
_ ExprNode
b) = ExprNode -> ExprNode -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ExprNode
a ExprNode
b

{- | Construct an exact Rational literal Expr at unknownPosition. This builder does not
validate resource limits; evaluation/serialization performs checked validation.
-}
literal :: Rational -> Expr
literal :: Rational -> Expr
literal = SourcePos -> ExprNode -> Expr
Expr SourcePos
unknownPosition (ExprNode -> Expr) -> (Rational -> ExprNode) -> Rational -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> ExprNode
Literal

{- | Construct a named variable Expr at unknownPosition; lookup and limit validation occur
during checked processing.
-}
variable :: String -> Expr
variable :: String -> Expr
variable = SourcePos -> ExprNode -> Expr
Expr SourcePos
unknownPosition (ExprNode -> Expr) -> (String -> ExprNode) -> String -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ExprNode
Variable

{- | Construct a Pi/Euler/Tau named-constant Expr at unknownPosition, without numeric
evaluation.
-}
constant :: NamedConstant -> Expr
constant :: NamedConstant -> Expr
constant = SourcePos -> ExprNode -> Expr
Expr SourcePos
unknownPosition (ExprNode -> Expr)
-> (NamedConstant -> ExprNode) -> NamedConstant -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedConstant -> ExprNode
Constant

-- | Given UnaryOp then child Expr, construct an unevaluated unary node at unknownPosition.
unary :: UnaryOp -> Expr -> Expr
unary :: UnaryOp -> Expr -> Expr
unary UnaryOp
op = SourcePos -> ExprNode -> Expr
Expr SourcePos
unknownPosition (ExprNode -> Expr) -> (Expr -> ExprNode) -> Expr -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnaryOp -> Expr -> ExprNode
Unary UnaryOp
op

{- | Given BinaryOp,left Expr,right Expr, construct an unevaluated binary node at
unknownPosition. Domain and resource checks occur when evaluated.
-}
binary :: BinaryOp -> Expr -> Expr -> Expr
binary :: BinaryOp -> Expr -> Expr -> Expr
binary BinaryOp
op Expr
a Expr
b = SourcePos -> ExprNode -> Expr
Expr SourcePos
unknownPosition (BinaryOp -> Expr -> Expr -> ExprNode
Binary BinaryOp
op Expr
a Expr
b)

{- | Given function name then argument Expr list, construct a call node at unknownPosition.
Evaluation resolves the supplied registry; construction does not execute a function.
-}
call :: String -> [Expr] -> Expr
call :: String -> [Expr] -> Expr
call String
name = SourcePos -> ExprNode -> Expr
Expr SourcePos
unknownPosition (ExprNode -> Expr) -> ([Expr] -> ExprNode) -> [Expr] -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Expr] -> ExprNode
Call String
name

{- | Given binding name,value Expr,body Expr, construct a lexically scoped let node at
unknownPosition. The binding applies in the body, not its own value expression.
-}
letIn :: String -> Expr -> Expr -> Expr
letIn :: String -> Expr -> Expr -> Expr
letIn String
name Expr
a Expr
b = SourcePos -> ExprNode -> Expr
Expr SourcePos
unknownPosition (String -> Expr -> Expr -> ExprNode
Let String
name Expr
a Expr
b)

{- | Explicit resource budgets checked before parsing,evaluation,serialization,and cache
growth; start from defaultLimits.
-}
data Limits = Limits
    { Limits -> Int
maximumSteps :: Int
    -- ^ Maximum checked evaluation/rewrite instruction steps.
    , Limits -> Int
maximumDepth :: Int
    -- ^ Maximum permitted parser/expression recursion depth.
    , Limits -> Int
maximumNodes :: Int
    -- ^ Maximum expression or compiled-node storage budget.
    , Limits -> Int
maximumInputChars :: Int
    -- ^ Maximum accepted input/serialized text characters.
    , Limits -> Int
maximumIntegerBits :: Int
    -- ^ Maximum exact-integer bit length in checked arithmetic.
    , Limits -> Int
maximumCacheEntries :: Int
    -- ^ Maximum retained compiled-expression cache entries; zero disables retention.
    }
    deriving (Limits -> Limits -> Bool
(Limits -> Limits -> Bool)
-> (Limits -> Limits -> Bool) -> Eq Limits
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Limits -> Limits -> Bool
== :: Limits -> Limits -> Bool
$c/= :: Limits -> Limits -> Bool
/= :: Limits -> Limits -> Bool
Eq, Int -> Limits -> ShowS
[Limits] -> ShowS
Limits -> String
(Int -> Limits -> ShowS)
-> (Limits -> String) -> ([Limits] -> ShowS) -> Show Limits
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Limits -> ShowS
showsPrec :: Int -> Limits -> ShowS
$cshow :: Limits -> String
show :: Limits -> String
$cshowList :: [Limits] -> ShowS
showList :: [Limits] -> ShowS
Show)

{- | Default expression budgets: 100000 steps, depth 128, 20000 nodes, 100000 input
characters, 1024 integer bits and 64 cache entries. Use record updates; validateLimits
checks hard implementation bounds.
-}
defaultLimits :: Limits
defaultLimits :: Limits
defaultLimits = Int -> Int -> Int -> Int -> Int -> Int -> Limits
Limits Int
100000 Int
128 Int
20000 Int
100000 Int
1024 Int
64

{- | Expression error category distinguishing syntax/name/type/domain/nonfinite failures
from bounded-resource exhaustion and unsupported operations.
-}
data ErrorKind
    = SyntaxError
    | UnknownName
    | TypeMismatch
    | DomainFailure
    | NonFinite
    | StepLimit
    | DepthLimit
    | MemoryLimit
    | InvalidLimits
    | Unsupported
    deriving (ErrorKind -> ErrorKind -> Bool
(ErrorKind -> ErrorKind -> Bool)
-> (ErrorKind -> ErrorKind -> Bool) -> Eq ErrorKind
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ErrorKind -> ErrorKind -> Bool
== :: ErrorKind -> ErrorKind -> Bool
$c/= :: ErrorKind -> ErrorKind -> Bool
/= :: ErrorKind -> ErrorKind -> Bool
Eq, Eq ErrorKind
Eq ErrorKind =>
(ErrorKind -> ErrorKind -> Ordering)
-> (ErrorKind -> ErrorKind -> Bool)
-> (ErrorKind -> ErrorKind -> Bool)
-> (ErrorKind -> ErrorKind -> Bool)
-> (ErrorKind -> ErrorKind -> Bool)
-> (ErrorKind -> ErrorKind -> ErrorKind)
-> (ErrorKind -> ErrorKind -> ErrorKind)
-> Ord ErrorKind
ErrorKind -> ErrorKind -> Bool
ErrorKind -> ErrorKind -> Ordering
ErrorKind -> ErrorKind -> ErrorKind
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ErrorKind -> ErrorKind -> Ordering
compare :: ErrorKind -> ErrorKind -> Ordering
$c< :: ErrorKind -> ErrorKind -> Bool
< :: ErrorKind -> ErrorKind -> Bool
$c<= :: ErrorKind -> ErrorKind -> Bool
<= :: ErrorKind -> ErrorKind -> Bool
$c> :: ErrorKind -> ErrorKind -> Bool
> :: ErrorKind -> ErrorKind -> Bool
$c>= :: ErrorKind -> ErrorKind -> Bool
>= :: ErrorKind -> ErrorKind -> Bool
$cmax :: ErrorKind -> ErrorKind -> ErrorKind
max :: ErrorKind -> ErrorKind -> ErrorKind
$cmin :: ErrorKind -> ErrorKind -> ErrorKind
min :: ErrorKind -> ErrorKind -> ErrorKind
Ord, Int -> ErrorKind -> ShowS
[ErrorKind] -> ShowS
ErrorKind -> String
(Int -> ErrorKind -> ShowS)
-> (ErrorKind -> String)
-> ([ErrorKind] -> ShowS)
-> Show ErrorKind
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ErrorKind -> ShowS
showsPrec :: Int -> ErrorKind -> ShowS
$cshow :: ErrorKind -> String
show :: ErrorKind -> String
$cshowList :: [ErrorKind] -> ShowS
showList :: [ErrorKind] -> ShowS
Show)

-- | Structured expression failure with category,source position,and human-readable detail.
data ExprError = ExprError
    { ExprError -> ErrorKind
errorKind :: ErrorKind
    -- ^ Structured syntax,name,domain,type,nonfinite,unsupported,or resource-error category.
    , ExprError -> SourcePos
errorPosition :: SourcePos
    -- ^ Source position attached to the failed operation.
    , ExprError -> String
errorMessage :: String
    -- ^ Human-readable detail for this expression failure.
    }
    deriving (ExprError -> ExprError -> Bool
(ExprError -> ExprError -> Bool)
-> (ExprError -> ExprError -> Bool) -> Eq ExprError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ExprError -> ExprError -> Bool
== :: ExprError -> ExprError -> Bool
$c/= :: ExprError -> ExprError -> Bool
/= :: ExprError -> ExprError -> Bool
Eq, Int -> ExprError -> ShowS
[ExprError] -> ShowS
ExprError -> String
(Int -> ExprError -> ShowS)
-> (ExprError -> String)
-> ([ExprError] -> ShowS)
-> Show ExprError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ExprError -> ShowS
showsPrec :: Int -> ExprError -> ShowS
$cshow :: ExprError -> String
show :: ExprError -> String
$cshowList :: [ExprError] -> ShowS
showList :: [ExprError] -> ShowS
Show)

err :: ErrorKind -> SourcePos -> String -> Either ExprError a
err :: forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
k SourcePos
p = ExprError -> Either ExprError a
forall a b. a -> Either a b
Left (ExprError -> Either ExprError a)
-> (String -> ExprError) -> String -> Either ExprError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorKind -> SourcePos -> String -> ExprError
ExprError ErrorKind
k SourcePos
p

{- | Return Right () if all resource budgets fit implementation bounds: steps 1..10000000,
depth 1..256, nodes 1..100000, input chars 1..1000000, integer bits 2..8192, cache
entries 0..1024. Otherwise return ExprError InvalidLimits.
-}
validateLimits :: Limits -> Either ExprError ()
validateLimits :: Limits -> Either ExprError ()
validateLimits Limits
l
    | [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or
        [ Limits -> Int
maximumSteps Limits
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1
        , Limits -> Int
maximumSteps Limits
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10000000
        , Limits -> Int
maximumDepth Limits
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1
        , Limits -> Int
maximumDepth Limits
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
256
        , Limits -> Int
maximumNodes Limits
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1
        , Limits -> Int
maximumNodes Limits
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
100000
        , Limits -> Int
maximumInputChars Limits
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1
        , Limits -> Int
maximumInputChars Limits
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1000000
        , Limits -> Int
maximumIntegerBits Limits
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2
        , Limits -> Int
maximumIntegerBits Limits
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
8192
        , Limits -> Int
maximumCacheEntries Limits
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0
        , Limits -> Int
maximumCacheEntries Limits
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1024
        ] =
        ErrorKind -> SourcePos -> String -> Either ExprError ()
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
InvalidLimits SourcePos
unknownPosition String
"limits exceed positive reference implementation bounds"
    | Bool
otherwise = () -> Either ExprError ()
forall a b. b -> Either a b
Right ()

data Budget = Budget !Int !Int
start :: Limits -> Budget
start :: Limits -> Budget
start Limits
l = Int -> Int -> Budget
Budget (Limits -> Int
maximumSteps Limits
l) (Limits -> Int
maximumNodes Limits
l)
charge :: SourcePos -> Int -> Int -> Budget -> Either ExprError Budget
charge :: SourcePos -> Int -> Int -> Budget -> Either ExprError Budget
charge SourcePos
p Int
s Int
m (Budget Int
steps Int
nodes)
    | Int
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
steps = ErrorKind -> SourcePos -> String -> Either ExprError Budget
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
StepLimit SourcePos
p String
"expression step budget exhausted"
    | Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
nodes = ErrorKind -> SourcePos -> String -> Either ExprError Budget
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
MemoryLimit SourcePos
p String
"expression allocation/payload budget exhausted"
    | Bool
otherwise = Budget -> Either ExprError Budget
forall a b. b -> Either a b
Right (Int -> Int -> Budget
Budget (Int
steps Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
s) (Int
nodes Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
m))
depth :: Limits -> SourcePos -> Int -> Either ExprError ()
depth :: Limits -> SourcePos -> Int -> Either ExprError ()
depth Limits
l SourcePos
p Int
n
    | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Limits -> Int
maximumDepth Limits
l = ErrorKind -> SourcePos -> String -> Either ExprError ()
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
DepthLimit SourcePos
p String
"expression recursion budget exhausted"
    | Bool
otherwise = () -> Either ExprError ()
forall a b. b -> Either a b
Right ()
identifier :: String -> Bool
identifier :: String -> Bool
identifier [] = Bool
False
identifier (Char
x : String
xs) =
    (Char -> Bool
isAlpha Char
x Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_')
        Bool -> Bool -> Bool
&& (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Char
c -> Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_') String
xs
        Bool -> Bool -> Bool
&& (Char
x Char -> ShowS
forall a. a -> [a] -> [a]
: String
xs) String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String
"let", String
"in"]
boundedLength :: Int -> [a] -> Int
boundedLength :: forall a. Int -> [a] -> Int
boundedLength Int
n = [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([a] -> Int) -> ([a] -> [a]) -> [a] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
bits :: Int -> Integer -> Int
bits :: Int -> Integer -> Int
bits Int
cap = Int -> Integer -> Int
forall {t}. Integral t => Int -> t -> Int
go Int
0 (Integer -> Int) -> (Integer -> Integer) -> Integer -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Integer
forall a. Num a => a -> a
abs
  where
    go :: Int -> t -> Int
go Int
n t
x
        | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
cap Bool -> Bool -> Bool
|| t
x t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
0 = Int
n
        | Bool
otherwise = Int -> t -> Int
go (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (t
x t -> t -> t
forall a. Integral a => a -> a -> a
`quot` t
2)
checkRational :: Limits -> SourcePos -> Rational -> Either ExprError ()
checkRational :: Limits -> SourcePos -> Rational -> Either ExprError ()
checkRational Limits
l SourcePos
p Rational
x
    | Rational -> Integer
forall a. Ratio a -> a
denominator Rational
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0 = ErrorKind -> SourcePos -> String -> Either ExprError ()
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
DomainFailure SourcePos
p String
"invalid rational denominator"
    | Int -> Integer -> Int
bits Int
cap (Rational -> Integer
forall a. Ratio a -> a
numerator Rational
x) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
cap Bool -> Bool -> Bool
|| Int -> Integer -> Int
bits Int
cap (Rational -> Integer
forall a. Ratio a -> a
denominator Rational
x) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
cap =
        ErrorKind -> SourcePos -> String -> Either ExprError ()
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
MemoryLimit SourcePos
p String
"integer bit budget exhausted"
    | Bool
otherwise = () -> Either ExprError ()
forall a b. b -> Either a b
Right ()
  where
    cap :: Int
cap = Limits -> Int
maximumIntegerBits Limits
l

-- | Validate size before traversing arbitrary user-created trees further.
validateExpression :: Limits -> Expr -> Either ExprError ()
validateExpression :: Limits -> Expr -> Either ExprError ()
validateExpression Limits
l Expr
e = Limits -> Either ExprError ()
validateLimits Limits
l Either ExprError ()
-> Either ExprError Budget -> Either ExprError Budget
forall a b.
Either ExprError a -> Either ExprError b -> Either ExprError b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Budget -> Expr -> Either ExprError Budget
go Int
1 (Limits -> Budget
start Limits
l) Expr
e Either ExprError Budget
-> Either ExprError () -> Either ExprError ()
forall a b.
Either ExprError a -> Either ExprError b -> Either ExprError b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> Either ExprError ()
forall a b. b -> Either a b
Right ()
  where
    go :: Int -> Budget -> Expr -> Either ExprError Budget
go Int
d Budget
b (Expr SourcePos
p ExprNode
node) = do
        Limits -> SourcePos -> Int -> Either ExprError ()
depth Limits
l SourcePos
p Int
d
        b1 <- SourcePos -> Int -> Int -> Budget -> Either ExprError Budget
charge SourcePos
p Int
1 Int
1 Budget
b
        case node of
            Literal Rational
q ->
                Limits -> SourcePos -> Rational -> Either ExprError ()
checkRational Limits
l SourcePos
p Rational
q
                    Either ExprError ()
-> Either ExprError Budget -> Either ExprError Budget
forall a b.
Either ExprError a -> Either ExprError b -> Either ExprError b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SourcePos -> Int -> Int -> Budget -> Either ExprError Budget
charge
                        SourcePos
p
                        Int
0
                        ((Int -> Integer -> Int
bits (Limits -> Int
maximumIntegerBits Limits
l) (Rational -> Integer
forall a. Ratio a -> a
numerator Rational
q) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Integer -> Int
bits (Limits -> Int
maximumIntegerBits Limits
l) (Rational -> Integer
forall a. Ratio a -> a
denominator Rational
q)) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8)
                        Budget
b1
            Constant NamedConstant
_ -> Budget -> Either ExprError Budget
forall a b. b -> Either a b
Right Budget
b1
            Variable String
n -> SourcePos -> String -> Budget -> Either ExprError Budget
name SourcePos
p String
n Budget
b1
            Unary UnaryOp
_ Expr
a -> Int -> Budget -> Expr -> Either ExprError Budget
go (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Budget
b1 Expr
a
            Binary BinaryOp
_ Expr
a Expr
c -> Int -> Budget -> Expr -> Either ExprError Budget
go (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Budget
b1 Expr
a Either ExprError Budget
-> (Budget -> Either ExprError Budget) -> Either ExprError Budget
forall a b.
Either ExprError a
-> (a -> Either ExprError b) -> Either ExprError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Budget
b2 -> Int -> Budget -> Expr -> Either ExprError Budget
go (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Budget
b2 Expr
c
            Call String
n [Expr]
xs -> do
                b2 <- SourcePos -> String -> Budget -> Either ExprError Budget
name SourcePos
p String
n Budget
b1
                if boundedLength (maximumNodes l) xs > maximumNodes l
                    then err MemoryLimit p "too many arguments"
                    else foldM (go (d + 1)) b2 xs
            Let String
n Expr
a Expr
c -> SourcePos -> String -> Budget -> Either ExprError Budget
name SourcePos
p String
n Budget
b1 Either ExprError Budget
-> (Budget -> Either ExprError Budget) -> Either ExprError Budget
forall a b.
Either ExprError a
-> (a -> Either ExprError b) -> Either ExprError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Budget
b2 -> Int -> Budget -> Expr -> Either ExprError Budget
go (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Budget
b2 Expr
a Either ExprError Budget
-> (Budget -> Either ExprError Budget) -> Either ExprError Budget
forall a b.
Either ExprError a
-> (a -> Either ExprError b) -> Either ExprError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Budget
b3 -> Int -> Budget -> Expr -> Either ExprError Budget
go (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Budget
b3 Expr
c
    name :: SourcePos -> String -> Budget -> Either ExprError Budget
name SourcePos
p String
n Budget
b =
        let k :: Int
k = Int -> String -> Int
forall a. Int -> [a] -> Int
boundedLength (Limits -> Int
maximumInputChars Limits
l) String
n
         in if Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Limits -> Int
maximumInputChars Limits
l
                then ErrorKind -> SourcePos -> String -> Either ExprError Budget
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
MemoryLimit SourcePos
p String
"identifier too long"
                else if Bool -> Bool
not (String -> Bool
identifier String
n) then ErrorKind -> SourcePos -> String -> Either ExprError Budget
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
SyntaxError SourcePos
p String
"invalid identifier" else SourcePos -> Int -> Int -> Budget -> Either ExprError Budget
charge SourcePos
p Int
k Int
k Budget
b

-- Lexer retains positions even for end-of-input diagnostics.
data Token = Number Rational | Name String | Punctuation Char | End deriving (Token -> Token -> Bool
(Token -> Token -> Bool) -> (Token -> Token -> Bool) -> Eq Token
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Token -> Token -> Bool
== :: Token -> Token -> Bool
$c/= :: Token -> Token -> Bool
/= :: Token -> Token -> Bool
Eq, Int -> Token -> ShowS
[Token] -> ShowS
Token -> String
(Int -> Token -> ShowS)
-> (Token -> String) -> ([Token] -> ShowS) -> Show Token
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Token -> ShowS
showsPrec :: Int -> Token -> ShowS
$cshow :: Token -> String
show :: Token -> String
$cshowList :: [Token] -> ShowS
showList :: [Token] -> ShowS
Show)
type LocatedToken = (SourcePos, Token)
advance :: SourcePos -> Char -> SourcePos
advance :: SourcePos -> Char -> SourcePos
advance (SourcePos Int
o Int
r Int
c) Char
x = if Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n' then Int -> Int -> Int -> SourcePos
SourcePos (Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
1 else Int -> Int -> Int -> SourcePos
SourcePos (Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
r (Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
lexExpression :: Limits -> String -> Either ExprError [LocatedToken]
lexExpression :: Limits -> String -> Either ExprError [LocatedToken]
lexExpression Limits
l String
input = do
    Limits -> Either ExprError ()
validateLimits Limits
l
    if Int -> String -> Int
forall a. Int -> [a] -> Int
boundedLength (Limits -> Int
maximumInputChars Limits
l) String
input Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Limits -> Int
maximumInputChars Limits
l
        then ErrorKind -> SourcePos -> String -> Either ExprError [LocatedToken]
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
MemoryLimit (Int -> Int -> Int -> SourcePos
SourcePos Int
0 Int
1 Int
1) String
"input character budget exhausted"
        else SourcePos -> Budget -> String -> Either ExprError [LocatedToken]
go (Int -> Int -> Int -> SourcePos
SourcePos Int
0 Int
1 Int
1) (Limits -> Budget
start Limits
l) String
input
  where
    go :: SourcePos -> Budget -> String -> Either ExprError [LocatedToken]
go SourcePos
p Budget
b [] = SourcePos -> Int -> Int -> Budget -> Either ExprError Budget
charge SourcePos
p Int
1 Int
1 Budget
b Either ExprError Budget
-> Either ExprError [LocatedToken]
-> Either ExprError [LocatedToken]
forall a b.
Either ExprError a -> Either ExprError b -> Either ExprError b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [LocatedToken] -> Either ExprError [LocatedToken]
forall a b. b -> Either a b
Right [(SourcePos
p, Token
End)]
    go SourcePos
p Budget
b s :: String
s@(Char
x : String
xs)
        | Char -> Bool
isSpace Char
x = SourcePos -> Int -> Int -> Budget -> Either ExprError Budget
charge SourcePos
p Int
1 Int
0 Budget
b Either ExprError Budget
-> (Budget -> Either ExprError [LocatedToken])
-> Either ExprError [LocatedToken]
forall a b.
Either ExprError a
-> (a -> Either ExprError b) -> Either ExprError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Budget
b1 -> SourcePos -> Budget -> String -> Either ExprError [LocatedToken]
go (SourcePos -> Char -> SourcePos
advance SourcePos
p Char
x) Budget
b1 String
xs
        | Char -> Bool
isAlpha Char
x Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' =
            let (String
n, String
rest) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (\Char
c -> Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_') String
s in SourcePos
-> Budget
-> String
-> Token
-> String
-> Either ExprError [LocatedToken]
emit SourcePos
p Budget
b String
n (String -> Token
Name String
n) String
rest
        | Char -> Bool
isDigit Char
x Bool -> Bool -> Bool
|| (Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' Bool -> Bool -> Bool
&& case String
xs of Char
y : String
_ -> Char -> Bool
isDigit Char
y; [] -> Bool
False) = do
            (q, raw, rest) <- SourcePos -> String -> Either ExprError (Rational, String, String)
number SourcePos
p String
s
            checkRational l p q
            emit p b raw (Number q) rest
        | Char
x Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"+-*/^(),=" = SourcePos
-> Budget
-> String
-> Token
-> String
-> Either ExprError [LocatedToken]
emit SourcePos
p Budget
b [Char
x] (Char -> Token
Punctuation Char
x) String
xs
        | Bool
otherwise = ErrorKind -> SourcePos -> String -> Either ExprError [LocatedToken]
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
SyntaxError SourcePos
p String
"unexpected character"
    emit :: SourcePos
-> Budget
-> String
-> Token
-> String
-> Either ExprError [LocatedToken]
emit SourcePos
p Budget
b String
raw Token
t String
rest = do
        b1 <- SourcePos -> Int -> Int -> Budget -> Either ExprError Budget
charge SourcePos
p (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
raw Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
raw Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Budget
b
        more <- go (foldl advance p raw) b1 rest
        Right ((p, t) : more)
    number :: SourcePos -> String -> Either ExprError (Rational, String, String)
number SourcePos
p String
s = do
        let (String
whole, String
rest) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit String
s
            (String
fraction, String
rest1) = case String
rest of Char
'.' : String
ys -> let (String
ds, String
zs) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit String
ys in (Char
'.' Char -> ShowS
forall a. a -> [a] -> [a]
: String
ds, String
zs); String
_ -> (String
"", String
rest)
            mantissa :: String
mantissa = String
whole String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fraction
            decimalDigits :: String
decimalDigits = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'.') String
mantissa
            cap :: Int
cap = Limits -> Int
maximumIntegerBits Limits
l
            parseDigits :: t Char -> Either ExprError Integer
parseDigits t Char
ds =
                if t Char -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t Char
ds Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
cap Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2
                    then ErrorKind -> SourcePos -> String -> Either ExprError Integer
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
MemoryLimit SourcePos
p String
"numeric literal bit budget"
                    else Integer -> Either ExprError Integer
forall a b. b -> Either a b
Right ((Integer -> Char -> Integer) -> Integer -> t Char -> Integer
forall b a. (b -> a -> b) -> b -> t a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Integer
a Char
c -> Integer
10 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
a Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'0')) Integer
0 t Char
ds)
        a <- String -> Either ExprError Integer
forall {t :: * -> *}.
Foldable t =>
t Char -> Either ExprError Integer
parseDigits String
decimalDigits
        case rest1 of
            Char
'/' : Char
'/' : String
ys | String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
fraction -> do
                let (String
ds, String
zs) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit String
ys
                if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
ds
                    then ErrorKind
-> SourcePos
-> String
-> Either ExprError (Rational, String, String)
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
SyntaxError SourcePos
p String
"rational denominator required"
                    else do
                        den <- String -> Either ExprError Integer
forall {t :: * -> *}.
Foldable t =>
t Char -> Either ExprError Integer
parseDigits String
ds
                        if den == 0
                            then err DomainFailure p "zero rational literal denominator"
                            else Right (a % den, mantissa ++ "//" ++ ds, zs)
            String
_ -> do
                (expo, expoText, zs) <- case String
rest1 of
                    Char
c : String
ys | Char
c Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"eE" -> do
                        let (Int
sign, String
ys1) = case String
ys of Char
'-' : String
tailDigits -> (-Int
1, String
tailDigits); Char
'+' : String
tailDigits -> (Int
1, String
tailDigits); String
_ -> (Int
1, String
ys)
                            (String
ds, String
z) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit String
ys1
                        if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
ds
                            then ErrorKind
-> SourcePos -> String -> Either ExprError (Int, String, String)
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
SyntaxError ((SourcePos -> Char -> SourcePos)
-> SourcePos -> String -> SourcePos
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl SourcePos -> Char -> SourcePos
advance SourcePos
p String
mantissa) String
"scientific exponent required"
                            else do
                                n <- String -> Either ExprError Integer
forall {t :: * -> *}.
Foldable t =>
t Char -> Either ExprError Integer
parseDigits String
ds
                                if n > toInteger cap
                                    then err MemoryLimit p "scientific exponent budget"
                                    else
                                        Right
                                            ( sign * fromInteger n
                                            , c : (case ys of Char
signCharacter : String
_ | Char
signCharacter Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"+-" -> [Char
signCharacter]; String
_ -> String
"") ++ ds
                                            , z
                                            )
                    String
_ -> (Int, String, String) -> Either ExprError (Int, String, String)
forall a b. b -> Either a b
Right (Int
0, String
"", String
rest1)
                let places = if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
fraction then Int
0 else String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
fraction Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
                    decimalPower = Int
expo Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
places
                if abs decimalPower > cap `div` 3
                    then err MemoryLimit p "decimal scale bit budget"
                    else
                        Right
                            ( if decimalPower >= 0 then fromInteger (a * 10 ^ decimalPower) else a % (10 ^ (-decimalPower))
                            , mantissa ++ expoText
                            , zs
                            )

type Parse a = Int -> [LocatedToken] -> Either ExprError (a, [LocatedToken])

{- | Parse with positions and a bounded lexer. Parentheses, calls, unary chains and
right-associative powers all count toward parser recursion.
-}
parseExpression :: Limits -> String -> Either ExprError Expr
parseExpression :: Limits -> String -> Either ExprError Expr
parseExpression Limits
l String
source = do
    ts <- Limits -> String -> Either ExprError [LocatedToken]
lexExpression Limits
l String
source
    (e, rest) <- expression 1 ts
    case rest of
        [(SourcePos
_, Token
End)] -> Limits -> Expr -> Either ExprError ()
validateExpression Limits
l Expr
e Either ExprError ()
-> Either ExprError Expr -> Either ExprError Expr
forall a b.
Either ExprError a -> Either ExprError b -> Either ExprError b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Expr -> Either ExprError Expr
forall a b. b -> Either a b
Right Expr
e
        (SourcePos
p, Token
_) : [LocatedToken]
_ -> ErrorKind -> SourcePos -> String -> Either ExprError Expr
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
SyntaxError SourcePos
p String
"unexpected trailing token"
        [] -> ErrorKind -> SourcePos -> String -> Either ExprError Expr
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
SyntaxError SourcePos
unknownPosition String
"missing end token"
  where
    guarded :: Int -> [(SourcePos, b)] -> Either ExprError b -> Either ExprError b
guarded Int
d [(SourcePos, b)]
ts Either ExprError b
action = Limits -> SourcePos -> Int -> Either ExprError ()
depth Limits
l ([(SourcePos, b)] -> SourcePos
forall {b}. [(SourcePos, b)] -> SourcePos
position [(SourcePos, b)]
ts) Int
d Either ExprError () -> Either ExprError b -> Either ExprError b
forall a b.
Either ExprError a -> Either ExprError b -> Either ExprError b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Either ExprError b
action
    expression :: Parse Expr
    expression :: Parse Expr
expression Int
d [LocatedToken]
ts = Int
-> [LocatedToken]
-> Either ExprError (Expr, [LocatedToken])
-> Either ExprError (Expr, [LocatedToken])
forall {b} {b}.
Int -> [(SourcePos, b)] -> Either ExprError b -> Either ExprError b
guarded Int
d [LocatedToken]
ts (Either ExprError (Expr, [LocatedToken])
 -> Either ExprError (Expr, [LocatedToken]))
-> Either ExprError (Expr, [LocatedToken])
-> Either ExprError (Expr, [LocatedToken])
forall a b. (a -> b) -> a -> b
$ case [LocatedToken]
ts of
        (SourcePos
p, Name String
"let") : (SourcePos
_, Name String
n) : (SourcePos
_, Punctuation Char
'=') : [LocatedToken]
xs | String -> Bool
identifier String
n -> do
            (a, ys) <- Parse Expr
expression (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [LocatedToken]
xs
            case ys of
                (SourcePos
_, Name String
"in") : [LocatedToken]
zs -> do (b, rest) <- Parse Expr
expression (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [LocatedToken]
zs; Right (Expr p (Let n a b), rest)
                [LocatedToken]
_ -> ErrorKind
-> SourcePos -> String -> Either ExprError (Expr, [LocatedToken])
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
SyntaxError ([LocatedToken] -> SourcePos
forall {b}. [(SourcePos, b)] -> SourcePos
position [LocatedToken]
ys) String
"expected 'in'"
        (SourcePos
_, Name String
"let") : [LocatedToken]
_ -> ErrorKind
-> SourcePos -> String -> Either ExprError (Expr, [LocatedToken])
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
SyntaxError ([LocatedToken] -> SourcePos
forall {b}. [(SourcePos, b)] -> SourcePos
position [LocatedToken]
ts) String
"expected let name = value in body"
        [LocatedToken]
_ -> Parse Expr
addParse Int
d [LocatedToken]
ts
    addParse :: Parse Expr
addParse Int
d [LocatedToken]
ts = Parse Expr
mulParse (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [LocatedToken]
ts Either ExprError (Expr, [LocatedToken])
-> ((Expr, [LocatedToken])
    -> Either ExprError (Expr, [LocatedToken]))
-> Either ExprError (Expr, [LocatedToken])
forall a b.
Either ExprError a
-> (a -> Either ExprError b) -> Either ExprError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Expr -> [LocatedToken] -> Either ExprError (Expr, [LocatedToken]))
-> (Expr, [LocatedToken])
-> Either ExprError (Expr, [LocatedToken])
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Int
-> [(Char, BinaryOp)]
-> ([LocatedToken] -> Either ExprError (Expr, [LocatedToken]))
-> Expr
-> [LocatedToken]
-> Either ExprError (Expr, [LocatedToken])
loop Int
d [(Char
'+', BinaryOp
Add), (Char
'-', BinaryOp
Subtract)] (Parse Expr
mulParse (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)))
    mulParse :: Parse Expr
mulParse Int
d [LocatedToken]
ts = Parse Expr
unaryParse (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [LocatedToken]
ts Either ExprError (Expr, [LocatedToken])
-> ((Expr, [LocatedToken])
    -> Either ExprError (Expr, [LocatedToken]))
-> Either ExprError (Expr, [LocatedToken])
forall a b.
Either ExprError a
-> (a -> Either ExprError b) -> Either ExprError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Expr -> [LocatedToken] -> Either ExprError (Expr, [LocatedToken]))
-> (Expr, [LocatedToken])
-> Either ExprError (Expr, [LocatedToken])
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Int
-> [(Char, BinaryOp)]
-> ([LocatedToken] -> Either ExprError (Expr, [LocatedToken]))
-> Expr
-> [LocatedToken]
-> Either ExprError (Expr, [LocatedToken])
loop Int
d [(Char
'*', BinaryOp
Multiply), (Char
'/', BinaryOp
Divide)] (Parse Expr
unaryParse (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)))
    loop :: Int
-> [(Char, BinaryOp)]
-> ([LocatedToken] -> Either ExprError (Expr, [LocatedToken]))
-> Expr
-> [LocatedToken]
-> Either ExprError (Expr, [LocatedToken])
loop Int
d [(Char, BinaryOp)]
ops [LocatedToken] -> Either ExprError (Expr, [LocatedToken])
next Expr
a [LocatedToken]
ts = Int
-> [LocatedToken]
-> Either ExprError (Expr, [LocatedToken])
-> Either ExprError (Expr, [LocatedToken])
forall {b} {b}.
Int -> [(SourcePos, b)] -> Either ExprError b -> Either ExprError b
guarded Int
d [LocatedToken]
ts (Either ExprError (Expr, [LocatedToken])
 -> Either ExprError (Expr, [LocatedToken]))
-> Either ExprError (Expr, [LocatedToken])
-> Either ExprError (Expr, [LocatedToken])
forall a b. (a -> b) -> a -> b
$ case [LocatedToken]
ts of
        (SourcePos
_, Punctuation Char
c) : [LocatedToken]
xs | Just BinaryOp
op <- Char -> [(Char, BinaryOp)] -> Maybe BinaryOp
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Char
c [(Char, BinaryOp)]
ops -> do
            (b, ys) <- [LocatedToken] -> Either ExprError (Expr, [LocatedToken])
next [LocatedToken]
xs
            let e = SourcePos -> ExprNode -> Expr
Expr (Expr -> SourcePos
expressionPosition Expr
a) (BinaryOp -> Expr -> Expr -> ExprNode
Binary BinaryOp
op Expr
a Expr
b)
            loop d ops next e ys
        [LocatedToken]
_ -> (Expr, [LocatedToken]) -> Either ExprError (Expr, [LocatedToken])
forall a b. b -> Either a b
Right (Expr
a, [LocatedToken]
ts)
    unaryParse :: Parse Expr
unaryParse Int
d [LocatedToken]
ts = Int
-> [LocatedToken]
-> Either ExprError (Expr, [LocatedToken])
-> Either ExprError (Expr, [LocatedToken])
forall {b} {b}.
Int -> [(SourcePos, b)] -> Either ExprError b -> Either ExprError b
guarded Int
d [LocatedToken]
ts (Either ExprError (Expr, [LocatedToken])
 -> Either ExprError (Expr, [LocatedToken]))
-> Either ExprError (Expr, [LocatedToken])
-> Either ExprError (Expr, [LocatedToken])
forall a b. (a -> b) -> a -> b
$ case [LocatedToken]
ts of
        (SourcePos
p, Punctuation Char
'-') : [LocatedToken]
xs -> do
            (a, ys) <- Parse Expr
unaryParse (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [LocatedToken]
xs
            let e = case Expr -> ExprNode
expressionNode Expr
a of Literal Rational
q -> SourcePos -> ExprNode -> Expr
Expr SourcePos
p (Rational -> ExprNode
Literal (-Rational
q)); ExprNode
_ -> SourcePos -> ExprNode -> Expr
Expr SourcePos
p (UnaryOp -> Expr -> ExprNode
Unary UnaryOp
Negate Expr
a)
            Right (e, ys)
        (SourcePos
_, Punctuation Char
'+') : [LocatedToken]
xs -> Parse Expr
unaryParse (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [LocatedToken]
xs
        [LocatedToken]
_ -> Parse Expr
powerParse (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [LocatedToken]
ts
    powerParse :: Parse Expr
powerParse Int
d [LocatedToken]
ts = Int
-> [LocatedToken]
-> Either ExprError (Expr, [LocatedToken])
-> Either ExprError (Expr, [LocatedToken])
forall {b} {b}.
Int -> [(SourcePos, b)] -> Either ExprError b -> Either ExprError b
guarded Int
d [LocatedToken]
ts (Either ExprError (Expr, [LocatedToken])
 -> Either ExprError (Expr, [LocatedToken]))
-> Either ExprError (Expr, [LocatedToken])
-> Either ExprError (Expr, [LocatedToken])
forall a b. (a -> b) -> a -> b
$ do
        (a, ys) <- Parse Expr
atom (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [LocatedToken]
ts
        case ys of
            (SourcePos
_, Punctuation Char
'^') : [LocatedToken]
zs -> do (b, rest) <- Parse Expr
unaryParse (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [LocatedToken]
zs; Right (Expr (expressionPosition a) (Binary Power a b), rest)
            [LocatedToken]
_ -> (Expr, [LocatedToken]) -> Either ExprError (Expr, [LocatedToken])
forall a b. b -> Either a b
Right (Expr
a, [LocatedToken]
ys)
    atom :: Parse Expr
atom Int
d [LocatedToken]
ts = Int
-> [LocatedToken]
-> Either ExprError (Expr, [LocatedToken])
-> Either ExprError (Expr, [LocatedToken])
forall {b} {b}.
Int -> [(SourcePos, b)] -> Either ExprError b -> Either ExprError b
guarded Int
d [LocatedToken]
ts (Either ExprError (Expr, [LocatedToken])
 -> Either ExprError (Expr, [LocatedToken]))
-> Either ExprError (Expr, [LocatedToken])
-> Either ExprError (Expr, [LocatedToken])
forall a b. (a -> b) -> a -> b
$ case [LocatedToken]
ts of
        (SourcePos
p, Number Rational
q) : [LocatedToken]
xs -> (Expr, [LocatedToken]) -> Either ExprError (Expr, [LocatedToken])
forall a b. b -> Either a b
Right (SourcePos -> ExprNode -> Expr
Expr SourcePos
p (Rational -> ExprNode
Literal Rational
q), [LocatedToken]
xs)
        (SourcePos
p, Name String
n) : (SourcePos
_, Punctuation Char
'(') : [LocatedToken]
xs | String -> Bool
identifier String
n -> do
            (args, ys) <- Int -> [LocatedToken] -> Either ExprError ([Expr], [LocatedToken])
arguments (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [LocatedToken]
xs
            Right (Expr p (Call n args), ys)
        (SourcePos
p, Name String
n) : [LocatedToken]
xs
            | String -> Bool
identifier String
n ->
                (Expr, [LocatedToken]) -> Either ExprError (Expr, [LocatedToken])
forall a b. b -> Either a b
Right (SourcePos -> ExprNode -> Expr
Expr SourcePos
p (ExprNode
-> (NamedConstant -> ExprNode) -> Maybe NamedConstant -> ExprNode
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> ExprNode
Variable String
n) NamedConstant -> ExprNode
Constant (String -> [(String, NamedConstant)] -> Maybe NamedConstant
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
n [(String
"pi", NamedConstant
Pi), (String
"e", NamedConstant
Euler), (String
"tau", NamedConstant
Tau)])), [LocatedToken]
xs)
        (SourcePos
_, Punctuation Char
'(') : [LocatedToken]
xs -> do
            (a, ys) <- Parse Expr
expression (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [LocatedToken]
xs
            case ys of
                (SourcePos
_, Punctuation Char
')') : [LocatedToken]
zs -> (Expr, [LocatedToken]) -> Either ExprError (Expr, [LocatedToken])
forall a b. b -> Either a b
Right (Expr
a, [LocatedToken]
zs)
                [LocatedToken]
_ -> ErrorKind
-> SourcePos -> String -> Either ExprError (Expr, [LocatedToken])
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
SyntaxError ([LocatedToken] -> SourcePos
forall {b}. [(SourcePos, b)] -> SourcePos
position [LocatedToken]
ys) String
"expected ')'"
        [LocatedToken]
_ -> ErrorKind
-> SourcePos -> String -> Either ExprError (Expr, [LocatedToken])
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
SyntaxError ([LocatedToken] -> SourcePos
forall {b}. [(SourcePos, b)] -> SourcePos
position [LocatedToken]
ts) String
"expected an expression"
    arguments :: Int -> [LocatedToken] -> Either ExprError ([Expr], [LocatedToken])
arguments Int
d [LocatedToken]
ts = Int
-> [LocatedToken]
-> Either ExprError ([Expr], [LocatedToken])
-> Either ExprError ([Expr], [LocatedToken])
forall {b} {b}.
Int -> [(SourcePos, b)] -> Either ExprError b -> Either ExprError b
guarded Int
d [LocatedToken]
ts (Either ExprError ([Expr], [LocatedToken])
 -> Either ExprError ([Expr], [LocatedToken]))
-> Either ExprError ([Expr], [LocatedToken])
-> Either ExprError ([Expr], [LocatedToken])
forall a b. (a -> b) -> a -> b
$ case [LocatedToken]
ts of
        (SourcePos
_, Punctuation Char
')') : [LocatedToken]
xs -> ([Expr], [LocatedToken])
-> Either ExprError ([Expr], [LocatedToken])
forall a b. b -> Either a b
Right ([], [LocatedToken]
xs)
        [LocatedToken]
_ -> do
            (a, ys) <- Parse Expr
expression (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [LocatedToken]
ts
            case ys of
                (SourcePos
_, Punctuation Char
')') : [LocatedToken]
zs -> ([Expr], [LocatedToken])
-> Either ExprError ([Expr], [LocatedToken])
forall a b. b -> Either a b
Right ([Expr
a], [LocatedToken]
zs)
                (SourcePos
_, Punctuation Char
',') : [LocatedToken]
zs -> do
                    case [LocatedToken]
zs of
                        (SourcePos
_, Punctuation Char
')') : [LocatedToken]
_ -> ErrorKind -> SourcePos -> String -> Either ExprError ()
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
SyntaxError ([LocatedToken] -> SourcePos
forall {b}. [(SourcePos, b)] -> SourcePos
position [LocatedToken]
zs) String
"missing argument"
                        [LocatedToken]
_ -> () -> Either ExprError ()
forall a b. b -> Either a b
Right ()
                    (as, rest) <- Int -> [LocatedToken] -> Either ExprError ([Expr], [LocatedToken])
arguments (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [LocatedToken]
zs
                    Right (a : as, rest)
                [LocatedToken]
_ -> ErrorKind
-> SourcePos -> String -> Either ExprError ([Expr], [LocatedToken])
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
SyntaxError ([LocatedToken] -> SourcePos
forall {b}. [(SourcePos, b)] -> SourcePos
position [LocatedToken]
ys) String
"expected ',' or ')'"
    position :: [(SourcePos, b)] -> SourcePos
position ((SourcePos
p, b
_) : [(SourcePos, b)]
_) = SourcePos
p
    position [] = SourcePos
unknownPosition

{- | Fully parenthesized, deterministic grammar output. Signed literal folding
during parsing is intentional; serialization additionally preserves raw nodes.
-}
prettyExpression :: Expr -> String
prettyExpression :: Expr -> String
prettyExpression (Expr SourcePos
_ ExprNode
node) = case ExprNode
node of
    Literal Rational
q ->
        let text :: String
text = Integer -> String
forall a. Show a => a -> String
show (Rational -> Integer
forall a. Ratio a -> a
numerator Rational
q) String -> ShowS
forall a. [a] -> [a] -> [a]
++ if Rational -> Integer
forall a. Ratio a -> a
denominator Rational
q Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1 then String
"" else String
"//" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show (Rational -> Integer
forall a. Ratio a -> a
denominator Rational
q)
         in if Rational
q Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
< Rational
0 then String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
text String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")" else String
text
    Variable String
n -> String
n
    Constant NamedConstant
n -> NamedConstant -> String
constantName NamedConstant
n
    Unary UnaryOp
Negate Expr
a -> String
"(-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Expr -> String
prettyExpression Expr
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
    Binary BinaryOp
op Expr
a Expr
b -> String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Expr -> String
prettyExpression Expr
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ BinaryOp -> String
operator BinaryOp
op String -> ShowS
forall a. [a] -> [a] -> [a]
++ Expr -> String
prettyExpression Expr
b String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
    Call String
n [Expr]
xs -> String
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ((Expr -> String) -> [Expr] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Expr -> String
prettyExpression [Expr]
xs) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
    Let String
n Expr
a Expr
b -> String
"(let " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Expr -> String
prettyExpression Expr
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" in " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Expr -> String
prettyExpression Expr
b String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"

constantName :: NamedConstant -> String
constantName :: NamedConstant -> String
constantName NamedConstant
Pi = String
"pi"
constantName NamedConstant
Euler = String
"e"
constantName NamedConstant
Tau = String
"tau"
operator :: BinaryOp -> String
operator :: BinaryOp -> String
operator BinaryOp
Add = String
"+"
operator BinaryOp
Subtract = String
"-"
operator BinaryOp
Multiply = String
"*"
operator BinaryOp
Divide = String
"/"
operator BinaryOp
Power = String
"^"

{- | Return sorted distinct variable names free in an Expr, respecting lexical let bindings.
No evaluation or name lookup occurs.
-}
freeVariables :: Expr -> [String]
freeVariables :: Expr -> [String]
freeVariables = Set String -> [String]
forall a. Set a -> [a]
Set.toAscList (Set String -> [String])
-> (Expr -> Set String) -> Expr -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> Set String
go
  where
    go :: Expr -> Set String
go (Expr SourcePos
_ ExprNode
n) = case ExprNode
n of
        Variable String
s -> String -> Set String
forall a. a -> Set a
Set.singleton String
s
        Literal Rational
_ -> Set String
forall a. Set a
Set.empty
        Constant NamedConstant
_ -> Set String
forall a. Set a
Set.empty
        Unary UnaryOp
_ Expr
a -> Expr -> Set String
go Expr
a
        Binary BinaryOp
_ Expr
a Expr
b -> Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
Set.union (Expr -> Set String
go Expr
a) (Expr -> Set String
go Expr
b)
        Call String
_ [Expr]
xs -> [Set String] -> Set String
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ((Expr -> Set String) -> [Expr] -> [Set String]
forall a b. (a -> b) -> [a] -> [b]
map Expr -> Set String
go [Expr]
xs)
        Let String
s Expr
a Expr
b -> Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
Set.union (Expr -> Set String
go Expr
a) (String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
Set.delete String
s (Expr -> Set String
go Expr
b))

{- | Expression numeric mode: ExactRational retains exact supported rational arithmetic;
Float64 uses checked binary64 evaluation. Unsupported exact transcendental operations
return structured errors.
-}
data Precision = ExactRational | Float64 deriving (Precision -> Precision -> Bool
(Precision -> Precision -> Bool)
-> (Precision -> Precision -> Bool) -> Eq Precision
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Precision -> Precision -> Bool
== :: Precision -> Precision -> Bool
$c/= :: Precision -> Precision -> Bool
/= :: Precision -> Precision -> Bool
Eq, Eq Precision
Eq Precision =>
(Precision -> Precision -> Ordering)
-> (Precision -> Precision -> Bool)
-> (Precision -> Precision -> Bool)
-> (Precision -> Precision -> Bool)
-> (Precision -> Precision -> Bool)
-> (Precision -> Precision -> Precision)
-> (Precision -> Precision -> Precision)
-> Ord Precision
Precision -> Precision -> Bool
Precision -> Precision -> Ordering
Precision -> Precision -> Precision
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Precision -> Precision -> Ordering
compare :: Precision -> Precision -> Ordering
$c< :: Precision -> Precision -> Bool
< :: Precision -> Precision -> Bool
$c<= :: Precision -> Precision -> Bool
<= :: Precision -> Precision -> Bool
$c> :: Precision -> Precision -> Bool
> :: Precision -> Precision -> Bool
$c>= :: Precision -> Precision -> Bool
>= :: Precision -> Precision -> Bool
$cmax :: Precision -> Precision -> Precision
max :: Precision -> Precision -> Precision
$cmin :: Precision -> Precision -> Precision
min :: Precision -> Precision -> Precision
Ord, Int -> Precision -> ShowS
[Precision] -> ShowS
Precision -> String
(Int -> Precision -> ShowS)
-> (Precision -> String)
-> ([Precision] -> ShowS)
-> Show Precision
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Precision -> ShowS
showsPrec :: Int -> Precision -> ShowS
$cshow :: Precision -> String
show :: Precision -> String
$cshowList :: [Precision] -> ShowS
showList :: [Precision] -> ShowS
Show)

{- | Evaluation result tagged ExactValue Rational or FloatValue Double. The selected
Precision controls permitted operations and conversions.
-}
data Value = ExactValue Rational | FloatValue Double deriving (Value -> Value -> Bool
(Value -> Value -> Bool) -> (Value -> Value -> Bool) -> Eq Value
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Value -> Value -> Bool
== :: Value -> Value -> Bool
$c/= :: Value -> Value -> Bool
/= :: Value -> Value -> Bool
Eq, Int -> Value -> ShowS
[Value] -> ShowS
Value -> String
(Int -> Value -> ShowS)
-> (Value -> String) -> ([Value] -> ShowS) -> Show Value
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Value -> ShowS
showsPrec :: Int -> Value -> ShowS
$cshow :: Value -> String
show :: Value -> String
$cshowList :: [Value] -> ShowS
showList :: [Value] -> ShowS
Show)

{- | Map from variable names to tagged expression Values. Lexical let bindings extend the
environment inside their body.
-}
type Bindings = Map.Map String Value

{- | Finite whitelist of supported scalar operations; Registry maps valid names/aliases to
these selectors, never arbitrary host code.
-}
data Builtin
    = Sin
    | Cos
    | Tan
    | Exp
    | Log
    | Sqrt
    | Abs
    | Signum
    | Floor
    | Ceiling
    | Min
    | Max
    | Asin
    | Acos
    | Atan
    | Sinh
    | Cosh
    | Tanh
    deriving (Builtin -> Builtin -> Bool
(Builtin -> Builtin -> Bool)
-> (Builtin -> Builtin -> Bool) -> Eq Builtin
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Builtin -> Builtin -> Bool
== :: Builtin -> Builtin -> Bool
$c/= :: Builtin -> Builtin -> Bool
/= :: Builtin -> Builtin -> Bool
Eq, Eq Builtin
Eq Builtin =>
(Builtin -> Builtin -> Ordering)
-> (Builtin -> Builtin -> Bool)
-> (Builtin -> Builtin -> Bool)
-> (Builtin -> Builtin -> Bool)
-> (Builtin -> Builtin -> Bool)
-> (Builtin -> Builtin -> Builtin)
-> (Builtin -> Builtin -> Builtin)
-> Ord Builtin
Builtin -> Builtin -> Bool
Builtin -> Builtin -> Ordering
Builtin -> Builtin -> Builtin
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Builtin -> Builtin -> Ordering
compare :: Builtin -> Builtin -> Ordering
$c< :: Builtin -> Builtin -> Bool
< :: Builtin -> Builtin -> Bool
$c<= :: Builtin -> Builtin -> Bool
<= :: Builtin -> Builtin -> Bool
$c> :: Builtin -> Builtin -> Bool
> :: Builtin -> Builtin -> Bool
$c>= :: Builtin -> Builtin -> Bool
>= :: Builtin -> Builtin -> Bool
$cmax :: Builtin -> Builtin -> Builtin
max :: Builtin -> Builtin -> Builtin
$cmin :: Builtin -> Builtin -> Builtin
min :: Builtin -> Builtin -> Builtin
Ord, Int -> Builtin -> ShowS
[Builtin] -> ShowS
Builtin -> String
(Int -> Builtin -> ShowS)
-> (Builtin -> String) -> ([Builtin] -> ShowS) -> Show Builtin
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Builtin -> ShowS
showsPrec :: Int -> Builtin -> ShowS
$cshow :: Builtin -> String
show :: Builtin -> String
$cshowList :: [Builtin] -> ShowS
showList :: [Builtin] -> ShowS
Show, Int -> Builtin
Builtin -> Int
Builtin -> [Builtin]
Builtin -> Builtin
Builtin -> Builtin -> [Builtin]
Builtin -> Builtin -> Builtin -> [Builtin]
(Builtin -> Builtin)
-> (Builtin -> Builtin)
-> (Int -> Builtin)
-> (Builtin -> Int)
-> (Builtin -> [Builtin])
-> (Builtin -> Builtin -> [Builtin])
-> (Builtin -> Builtin -> [Builtin])
-> (Builtin -> Builtin -> Builtin -> [Builtin])
-> Enum Builtin
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Builtin -> Builtin
succ :: Builtin -> Builtin
$cpred :: Builtin -> Builtin
pred :: Builtin -> Builtin
$ctoEnum :: Int -> Builtin
toEnum :: Int -> Builtin
$cfromEnum :: Builtin -> Int
fromEnum :: Builtin -> Int
$cenumFrom :: Builtin -> [Builtin]
enumFrom :: Builtin -> [Builtin]
$cenumFromThen :: Builtin -> Builtin -> [Builtin]
enumFromThen :: Builtin -> Builtin -> [Builtin]
$cenumFromTo :: Builtin -> Builtin -> [Builtin]
enumFromTo :: Builtin -> Builtin -> [Builtin]
$cenumFromThenTo :: Builtin -> Builtin -> Builtin -> [Builtin]
enumFromThenTo :: Builtin -> Builtin -> Builtin -> [Builtin]
Enum, Builtin
Builtin -> Builtin -> Bounded Builtin
forall a. a -> a -> Bounded a
$cminBound :: Builtin
minBound :: Builtin
$cmaxBound :: Builtin
maxBound :: Builtin
Bounded)

{- | Immutable safe builtin-name registry, initialized with emptyRegistry or defaultRegistry
and extended with registerFunction.
-}
newtype Registry = Registry (Map.Map String Builtin) deriving (Registry -> Registry -> Bool
(Registry -> Registry -> Bool)
-> (Registry -> Registry -> Bool) -> Eq Registry
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Registry -> Registry -> Bool
== :: Registry -> Registry -> Bool
$c/= :: Registry -> Registry -> Bool
/= :: Registry -> Registry -> Bool
Eq, Int -> Registry -> ShowS
[Registry] -> ShowS
Registry -> String
(Int -> Registry -> ShowS)
-> (Registry -> String) -> ([Registry] -> ShowS) -> Show Registry
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Registry -> ShowS
showsPrec :: Int -> Registry -> ShowS
$cshow :: Registry -> String
show :: Registry -> String
$cshowList :: [Registry] -> ShowS
showList :: [Registry] -> ShowS
Show)

{- | Construct a registry containing no builtins; callers may add permitted names with
registerFunction.
-}
emptyRegistry :: Registry
emptyRegistry :: Registry
emptyRegistry = Map String Builtin -> Registry
Registry Map String Builtin
forall k a. Map k a
Map.empty

{- | Registry of supported safe scalar builtins (trigonometric/hyperbolic functions,
exp/log/sqrt, abs/signum, rounding and min/max). Evaluation dispatches known Builtin
values, never arbitrary source code.
-}
defaultRegistry :: Registry
defaultRegistry :: Registry
defaultRegistry =
    Map String Builtin -> Registry
Registry
        ( [(String, Builtin)] -> Map String Builtin
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
            ( [String] -> [Builtin] -> [(String, Builtin)]
forall a b. [a] -> [b] -> [(a, b)]
zip
                [ String
"sin"
                , String
"cos"
                , String
"tan"
                , String
"exp"
                , String
"log"
                , String
"sqrt"
                , String
"abs"
                , String
"signum"
                , String
"floor"
                , String
"ceil"
                , String
"min"
                , String
"max"
                , String
"asin"
                , String
"acos"
                , String
"atan"
                , String
"sinh"
                , String
"cosh"
                , String
"tanh"
                ]
                [Builtin
forall a. Bounded a => a
minBound .. Builtin
forall a. Bounded a => a
maxBound]
            )
        )

{- | Given valid identifier name,Builtin selector,then registry, insert or replace an alias.
Reject invalid names (including length>1024) or more than 256 distinct entries with
structured ExprError.
-}
registerFunction :: String -> Builtin -> Registry -> Either ExprError Registry
registerFunction :: String -> Builtin -> Registry -> Either ExprError Registry
registerFunction String
n Builtin
f (Registry Map String Builtin
m)
    | String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
1025 String
n) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1024 Bool -> Bool -> Bool
|| Bool -> Bool
not (String -> Bool
identifier String
n) =
        ErrorKind -> SourcePos -> String -> Either ExprError Registry
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
SyntaxError SourcePos
unknownPosition String
"invalid registry name"
    | Map String Builtin -> Int
forall k a. Map k a -> Int
Map.size Map String Builtin
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
256 Bool -> Bool -> Bool
&& String -> Map String Builtin -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.notMember String
n Map String Builtin
m =
        ErrorKind -> SourcePos -> String -> Either ExprError Registry
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
MemoryLimit SourcePos
unknownPosition String
"registry supports at most 256 names"
    | Bool
otherwise = Registry -> Either ExprError Registry
forall a b. b -> Either a b
Right (Map String Builtin -> Registry
Registry (String -> Builtin -> Map String Builtin -> Map String Builtin
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
n Builtin
f Map String Builtin
m))

-- | Sorted function and alias names accepted by a registry; no evaluation occurs.
allowedFunctions :: Registry -> [String]
allowedFunctions :: Registry -> [String]
allowedFunctions (Registry Map String Builtin
m) = Map String Builtin -> [String]
forall k a. Map k a -> [k]
Map.keys Map String Builtin
m

arity :: Builtin -> Int
arity :: Builtin -> Int
arity Builtin
f = if Builtin
f Builtin -> [Builtin] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Builtin
Min, Builtin
Max] then Int
2 else Int
1
finite :: Double -> Bool
finite :: Double -> Bool
finite Double
x = Bool -> Bool
not (Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
x Bool -> Bool -> Bool
|| Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Double
x)
checkValue :: Limits -> Precision -> SourcePos -> Value -> Either ExprError Value
checkValue :: Limits -> Precision -> SourcePos -> Value -> Either ExprError Value
checkValue Limits
l Precision
mode SourcePos
p Value
v = case (Precision
mode, Value
v) of
    (Precision
ExactRational, ExactValue Rational
q) -> Limits -> SourcePos -> Rational -> Either ExprError ()
checkRational Limits
l SourcePos
p Rational
q Either ExprError ()
-> Either ExprError Value -> Either ExprError Value
forall a b.
Either ExprError a -> Either ExprError b -> Either ExprError b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Value -> Either ExprError Value
forall a b. b -> Either a b
Right Value
v
    (Precision
Float64, FloatValue Double
x)
        | Double -> Bool
finite Double
x -> Value -> Either ExprError Value
forall a b. b -> Either a b
Right Value
v
        | Bool
otherwise -> ErrorKind -> SourcePos -> String -> Either ExprError Value
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
NonFinite SourcePos
p String
"nonfinite floating value"
    (Precision, Value)
_ -> ErrorKind -> SourcePos -> String -> Either ExprError Value
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
TypeMismatch SourcePos
p String
"binding precision differs from selected precision"
fromQ :: Limits -> Precision -> SourcePos -> Rational -> Either ExprError Value
fromQ :: Limits
-> Precision -> SourcePos -> Rational -> Either ExprError Value
fromQ Limits
l Precision
mode SourcePos
p Rational
q =
    Limits -> SourcePos -> Rational -> Either ExprError ()
checkRational Limits
l SourcePos
p Rational
q
        Either ExprError ()
-> Either ExprError Value -> Either ExprError Value
forall a b.
Either ExprError a -> Either ExprError b -> Either ExprError b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Limits -> Precision -> SourcePos -> Value -> Either ExprError Value
checkValue
            Limits
l
            Precision
mode
            SourcePos
p
            (case Precision
mode of Precision
ExactRational -> Rational -> Value
ExactValue Rational
q; Precision
Float64 -> Double -> Value
FloatValue (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
q))
constantValue :: Precision -> SourcePos -> NamedConstant -> Either ExprError Value
constantValue :: Precision -> SourcePos -> NamedConstant -> Either ExprError Value
constantValue Precision
ExactRational SourcePos
p NamedConstant
_ = ErrorKind -> SourcePos -> String -> Either ExprError Value
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
TypeMismatch SourcePos
p String
"irrational constant in exact mode"
constantValue Precision
Float64 SourcePos
_ NamedConstant
c = Value -> Either ExprError Value
forall a b. b -> Either a b
Right (Double -> Value
FloatValue (case NamedConstant
c of NamedConstant
Pi -> Double
forall a. Floating a => a
pi; NamedConstant
Euler -> Double -> Double
forall a. Floating a => a -> a
exp Double
1; NamedConstant
Tau -> Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
forall a. Floating a => a
pi))
applyBinary :: Limits -> SourcePos -> BinaryOp -> Value -> Value -> Either ExprError Value
applyBinary :: Limits
-> SourcePos
-> BinaryOp
-> Value
-> Value
-> Either ExprError Value
applyBinary Limits
l SourcePos
p BinaryOp
op (ExactValue Rational
a) (ExactValue Rational
b) = do
    let cap :: Int
cap = Limits -> Int
maximumIntegerBits Limits
l
        size :: Rational -> Int
size Rational
q = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (Int -> Integer -> Int
bits Int
cap (Rational -> Integer
forall a. Ratio a -> a
numerator Rational
q)) (Int -> Integer -> Int
bits Int
cap (Rational -> Integer
forall a. Ratio a -> a
denominator Rational
q))
        estimate :: Integer
estimate = case BinaryOp
op of
            BinaryOp
Power -> if Rational -> Integer
forall a. Ratio a -> a
denominator Rational
b Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1 then Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Rational -> Int
size Rational
a)) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer -> Integer
forall a. Num a => a -> a
abs (Rational -> Integer
forall a. Ratio a -> a
numerator Rational
b) else Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
cap Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1
            BinaryOp
_ -> Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Rational -> Int
size Rational
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Rational -> Int
size Rational
b Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
    case BinaryOp
op of
        BinaryOp
Divide | Rational
b Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
== Rational
0 -> ErrorKind -> SourcePos -> String -> Either ExprError ()
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
DomainFailure SourcePos
p String
"division by zero"
        BinaryOp
Power | Rational -> Integer
forall a. Ratio a -> a
denominator Rational
b Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
1 -> ErrorKind -> SourcePos -> String -> Either ExprError ()
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
TypeMismatch SourcePos
p String
"exact powers require an integer exponent"
        BinaryOp
Power | Rational
a Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
== Rational
0 Bool -> Bool -> Bool
&& Rational
b Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
<= Rational
0 -> ErrorKind -> SourcePos -> String -> Either ExprError ()
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
DomainFailure SourcePos
p String
"zero to nonpositive power"
        BinaryOp
_ -> () -> Either ExprError ()
forall a b. b -> Either a b
Right ()
    if Integer
estimate Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
cap then ErrorKind -> SourcePos -> String -> Either ExprError ()
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
MemoryLimit SourcePos
p String
"intermediate integer bit budget" else () -> Either ExprError ()
forall a b. b -> Either a b
Right ()
    let q :: Rational
q = case BinaryOp
op of
            BinaryOp
Add -> Rational
a Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
b
            BinaryOp
Subtract -> Rational
a Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Rational
b
            BinaryOp
Multiply -> Rational
a Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
b
            BinaryOp
Divide -> Rational
a Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
b
            BinaryOp
Power -> Rational
a Rational -> Integer -> Rational
forall a b. (Fractional a, Integral b) => a -> b -> a
^^ Rational -> Integer
forall a. Ratio a -> a
numerator Rational
b
    Limits -> SourcePos -> Rational -> Either ExprError ()
checkRational Limits
l SourcePos
p Rational
q
    Value -> Either ExprError Value
forall a b. b -> Either a b
Right (Rational -> Value
ExactValue Rational
q)
applyBinary Limits
_ SourcePos
p BinaryOp
op (FloatValue Double
a) (FloatValue Double
b) = do
    if (BinaryOp
op BinaryOp -> BinaryOp -> Bool
forall a. Eq a => a -> a -> Bool
== BinaryOp
Divide Bool -> Bool -> Bool
&& Double
b Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
0)
        Bool -> Bool -> Bool
|| (BinaryOp
op BinaryOp -> BinaryOp -> Bool
forall a. Eq a => a -> a -> Bool
== BinaryOp
Power Bool -> Bool -> Bool
&& ((Double
a Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
0 Bool -> Bool -> Bool
&& Double
b Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
0) Bool -> Bool -> Bool
|| (Double
a Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0 Bool -> Bool -> Bool
&& Double
b Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer -> Double
forall a. Num a => Integer -> a
fromInteger (Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate Double
b))))
        then ErrorKind -> SourcePos -> String -> Either ExprError ()
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
DomainFailure SourcePos
p String
"invalid real division or power"
        else () -> Either ExprError ()
forall a b. b -> Either a b
Right ()
    let x :: Double
x = case BinaryOp
op of BinaryOp
Add -> Double
a Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
b; BinaryOp
Subtract -> Double
a Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
b; BinaryOp
Multiply -> Double
a Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
b; BinaryOp
Divide -> Double
a Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
b; BinaryOp
Power -> Double
a Double -> Double -> Double
forall a. Floating a => a -> a -> a
** Double
b
    if Double -> Bool
finite Double
x then Value -> Either ExprError Value
forall a b. b -> Either a b
Right (Double -> Value
FloatValue Double
x) else ErrorKind -> SourcePos -> String -> Either ExprError Value
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
NonFinite SourcePos
p String
"nonfinite arithmetic result"
applyBinary Limits
_ SourcePos
p BinaryOp
_ Value
_ Value
_ = ErrorKind -> SourcePos -> String -> Either ExprError Value
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
TypeMismatch SourcePos
p String
"mixed arithmetic precisions"
integerSqrt :: Integer -> Integer
integerSqrt :: Integer -> Integer
integerSqrt Integer
n
    | Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
2 = Integer
n
    | Bool
otherwise = Integer -> Integer
go (Integer
2 Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ ((Int -> Integer -> Int
bits Int
8192 Integer
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2))
  where
    go :: Integer -> Integer
go Integer
x = let y :: Integer
y = (Integer
x Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
n Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`quot` Integer
x) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`quot` Integer
2 in if Integer
y Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
x then Integer
x else Integer -> Integer
go Integer
y
applyBuiltin :: Limits -> SourcePos -> Builtin -> [Value] -> Either ExprError Value
applyBuiltin :: Limits -> SourcePos -> Builtin -> [Value] -> Either ExprError Value
applyBuiltin Limits
l SourcePos
p Builtin
f [Value]
args
    | [Value] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Value]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Builtin -> Int
arity Builtin
f = ErrorKind -> SourcePos -> String -> Either ExprError Value
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
TypeMismatch SourcePos
p String
"wrong function arity"
    | Bool
otherwise = case [Value]
args of
        [ExactValue Rational
a] -> case Builtin
f of
            Builtin
Abs -> Value -> Either ExprError Value
forall a b. b -> Either a b
Right (Rational -> Value
ExactValue (Rational -> Rational
forall a. Num a => a -> a
abs Rational
a))
            Builtin
Signum -> Value -> Either ExprError Value
forall a b. b -> Either a b
Right (Rational -> Value
ExactValue (Rational -> Rational
forall a. Num a => a -> a
signum Rational
a))
            Builtin
Floor -> Value -> Either ExprError Value
forall a b. b -> Either a b
Right (Rational -> Value
ExactValue (Integer -> Rational
forall a. Num a => Integer -> a
fromInteger (Rational -> Integer
forall b. Integral b => Rational -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor Rational
a)))
            Builtin
Ceiling -> Value -> Either ExprError Value
forall a b. b -> Either a b
Right (Rational -> Value
ExactValue (Integer -> Rational
forall a. Num a => Integer -> a
fromInteger (Rational -> Integer
forall b. Integral b => Rational -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling Rational
a)))
            Builtin
Sqrt
                | Rational
a Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
< Rational
0 -> ErrorKind -> SourcePos -> String -> Either ExprError Value
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
DomainFailure SourcePos
p String
"negative square root"
                | Bool
otherwise ->
                    let n :: Integer
n = Integer -> Integer
integerSqrt (Rational -> Integer
forall a. Ratio a -> a
numerator Rational
a); d :: Integer
d = Integer -> Integer
integerSqrt (Rational -> Integer
forall a. Ratio a -> a
denominator Rational
a)
                     in if Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
n Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Rational -> Integer
forall a. Ratio a -> a
numerator Rational
a Bool -> Bool -> Bool
&& Integer
d Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
d Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Rational -> Integer
forall a. Ratio a -> a
denominator Rational
a
                            then Limits
-> Precision -> SourcePos -> Rational -> Either ExprError Value
fromQ Limits
l Precision
ExactRational SourcePos
p (Integer
n Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
d)
                            else ErrorKind -> SourcePos -> String -> Either ExprError Value
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
TypeMismatch SourcePos
p String
"irrational exact square root"
            Builtin
_ -> ErrorKind -> SourcePos -> String -> Either ExprError Value
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
TypeMismatch SourcePos
p String
"transcendental function requires Float64"
        [ExactValue Rational
a, ExactValue Rational
b]
            | Builtin
f Builtin -> Builtin -> Bool
forall a. Eq a => a -> a -> Bool
== Builtin
Min -> Value -> Either ExprError Value
forall a b. b -> Either a b
Right (Rational -> Value
ExactValue (Rational -> Rational -> Rational
forall a. Ord a => a -> a -> a
min Rational
a Rational
b))
            | Builtin
f Builtin -> Builtin -> Bool
forall a. Eq a => a -> a -> Bool
== Builtin
Max -> Value -> Either ExprError Value
forall a b. b -> Either a b
Right (Rational -> Value
ExactValue (Rational -> Rational -> Rational
forall a. Ord a => a -> a -> a
max Rational
a Rational
b))
        [FloatValue Double
a] -> do
            if (Builtin
f Builtin -> Builtin -> Bool
forall a. Eq a => a -> a -> Bool
== Builtin
Log Bool -> Bool -> Bool
&& Double
a Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
0) Bool -> Bool -> Bool
|| (Builtin
f Builtin -> Builtin -> Bool
forall a. Eq a => a -> a -> Bool
== Builtin
Sqrt Bool -> Bool -> Bool
&& Double
a Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0) Bool -> Bool -> Bool
|| (Builtin
f Builtin -> [Builtin] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Builtin
Asin, Builtin
Acos] Bool -> Bool -> Bool
&& Double -> Double
forall a. Num a => a -> a
abs Double
a Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
1)
                then ErrorKind -> SourcePos -> String -> Either ExprError ()
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
DomainFailure SourcePos
p String
"function outside real domain"
                else () -> Either ExprError ()
forall a b. b -> Either a b
Right ()
            let x :: Double
x = case Builtin
f of
                    Builtin
Sin -> Double -> Double
forall a. Floating a => a -> a
sin Double
a
                    Builtin
Cos -> Double -> Double
forall a. Floating a => a -> a
cos Double
a
                    Builtin
Tan -> Double -> Double
forall a. Floating a => a -> a
tan Double
a
                    Builtin
Exp -> Double -> Double
forall a. Floating a => a -> a
exp Double
a
                    Builtin
Log -> Double -> Double
forall a. Floating a => a -> a
log Double
a
                    Builtin
Sqrt -> Double -> Double
forall a. Floating a => a -> a
sqrt Double
a
                    Builtin
Abs -> Double -> Double
forall a. Num a => a -> a
abs Double
a
                    Builtin
Signum -> Double -> Double
forall a. Num a => a -> a
signum Double
a
                    Builtin
Floor -> Integer -> Double
forall a. Num a => Integer -> a
fromInteger (Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor Double
a)
                    Builtin
Ceiling -> Integer -> Double
forall a. Num a => Integer -> a
fromInteger (Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling Double
a)
                    Builtin
Asin -> Double -> Double
forall a. Floating a => a -> a
asin Double
a
                    Builtin
Acos -> Double -> Double
forall a. Floating a => a -> a
acos Double
a
                    Builtin
Atan -> Double -> Double
forall a. Floating a => a -> a
atan Double
a
                    Builtin
Sinh -> Double -> Double
forall a. Floating a => a -> a
sinh Double
a
                    Builtin
Cosh -> Double -> Double
forall a. Floating a => a -> a
cosh Double
a
                    Builtin
Tanh -> Double -> Double
forall a. Floating a => a -> a
tanh Double
a
                    Builtin
Min -> Double
a
                    Builtin
Max -> Double
a
            if Double -> Bool
finite Double
x then Value -> Either ExprError Value
forall a b. b -> Either a b
Right (Double -> Value
FloatValue Double
x) else ErrorKind -> SourcePos -> String -> Either ExprError Value
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
NonFinite SourcePos
p String
"nonfinite function result"
        [FloatValue Double
a, FloatValue Double
b]
            | Builtin
f Builtin -> Builtin -> Bool
forall a. Eq a => a -> a -> Bool
== Builtin
Min -> Value -> Either ExprError Value
forall a b. b -> Either a b
Right (Double -> Value
FloatValue (Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
a Double
b))
            | Builtin
f Builtin -> Builtin -> Bool
forall a. Eq a => a -> a -> Bool
== Builtin
Max -> Value -> Either ExprError Value
forall a b. b -> Either a b
Right (Double -> Value
FloatValue (Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
a Double
b))
        [Value]
_ -> ErrorKind -> SourcePos -> String -> Either ExprError Value
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
TypeMismatch SourcePos
p String
"function argument precision mismatch"
lookupFunction :: Registry -> SourcePos -> String -> Int -> Either ExprError Builtin
lookupFunction :: Registry -> SourcePos -> String -> Int -> Either ExprError Builtin
lookupFunction (Registry Map String Builtin
registry) SourcePos
p String
name Int
n = case String -> Map String Builtin -> Maybe Builtin
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
name Map String Builtin
registry of
    Maybe Builtin
Nothing -> ErrorKind -> SourcePos -> String -> Either ExprError Builtin
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
UnknownName SourcePos
p (String
"function not allowed: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name)
    Just Builtin
f
        | Builtin -> Int
arity Builtin
f Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
n -> ErrorKind -> SourcePos -> String -> Either ExprError Builtin
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
TypeMismatch SourcePos
p String
"wrong function arity"
        | Bool
otherwise -> Builtin -> Either ExprError Builtin
forall a b. b -> Either a b
Right Builtin
f

{- | Static scalar/precision/name/arity checking. Domains and integer-valued
variable exponents are checked during evaluation, since they depend on values.
Let-bound names are typed lexically without evaluating their initializers.
-}
typeCheckExpression ::
    Limits -> Precision -> Registry -> Bindings -> Expr -> Either ExprError Precision
typeCheckExpression :: Limits
-> Precision
-> Registry
-> Bindings
-> Expr
-> Either ExprError Precision
typeCheckExpression Limits
l Precision
mode Registry
registry Bindings
env Expr
e = do
    Limits -> Expr -> Either ExprError ()
validateExpression Limits
l Expr
e
    _ <- Int -> Budget -> Set String -> Expr -> Either ExprError Budget
go Int
1 (Limits -> Budget
start Limits
l) Set String
forall a. Set a
Set.empty Expr
e
    Right mode
  where
    go :: Int -> Budget -> Set String -> Expr -> Either ExprError Budget
go Int
d Budget
budget Set String
locals (Expr SourcePos
p ExprNode
node) = do
        Limits -> SourcePos -> Int -> Either ExprError ()
depth Limits
l SourcePos
p Int
d
        next <- SourcePos -> Int -> Int -> Budget -> Either ExprError Budget
charge SourcePos
p Int
1 Int
1 Budget
budget
        case node of
            Literal Rational
q -> Limits
-> Precision -> SourcePos -> Rational -> Either ExprError Value
fromQ Limits
l Precision
mode SourcePos
p Rational
q Either ExprError Value
-> Either ExprError Budget -> Either ExprError Budget
forall a b.
Either ExprError a -> Either ExprError b -> Either ExprError b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Budget -> Either ExprError Budget
forall a b. b -> Either a b
Right Budget
next
            Constant NamedConstant
c -> Precision -> SourcePos -> NamedConstant -> Either ExprError Value
constantValue Precision
mode SourcePos
p NamedConstant
c Either ExprError Value
-> Either ExprError Budget -> Either ExprError Budget
forall a b.
Either ExprError a -> Either ExprError b -> Either ExprError b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Budget -> Either ExprError Budget
forall a b. b -> Either a b
Right Budget
next
            Variable String
n
                | String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member String
n Set String
locals -> Budget -> Either ExprError Budget
forall a b. b -> Either a b
Right Budget
next
                | Bool
otherwise -> case String -> Bindings -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
n Bindings
env of
                    Maybe Value
Nothing -> ErrorKind -> SourcePos -> String -> Either ExprError Budget
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
UnknownName SourcePos
p (String
"unknown variable: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
n)
                    Just Value
v -> Limits -> Precision -> SourcePos -> Value -> Either ExprError Value
checkValue Limits
l Precision
mode SourcePos
p Value
v Either ExprError Value
-> Either ExprError Budget -> Either ExprError Budget
forall a b.
Either ExprError a -> Either ExprError b -> Either ExprError b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Budget -> Either ExprError Budget
forall a b. b -> Either a b
Right Budget
next
            Unary UnaryOp
_ Expr
a -> Int -> Budget -> Set String -> Expr -> Either ExprError Budget
go (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Budget
next Set String
locals Expr
a
            Binary BinaryOp
_ Expr
a Expr
b -> Int -> Budget -> Set String -> Expr -> Either ExprError Budget
go (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Budget
next Set String
locals Expr
a Either ExprError Budget
-> (Budget -> Either ExprError Budget) -> Either ExprError Budget
forall a b.
Either ExprError a
-> (a -> Either ExprError b) -> Either ExprError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Budget
remaining -> Int -> Budget -> Set String -> Expr -> Either ExprError Budget
go (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Budget
remaining Set String
locals Expr
b
            Call String
name [Expr]
xs -> do
                f <- Registry -> SourcePos -> String -> Int -> Either ExprError Builtin
lookupFunction Registry
registry SourcePos
p String
name ([Expr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expr]
xs)
                if mode == ExactRational && f `notElem` [Sqrt, Abs, Signum, Floor, Ceiling, Min, Max]
                    then err TypeMismatch p "transcendental function requires Float64"
                    else Right ()
                foldM (\Budget
remaining Expr
child -> Int -> Budget -> Set String -> Expr -> Either ExprError Budget
go (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Budget
remaining Set String
locals Expr
child) next xs
            Let String
name Expr
a Expr
b -> Int -> Budget -> Set String -> Expr -> Either ExprError Budget
go (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Budget
next Set String
locals Expr
a Either ExprError Budget
-> (Budget -> Either ExprError Budget) -> Either ExprError Budget
forall a b.
Either ExprError a
-> (a -> Either ExprError b) -> Either ExprError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Budget
remaining -> Int -> Budget -> Set String -> Expr -> Either ExprError Budget
go (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Budget
remaining (String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
Set.insert String
name Set String
locals) Expr
b

{- | Direct left-to-right evaluation. Unused let bindings are still evaluated;
unreferenced external bindings are not inspected or copied.
-}
evaluateExpression :: Limits -> Precision -> Registry -> Bindings -> Expr -> Either ExprError Value
evaluateExpression :: Limits
-> Precision
-> Registry
-> Bindings
-> Expr
-> Either ExprError Value
evaluateExpression Limits
l Precision
mode Registry
registry Bindings
env Expr
expression = do
    Limits -> Expr -> Either ExprError ()
validateExpression Limits
l Expr
expression
    (Value, Budget) -> Value
forall a b. (a, b) -> a
fst ((Value, Budget) -> Value)
-> Either ExprError (Value, Budget) -> Either ExprError Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> Budget -> Bindings -> Expr -> Either ExprError (Value, Budget)
go Int
1 (Limits -> Budget
start Limits
l) Bindings
env Expr
expression
  where
    go :: Int
-> Budget -> Bindings -> Expr -> Either ExprError (Value, Budget)
go Int
d Budget
b Bindings
vars (Expr SourcePos
p ExprNode
node) = do
        Limits -> SourcePos -> Int -> Either ExprError ()
depth Limits
l SourcePos
p Int
d
        b1 <- SourcePos -> Int -> Int -> Budget -> Either ExprError Budget
charge SourcePos
p Int
1 Int
1 Budget
b
        case node of
            Literal Rational
q -> do v <- Limits
-> Precision -> SourcePos -> Rational -> Either ExprError Value
fromQ Limits
l Precision
mode SourcePos
p Rational
q; Right (v, b1)
            Constant NamedConstant
c -> do v <- Precision -> SourcePos -> NamedConstant -> Either ExprError Value
constantValue Precision
mode SourcePos
p NamedConstant
c; Right (v, b1)
            Variable String
n -> case String -> Bindings -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
n Bindings
vars of
                Maybe Value
Nothing -> ErrorKind
-> SourcePos -> String -> Either ExprError (Value, Budget)
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
UnknownName SourcePos
p (String
"unknown variable: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
n)
                Just Value
v -> do x <- Limits -> Precision -> SourcePos -> Value -> Either ExprError Value
checkValue Limits
l Precision
mode SourcePos
p Value
v; Right (x, b1)
            Unary UnaryOp
Negate Expr
a -> do
                (x, b2) <- Int
-> Budget -> Bindings -> Expr -> Either ExprError (Value, Budget)
go (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Budget
b1 Bindings
vars Expr
a
                Right (case x of ExactValue Rational
q -> Rational -> Value
ExactValue (-Rational
q); FloatValue Double
q -> Double -> Value
FloatValue (-Double
q), b2)
            Binary BinaryOp
op Expr
a Expr
c -> do
                (x, b2) <- Int
-> Budget -> Bindings -> Expr -> Either ExprError (Value, Budget)
go (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Budget
b1 Bindings
vars Expr
a
                (y, b3) <- go (d + 1) b2 vars c
                v <- applyBinary l p op x y
                Right (v, b3)
            Call String
name [Expr]
xs -> do
                f <- Registry -> SourcePos -> String -> Int -> Either ExprError Builtin
lookupFunction Registry
registry SourcePos
p String
name ([Expr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expr]
xs)
                (args, b2) <-
                    foldM (\([Value]
vs, Budget
bg) Expr
e -> do (v, bg1) <- Int
-> Budget -> Bindings -> Expr -> Either ExprError (Value, Budget)
go (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Budget
bg Bindings
vars Expr
e; Right (vs ++ [v], bg1)) ([], b1) xs
                v <- applyBuiltin l p f args
                Right (v, b2)
            Let String
n Expr
a Expr
c -> do (x, b2) <- Int
-> Budget -> Bindings -> Expr -> Either ExprError (Value, Budget)
go (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Budget
b1 Bindings
vars Expr
a; b3 <- charge p 1 1 b2; go (d + 1) b3 (Map.insert n x vars) c

{- | Given limits,precision,registry,bindings,then source text, parse and evaluate under the
checked expression budgets. Return exact Rational or Float64 Value according to mode;
syntax/name/domain/resource failures return positioned ExprError.
-}
evaluateText :: Limits -> Precision -> Registry -> Bindings -> String -> Either ExprError Value
evaluateText :: Limits
-> Precision
-> Registry
-> Bindings
-> String
-> Either ExprError Value
evaluateText Limits
l Precision
mode Registry
registry Bindings
env String
source = Limits -> String -> Either ExprError Expr
parseExpression Limits
l String
source Either ExprError Expr
-> (Expr -> Either ExprError Value) -> Either ExprError Value
forall a b.
Either ExprError a
-> (a -> Either ExprError b) -> Either ExprError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Limits
-> Precision
-> Registry
-> Bindings
-> Expr
-> Either ExprError Value
evaluateExpression Limits
l Precision
mode Registry
registry Bindings
env

-- CSE keys refer only to previously emitted nodes. Lexical bindings resolve to
-- node IDs before interning, so expressions in distinct scopes cannot alias.
data Key
    = KLiteral Rational
    | KConstant NamedConstant
    | KVariable String
    | KUnary UnaryOp Int
    | KBinary BinaryOp Int Int
    | KCall String [Int]
    | KStrictLet Int Int
    deriving (Key -> Key -> Bool
(Key -> Key -> Bool) -> (Key -> Key -> Bool) -> Eq Key
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Key -> Key -> Bool
== :: Key -> Key -> Bool
$c/= :: Key -> Key -> Bool
/= :: Key -> Key -> Bool
Eq, Eq Key
Eq Key =>
(Key -> Key -> Ordering)
-> (Key -> Key -> Bool)
-> (Key -> Key -> Bool)
-> (Key -> Key -> Bool)
-> (Key -> Key -> Bool)
-> (Key -> Key -> Key)
-> (Key -> Key -> Key)
-> Ord Key
Key -> Key -> Bool
Key -> Key -> Ordering
Key -> Key -> Key
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Key -> Key -> Ordering
compare :: Key -> Key -> Ordering
$c< :: Key -> Key -> Bool
< :: Key -> Key -> Bool
$c<= :: Key -> Key -> Bool
<= :: Key -> Key -> Bool
$c> :: Key -> Key -> Bool
> :: Key -> Key -> Bool
$c>= :: Key -> Key -> Bool
>= :: Key -> Key -> Bool
$cmax :: Key -> Key -> Key
max :: Key -> Key -> Key
$cmin :: Key -> Key -> Key
min :: Key -> Key -> Key
Ord, Int -> Key -> ShowS
[Key] -> ShowS
Key -> String
(Int -> Key -> ShowS)
-> (Key -> String) -> ([Key] -> ShowS) -> Show Key
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Key -> ShowS
showsPrec :: Int -> Key -> ShowS
$cshow :: Key -> String
show :: Key -> String
$cshowList :: [Key] -> ShowS
showList :: [Key] -> ShowS
Show)
data Instruction = Instruction SourcePos Key deriving (Instruction -> Instruction -> Bool
(Instruction -> Instruction -> Bool)
-> (Instruction -> Instruction -> Bool) -> Eq Instruction
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Instruction -> Instruction -> Bool
== :: Instruction -> Instruction -> Bool
$c/= :: Instruction -> Instruction -> Bool
/= :: Instruction -> Instruction -> Bool
Eq, Int -> Instruction -> ShowS
[Instruction] -> ShowS
Instruction -> String
(Int -> Instruction -> ShowS)
-> (Instruction -> String)
-> ([Instruction] -> ShowS)
-> Show Instruction
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Instruction -> ShowS
showsPrec :: Int -> Instruction -> ShowS
$cshow :: Instruction -> String
show :: Instruction -> String
$cshowList :: [Instruction] -> ShowS
showList :: [Instruction] -> ShowS
Show)

{- | Opaque validated expression DAG with common-subexpression sharing and source locations.
Use compileExpression/evaluateCompiled.
-}
data Compiled = Compiled Expr Int (Map.Map Int Instruction) deriving (Compiled -> Compiled -> Bool
(Compiled -> Compiled -> Bool)
-> (Compiled -> Compiled -> Bool) -> Eq Compiled
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Compiled -> Compiled -> Bool
== :: Compiled -> Compiled -> Bool
$c/= :: Compiled -> Compiled -> Bool
/= :: Compiled -> Compiled -> Bool
Eq, Int -> Compiled -> ShowS
[Compiled] -> ShowS
Compiled -> String
(Int -> Compiled -> ShowS)
-> (Compiled -> String) -> ([Compiled] -> ShowS) -> Show Compiled
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Compiled -> ShowS
showsPrec :: Int -> Compiled -> ShowS
$cshow :: Compiled -> String
show :: Compiled -> String
$cshowList :: [Compiled] -> ShowS
showList :: [Compiled] -> ShowS
Show)

data Build = Build !Int (Map.Map Key Int) (Map.Map Int Instruction) Budget

{- | Compile to a hash-consed DAG. Strict lets are retained, including unused
bindings. CSE changes work requirements, but preserves numeric/domain errors.
-}
compileExpression :: Limits -> Expr -> Either ExprError Compiled
compileExpression :: Limits -> Expr -> Either ExprError Compiled
compileExpression Limits
l Expr
expression = do
    Limits -> Expr -> Either ExprError ()
validateExpression Limits
l Expr
expression
    (root, Build _ _ instructions _) <-
        Int
-> Map String Int -> Build -> Expr -> Either ExprError (Int, Build)
go Int
1 Map String Int
forall k a. Map k a
Map.empty (Int -> Map Key Int -> Map Int Instruction -> Budget -> Build
Build Int
0 Map Key Int
forall k a. Map k a
Map.empty Map Int Instruction
forall k a. Map k a
Map.empty (Limits -> Budget
start Limits
l)) Expr
expression
    Right (Compiled expression root instructions)
  where
    go :: Int
-> Map String Int -> Build -> Expr -> Either ExprError (Int, Build)
go Int
d Map String Int
locals Build
state (Expr SourcePos
p ExprNode
node) = do
        Limits -> SourcePos -> Int -> Either ExprError ()
depth Limits
l SourcePos
p Int
d
        st <- SourcePos -> Build -> Either ExprError Build
spend SourcePos
p Build
state
        case node of
            Literal Rational
q -> SourcePos -> Key -> Build -> Either ExprError (Int, Build)
intern SourcePos
p (Rational -> Key
KLiteral Rational
q) Build
st
            Constant NamedConstant
c -> SourcePos -> Key -> Build -> Either ExprError (Int, Build)
intern SourcePos
p (NamedConstant -> Key
KConstant NamedConstant
c) Build
st
            Variable String
n -> case String -> Map String Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
n Map String Int
locals of Just Int
i -> (Int, Build) -> Either ExprError (Int, Build)
forall a b. b -> Either a b
Right (Int
i, Build
st); Maybe Int
Nothing -> SourcePos -> Key -> Build -> Either ExprError (Int, Build)
intern SourcePos
p (String -> Key
KVariable String
n) Build
st
            Unary UnaryOp
op Expr
a -> do (i, s) <- Int
-> Map String Int -> Build -> Expr -> Either ExprError (Int, Build)
go (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Map String Int
locals Build
st Expr
a; intern p (KUnary op i) s
            Binary BinaryOp
op Expr
a Expr
b -> do (i, s) <- Int
-> Map String Int -> Build -> Expr -> Either ExprError (Int, Build)
go (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Map String Int
locals Build
st Expr
a; (j, t) <- go (d + 1) locals s b; intern p (KBinary op i j) t
            Call String
n [Expr]
xs -> do
                (ids, s) <-
                    (([Int], Build) -> Expr -> Either ExprError ([Int], Build))
-> ([Int], Build) -> [Expr] -> Either ExprError ([Int], Build)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\([Int]
is, Build
t) Expr
e -> do (i, u) <- Int
-> Map String Int -> Build -> Expr -> Either ExprError (Int, Build)
go (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Map String Int
locals Build
t Expr
e; Right (is ++ [i], u)) ([], Build
st) [Expr]
xs
                intern p (KCall n ids) s
            Let String
n Expr
a Expr
b -> do
                (i, s) <- Int
-> Map String Int -> Build -> Expr -> Either ExprError (Int, Build)
go (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Map String Int
locals Build
st Expr
a
                (j, t) <- go (d + 1) (Map.insert n i locals) s b
                intern p (KStrictLet i j) t
    spend :: SourcePos -> Build -> Either ExprError Build
spend SourcePos
p (Build Int
n Map Key Int
keys Map Int Instruction
instructions Budget
b) = do b1 <- SourcePos -> Int -> Int -> Budget -> Either ExprError Budget
charge SourcePos
p Int
1 Int
0 Budget
b; Right (Build n keys instructions b1)
    intern :: SourcePos -> Key -> Build -> Either ExprError (Int, Build)
intern SourcePos
p Key
key (Build Int
n Map Key Int
keys Map Int Instruction
instructions Budget
b) = case Key -> Map Key Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Key
key Map Key Int
keys of
        Just Int
i -> (Int, Build) -> Either ExprError (Int, Build)
forall a b. b -> Either a b
Right (Int
i, Int -> Map Key Int -> Map Int Instruction -> Budget -> Build
Build Int
n Map Key Int
keys Map Int Instruction
instructions Budget
b)
        Maybe Int
Nothing -> do
            b1 <- SourcePos -> Int -> Int -> Budget -> Either ExprError Budget
charge SourcePos
p Int
1 Int
1 Budget
b
            Right (n, Build (n + 1) (Map.insert key n keys) (Map.insert n (Instruction p key) instructions) b1)

-- | Number of unique DAG instructions after common-subexpression sharing.
compiledNodeCount :: Compiled -> Int
compiledNodeCount :: Compiled -> Int
compiledNodeCount (Compiled Expr
_ Int
_ Map Int Instruction
nodes) = Map Int Instruction -> Int
forall k a. Map k a -> Int
Map.size Map Int Instruction
nodes

{- | DAG evaluation memoizes successful nodes only; errors keep the first
left-to-right source location. Registry checks occur even on compiled calls.
-}
evaluateCompiled ::
    Limits -> Precision -> Registry -> Bindings -> Compiled -> Either ExprError Value
evaluateCompiled :: Limits
-> Precision
-> Registry
-> Bindings
-> Compiled
-> Either ExprError Value
evaluateCompiled Limits
l Precision
mode Registry
registry Bindings
env (Compiled Expr
original Int
root Map Int Instruction
instructions) = do
    Limits -> Expr -> Either ExprError ()
validateExpression Limits
l Expr
original
    (v, _, _) <- Int
-> Budget
-> Map Int Value
-> Int
-> Either ExprError (Value, Budget, Map Int Value)
go Int
1 (Limits -> Budget
start Limits
l) Map Int Value
forall k a. Map k a
Map.empty Int
root
    Right v
  where
    go :: Int
-> Budget
-> Map Int Value
-> Int
-> Either ExprError (Value, Budget, Map Int Value)
go Int
d Budget
b Map Int Value
memo Int
i = case Int -> Map Int Instruction -> Maybe Instruction
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
i Map Int Instruction
instructions of
        Maybe Instruction
Nothing -> ErrorKind
-> SourcePos
-> String
-> Either ExprError (Value, Budget, Map Int Value)
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
Unsupported SourcePos
unknownPosition String
"invalid compiled instruction"
        Just (Instruction SourcePos
p Key
key) -> do
            Limits -> SourcePos -> Int -> Either ExprError ()
depth Limits
l SourcePos
p Int
d
            b1 <- SourcePos -> Int -> Int -> Budget -> Either ExprError Budget
charge SourcePos
p Int
1 Int
0 Budget
b
            case Map.lookup i memo of
                Just Value
v -> (Value, Budget, Map Int Value)
-> Either ExprError (Value, Budget, Map Int Value)
forall a b. b -> Either a b
Right (Value
v, Budget
b1, Map Int Value
memo)
                Maybe Value
Nothing -> do
                    (v, b2, m2) <- Int
-> Budget
-> Map Int Value
-> SourcePos
-> Key
-> Either ExprError (Value, Budget, Map Int Value)
execute Int
d Budget
b1 Map Int Value
memo SourcePos
p Key
key
                    b3 <- charge p 0 1 b2
                    Right (v, b3, Map.insert i v m2)
    execute :: Int
-> Budget
-> Map Int Value
-> SourcePos
-> Key
-> Either ExprError (Value, Budget, Map Int Value)
execute Int
d Budget
b Map Int Value
m SourcePos
p Key
key = case Key
key of
        KLiteral Rational
q -> do v <- Limits
-> Precision -> SourcePos -> Rational -> Either ExprError Value
fromQ Limits
l Precision
mode SourcePos
p Rational
q; Right (v, b, m)
        KConstant NamedConstant
c -> do v <- Precision -> SourcePos -> NamedConstant -> Either ExprError Value
constantValue Precision
mode SourcePos
p NamedConstant
c; Right (v, b, m)
        KVariable String
n -> case String -> Bindings -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
n Bindings
env of
            Maybe Value
Nothing -> ErrorKind
-> SourcePos
-> String
-> Either ExprError (Value, Budget, Map Int Value)
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
UnknownName SourcePos
p (String
"unknown variable: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
n)
            Just Value
v -> do w <- Limits -> Precision -> SourcePos -> Value -> Either ExprError Value
checkValue Limits
l Precision
mode SourcePos
p Value
v; Right (w, b, m)
        KUnary UnaryOp
Negate Int
i -> do
            (v, b1, m1) <- Int
-> Budget
-> Map Int Value
-> Int
-> Either ExprError (Value, Budget, Map Int Value)
go (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Budget
b Map Int Value
m Int
i
            Right (case v of ExactValue Rational
q -> Rational -> Value
ExactValue (-Rational
q); FloatValue Double
q -> Double -> Value
FloatValue (-Double
q), b1, m1)
        KBinary BinaryOp
op Int
i Int
j -> do
            (x, b1, m1) <- Int
-> Budget
-> Map Int Value
-> Int
-> Either ExprError (Value, Budget, Map Int Value)
go (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Budget
b Map Int Value
m Int
i
            (y, b2, m2) <- go (d + 1) b1 m1 j
            v <- applyBinary l p op x y
            Right (v, b2, m2)
        KCall String
name [Int]
ids -> do
            f <- Registry -> SourcePos -> String -> Int -> Either ExprError Builtin
lookupFunction Registry
registry SourcePos
p String
name ([Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
ids)
            (args, b1, m1) <-
                foldM
                    (\([Value]
vs, Budget
bg, Map Int Value
mm) Int
j -> do (v, bg1, mm1) <- Int
-> Budget
-> Map Int Value
-> Int
-> Either ExprError (Value, Budget, Map Int Value)
go (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Budget
bg Map Int Value
mm Int
j; Right (vs ++ [v], bg1, mm1))
                    ([], b, m)
                    ids
            v <- applyBuiltin l p f args
            Right (v, b1, m1)
        KStrictLet Int
i Int
j -> do (_, b1, m1) <- Int
-> Budget
-> Map Int Value
-> Int
-> Either ExprError (Value, Budget, Map Int Value)
go (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Budget
b Map Int Value
m Int
i; go (d + 1) b1 m1 j

{- | Conservative constant folding of literal arithmetic only. Calls, division
by zero and failing/oversized operations remain intact, preserving failures
and registry restrictions. Floating mode does not reassociate operations.
-}
optimizeExpression :: Limits -> Precision -> Expr -> Either ExprError Expr
optimizeExpression :: Limits -> Precision -> Expr -> Either ExprError Expr
optimizeExpression Limits
l Precision
mode Expr
expression = Limits -> Expr -> Either ExprError ()
validateExpression Limits
l Expr
expression Either ExprError ()
-> Either ExprError Expr -> Either ExprError Expr
forall a b.
Either ExprError a -> Either ExprError b -> Either ExprError b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Expr -> Either ExprError Expr
forall {a}. Expr -> Either a Expr
go Expr
expression Either ExprError Expr
-> (Expr -> Either ExprError Expr) -> Either ExprError Expr
forall a b.
Either ExprError a
-> (a -> Either ExprError b) -> Either ExprError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Expr
e -> Limits -> Expr -> Either ExprError ()
validateExpression Limits
l Expr
e Either ExprError ()
-> Either ExprError Expr -> Either ExprError Expr
forall a b.
Either ExprError a -> Either ExprError b -> Either ExprError b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Expr -> Either ExprError Expr
forall a b. b -> Either a b
Right Expr
e
  where
    go :: Expr -> Either a Expr
go (Expr SourcePos
p ExprNode
node) = case ExprNode
node of
        Unary UnaryOp
op Expr
a -> do
            x <- Expr -> Either a Expr
go Expr
a
            case expressionNode x of
                Literal Rational
q -> Expr -> Either a Expr
forall a b. b -> Either a b
Right (SourcePos -> ExprNode -> Expr
Expr SourcePos
p (Rational -> ExprNode
Literal (-Rational
q)))
                ExprNode
_ -> Expr -> Either a Expr
forall a b. b -> Either a b
Right (SourcePos -> ExprNode -> Expr
Expr SourcePos
p (UnaryOp -> Expr -> ExprNode
Unary UnaryOp
op Expr
x))
        Binary BinaryOp
op Expr
a Expr
b -> do
            x <- Expr -> Either a Expr
go Expr
a
            y <- go b
            case (mode, expressionNode x, expressionNode y) of
                (Precision
ExactRational, Literal Rational
q, Literal Rational
r) -> case Limits
-> SourcePos
-> BinaryOp
-> Value
-> Value
-> Either ExprError Value
applyBinary Limits
l SourcePos
p BinaryOp
op (Rational -> Value
ExactValue Rational
q) (Rational -> Value
ExactValue Rational
r) of
                    Right (ExactValue Rational
s) -> Expr -> Either a Expr
forall a b. b -> Either a b
Right (SourcePos -> ExprNode -> Expr
Expr SourcePos
p (Rational -> ExprNode
Literal Rational
s))
                    Either ExprError Value
_ -> Expr -> Either a Expr
forall a b. b -> Either a b
Right (SourcePos -> ExprNode -> Expr
Expr SourcePos
p (BinaryOp -> Expr -> Expr -> ExprNode
Binary BinaryOp
op Expr
x Expr
y))
                (Precision, ExprNode, ExprNode)
_ -> Expr -> Either a Expr
forall a b. b -> Either a b
Right (SourcePos -> ExprNode -> Expr
Expr SourcePos
p (BinaryOp -> Expr -> Expr -> ExprNode
Binary BinaryOp
op Expr
x Expr
y))
        Call String
n [Expr]
xs -> SourcePos -> ExprNode -> Expr
Expr SourcePos
p (ExprNode -> Expr) -> ([Expr] -> ExprNode) -> [Expr] -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Expr] -> ExprNode
Call String
n ([Expr] -> Expr) -> Either a [Expr] -> Either a Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expr -> Either a Expr) -> [Expr] -> Either a [Expr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Expr -> Either a Expr
go [Expr]
xs
        Let String
n Expr
a Expr
b -> do x <- Expr -> Either a Expr
go Expr
a; y <- go b; Right (Expr p (Let n x y))
        ExprNode
_ -> Expr -> Either a Expr
forall a b. b -> Either a b
Right (SourcePos -> ExprNode -> Expr
Expr SourcePos
p ExprNode
node)

{- | Immutable FIFO cache. Its entries contain syntax only, never environments
or results. Keys include exact source; eviction occurs at the caller's limit.
-}
newtype ExpressionCache = ExpressionCache [(String, Compiled)] deriving (ExpressionCache -> ExpressionCache -> Bool
(ExpressionCache -> ExpressionCache -> Bool)
-> (ExpressionCache -> ExpressionCache -> Bool)
-> Eq ExpressionCache
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ExpressionCache -> ExpressionCache -> Bool
== :: ExpressionCache -> ExpressionCache -> Bool
$c/= :: ExpressionCache -> ExpressionCache -> Bool
/= :: ExpressionCache -> ExpressionCache -> Bool
Eq, Int -> ExpressionCache -> ShowS
[ExpressionCache] -> ShowS
ExpressionCache -> String
(Int -> ExpressionCache -> ShowS)
-> (ExpressionCache -> String)
-> ([ExpressionCache] -> ShowS)
-> Show ExpressionCache
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ExpressionCache -> ShowS
showsPrec :: Int -> ExpressionCache -> ShowS
$cshow :: ExpressionCache -> String
show :: ExpressionCache -> String
$cshowList :: [ExpressionCache] -> ShowS
showList :: [ExpressionCache] -> ShowS
Show)

{- | Construct an empty immutable compiled-expression cache. cachedExpression returns an
updated cache explicitly.
-}
emptyExpressionCache :: ExpressionCache
emptyExpressionCache :: ExpressionCache
emptyExpressionCache = [(String, Compiled)] -> ExpressionCache
ExpressionCache []

{- | Return number of retained compiled-source entries; does not compile or evaluate
anything.
-}
cacheSize :: ExpressionCache -> Int
cacheSize :: ExpressionCache -> Int
cacheSize (ExpressionCache [(String, Compiled)]
xs) = [(String, Compiled)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(String, Compiled)]
xs

{- | Given limits,source text,then cache, return (compiled expression,updated cache),
reusing a matching entry when permitted. Enforce entry and aggregate source/instruction
budgets; parse/compile/resource failures return ExprError.
-}
cachedExpression ::
    Limits -> String -> ExpressionCache -> Either ExprError (Compiled, ExpressionCache)
cachedExpression :: Limits
-> String
-> ExpressionCache
-> Either ExprError (Compiled, ExpressionCache)
cachedExpression Limits
l String
source (ExpressionCache [(String, Compiled)]
entries) = do
    Limits -> Either ExprError ()
validateLimits Limits
l
    if Int -> String -> Int
forall a. Int -> [a] -> Int
boundedLength (Limits -> Int
maximumInputChars Limits
l) String
source Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Limits -> Int
maximumInputChars Limits
l
        then ErrorKind -> SourcePos -> String -> Either ExprError ()
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
MemoryLimit (Int -> Int -> Int -> SourcePos
SourcePos Int
0 Int
1 Int
1) String
"cached input character budget"
        else () -> Either ExprError ()
forall a b. b -> Either a b
Right ()
    -- Aggregate source and instruction storage is bounded, including old entries
    -- when a cache is reused with tighter limits.
    let retained :: [(String, Compiled)]
retained = Int -> [(String, Compiled)] -> [(String, Compiled)]
forall a. Int -> [a] -> [a]
take (Limits -> Int
maximumCacheEntries Limits
l) [(String, Compiled)]
entries
        storage :: Integer
storage = [Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int -> Integer
forall a. Integral a => a -> Integer
toInteger (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Compiled -> Int
compiledNodeCount Compiled
c) | (String
s, Compiled
c) <- [(String, Compiled)]
retained]
    if Integer
storage Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Limits -> Int
maximumNodes Limits
l)
        then ErrorKind -> SourcePos -> String -> Either ExprError ()
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
MemoryLimit SourcePos
unknownPosition String
"cache aggregate storage budget"
        else () -> Either ExprError ()
forall a b. b -> Either a b
Right ()
    case String -> [(String, Compiled)] -> Maybe Compiled
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
source [(String, Compiled)]
retained of
        Just c :: Compiled
c@(Compiled Expr
e Int
_ Map Int Instruction
_) -> Limits -> Expr -> Either ExprError ()
validateExpression Limits
l Expr
e Either ExprError ()
-> Either ExprError (Compiled, ExpressionCache)
-> Either ExprError (Compiled, ExpressionCache)
forall a b.
Either ExprError a -> Either ExprError b -> Either ExprError b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Compiled, ExpressionCache)
-> Either ExprError (Compiled, ExpressionCache)
forall a b. b -> Either a b
Right (Compiled
c, [(String, Compiled)] -> ExpressionCache
ExpressionCache [(String, Compiled)]
retained)
        Maybe Compiled
Nothing -> do
            e <- Limits -> String -> Either ExprError Expr
parseExpression Limits
l String
source
            c <- compileExpression l e
            let next = Int -> [(String, Compiled)] -> [(String, Compiled)]
forall a. Int -> [a] -> [a]
take (Limits -> Int
maximumCacheEntries Limits
l) ((String
source, Compiled
c) (String, Compiled) -> [(String, Compiled)] -> [(String, Compiled)]
forall a. a -> [a] -> [a]
: [(String, Compiled)]
retained)
                size = [Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int -> Integer
forall a. Integral a => a -> Integer
toInteger (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Compiled -> Int
compiledNodeCount Compiled
p) | (String
s, Compiled
p) <- [(String, Compiled)]
next]
            if size > toInteger (maximumNodes l)
                then err MemoryLimit unknownPosition "cache aggregate storage budget"
                else Right (c, ExpressionCache next)

-- | Scientific notation with 0..30 fractional digits, for finite values.
formatScientific :: Int -> Value -> Either ExprError String
formatScientific :: Int -> Value -> Either ExprError String
formatScientific Int
places Value
value
    | Int
places Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
places Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
30 = ErrorKind -> SourcePos -> String -> Either ExprError String
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
DomainFailure SourcePos
unknownPosition String
"scientific digits must be 0..30"
    | Bool -> Bool
not (Double -> Bool
finite Double
x) = ErrorKind -> SourcePos -> String -> Either ExprError String
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
NonFinite SourcePos
unknownPosition String
"value cannot be represented as finite Double"
    | Bool
otherwise = String -> Either ExprError String
forall a b. b -> Either a b
Right (Maybe Int -> Double -> ShowS
forall a. RealFloat a => Maybe Int -> a -> ShowS
showEFloat (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
places) Double
x String
"")
  where
    x :: Double
x = case Value
value of ExactValue Rational
q -> Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
q; FloatValue Double
y -> Double
y

-- | Integer radix 2..36; fractional values and nonfinite Double are rejected.
formatRadix :: Int -> Value -> Either ExprError String
formatRadix :: Int -> Value -> Either ExprError String
formatRadix Int
base Value
value
    | Int
base Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 Bool -> Bool -> Bool
|| Int
base Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
36 = ErrorKind -> SourcePos -> String -> Either ExprError String
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
DomainFailure SourcePos
unknownPosition String
"radix must be 2..36"
    | Bool
otherwise = case Value
value of
        ExactValue Rational
q
            | Rational -> Integer
forall a. Ratio a -> a
denominator Rational
q Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1 -> String -> Either ExprError String
forall a b. b -> Either a b
Right (Integer -> String
render (Rational -> Integer
forall a. Ratio a -> a
numerator Rational
q))
            | Bool
otherwise -> ErrorKind -> SourcePos -> String -> Either ExprError String
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
TypeMismatch SourcePos
unknownPosition String
"radix formatting requires an integer"
        FloatValue Double
x
            | Bool -> Bool
not (Double -> Bool
finite Double
x) -> ErrorKind -> SourcePos -> String -> Either ExprError String
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
NonFinite SourcePos
unknownPosition String
"nonfinite radix input"
            | Double
x Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer -> Double
forall a. Num a => Integer -> a
fromInteger (Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate Double
x) ->
                ErrorKind -> SourcePos -> String -> Either ExprError String
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
TypeMismatch SourcePos
unknownPosition String
"radix formatting requires an integer"
            | Bool
otherwise -> String -> Either ExprError String
forall a b. b -> Either a b
Right (Integer -> String
render (Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate Double
x))
  where
    render :: Integer -> String
render Integer
n =
        (if Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 then String
"-" else String
"")
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> (Int -> Char) -> Integer -> ShowS
forall a. Integral a => a -> (Int -> Char) -> a -> ShowS
showIntAtBase (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
base) (\Int
i -> String
"0123456789abcdefghijklmnopqrstuvwxyz" String -> Int -> Char
forall a. HasCallStack => [a] -> Int -> a
!! Int
i) (Integer -> Integer
forall a. Num a => a -> a
abs Integer
n) String
""

-- Serialization uses a reserved constructor vocabulary, not Read: input cannot
-- manufacture a Ratio with denominator zero or bypass parser resource limits.

{- | Given limits then Expr, validate its structure and produce versioned safe textual
encoding, retaining expression structure. Exceeded character/structure limits return
ExprError.
-}
serializeExpression :: Limits -> Expr -> Either ExprError String
serializeExpression :: Limits -> Expr -> Either ExprError String
serializeExpression Limits
l Expr
e = do
    Limits -> Expr -> Either ExprError ()
validateExpression Limits
l Expr
e
    let s :: String
s = Expr -> String
encode Expr
e
    if Int -> String -> Int
forall a. Int -> [a] -> Int
boundedLength (Limits -> Int
maximumInputChars Limits
l) String
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Limits -> Int
maximumInputChars Limits
l
        then ErrorKind -> SourcePos -> String -> Either ExprError String
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
MemoryLimit SourcePos
unknownPosition String
"serialized character budget"
        else String -> Either ExprError String
forall a b. b -> Either a b
Right String
s
  where
    encode :: Expr -> String
encode (Expr SourcePos
_ ExprNode
n) = case ExprNode
n of
        Literal Rational
q -> String
"__lit(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show (Rational -> Integer
forall a. Ratio a -> a
numerator Rational
q) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"," String -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show (Rational -> Integer
forall a. Ratio a -> a
denominator Rational
q) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
        Variable String
name -> String
"__var(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
        Constant NamedConstant
c -> String
"__const(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ NamedConstant -> String
constantName NamedConstant
c String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
        Unary UnaryOp
Negate Expr
a -> String
"__neg(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Expr -> String
encode Expr
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
        Binary BinaryOp
op Expr
a Expr
b -> String
"__" String -> ShowS
forall a. [a] -> [a] -> [a]
++ BinaryOp -> String
forall a. Show a => a -> String
show BinaryOp
op String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Expr -> String
encode Expr
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"," String -> ShowS
forall a. [a] -> [a] -> [a]
++ Expr -> String
encode Expr
b String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
        Call String
name [Expr]
xs -> String
"__call(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Expr -> String) -> [Expr] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((String
", " String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> (Expr -> String) -> Expr -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> String
encode) [Expr]
xs String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
        Let String
name Expr
a Expr
b -> String
"__let(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"," String -> ShowS
forall a. [a] -> [a] -> [a]
++ Expr -> String
encode Expr
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"," String -> ShowS
forall a. [a] -> [a] -> [a]
++ Expr -> String
encode Expr
b String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"

{- | Given limits then encoded text, parse the supported serialization and revalidate its
structure. Malformed/unsupported nodes or exceeded limits return ExprError; no host
code evaluation is used.
-}
deserializeExpression :: Limits -> String -> Either ExprError Expr
deserializeExpression :: Limits -> String -> Either ExprError Expr
deserializeExpression Limits
l String
source = do
    encoded <- Limits -> String -> Either ExprError Expr
parseExpression Limits
l String
source
    e <- decode encoded
    validateExpression l e
    Right e
  where
    decode :: Expr -> Either ExprError Expr
decode (Expr SourcePos
p ExprNode
node) = case ExprNode
node of
        Call String
"__lit" [Expr
a, Expr
b] -> do
            n <- Expr -> Either ExprError Integer
integer Expr
a
            d <- integer b
            if d <= 0 then err DomainFailure p "invalid serialized denominator" else Right (literal (n % d))
        Call String
"__var" [Expr
n] -> String -> Expr
variable (String -> Expr)
-> Either ExprError String -> Either ExprError Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> Either ExprError String
name Expr
n
        Call String
"__const" [Expr SourcePos
_ (Constant NamedConstant
c)] -> Expr -> Either ExprError Expr
forall a b. b -> Either a b
Right (NamedConstant -> Expr
constant NamedConstant
c)
        Call String
"__neg" [Expr
a] -> UnaryOp -> Expr -> Expr
unary UnaryOp
Negate (Expr -> Expr) -> Either ExprError Expr -> Either ExprError Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> Either ExprError Expr
decode Expr
a
        Call String
n [Expr
a, Expr
b]
            | Just BinaryOp
op <- String -> [(String, BinaryOp)] -> Maybe BinaryOp
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
n [(String
"__" String -> ShowS
forall a. [a] -> [a] -> [a]
++ BinaryOp -> String
forall a. Show a => a -> String
show BinaryOp
op, BinaryOp
op) | BinaryOp
op <- [BinaryOp
Add, BinaryOp
Subtract, BinaryOp
Multiply, BinaryOp
Divide, BinaryOp
Power]] ->
                BinaryOp -> Expr -> Expr -> Expr
binary BinaryOp
op (Expr -> Expr -> Expr)
-> Either ExprError Expr -> Either ExprError (Expr -> Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> Either ExprError Expr
decode Expr
a Either ExprError (Expr -> Expr)
-> Either ExprError Expr -> Either ExprError Expr
forall a b.
Either ExprError (a -> b)
-> Either ExprError a -> Either ExprError b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr -> Either ExprError Expr
decode Expr
b
        Call String
"__call" (Expr
n : [Expr]
xs) -> String -> [Expr] -> Expr
call (String -> [Expr] -> Expr)
-> Either ExprError String -> Either ExprError ([Expr] -> Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> Either ExprError String
name Expr
n Either ExprError ([Expr] -> Expr)
-> Either ExprError [Expr] -> Either ExprError Expr
forall a b.
Either ExprError (a -> b)
-> Either ExprError a -> Either ExprError b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Expr -> Either ExprError Expr)
-> [Expr] -> Either ExprError [Expr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Expr -> Either ExprError Expr
decode [Expr]
xs
        Call String
"__let" [Expr
n, Expr
a, Expr
b] -> String -> Expr -> Expr -> Expr
letIn (String -> Expr -> Expr -> Expr)
-> Either ExprError String
-> Either ExprError (Expr -> Expr -> Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> Either ExprError String
name Expr
n Either ExprError (Expr -> Expr -> Expr)
-> Either ExprError Expr -> Either ExprError (Expr -> Expr)
forall a b.
Either ExprError (a -> b)
-> Either ExprError a -> Either ExprError b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr -> Either ExprError Expr
decode Expr
a Either ExprError (Expr -> Expr)
-> Either ExprError Expr -> Either ExprError Expr
forall a b.
Either ExprError (a -> b)
-> Either ExprError a -> Either ExprError b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr -> Either ExprError Expr
decode Expr
b
        ExprNode
_ -> ErrorKind -> SourcePos -> String -> Either ExprError Expr
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
SyntaxError SourcePos
p String
"invalid serialized constructor"
    name :: Expr -> Either ExprError String
name (Expr SourcePos
_ (Variable String
n)) = String -> Either ExprError String
forall a b. b -> Either a b
Right String
n
    name (Expr SourcePos
_ (Constant NamedConstant
c)) = String -> Either ExprError String
forall a b. b -> Either a b
Right (NamedConstant -> String
constantName NamedConstant
c)
    name Expr
e = ErrorKind -> SourcePos -> String -> Either ExprError String
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
SyntaxError (Expr -> SourcePos
expressionPosition Expr
e) String
"invalid serialized name"
    integer :: Expr -> Either ExprError Integer
integer (Expr SourcePos
_ (Literal Rational
q)) | Rational -> Integer
forall a. Ratio a -> a
denominator Rational
q Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1 = Integer -> Either ExprError Integer
forall a b. b -> Either a b
Right (Rational -> Integer
forall a. Ratio a -> a
numerator Rational
q)
    integer Expr
e = ErrorKind -> SourcePos -> String -> Either ExprError Integer
forall a. ErrorKind -> SourcePos -> String -> Either ExprError a
err ErrorKind
SyntaxError (Expr -> SourcePos
expressionPosition Expr
e) String
"serialized integer required"

{- | Stable FNV-1a over canonical serialization Unicode code points (not UTF-8
bytes). This is an identity hash, never a cryptographic authenticator.
-}
expressionHash :: Limits -> Expr -> Either ExprError Word64
expressionHash :: Limits -> Expr -> Either ExprError Word64
expressionHash Limits
l Expr
e =
    (Word64 -> Char -> Word64) -> Word64 -> String -> Word64
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Word64
h Char
c -> (Word64
h Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c)) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
1099511628211) Word64
14695981039346656037
        (String -> Word64)
-> Either ExprError String -> Either ExprError Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Limits -> Expr -> Either ExprError String
serializeExpression Limits
l Expr
e