{-# LANGUAGE OverloadedStrings #-}
module Funcons.Core.Values.Composite.Variants.Variants where
import Funcons.EDSL
import Funcons.Operations hiding (Values)
entities = []
types = typeEnvFromList
[("variants",DataTypeMemberss "variants" [TPVar "MIT"] [DataTypeMemberConstructor "variant" [TName "ids",TName "defined-values"] (Just [TPVar "MIT"])])]
funcons = libFromList
[("variant",StrictFuncon stepVariant),("variant-id",StrictFuncon stepVariant_id),("variant-value",StrictFuncon stepVariant_value),("variants",StrictFuncon stepVariants)]
variant_ fargs = FApp "variant" (fargs)
stepVariant fargs =
evalRules [rewrite1] []
where rewrite1 = do
let env = emptyEnv
env <- vsMatch fargs [VPMetaVar "_X1",VPMetaVar "_X2"] env
env <- sideCondition (SCIsInSort (TVar "_X1") (TName "values")) env
env <- sideCondition (SCIsInSort (TVar "_X2") (TName "values")) env
rewriteTermTo (TApp "datatype-value" [TFuncon (FValue (ADTVal "list" [FValue (Ascii 'v'),FValue (Ascii 'a'),FValue (Ascii 'r'),FValue (Ascii 'i'),FValue (Ascii 'a'),FValue (Ascii 'n'),FValue (Ascii 't')])),TVar "_X1",TVar "_X2"]) env
variant_id_ fargs = FApp "variant-id" (fargs)
stepVariant_id fargs =
evalRules [rewrite1] []
where rewrite1 = do
let env = emptyEnv
env <- vsMatch fargs [PADT "variant" [VPAnnotated (VPMetaVar "I") (TName "ids"),VPAnnotated (VPMetaVar "DV") (TName "defined-values")]] env
rewriteTermTo (TVar "I") env
variant_value_ fargs = FApp "variant-value" (fargs)
stepVariant_value fargs =
evalRules [rewrite1] []
where rewrite1 = do
let env = emptyEnv
env <- vsMatch fargs [PADT "variant" [VPAnnotated (VPMetaVar "I") (TName "ids"),VPAnnotated (VPMetaVar "DV") (TName "defined-values")]] env
rewriteTermTo (TVar "DV") env
variants_ = FApp "variants"
stepVariants ts = rewriteType "variants" ts