{-# LANGUAGE OverloadedStrings #-}

module Funcons.Operations.ADTs where

import Funcons.Operations.Internal

import Data.Text (pack, unpack)
import Data.String(fromString)

library :: HasValues t => Ord t => Library t
library :: Library t
library = [(OP, ValueOp t)] -> Library t
forall t. [(OP, ValueOp t)] -> Library t
libFromList [
    (OP
"adts", NullaryExpr t -> ValueOp t
forall t. NullaryExpr t -> ValueOp t
NullaryExpr NullaryExpr t
forall t. HasValues t => OpExpr t
adts)
  , (OP
"adt-construct", NaryExpr t -> ValueOp t
forall t. NaryExpr t -> ValueOp t
NaryExpr NaryExpr t
forall t. HasValues t => [OpExpr t] -> OpExpr t
adt_construct_)
  , (OP
"adt-type", NaryExpr t -> ValueOp t
forall t. NaryExpr t -> ValueOp t
NaryExpr NaryExpr t
forall t. HasValues t => [OpExpr t] -> OpExpr t
adt_type_construct_)
  , (OP
"adt-type-construct", NaryExpr t -> ValueOp t
forall t. NaryExpr t -> ValueOp t
NaryExpr NaryExpr t
forall t. HasValues t => [OpExpr t] -> OpExpr t
adt_type_construct_)
  , (OP
"adt-constructor", UnaryExpr t -> ValueOp t
forall t. UnaryExpr t -> ValueOp t
UnaryExpr UnaryExpr t
forall t. HasValues t => OpExpr t -> OpExpr t
adt_constructor)
  , (OP
"adt-fields", UnaryExpr t -> ValueOp t
forall t. UnaryExpr t -> ValueOp t
UnaryExpr UnaryExpr t
forall t. HasValues t => OpExpr t -> OpExpr t
adt_fields)
  ]

adts_ :: HasValues t => [OpExpr t] -> OpExpr t
adts_ :: [OpExpr t] -> OpExpr t
adts_ = OpExpr t -> [OpExpr t] -> OpExpr t
forall t. NullaryExpr t -> [NullaryExpr t] -> NullaryExpr t
nullaryOp OpExpr t
forall t. HasValues t => OpExpr t
adts
adts :: HasValues t => OpExpr t
adts :: OpExpr t
adts = OP -> NullaryOp t -> OpExpr t
forall t. OP -> NullaryOp t -> OpExpr t
NullaryOp OP
"adts" (t -> NullaryOp t
forall t. t -> Result t
Normal (t -> NullaryOp t) -> t -> NullaryOp t
forall a b. (a -> b) -> a -> b
$ Types t -> t
forall t. HasTypes t => Types t -> t
injectT Types t
forall t. Types t
ADTs)

adt_construct_ :: HasValues t => [OpExpr t] -> OpExpr t
adt_construct_ :: [OpExpr t] -> OpExpr t
adt_construct_ = OP -> NaryOp t -> [OpExpr t] -> OpExpr t
forall t. OP -> NaryOp t -> [OpExpr t] -> OpExpr t
NaryOp OP
"adt-construct" NaryOp t
forall t. HasValues t => [t] -> Result t
op
  where op :: HasValues t => [t] -> Result t
        op :: [t] -> Result t
op (t
x : [t]
vs) = case t -> Maybe (Values t)
forall t. HasValues t => t -> Maybe (Values t)
project t
x of
          Just Values t
v -> 
            if Values t -> Bool
forall t. HasValues t => Values t -> Bool
isString_ Values t
v 
              then t -> Result t
forall t. t -> Result t
Normal (t -> Result t) -> t -> Result t
forall a b. (a -> b) -> a -> b
$ Values t -> t
forall t. HasValues t => Values t -> t
inject (Values t -> t) -> Values t -> t
forall a b. (a -> b) -> a -> b
$ Name -> [t] -> Values t
forall t. Name -> [t] -> Values t
ADTVal (OP -> Name
pack (Values t -> OP
forall t. HasValues t => Values t -> OP
unString Values t
v)) [t]
vs
              else OP -> Result t
forall t. OP -> Result t
SortErr OP
"adt-construct: first argument not a string"
          Maybe (Values t)
_      -> OP -> Result t
forall t. OP -> Result t
ProjErr OP
"adt-construct"
        op [t]
_  = OP -> Result t
forall t. OP -> Result t
SortErr OP
"adt-construct: insufficient arguments"

adt_type_construct_ :: HasValues t => [OpExpr t] -> OpExpr t
adt_type_construct_ :: [OpExpr t] -> OpExpr t
adt_type_construct_ = OP -> NaryVOp t -> [OpExpr t] -> OpExpr t
forall t. HasValues t => OP -> NaryVOp t -> [OpExpr t] -> OpExpr t
vNaryOp OP
"adt-type-construct" NaryVOp t
forall t. HasValues t => [Values t] -> Result t
op
  where op :: [Values t] -> Result t
op (Values t
s : [Values t]
vs) 
          | Values t -> Bool
forall t. HasValues t => Values t -> Bool
isString_ Values t
s = t -> Result t
forall t. t -> Result t
Normal (t -> Result t) -> t -> Result t
forall a b. (a -> b) -> a -> b
$ Types t -> t
forall t. HasTypes t => Types t -> t
injectT (Types t -> t) -> Types t -> t
forall a b. (a -> b) -> a -> b
$ Name -> [t] -> Types t
forall t. Name -> [t] -> Types t
ADT (OP -> Name
pack (Values t -> OP
forall t. HasValues t => Values t -> OP
unString Values t
s))
                            ((Values t -> t) -> [Values t] -> [t]
forall a b. (a -> b) -> [a] -> [b]
map Values t -> t
forall t. HasValues t => Values t -> t
inject [Values t]
vs)
        op [Values t]
_  = OP -> Result t
forall t. OP -> Result t
SortErr OP
"adt-construct: first argument not a string"

adt_constructor_ :: HasValues t => [OpExpr t] -> OpExpr t
adt_constructor_ :: [OpExpr t] -> OpExpr t
adt_constructor_ = UnaryExpr t -> [OpExpr t] -> OpExpr t
forall t. UnaryExpr t -> [OpExpr t] -> OpExpr t
unaryOp UnaryExpr t
forall t. HasValues t => OpExpr t -> OpExpr t
adt_constructor
adt_constructor :: HasValues t => OpExpr t -> OpExpr t
adt_constructor :: OpExpr t -> OpExpr t
adt_constructor = OP -> UnaryVOp t -> OpExpr t -> OpExpr t
forall t. HasValues t => OP -> UnaryVOp t -> OpExpr t -> OpExpr t
vUnaryOp OP
"adt-constructor" UnaryVOp t
forall t t. HasValues t => Values t -> Result t
op
  where op :: Values t -> Result t
op (ADTVal Name
cons [t]
_) = t -> Result t
forall t. t -> Result t
Normal (t -> Result t) -> t -> Result t
forall a b. (a -> b) -> a -> b
$ Values t -> t
forall t. HasValues t => Values t -> t
inject (Values t -> t) -> Values t -> t
forall a b. (a -> b) -> a -> b
$ OP -> Values t
forall a. IsString a => OP -> a
fromString (Name -> OP
unpack Name
cons)
        op Values t
_ = OP -> Result t
forall t. OP -> Result t
SortErr OP
"adt-constructor: argument not an adt value"

adt_fields_ :: HasValues t => [OpExpr t] -> OpExpr t
adt_fields_ :: [OpExpr t] -> OpExpr t
adt_fields_ = UnaryExpr t -> [OpExpr t] -> OpExpr t
forall t. UnaryExpr t -> [OpExpr t] -> OpExpr t
unaryOp UnaryExpr t
forall t. HasValues t => OpExpr t -> OpExpr t
adt_fields
adt_fields :: HasValues t => OpExpr t -> OpExpr t
adt_fields :: OpExpr t -> OpExpr t
adt_fields = OP -> UnaryVOp t -> OpExpr t -> OpExpr t
forall t. HasValues t => OP -> UnaryVOp t -> OpExpr t -> OpExpr t
vUnaryOp OP
"adt-fields" UnaryVOp t
forall t. HasValues t => Values t -> Result t
op
  where op :: Values t -> Result t
op (ADTVal Name
_ [t]
fs) = t -> Result t
forall t. t -> Result t
Normal (t -> Result t) -> t -> Result t
forall a b. (a -> b) -> a -> b
$ Values t -> t
forall t. HasValues t => Values t -> t
inject (Values t -> t) -> Values t -> t
forall a b. (a -> b) -> a -> b
$ Name -> [t] -> Values t
forall t. Name -> [t] -> Values t
ADTVal Name
"list" [t]
fs 
        op Values t
_ = OP -> Result t
forall t. OP -> Result t
SortErr OP
"adt-fields: argument not an adt value"