{-# 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"