{-# LANGUAGE OverloadedStrings, LambdaCase #-}
module Funcons.Core.Values.Composite.DatatypesBuiltin where
import Funcons.EDSL
import Funcons.MSOS (evalStrictSequence, evalSequence, Strictness(..))
import Funcons.Operations (Values(..), Types(..), ComputationTypes(..))
import Data.Text (pack,unpack)
library :: FunconLibrary
library = [(Name, EvalFunction)] -> FunconLibrary
libFromList [
(Name
"datatype-value", NonStrictFuncon -> EvalFunction
NonStrictFuncon NonStrictFuncon
evalADT)
, (Name
"non-strict-datatype-value", NonStrictFuncon -> EvalFunction
NonStrictFuncon NonStrictFuncon
evalLazyADT)
, (Name
"adt-construct", StrictFuncon -> EvalFunction
StrictFuncon StrictFuncon
adtConstruct)
, (Name
"adt-type-construct", StrictFuncon -> EvalFunction
StrictFuncon StrictFuncon
adtTypeConstruct)
, (Name
"adt-constructor", StrictFuncon -> EvalFunction
StrictFuncon StrictFuncon
adtConstructor)
, (Name
"adt-fields", StrictFuncon -> EvalFunction
StrictFuncon StrictFuncon
adtFields)
]
datatype_value_ :: [Funcons] -> Funcons
datatype_value_ = Name -> [Funcons] -> Funcons
applyFuncon Name
"datatype-value"
adt_val_ :: [Funcons] -> Funcons
adt_val_ = [Funcons] -> Funcons
datatype_value_
evalADT :: NonStrictFuncon
evalADT (Funcons
f:[Funcons]
fs) = [Funcons]
-> StrictFuncon -> ([Funcons] -> Funcons) -> Rewrite Rewritten
evalStrictSequence (Funcons
fFuncons -> [Funcons] -> [Funcons]
forall a. a -> [a] -> [a]
:[Funcons]
fs) StrictFuncon
cont [Funcons] -> Funcons
adt_val_
where
cont :: StrictFuncon
cont [] = [Char] -> Rewrite Rewritten
forall a. HasCallStack => [Char] -> a
error [Char]
"eval-adt assert"
cont (Values Funcons
v:[Values Funcons]
vs) = if Values Funcons -> Bool
forall t. HasValues t => Values t -> Bool
isString_ Values Funcons
v
then Values Funcons -> Rewrite Rewritten
rewritten (Values Funcons -> Rewrite Rewritten)
-> Values Funcons -> Rewrite Rewritten
forall a b. (a -> b) -> a -> b
$ Name -> [Funcons] -> Values Funcons
forall t. Name -> [t] -> Values t
ADTVal ([Char] -> Name
pack (Values Funcons -> [Char]
forall t. HasValues t => Values t -> [Char]
unString Values Funcons
v)) ([Funcons] -> Values Funcons) -> [Funcons] -> Values Funcons
forall a b. (a -> b) -> a -> b
$ (Values Funcons -> Funcons) -> [Values Funcons] -> [Funcons]
forall a b. (a -> b) -> [a] -> [b]
map Values Funcons -> Funcons
FValue [Values Funcons]
vs
else Funcons -> [Char] -> Rewrite Rewritten
forall a. Funcons -> [Char] -> Rewrite a
sortErr ([Funcons] -> Funcons
adt_val_ ((Values Funcons -> Funcons) -> [Values Funcons] -> [Funcons]
forall a b. (a -> b) -> [a] -> [b]
map Values Funcons -> Funcons
FValue (Values Funcons
vValues Funcons -> [Values Funcons] -> [Values Funcons]
forall a. a -> [a] -> [a]
:[Values Funcons]
vs))) ([Char]
"first argument of datatype-value not a string")
evalADT [] = Funcons -> [Char] -> Rewrite Rewritten
forall a. Funcons -> [Char] -> Rewrite a
sortErr ([Funcons] -> Funcons
adt_val_ [])
[Char]
"algebraic-datatype not applied to a string and a sequence of fields"
lazy_adt_val_ :: [Funcons] -> Funcons
lazy_adt_val_ = Name -> [Funcons] -> Funcons
applyFuncon Name
"non-strict-datatype-value"
evalLazyADT :: NonStrictFuncon
evalLazyADT (Funcons
f:[Funcons]
fs) = [Strictness]
-> [Funcons]
-> NonStrictFuncon
-> ([Funcons] -> Funcons)
-> Rewrite Rewritten
evalSequence (Strictness
Strict Strictness -> [Strictness] -> [Strictness]
forall a. a -> [a] -> [a]
: Int -> Strictness -> [Strictness]
forall a. Int -> a -> [a]
replicate ([Funcons] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Funcons]
fs) Strictness
NonStrict)
(Funcons
fFuncons -> [Funcons] -> [Funcons]
forall a. a -> [a] -> [a]
:[Funcons]
fs) NonStrictFuncon
cont [Funcons] -> Funcons
lazy_adt_val_
where
cont :: NonStrictFuncon
cont [] = [Char] -> Rewrite Rewritten
forall a. HasCallStack => [Char] -> a
error [Char]
"lazy-eval-adt assert"
cont (Funcons
v:[Funcons]
vs) = case Funcons
v of
FValue Values Funcons
s | Values Funcons -> Bool
forall t. HasValues t => Values t -> Bool
isString_ Values Funcons
s
-> Values Funcons -> Rewrite Rewritten
rewritten (Values Funcons -> Rewrite Rewritten)
-> Values Funcons -> Rewrite Rewritten
forall a b. (a -> b) -> a -> b
$ Name -> [Funcons] -> Values Funcons
forall t. Name -> [t] -> Values t
ADTVal ([Char] -> Name
pack (Values Funcons -> [Char]
forall t. HasValues t => Values t -> [Char]
unString Values Funcons
s)) [Funcons]
vs
Funcons
_ -> Funcons -> [Char] -> Rewrite Rewritten
forall a. Funcons -> [Char] -> Rewrite a
sortErr ([Funcons] -> Funcons
lazy_adt_val_ (Funcons
vFuncons -> [Funcons] -> [Funcons]
forall a. a -> [a] -> [a]
:[Funcons]
vs)) ([Char]
"first argument of value constructor not a string")
evalLazyADT [] = Funcons -> [Char] -> Rewrite Rewritten
forall a. Funcons -> [Char] -> Rewrite a
sortErr ([Funcons] -> Funcons
lazy_adt_val_ [])
[Char]
"value constructor not applied to a string and a sequence of computations"
adt_construct_ :: [Funcons] -> Funcons
adt_construct_ = Name -> [Funcons] -> Funcons
applyFuncon Name
"adt-construct"
adtConstruct :: StrictFuncon
adtConstruct (Values Funcons
v:[Values Funcons]
vs) =
if Values Funcons -> Bool
forall t. HasValues t => Values t -> Bool
isString_ Values Funcons
v
then Values Funcons -> Rewrite Rewritten
rewritten (Values Funcons -> Rewrite Rewritten)
-> Values Funcons -> Rewrite Rewritten
forall a b. (a -> b) -> a -> b
$ Name -> [Funcons] -> Values Funcons
forall t. Name -> [t] -> Values t
ADTVal ([Char] -> Name
pack (Values Funcons -> [Char]
forall t. HasValues t => Values t -> [Char]
unString Values Funcons
v)) ([Funcons] -> Values Funcons) -> [Funcons] -> Values Funcons
forall a b. (a -> b) -> a -> b
$ (Values Funcons -> Funcons) -> [Values Funcons] -> [Funcons]
forall a b. (a -> b) -> [a] -> [b]
map Values Funcons -> Funcons
FValue [Values Funcons]
vs
else Funcons -> [Char] -> Rewrite Rewritten
forall a. Funcons -> [Char] -> Rewrite a
sortErr ([Funcons] -> Funcons
adt_val_ ((Values Funcons -> Funcons) -> [Values Funcons] -> [Funcons]
forall a b. (a -> b) -> [a] -> [b]
map Values Funcons -> Funcons
FValue (Values Funcons
vValues Funcons -> [Values Funcons] -> [Values Funcons]
forall a. a -> [a] -> [a]
:[Values Funcons]
vs))) ([Char]
"first argument of adt-construct not a string")
adtConstruct [] = Funcons -> [Char] -> Rewrite Rewritten
forall a. Funcons -> [Char] -> Rewrite a
sortErr ([Funcons] -> Funcons
adt_val_ [])
[Char]
"adt-construct not applied to a string and a sequence of fields"
adt_type_construct_ :: [Funcons] -> Funcons
adt_type_construct_ = Name -> [Funcons] -> Funcons
applyFuncon Name
"adt-type-construct"
adtTypeConstruct :: StrictFuncon
adtTypeConstruct (Values Funcons
v:[Values Funcons]
vs)
| Values Funcons -> Bool
forall t. HasValues t => Values t -> Bool
isString_ Values Funcons
v = Values Funcons -> Rewrite Rewritten
rewritten (Values Funcons -> Rewrite Rewritten)
-> Values Funcons -> Rewrite Rewritten
forall a b. (a -> b) -> a -> b
$ ComputationTypes Funcons -> Values Funcons
forall t. ComputationTypes t -> Values t
ComputationType (ComputationTypes Funcons -> Values Funcons)
-> ComputationTypes Funcons -> Values Funcons
forall a b. (a -> b) -> a -> b
$ Types Funcons -> ComputationTypes Funcons
forall t. Types t -> ComputationTypes t
Type (Types Funcons -> ComputationTypes Funcons)
-> Types Funcons -> ComputationTypes Funcons
forall a b. (a -> b) -> a -> b
$ Name -> [Funcons] -> Types Funcons
forall t. Name -> [t] -> Types t
ADT ([Char] -> Name
pack (Values Funcons -> [Char]
forall t. HasValues t => Values t -> [Char]
unString Values Funcons
v)) [Funcons]
fs
| Bool
otherwise = Funcons -> [Char] -> Rewrite Rewritten
forall a. Funcons -> [Char] -> Rewrite a
sortErr ([Funcons] -> Funcons
adt_val_ (Values Funcons -> Funcons
FValue Values Funcons
v Funcons -> [Funcons] -> [Funcons]
forall a. a -> [a] -> [a]
: [Funcons]
fs)) ([Char]
"first argument of adt-type-construct not a string")
where fs :: [Funcons]
fs = (Values Funcons -> Funcons) -> [Values Funcons] -> [Funcons]
forall a b. (a -> b) -> [a] -> [b]
map Values Funcons -> Funcons
FValue [Values Funcons]
vs
adtTypeConstruct [] = Funcons -> [Char] -> Rewrite Rewritten
forall a. Funcons -> [Char] -> Rewrite a
sortErr ([Funcons] -> Funcons
adt_val_ [])
[Char]
"adt-type-construct not applied to a string and a sequence of type arguments (values)"
adt_constructor_ :: [Funcons] -> Funcons
adt_constructor_ = Name -> [Funcons] -> Funcons
applyFuncon Name
"adt-constructor"
adtConstructor :: StrictFuncon
adtConstructor [ADTVal Name
cons [Funcons]
_] = Values Funcons -> Rewrite Rewritten
rewritten (Values Funcons -> Rewrite Rewritten)
-> Values Funcons -> Rewrite Rewritten
forall a b. (a -> b) -> a -> b
$ [Char] -> Values Funcons
string__ (Name -> [Char]
unpack Name
cons)
adtConstructor [Values Funcons]
vs = Funcons -> [Char] -> Rewrite Rewritten
forall a. Funcons -> [Char] -> Rewrite a
sortErr ([Funcons] -> Funcons
adt_constructor_ ((Values Funcons -> Funcons) -> [Values Funcons] -> [Funcons]
forall a b. (a -> b) -> [a] -> [b]
map Values Funcons -> Funcons
FValue [Values Funcons]
vs)) [Char]
"argument of adt-constructor not an adt value"
adt_fields_ :: [Funcons] -> Funcons
adt_fields_ = Name -> [Funcons] -> Funcons
applyFuncon Name
"adt-fields"
adtFields :: StrictFuncon
adtFields [ADTVal Name
_ [Funcons]
fs] = Values Funcons -> Rewrite Rewritten
rewritten (Values Funcons -> Rewrite Rewritten)
-> Values Funcons -> Rewrite Rewritten
forall a b. (a -> b) -> a -> b
$ Name -> [Funcons] -> Values Funcons
forall t. Name -> [t] -> Values t
ADTVal Name
"list" [Funcons]
fs
adtFields [Values Funcons]
vs = Funcons -> [Char] -> Rewrite Rewritten
forall a. Funcons -> [Char] -> Rewrite a
sortErr ([Funcons] -> Funcons
adt_fields_ ((Values Funcons -> Funcons) -> [Values Funcons] -> [Funcons]
forall a b. (a -> b) -> [a] -> [b]
map Values Funcons -> Funcons
FValue [Values Funcons]
vs)) [Char]
"argument of adt-fields not an adt value"