{-# 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)
    -- backwards compatibility
    ,   (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"