diff --git a/cbs/Funcons/Core/Abstractions/Closures/Close.hs b/cbs/Funcons/Core/Abstractions/Closures/Close.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Abstractions/Closures/Close.hs +++ /dev/null @@ -1,26 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Abstractions/Closures/close.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Abstractions.Closures.Close where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("close",StrictFuncon stepClose)] - --- | --- /close(_)/ closes a thunked computation with respect to the --- current environment. -close_ fargs = FApp "close" (FTuple fargs) -stepClose fargs = - evalRules [] [step1] - where step1 = do - let env = emptyEnv - env <- lifted_vsMatch fargs [VPAnnotated (VPMetaVar "F") (TApp "thunks" (TTuple [TSortComputes (TName "values")]))] env - env <- getInhPatt "environment" (VPMetaVar "Rho") env - stepTermTo (TApp "thunk" (TTuple [TApp "closure" (TTuple [TApp "force" (TTuple [TVar "F"]),TVar "Rho"])])) env diff --git a/cbs/Funcons/Core/Abstractions/Closures/Closure.hs b/cbs/Funcons/Core/Abstractions/Closures/Closure.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Abstractions/Closures/Closure.hs +++ /dev/null @@ -1,31 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Abstractions/Closures/closure.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Abstractions.Closures.Closure where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("closure",PartiallyStrictFuncon [NonStrict,Strict] stepClosure)] - --- | --- /closure(X,Rho)/ evaluates /X/ using /Rho/ as the current environment. -closure_ fargs = FApp "closure" (FTuple fargs) -stepClosure fargs@[arg1,arg2] = - evalRules [rewrite1] [step1] - where rewrite1 = do - let env = emptyEnv - env <- fsMatch fargs [PAnnotated (PMetaVar "V") (TName "values"),PAnnotated (PWildCard) (TName "environments")] env - rewriteTermTo (TVar "V") env - step1 = do - let env = emptyEnv - env <- lifted_fsMatch fargs [PMetaVar "X",PAnnotated (PMetaVar "Rho") (TName "environments")] env - env <- getInhPatt "environment" (VPWildCard) env - env <- withInhTerm "environment" (TTuple [TVar "Rho"]) env (premise (TVar "X") (PMetaVar "X'") env) - stepTermTo (TApp "closure" (TTuple [TVar "X'",TVar "Rho"])) env -stepClosure fargs = sortErr (FApp "closure" (FTuple fargs)) "invalid number of arguments" diff --git a/cbs/Funcons/Core/Abstractions/Functions/Apply.hs b/cbs/Funcons/Core/Abstractions/Functions/Apply.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Abstractions/Functions/Apply.hs +++ /dev/null @@ -1,24 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Abstractions/Functions/apply.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Abstractions.Functions.Apply where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("apply",StrictFuncon stepApply)] - --- | --- /apply(F,V)/ applies the function /F/ to the value /V/ . -apply_ fargs = FApp "apply" (FTuple fargs) -stepApply fargs = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "F") (TName "values"),VPAnnotated (VPMetaVar "V") (TName "values")] env - rewriteTermTo (TApp "give" (TTuple [TVar "V",TApp "force" (TTuple [TVar "F"])])) env diff --git a/cbs/Funcons/Core/Abstractions/Functions/BindingLambda.hs b/cbs/Funcons/Core/Abstractions/Functions/BindingLambda.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Abstractions/Functions/BindingLambda.hs +++ /dev/null @@ -1,26 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Abstractions/Functions/binding-lambda.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Abstractions.Functions.BindingLambda where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("binding-lambda",PartiallyStrictFuncon [Strict,NonStrict] stepBinding_lambda)] - --- | --- /binding-lambda(B,E)/ computes a statically scoped function (i.e. a closed --- thunk). When applied to a value /V/ , free occurrences of /bound(B)/ in /E/ refer to /V/ . -binding_lambda_ fargs = FApp "binding-lambda" (FTuple fargs) -stepBinding_lambda fargs@[arg1,arg2] = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- fsMatch fargs [PAnnotated (PMetaVar "B") (TName "values"),PMetaVar "E"] env - rewriteTermTo (TApp "lambda" (TTuple [TApp "scope" (TTuple [TApp "bind" (TTuple [TVar "B",TName "given"]),TVar "E"])])) env -stepBinding_lambda fargs = sortErr (FApp "binding-lambda" (FTuple fargs)) "invalid number of arguments" diff --git a/cbs/Funcons/Core/Abstractions/Functions/Compose.hs b/cbs/Funcons/Core/Abstractions/Functions/Compose.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Abstractions/Functions/Compose.hs +++ /dev/null @@ -1,25 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Abstractions/Functions/compose.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Abstractions.Functions.Compose where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("compose",StrictFuncon stepCompose)] - --- | --- /compose(G,F)/ composes two functions /G/ and /F/ by --- giving the result of /F/ as the argument to /G/ . -compose_ fargs = FApp "compose" (FTuple fargs) -stepCompose fargs = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "G") (TName "values"),VPAnnotated (VPMetaVar "F") (TName "values")] env - rewriteTermTo (TApp "thunk" (TTuple [TApp "apply" (TTuple [TVar "G",TApp "apply" (TTuple [TVar "F",TName "given"])])])) env diff --git a/cbs/Funcons/Core/Abstractions/Functions/Curry.hs b/cbs/Funcons/Core/Abstractions/Functions/Curry.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Abstractions/Functions/Curry.hs +++ /dev/null @@ -1,26 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Abstractions/Functions/curry.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Abstractions.Functions.Curry where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("curry",StrictFuncon stepCurry)] - --- | --- /curry(F)/ converts a function that takes a pair of arguments into a function --- that takes the first argument of the pair, and returns a function that takes --- the second argument of the pair. -curry_ fargs = FApp "curry" (FTuple fargs) -stepCurry fargs = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "F") (TName "values")] env - rewriteTermTo (TApp "thunk" (TTuple [TApp "partial-apply" (TTuple [TVar "F",TName "given"])])) env diff --git a/cbs/Funcons/Core/Abstractions/Functions/Lambda.hs b/cbs/Funcons/Core/Abstractions/Functions/Lambda.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Abstractions/Functions/Lambda.hs +++ /dev/null @@ -1,25 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Abstractions/Functions/lambda.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Abstractions.Functions.Lambda where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("lambda",NonStrictFuncon stepLambda)] - --- | --- /lambda(E)/ computes a statically scoped function (i.e. a closed thunk). --- When applied to a value /V/ , free occurrences of /given/ in /E/ refer to /V/ . -lambda_ fargs = FApp "lambda" (FTuple fargs) -stepLambda fargs = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- fsMatch fargs [PMetaVar "E"] env - rewriteTermTo (TApp "close" (TTuple [TApp "thunk" (TTuple [TVar "E"])])) env diff --git a/cbs/Funcons/Core/Abstractions/Functions/PartialApply.hs b/cbs/Funcons/Core/Abstractions/Functions/PartialApply.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Abstractions/Functions/PartialApply.hs +++ /dev/null @@ -1,26 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Abstractions/Functions/partial-apply.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Abstractions.Functions.PartialApply where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("partial-apply",StrictFuncon stepPartial_apply)] - --- | --- /partial-apply(F,V)/ provides /V/ as the first argument to a function --- expecting a pair of arguments, returning a function expecting only the --- second argument. -partial_apply_ fargs = FApp "partial-apply" (FTuple fargs) -stepPartial_apply fargs = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "F") (TName "values"),VPAnnotated (VPMetaVar "V") (TName "values")] env - rewriteTermTo (TApp "thunk" (TTuple [TApp "apply" (TTuple [TVar "F",TTuple [TVar "V",TName "given"]])])) env diff --git a/cbs/Funcons/Core/Abstractions/Functions/Supply.hs b/cbs/Funcons/Core/Abstractions/Functions/Supply.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Abstractions/Functions/Supply.hs +++ /dev/null @@ -1,26 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Abstractions/Functions/supply.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Abstractions.Functions.Supply where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("supply",StrictFuncon stepSupply)] - --- | --- /supply(V,F)/ supplies /V/ as the argument to the function /F/ , without --- executing the function. The result is a thunk that does not depend on --- an argument when forced. -supply_ fargs = FApp "supply" (FTuple fargs) -stepSupply fargs = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "V") (TName "values"),VPAnnotated (VPMetaVar "F") (TName "values")] env - rewriteTermTo (TApp "thunk" (TTuple [TApp "apply" (TTuple [TVar "F",TVar "V"])])) env diff --git a/cbs/Funcons/Core/Abstractions/Functions/Uncurry.hs b/cbs/Funcons/Core/Abstractions/Functions/Uncurry.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Abstractions/Functions/Uncurry.hs +++ /dev/null @@ -1,25 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Abstractions/Functions/uncurry.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Abstractions.Functions.Uncurry where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("uncurry",StrictFuncon stepUncurry)] - --- | --- /uncurry(F)/ converts a function that computes a function into a single --- function that takes both arguments as a pair. -uncurry_ fargs = FApp "uncurry" (FTuple fargs) -stepUncurry fargs = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "F") (TName "values")] env - rewriteTermTo (TApp "thunk" (TTuple [TApp "apply" (TTuple [TApp "apply" (TTuple [TVar "F",TName "given1"]),TName "given2"])])) env diff --git a/cbs/Funcons/Core/Abstractions/IsGroundValue.hs b/cbs/Funcons/Core/Abstractions/IsGroundValue.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Abstractions/IsGroundValue.hs +++ /dev/null @@ -1,69 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Abstractions/is-ground-value.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Abstractions.IsGroundValue where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("is-ground-value",StrictFuncon stepIs_ground_value)] - --- | --- A ground-value is any (potentially composite) value that --- does not contain thunks anywhere within it. -is_ground_value_ fargs = FApp "is-ground-value" (FTuple fargs) -stepIs_ground_value fargs = - evalRules [rewrite1,rewrite2,rewrite3,rewrite4,rewrite5,rewrite6,rewrite7,rewrite8,rewrite9,rewrite10] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [VPMetaVar "V"] env - env <- sideCondition (SCNotInSort (TVar "V") (TApp "thunks" (TTuple [TSortComputes (TName "values")]))) env - env <- sideCondition (SCNotInSort (TVar "V") (TName "algebraic-datatypes")) env - env <- sideCondition (SCNotInSort (TVar "V") (TApp "lists" (TTuple [TName "values"]))) env - env <- sideCondition (SCNotInSort (TVar "V") (TApp "maps" (TTuple [TName "values",TName "values"]))) env - env <- sideCondition (SCNotInSort (TVar "V") (TApp "multisets" (TTuple [TName "values"]))) env - env <- sideCondition (SCNotInSort (TVar "V") (TApp "sets" (TTuple [TName "values"]))) env - env <- sideCondition (SCNotInSort (TVar "V") (TApp "tuples" (TTuple [TName "values",TSortSeq (TName "values") PlusOp]))) env - env <- sideCondition (SCNotInSort (TVar "V") (TApp "vectors" (TTuple [TName "values"]))) env - rewriteTo (FName "true") - rewrite2 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPWildCard) (TApp "thunks" (TTuple [TSortComputes (TName "values")]))] env - rewriteTo (FName "false") - rewrite3 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "A") (TName "algebraic-datatypes")] env - rewriteTermTo (TApp "is-ground-value" (TTuple [TApp "algebraic-datatype-value" (TTuple [TVar "A"])])) env - rewrite4 = do - let env = emptyEnv - env <- vsMatch fargs [PList []] env - rewriteTo (FName "true") - rewrite5 = do - let env = emptyEnv - env <- vsMatch fargs [PList [VPMetaVar "V",VPSeqVar "V*" StarOp]] env - rewriteTermTo (TApp "and" (TTuple [TApp "is-ground-value" (TTuple [TVar "V"]),TApp "is-ground-value" (TList [TVar "V*"])])) env - rewrite6 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "M") (TApp "maps" (TTuple [TName "values",TName "values"]))] env - rewriteTermTo (TApp "is-ground-value" (TTuple [TApp "map-to-list" (TTuple [TVar "M"])])) env - rewrite7 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "M") (TApp "multisets" (TTuple [TName "values"]))] env - rewriteTermTo (TApp "is-ground-value" (TTuple [TApp "multiset-to-set" (TTuple [TVar "M"])])) env - rewrite8 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "S") (TApp "sets" (TTuple [TName "values"]))] env - rewriteTermTo (TApp "is-ground-value" (TTuple [TApp "set-to-list" (TTuple [TVar "S"])])) env - rewrite9 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "V") (TName "values"),VPAnnotated (VPSeqVar "V+" PlusOp) (TName "values")] env - rewriteTermTo (TApp "and" (TTuple [TApp "is-ground-value" (TTuple [TVar "V"]),TApp "is-ground-value" (TTuple [TVar "V+"])])) env - rewrite10 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "V") (TApp "vectors" (TTuple [TName "values"]))] env - rewriteTermTo (TApp "is-ground-value" (TTuple [TApp "vector-to-list" (TTuple [TVar "V"])])) env diff --git a/cbs/Funcons/Core/Abstractions/Patterns/Case.hs b/cbs/Funcons/Core/Abstractions/Patterns/Case.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Abstractions/Patterns/Case.hs +++ /dev/null @@ -1,27 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Abstractions/Patterns/case.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Abstractions.Patterns.Case where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("case",PartiallyStrictFuncon [Strict,NonStrict] stepCase)] - --- | --- /case(P,X)/ attempts to match the (potentially composite) /given-value/ against the (potentially composite) pattern /P/ . --- If successful, /X/ is executed in the scope of any computed bindings. --- Otherwise, it fails. -case_ fargs = FApp "case" (FTuple fargs) -stepCase fargs@[arg1,arg2] = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- fsMatch fargs [PAnnotated (PMetaVar "P") (TName "values"),PMetaVar "F"] env - rewriteTermTo (TApp "scope" (TTuple [TApp "match" (TTuple [TName "given",TVar "P"]),TVar "F"])) env -stepCase fargs = sortErr (FApp "case" (FTuple fargs)) "invalid number of arguments" diff --git a/cbs/Funcons/Core/Abstractions/Patterns/Match.hs b/cbs/Funcons/Core/Abstractions/Patterns/Match.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Abstractions/Patterns/Match.hs +++ /dev/null @@ -1,70 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Abstractions/Patterns/match.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Abstractions.Patterns.Match where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("match",StrictFuncon stepMatch)] - --- | --- /match(V,P)/ matches the (potentially composite) value /V/ against the --- (potentially composite) pattern /P/ . -match_ fargs = FApp "match" (FTuple fargs) -stepMatch fargs = - evalRules [rewrite1,rewrite2,rewrite3,rewrite4,rewrite5,rewrite6,rewrite7,rewrite8,rewrite9,rewrite10] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "V") (TName "values"),VPAnnotated (VPMetaVar "P") (TApp "thunks" (TTuple [TSortComputesFrom (TName "values") (TName "environments")]))] env - rewriteTermTo (TApp "apply" (TTuple [TVar "P",TVar "V"])) env - rewrite2 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "V") (TName "values"),VPMetaVar "P"] env - env <- sideCondition (SCNotInSort (TVar "P") (TApp "thunks" (TTuple [TSortComputesFrom (TName "values") (TName "environments")]))) env - env <- sideCondition (SCNotInSort (TVar "P") (TName "algebraic-datatypes")) env - env <- sideCondition (SCNotInSort (TVar "P") (TApp "lists" (TTuple [TName "values"]))) env - env <- sideCondition (SCNotInSort (TVar "P") (TApp "maps" (TTuple [TName "values",TName "values"]))) env - env <- sideCondition (SCNotInSort (TVar "P") (TApp "tuples" (TTuple [TName "values",TSortSeq (TName "values") PlusOp]))) env - env <- sideCondition (SCNotInSort (TVar "P") (TApp "vectors" (TTuple [TName "values"]))) env - rewriteTermTo (TApp "sequential" (TTuple [TApp "check-true" (TTuple [TApp "is-equal" (TTuple [TVar "V",TVar "P"])]),TName "map-empty"])) env - rewrite3 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "V") (TName "values"),VPAnnotated (VPMetaVar "P") (TName "algebraic-datatypes")] env - rewriteTermTo (TApp "sequential" (TTuple [TApp "check-true" (TTuple [TApp "is-in-type" (TTuple [TVar "V",TName "algebraic-datatypes"])]),TApp "check-true" (TTuple [TApp "is-equal" (TTuple [TApp "algebraic-datatype-constructor" (TTuple [TVar "V"]),TApp "algebraic-datatype-constructor" (TTuple [TVar "P"])])]),TApp "match" (TTuple [TApp "algebraic-datatype-value" (TTuple [TVar "V"]),TApp "algebraic-datatype-value" (TTuple [TVar "P"])])])) env - rewrite4 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "V") (TName "values"),PList []] env - rewriteTermTo (TApp "sequential" (TTuple [TApp "check-true" (TTuple [TApp "is-equal" (TTuple [TVar "V",TList []])]),TName "map-empty"])) env - rewrite5 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "V") (TName "values"),PList [VPMetaVar "P",VPSeqVar "P*" StarOp]] env - rewriteTermTo (TApp "sequential" (TTuple [TApp "check-true" (TTuple [TApp "is-in-type" (TTuple [TVar "V",TApp "lists" (TTuple [TName "values"])])]),TApp "check-true" (TTuple [TApp "not" (TTuple [TApp "is-nil" (TTuple [TVar "V"])])]),TApp "map-unite" (TTuple [TApp "match" (TTuple [TApp "head" (TTuple [TVar "V"]),TVar "P"]),TApp "match" (TTuple [TApp "tail" (TTuple [TVar "V"]),TList [TVar "P*"]])])])) env - rewrite6 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "V") (TName "values"),VPMetaVar "P"] env - env <- sideCondition (SCEquality (TVar "P") (TName "map-empty")) env - rewriteTermTo (TApp "sequential" (TTuple [TApp "check-true" (TTuple [TApp "is-equal" (TTuple [TVar "V",TName "map-empty"])]),TName "map-empty"])) env - rewrite7 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "VM") (TName "values"),VPAnnotated (VPMetaVar "PM") (TApp "maps" (TTuple [TName "values",TName "values"]))] env - env <- sideCondition (SCPatternMatch (TApp "some-element" (TTuple [TApp "domain" (TTuple [TVar "PM"])])) (VPMetaVar "K")) env - rewriteTermTo (TApp "sequential" (TTuple [TApp "check-true" (TTuple [TApp "is-in-type" (TTuple [TVar "VM",TApp "maps" (TTuple [TName "values",TName "values"])])]),TApp "check-true" (TTuple [TApp "is-equal" (TTuple [TApp "domain" (TTuple [TVar "PM"]),TApp "domain" (TTuple [TVar "VM"])])]),TApp "map-unite" (TTuple [TApp "match" (TTuple [TApp "lookup" (TTuple [TVar "K",TVar "VM"]),TApp "lookup" (TTuple [TVar "K",TVar "PM"])]),TApp "match" (TTuple [TApp "map-delete" (TTuple [TVar "VM",TSet [TVar "K"]]),TApp "map-delete" (TTuple [TVar "PM",TSet [TVar "K"]])])])])) env - rewrite8 = do - let env = emptyEnv - env <- vsMatch fargs [PTuple [VPAnnotated (VPMetaVar "V") (TName "values"),VPAnnotated (VPSeqVar "V+" PlusOp) (TName "values")],PTuple [VPAnnotated (VPMetaVar "P") (TName "values"),VPAnnotated (VPSeqVar "P+" PlusOp) (TName "values")]] env - rewriteTermTo (TApp "map-unite" (TTuple [TApp "match" (TTuple [TVar "V",TVar "P"]),TApp "match" (TTuple [TTuple [TVar "V+"],TTuple [TVar "P+"]])])) env - rewrite9 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "V") (TName "values"),PTuple [VPAnnotated (VPMetaVar "P") (TName "values"),VPAnnotated (VPSeqVar "P+" PlusOp) (TName "values")]] env - env <- sideCondition (SCNotInSort (TVar "V") (TApp "tuples" (TTuple [TName "values",TSortSeq (TName "values") PlusOp]))) env - rewriteTo (FName "fail") - rewrite10 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "V") (TName "values"),VPAnnotated (VPMetaVar "P") (TApp "vectors" (TTuple [TName "patterns"]))] env - rewriteTermTo (TApp "sequential" (TTuple [TApp "check-true" (TTuple [TApp "is-in-type" (TTuple [TVar "V",TApp "vectors" (TTuple [TName "values"])])]),TApp "match" (TTuple [TApp "vector-to-list" (TTuple [TVar "V"]),TApp "vector-to-list" (TTuple [TVar "P"])])])) env diff --git a/cbs/Funcons/Core/Abstractions/Patterns/MatchLoosely.hs b/cbs/Funcons/Core/Abstractions/Patterns/MatchLoosely.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Abstractions/Patterns/MatchLoosely.hs +++ /dev/null @@ -1,81 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Abstractions/Patterns/match-loosely.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Abstractions.Patterns.MatchLoosely where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("match-loosely",StrictFuncon stepMatch_loosely)] - --- | --- /match-loosely(V,P)/ loosely matches the (potentially composite) value /V/ against the (potentially composite) pattern /P/ . In the case of /sets/ , --- /maps/ and /vectors/ , the pattern may be a sub-set/sub-multiset/sub-map/ --- sub-vector of the value being matched against (recursively). -match_loosely_ fargs = FApp "match-loosely" (FTuple fargs) -stepMatch_loosely fargs = - evalRules [rewrite1,rewrite2,rewrite3,rewrite4,rewrite5,rewrite6,rewrite7,rewrite8,rewrite9,rewrite10,rewrite11,rewrite12] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "V") (TName "values"),VPAnnotated (VPMetaVar "P") (TApp "thunks" (TTuple [TSortComputesFrom (TName "values") (TName "environments")]))] env - rewriteTermTo (TApp "apply" (TTuple [TVar "P",TVar "V"])) env - rewrite2 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "V") (TName "values"),VPMetaVar "P"] env - env <- sideCondition (SCNotInSort (TVar "P") (TApp "thunks" (TTuple [TSortComputesFrom (TName "values") (TName "environments")]))) env - env <- sideCondition (SCNotInSort (TVar "P") (TName "algebraic-datatypes")) env - env <- sideCondition (SCNotInSort (TVar "P") (TApp "lists" (TTuple [TName "values"]))) env - env <- sideCondition (SCNotInSort (TVar "P") (TApp "maps" (TTuple [TName "values",TName "values"]))) env - env <- sideCondition (SCNotInSort (TVar "P") (TApp "multisets" (TTuple [TName "values"]))) env - env <- sideCondition (SCNotInSort (TVar "P") (TApp "sets" (TTuple [TName "values"]))) env - env <- sideCondition (SCNotInSort (TVar "P") (TApp "tuples" (TTuple [TName "values",TSortSeq (TName "values") PlusOp]))) env - env <- sideCondition (SCNotInSort (TVar "P") (TApp "vectors" (TTuple [TName "values"]))) env - rewriteTermTo (TApp "sequential" (TTuple [TApp "check-true" (TTuple [TApp "is-equal" (TTuple [TVar "V",TVar "P"])]),TName "map-empty"])) env - rewrite3 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "V") (TName "values"),VPAnnotated (VPMetaVar "P") (TName "algebraic-datatypes")] env - rewriteTermTo (TApp "sequential" (TTuple [TApp "check-true" (TTuple [TApp "is-in-type" (TTuple [TVar "V",TName "algebraic-datatypes"])]),TApp "check-true" (TTuple [TApp "is-equal" (TTuple [TApp "algebraic-datatype-constructor" (TTuple [TVar "V"]),TApp "algebraic-datatype-constructor" (TTuple [TVar "P"])])]),TApp "match-loosely" (TTuple [TApp "algebraic-datatype-value" (TTuple [TVar "V"]),TApp "algebraic-datatype-value" (TTuple [TVar "P"])])])) env - rewrite4 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "V") (TName "values"),PList []] env - rewriteTermTo (TApp "sequential" (TTuple [TApp "check-true" (TTuple [TApp "is-equal" (TTuple [TVar "V",TList []])]),TName "map-empty"])) env - rewrite5 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "V") (TName "values"),PList [VPMetaVar "P",VPSeqVar "P*" StarOp]] env - rewriteTermTo (TApp "sequential" (TTuple [TApp "check-true" (TTuple [TApp "is-in-type" (TTuple [TVar "V",TApp "lists" (TTuple [TName "values"])])]),TApp "check-true" (TTuple [TApp "not" (TTuple [TApp "is-nil" (TTuple [TVar "V"])])]),TApp "map-unite" (TTuple [TApp "match-loosely" (TTuple [TApp "head" (TTuple [TVar "V"]),TVar "P"]),TApp "match-loosely" (TTuple [TApp "tail" (TTuple [TVar "V"]),TList [TVar "P*"]])])])) env - rewrite6 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "V") (TName "values"),VPMetaVar "P"] env - env <- sideCondition (SCEquality (TVar "P") (TName "map-empty")) env - rewriteTermTo (TApp "sequential" (TTuple [TApp "check-true" (TTuple [TApp "is-in-type" (TTuple [TVar "V",TApp "maps" (TTuple [TName "values",TName "values"])])]),TName "map-empty"])) env - rewrite7 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "VM") (TName "values"),VPAnnotated (VPMetaVar "PM") (TApp "maps" (TTuple [TName "values",TName "values"]))] env - env <- sideCondition (SCPatternMatch (TApp "some-element" (TTuple [TApp "domain" (TTuple [TVar "PM"])])) (VPMetaVar "K")) env - rewriteTermTo (TApp "sequential" (TTuple [TApp "check-true" (TTuple [TApp "is-in-type" (TTuple [TVar "VM",TApp "maps" (TTuple [TName "values",TName "values"])])]),TApp "check-true" (TTuple [TApp "is-subset" (TTuple [TApp "domain" (TTuple [TVar "PM"]),TApp "domain" (TTuple [TVar "VM"])])]),TApp "map-unite" (TTuple [TApp "match-loosely" (TTuple [TApp "lookup" (TTuple [TVar "K",TVar "VM"]),TApp "lookup" (TTuple [TVar "K",TVar "PM"])]),TApp "match-loosely" (TTuple [TApp "map-delete" (TTuple [TVar "VM",TSet [TVar "K"]]),TApp "map-delete" (TTuple [TVar "PM",TSet [TVar "K"]])])])])) env - rewrite8 = do - let env = emptyEnv - env <- vsMatch fargs [VPMetaVar "V",VPAnnotated (VPMetaVar "P") (TApp "multisets" (TTuple [TName "values"]))] env - rewriteTermTo (TApp "sequential" (TTuple [TApp "check-true" (TTuple [TApp "is-in-type" (TTuple [TVar "V",TApp "multisets" (TTuple [TName "values"])])]),TApp "check-true" (TTuple [TApp "is-submultiset" (TTuple [TVar "P",TVar "V"])]),TName "map-empty"])) env - rewrite9 = do - let env = emptyEnv - env <- vsMatch fargs [VPMetaVar "V",VPAnnotated (VPMetaVar "P") (TApp "sets" (TTuple [TName "values"]))] env - rewriteTermTo (TApp "sequential" (TTuple [TApp "check-true" (TTuple [TApp "is-in-type" (TTuple [TVar "V",TApp "sets" (TTuple [TName "values"])])]),TApp "check-true" (TTuple [TApp "is-subset" (TTuple [TVar "P",TVar "V"])]),TName "map-empty"])) env - rewrite10 = do - let env = emptyEnv - env <- vsMatch fargs [PTuple [VPAnnotated (VPMetaVar "V") (TName "values"),VPAnnotated (VPSeqVar "V+" PlusOp) (TName "values")],PTuple [VPAnnotated (VPMetaVar "P") (TName "values"),VPAnnotated (VPSeqVar "P+" PlusOp) (TName "values")]] env - rewriteTermTo (TApp "map-unite" (TTuple [TApp "match-loosely" (TTuple [TVar "V",TVar "P"]),TApp "match-loosely" (TTuple [TTuple [TVar "V+"],TTuple [TVar "P+"]])])) env - rewrite11 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "V") (TName "values"),PTuple [VPAnnotated (VPMetaVar "P") (TName "values"),VPAnnotated (VPSeqVar "P+" PlusOp) (TName "values")]] env - env <- sideCondition (SCNotInSort (TVar "V") (TApp "tuples" (TTuple [TName "values",TSortSeq (TName "values") PlusOp]))) env - rewriteTo (FName "fail") - rewrite12 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "V") (TName "values"),VPAnnotated (VPMetaVar "P") (TApp "vectors" (TTuple [TName "patterns"]))] env - rewriteTermTo (TApp "sequential" (TTuple [TApp "check-true" (TTuple [TApp "is-in-type" (TTuple [TVar "V",TApp "vectors" (TTuple [TName "values"])])]),TApp "check-true" (TTuple [TApp "is-greater-or-equal" (TTuple [TApp "vector-length" (TTuple [TVar "V"]),TApp "vector-length" (TTuple [TVar "P"])])]),TApp "match-loosely" (TTuple [TApp "list-prefix" (TTuple [TApp "vector-length" (TTuple [TVar "P"]),TApp "vector-to-list" (TTuple [TVar "V"])]),TApp "vector-to-list" (TTuple [TVar "P"])])])) env diff --git a/cbs/Funcons/Core/Abstractions/Patterns/PatternAny.hs b/cbs/Funcons/Core/Abstractions/Patterns/PatternAny.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Abstractions/Patterns/PatternAny.hs +++ /dev/null @@ -1,23 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Abstractions/Patterns/pattern-any.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Abstractions.Patterns.PatternAny where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("pattern-any",NullaryFuncon stepPattern_any)] - --- | --- /pattern-any/ is a pattern that matches any value, --- computing the empty environment. -pattern_any_ = FName "pattern-any" -stepPattern_any = evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - rewriteTo (FApp "thunk" (FTuple [FName "map-empty"])) diff --git a/cbs/Funcons/Core/Abstractions/Patterns/PatternBind.hs b/cbs/Funcons/Core/Abstractions/Patterns/PatternBind.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Abstractions/Patterns/PatternBind.hs +++ /dev/null @@ -1,25 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Abstractions/Patterns/pattern-bind.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Abstractions.Patterns.PatternBind where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("pattern-bind",StrictFuncon stepPattern_bind)] - --- | --- /pattern-bind(B)/ is a pattern that matches any value /V/ , --- computing the singleton environment /{B |-> V}/ -pattern_bind_ fargs = FApp "pattern-bind" (FTuple fargs) -stepPattern_bind fargs = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "B") (TName "values")] env - rewriteTermTo (TApp "thunk" (TTuple [TApp "bind" (TTuple [TVar "B",TName "given"])])) env diff --git a/cbs/Funcons/Core/Abstractions/Patterns/PatternPrefer.hs b/cbs/Funcons/Core/Abstractions/Patterns/PatternPrefer.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Abstractions/Patterns/PatternPrefer.hs +++ /dev/null @@ -1,26 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Abstractions/Patterns/pattern-prefer.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Abstractions.Patterns.PatternPrefer where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("pattern-prefer",StrictFuncon stepPattern_prefer)] - --- | --- /pattern-prefer(P1,P2)/ is a pattern that attempts to match the value against --- /P1/ . If this succeeds then the resulting environment is returned. --- Otherwise, the value is matched against /P2/ . -pattern_prefer_ fargs = FApp "pattern-prefer" (FTuple fargs) -stepPattern_prefer fargs = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "P1") (TName "values"),VPAnnotated (VPMetaVar "P2") (TName "values")] env - rewriteTermTo (TApp "thunk" (TTuple [TApp "else" (TTuple [TApp "match" (TTuple [TName "given",TVar "P1"]),TApp "match" (TTuple [TName "given",TVar "P2"])])])) env diff --git a/cbs/Funcons/Core/Abstractions/Patterns/PatternUnite.hs b/cbs/Funcons/Core/Abstractions/Patterns/PatternUnite.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Abstractions/Patterns/PatternUnite.hs +++ /dev/null @@ -1,25 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Abstractions/Patterns/pattern-unite.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Abstractions.Patterns.PatternUnite where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("pattern-unite",StrictFuncon stepPattern_unite)] - --- | --- /pattern-unite(P1,P2)/ is a pattern that requires the matched value to match --- both /P1/ and /P2/ , uniting the resulting /environments/ . -pattern_unite_ fargs = FApp "pattern-unite" (FTuple fargs) -stepPattern_unite fargs = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "P1") (TName "values"),VPAnnotated (VPMetaVar "P2") (TName "values")] env - rewriteTermTo (TApp "thunk" (TTuple [TApp "map-unite" (TTuple [TApp "match" (TTuple [TName "given",TVar "P1"]),TApp "match" (TTuple [TName "given",TVar "P2"])])])) env diff --git a/cbs/Funcons/Core/Abstractions/Patterns/Patterns.hs b/cbs/Funcons/Core/Abstractions/Patterns/Patterns.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Abstractions/Patterns/Patterns.hs +++ /dev/null @@ -1,20 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Abstractions/Patterns/patterns.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Abstractions.Patterns.Patterns where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("patterns",NullaryFuncon stepPatterns)] - -patterns_ = FName "patterns" -stepPatterns = evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - rewriteTo (FName "values") diff --git a/cbs/Funcons/Core/Computations/Abnormal/Abrupting/Abrupting.hs b/cbs/Funcons/Core/Computations/Abnormal/Abrupting/Abrupting.hs new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/Abnormal/Abrupting/Abrupting.hs @@ -0,0 +1,77 @@ +-- GeNeRaTeD fOr: ../../CBS-beta/Funcons-beta/Computations/Abnormal/Abrupting/Abrupting.cbs +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Computations.Abnormal.Abrupting.Abrupting where + +import Funcons.EDSL + +import Funcons.Operations hiding (Values) +entities = [] + +types = typeEnvFromList + [] + +funcons = libFromList + [("finalise-abrupting",NonStrictFuncon stepFinalise_abrupting),("abrupt",StrictFuncon stepAbrupt),("handle-abrupt",NonStrictFuncon stepHandle_abrupt),("finally",NonStrictFuncon stepFinally)] + +finalise_abrupting_ fargs = FApp "finalise-abrupting" (fargs) +stepFinalise_abrupting fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PMetaVar "X"] env + rewriteTermTo (TApp "handle-abrupt" [TVar "X",TName "none"]) env + +abrupt_ fargs = FApp "abrupt" (fargs) +stepAbrupt fargs = + evalRules [] [step1] + where step1 = do + let env = emptyEnv + env <- lifted_vsMatch fargs [VPAnnotated (VPMetaVar "V") (TName "defined-values")] env + env <- getControlPatt "abrupted" (Just (VPMetaVar "V")) env + raiseTerm "abrupted" (TVar "V") env + stepTermTo (TName "stuck") env + +handle_abrupt_ fargs = FApp "handle-abrupt" (fargs) +stepHandle_abrupt fargs = + evalRules [rewrite1] [step1,step2] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PAnnotated (PMetaVar "V") (TName "values"),PMetaVar "Y"] env + rewriteTermTo (TVar "V") env + step1 = do + let env = emptyEnv + env <- lifted_fsMatch fargs [PMetaVar "X",PMetaVar "Y"] env + env <- getControlPatt "abrupted" (Nothing) env + (env,[__varabrupted]) <- receiveSignals ["abrupted"] (withControlTerm "abrupted" (Nothing) env (premise (TVar "X") (PMetaVar "X'") env)) + env <- receiveSignalPatt __varabrupted (Nothing) env + stepTermTo (TApp "handle-abrupt" [TVar "X'",TVar "Y"]) env + step2 = do + let env = emptyEnv + env <- lifted_fsMatch fargs [PMetaVar "X",PMetaVar "Y"] env + env <- getControlPatt "abrupted" (Nothing) env + (env,[__varabrupted]) <- receiveSignals ["abrupted"] (withControlTerm "abrupted" (Just (TVar "V")) env (premise (TVar "X") (PMetaVar "X'") env)) + env <- receiveSignalPatt __varabrupted (Just (VPAnnotated (VPMetaVar "V") (TName "defined-values"))) env + stepTermTo (TApp "give" [TVar "V",TVar "Y"]) env + +finally_ fargs = FApp "finally" (fargs) +stepFinally fargs = + evalRules [rewrite1] [step1,step2] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PAnnotated (PMetaVar "V") (TName "values"),PMetaVar "Y"] env + rewriteTermTo (TApp "sequential" [TVar "Y",TVar "V"]) env + step1 = do + let env = emptyEnv + env <- lifted_fsMatch fargs [PMetaVar "X",PMetaVar "Y"] env + env <- getControlPatt "abrupted" (Nothing) env + (env,[__varabrupted]) <- receiveSignals ["abrupted"] (withControlTerm "abrupted" (Nothing) env (premise (TVar "X") (PMetaVar "X'") env)) + env <- receiveSignalPatt __varabrupted (Nothing) env + stepTermTo (TApp "finally" [TVar "X'",TVar "Y"]) env + step2 = do + let env = emptyEnv + env <- lifted_fsMatch fargs [PMetaVar "X",PMetaVar "Y"] env + env <- getControlPatt "abrupted" (Nothing) env + (env,[__varabrupted]) <- receiveSignals ["abrupted"] (withControlTerm "abrupted" (Just (TVar "V")) env (premise (TVar "X") (PMetaVar "X'") env)) + env <- receiveSignalPatt __varabrupted (Just (VPAnnotated (VPMetaVar "V") (TName "defined-values"))) env + stepTermTo (TApp "sequential" [TVar "Y",TApp "abrupt" [TVar "V"]]) env diff --git a/cbs/Funcons/Core/Computations/Abnormal/Breaking/Breaking.hs b/cbs/Funcons/Core/Computations/Abnormal/Breaking/Breaking.hs new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/Abnormal/Breaking/Breaking.hs @@ -0,0 +1,68 @@ +-- GeNeRaTeD fOr: ../../CBS-beta/Funcons-beta/Computations/Abnormal/Breaking/Breaking.cbs +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Computations.Abnormal.Breaking.Breaking where + +import Funcons.EDSL + +import Funcons.Operations hiding (Values) +entities = [] + +types = typeEnvFromList + [("breaking",DataTypeMemberss "breaking" [] [DataTypeMemberConstructor "broken" [] (Just [])])] + +funcons = libFromList + [("broken",NullaryFuncon stepBroken),("finalise-breaking",NonStrictFuncon stepFinalise_breaking),("break",NullaryFuncon stepBreak),("handle-break",NonStrictFuncon stepHandle_break),("breaking",NullaryFuncon stepBreaking)] + +broken_ = FName "broken" +stepBroken = evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + rewriteTermTo (TApp "datatype-value" [TFuncon (FValue (ADTVal "list" [FValue (Ascii 'b'),FValue (Ascii 'r'),FValue (Ascii 'o'),FValue (Ascii 'k'),FValue (Ascii 'e'),FValue (Ascii 'n')]))]) env + +finalise_breaking_ fargs = FApp "finalise-breaking" (fargs) +stepFinalise_breaking fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PMetaVar "X"] env + rewriteTermTo (TApp "finalise-abrupting" [TVar "X"]) env + +break_ = FName "break" +stepBreak = evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + rewriteTermTo (TApp "abrupt" [TName "broken"]) env + +handle_break_ fargs = FApp "handle-break" (fargs) +stepHandle_break fargs = + evalRules [rewrite1] [step1,step2,step3] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PValue (PADT "none" [])] env + rewriteTermTo (TName "none") env + step1 = do + let env = emptyEnv + env <- lifted_fsMatch fargs [PMetaVar "X"] env + env <- getControlPatt "abrupted" (Nothing) env + (env,[__varabrupted]) <- receiveSignals ["abrupted"] (withControlTerm "abrupted" (Nothing) env (premise (TVar "X") (PMetaVar "X'") env)) + env <- receiveSignalPatt __varabrupted (Nothing) env + stepTermTo (TApp "handle-break" [TVar "X'"]) env + step2 = do + let env = emptyEnv + env <- lifted_fsMatch fargs [PMetaVar "X"] env + env <- getControlPatt "abrupted" (Nothing) env + (env,[__varabrupted]) <- receiveSignals ["abrupted"] (withControlTerm "abrupted" (Just (TName "broken")) env (premise (TVar "X") (PWildCard) env)) + env <- receiveSignalPatt __varabrupted (Just (PADT "broken" [])) env + stepTermTo (TName "none") env + step3 = do + let env = emptyEnv + env <- lifted_fsMatch fargs [PMetaVar "X"] env + env <- getControlPatt "abrupted" (Just (VPMetaVar "V")) env + (env,[__varabrupted]) <- receiveSignals ["abrupted"] (withControlTerm "abrupted" (Just (TVar "V")) env (premise (TVar "X") (PMetaVar "X'") env)) + env <- receiveSignalPatt __varabrupted (Just (VPAnnotated (VPMetaVar "V") (TSortComplement (TName "breaking")))) env + raiseTerm "abrupted" (TVar "V") env + stepTermTo (TApp "handle-break" [TVar "X'"]) env + +breaking_ = FName "breaking" +stepBreaking = rewriteType "breaking" [] diff --git a/cbs/Funcons/Core/Computations/Abnormal/Continuing/Continuing.hs b/cbs/Funcons/Core/Computations/Abnormal/Continuing/Continuing.hs new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/Abnormal/Continuing/Continuing.hs @@ -0,0 +1,68 @@ +-- GeNeRaTeD fOr: ../../CBS-beta/Funcons-beta/Computations/Abnormal/Continuing/Continuing.cbs +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Computations.Abnormal.Continuing.Continuing where + +import Funcons.EDSL + +import Funcons.Operations hiding (Values) +entities = [] + +types = typeEnvFromList + [("continuing",DataTypeMemberss "continuing" [] [DataTypeMemberConstructor "continued" [] (Just [])])] + +funcons = libFromList + [("continued",NullaryFuncon stepContinued),("finalise-continuing",NonStrictFuncon stepFinalise_continuing),("continue",NullaryFuncon stepContinue),("handle-continue",NonStrictFuncon stepHandle_continue),("continuing",NullaryFuncon stepContinuing)] + +continued_ = FName "continued" +stepContinued = evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + rewriteTermTo (TApp "datatype-value" [TFuncon (FValue (ADTVal "list" [FValue (Ascii 'c'),FValue (Ascii 'o'),FValue (Ascii 'n'),FValue (Ascii 't'),FValue (Ascii 'i'),FValue (Ascii 'n'),FValue (Ascii 'u'),FValue (Ascii 'e'),FValue (Ascii 'd')]))]) env + +finalise_continuing_ fargs = FApp "finalise-continuing" (fargs) +stepFinalise_continuing fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PMetaVar "X"] env + rewriteTermTo (TApp "finalise-abrupting" [TVar "X"]) env + +continue_ = FName "continue" +stepContinue = evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + rewriteTermTo (TApp "abrupt" [TName "continued"]) env + +handle_continue_ fargs = FApp "handle-continue" (fargs) +stepHandle_continue fargs = + evalRules [rewrite1] [step1,step2,step3] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PValue (PADT "none" [])] env + rewriteTermTo (TName "none") env + step1 = do + let env = emptyEnv + env <- lifted_fsMatch fargs [PMetaVar "X"] env + env <- getControlPatt "abrupted" (Nothing) env + (env,[__varabrupted]) <- receiveSignals ["abrupted"] (withControlTerm "abrupted" (Nothing) env (premise (TVar "X") (PMetaVar "X'") env)) + env <- receiveSignalPatt __varabrupted (Nothing) env + stepTermTo (TApp "handle-continue" [TVar "X'"]) env + step2 = do + let env = emptyEnv + env <- lifted_fsMatch fargs [PMetaVar "X"] env + env <- getControlPatt "abrupted" (Nothing) env + (env,[__varabrupted]) <- receiveSignals ["abrupted"] (withControlTerm "abrupted" (Just (TName "continued")) env (premise (TVar "X") (PWildCard) env)) + env <- receiveSignalPatt __varabrupted (Just (PADT "continued" [])) env + stepTermTo (TName "none") env + step3 = do + let env = emptyEnv + env <- lifted_fsMatch fargs [PMetaVar "X"] env + env <- getControlPatt "abrupted" (Just (VPMetaVar "V")) env + (env,[__varabrupted]) <- receiveSignals ["abrupted"] (withControlTerm "abrupted" (Just (TVar "V")) env (premise (TVar "X") (PMetaVar "X'") env)) + env <- receiveSignalPatt __varabrupted (Just (VPAnnotated (VPMetaVar "V") (TSortComplement (TName "continuing")))) env + raiseTerm "abrupted" (TVar "V") env + stepTermTo (TApp "handle-continue" [TVar "X'"]) env + +continuing_ = FName "continuing" +stepContinuing = rewriteType "continuing" [] diff --git a/cbs/Funcons/Core/Computations/Abnormal/Controlling/Controlling.hs b/cbs/Funcons/Core/Computations/Abnormal/Controlling/Controlling.hs new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/Abnormal/Controlling/Controlling.hs @@ -0,0 +1,78 @@ +-- GeNeRaTeD fOr: ../../CBS-beta/Funcons-beta/Computations/Abnormal/Controlling/Controlling.cbs +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Computations.Abnormal.Controlling.Controlling where + +import Funcons.EDSL + +import Funcons.Operations hiding (Values) +entities = [] + +types = typeEnvFromList + [("continuations",DataTypeMemberss "continuations" [TPVar "T1",TPVar "T2"] [DataTypeMemberConstructor "continuation" [TApp "abstractions" [TVar "T2"]] (Just [TPVar "T1",TPVar "T2"])])] + +funcons = libFromList + [("continuation",StrictFuncon stepContinuation),("hole",NullaryFuncon stepHole),("resume-continuation",StrictFuncon stepResume_continuation),("control",StrictFuncon stepControl),("delimit-continuations",NonStrictFuncon stepDelimit_continuations),("continuations",StrictFuncon stepContinuations)] + +continuation_ fargs = FApp "continuation" (fargs) +stepContinuation fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPMetaVar "_X1"] env + env <- sideCondition (SCIsInSort (TVar "_X1") (TName "values")) env + rewriteTermTo (TApp "datatype-value" [TFuncon (FValue (ADTVal "list" [FValue (Ascii 'c'),FValue (Ascii 'o'),FValue (Ascii 'n'),FValue (Ascii 't'),FValue (Ascii 'i'),FValue (Ascii 'n'),FValue (Ascii 'u'),FValue (Ascii 'a'),FValue (Ascii 't'),FValue (Ascii 'i'),FValue (Ascii 'o'),FValue (Ascii 'n')])),TVar "_X1"]) env + +hole_ = FName "hole" +stepHole = evalRules [] [step1] + where step1 = do + let env = emptyEnv + env <- getControlPatt "plug-signal" (Just (VPMetaVar "V")) env + raiseTerm "plug-signal" (TVar "V") env + stepTermTo (TVar "V") env + +resume_continuation_ fargs = FApp "resume-continuation" (fargs) +stepResume_continuation fargs = + evalRules [] [step1] + where step1 = do + let env = emptyEnv + env <- lifted_vsMatch fargs [PADT "continuation" [PADT "abstraction" [VPMetaVar "X"]],VPAnnotated (VPMetaVar "V") (TName "values")] env + env <- getControlPatt "plug-signal" (Nothing) env + (env,[__varplug_signal]) <- receiveSignals ["plug-signal"] (withControlTerm "plug-signal" (Just (TVar "V")) env (premise (TVar "X") (PMetaVar "X'") env)) + env <- receiveSignalPatt __varplug_signal (Just (VPMetaVar "V")) env + stepTermTo (TVar "X'") env + +control_ fargs = FApp "control" (fargs) +stepControl fargs = + evalRules [] [step1] + where step1 = do + let env = emptyEnv + env <- lifted_vsMatch fargs [VPAnnotated (VPMetaVar "F") (TApp "functions" [TApp "continuations" [TName "values",TName "values"],TName "values"])] env + env <- getControlPatt "control-signal" (Just (VPMetaVar "F")) env + raiseTerm "control-signal" (TVar "F") env + stepTermTo (TName "hole") env + +delimit_continuations_ fargs = FApp "delimit-continuations" (fargs) +stepDelimit_continuations fargs = + evalRules [rewrite1] [step1,step2] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PAnnotated (PMetaVar "V") (TName "values")] env + rewriteTermTo (TVar "V") env + step1 = do + let env = emptyEnv + env <- lifted_fsMatch fargs [PMetaVar "E"] env + env <- getControlPatt "control-signal" (Nothing) env + (env,[__varcontrol_signal]) <- receiveSignals ["control-signal"] (withControlTerm "control-signal" (Nothing) env (premise (TVar "E") (PMetaVar "E'") env)) + env <- receiveSignalPatt __varcontrol_signal (Nothing) env + stepTermTo (TApp "delimit-continuations" [TVar "E'"]) env + step2 = do + let env = emptyEnv + env <- lifted_fsMatch fargs [PMetaVar "E"] env + env <- getControlPatt "control-signal" (Nothing) env + (env,[__varcontrol_signal]) <- receiveSignals ["control-signal"] (withControlTerm "control-signal" (Just (TVar "F")) env (premise (TVar "E") (PMetaVar "E'") env)) + env <- receiveSignalPatt __varcontrol_signal (Just (VPMetaVar "F")) env + stepTermTo (TApp "delimit-continuations" [TApp "apply" [TVar "F",TApp "continuation" [TApp "closure" [TVar "E'"]]]]) env + +continuations_ = FApp "continuations" +stepContinuations ts = rewriteType "continuations" ts diff --git a/cbs/Funcons/Core/Computations/Abnormal/Failing/Failing.hs b/cbs/Funcons/Core/Computations/Abnormal/Failing/Failing.hs new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/Abnormal/Failing/Failing.hs @@ -0,0 +1,110 @@ +-- GeNeRaTeD fOr: ../../CBS-beta/Funcons-beta/Computations/Abnormal/Failing/Failing.cbs +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Computations.Abnormal.Failing.Failing where + +import Funcons.EDSL + +import Funcons.Operations hiding (Values) +entities = [] + +types = typeEnvFromList + [("failing",DataTypeMemberss "failing" [] [DataTypeMemberConstructor "failed" [] (Just [])])] + +funcons = libFromList + [("failed",NullaryFuncon stepFailed),("finalise-failing",NonStrictFuncon stepFinalise_failing),("fail",NullaryFuncon stepFail),("else",NonStrictFuncon stepElse),("else-choice",NonStrictFuncon stepElse_choice),("check-true",StrictFuncon stepCheck_true),("check",StrictFuncon stepCheck_true),("defined",StrictFuncon stepDefined),("def",StrictFuncon stepDefined),("failing",NullaryFuncon stepFailing)] + +failed_ = FName "failed" +stepFailed = evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + rewriteTermTo (TApp "datatype-value" [TFuncon (FValue (ADTVal "list" [FValue (Ascii 'f'),FValue (Ascii 'a'),FValue (Ascii 'i'),FValue (Ascii 'l'),FValue (Ascii 'e'),FValue (Ascii 'd')]))]) env + +finalise_failing_ fargs = FApp "finalise-failing" (fargs) +stepFinalise_failing fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PMetaVar "X"] env + rewriteTermTo (TApp "finalise-abrupting" [TVar "X"]) env + +fail_ = FName "fail" +stepFail = evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + rewriteTermTo (TApp "abrupt" [TName "failed"]) env + +else_ fargs = FApp "else" (fargs) +stepElse fargs = + evalRules [rewrite1,rewrite2] [step1,step2,step3] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PAnnotated (PMetaVar "V") (TName "values"),PMetaVar "Y"] env + rewriteTermTo (TVar "V") env + rewrite2 = do + let env = emptyEnv + env <- fsMatch fargs [PMetaVar "X",PMetaVar "Y",PSeqVar "Z+" PlusOp] env + rewriteTermTo (TApp "else" [TVar "X",TApp "else" [TVar "Y",TVar "Z+"]]) env + step1 = do + let env = emptyEnv + env <- lifted_fsMatch fargs [PMetaVar "X",PMetaVar "Y"] env + env <- getControlPatt "abrupted" (Nothing) env + (env,[__varabrupted]) <- receiveSignals ["abrupted"] (withControlTerm "abrupted" (Nothing) env (premise (TVar "X") (PMetaVar "X'") env)) + env <- receiveSignalPatt __varabrupted (Nothing) env + stepTermTo (TApp "else" [TVar "X'",TVar "Y"]) env + step2 = do + let env = emptyEnv + env <- lifted_fsMatch fargs [PMetaVar "X",PMetaVar "Y"] env + env <- getControlPatt "abrupted" (Nothing) env + (env,[__varabrupted]) <- receiveSignals ["abrupted"] (withControlTerm "abrupted" (Just (TName "failed")) env (premise (TVar "X") (PWildCard) env)) + env <- receiveSignalPatt __varabrupted (Just (PADT "failed" [])) env + stepTermTo (TVar "Y") env + step3 = do + let env = emptyEnv + env <- lifted_fsMatch fargs [PMetaVar "X",PMetaVar "Y"] env + env <- getControlPatt "abrupted" (Just (VPMetaVar "V")) env + (env,[__varabrupted]) <- receiveSignals ["abrupted"] (withControlTerm "abrupted" (Just (TVar "V")) env (premise (TVar "X") (PMetaVar "X'") env)) + env <- receiveSignalPatt __varabrupted (Just (VPAnnotated (VPMetaVar "V") (TSortComplement (TName "failing")))) env + raiseTerm "abrupted" (TVar "V") env + stepTermTo (TApp "else" [TVar "X'",TVar "Y"]) env + +else_choice_ fargs = FApp "else-choice" (fargs) +stepElse_choice fargs = + evalRules [rewrite1,rewrite2] [] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PSeqVar "W*" StarOp,PMetaVar "X",PMetaVar "Y",PSeqVar "Z*" StarOp] env + rewriteTermTo (TApp "choice" [TApp "else" [TVar "X",TApp "else-choice" [TVar "W*",TVar "Y",TVar "Z*"],TApp "else" [TVar "Y",TApp "else-choice" [TVar "W*",TVar "X",TVar "Z*"]]]]) env + rewrite2 = do + let env = emptyEnv + env <- fsMatch fargs [PMetaVar "X"] env + rewriteTermTo (TVar "X") env + +check_true_ fargs = FApp "check-true" (fargs) +check_ fargs = FApp "check-true" (fargs) +stepCheck_true fargs = + evalRules [rewrite1,rewrite2] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "true" []] env + rewriteTermTo (TName "none") env + rewrite2 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "false" []] env + rewriteTermTo (TName "fail") env + +defined_ fargs = FApp "defined" (fargs) +def_ fargs = FApp "defined" (fargs) +stepDefined fargs = + evalRules [rewrite1,rewrite2] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "V") (TName "defined-values")] env + rewriteTermTo (TVar "V") env + rewrite2 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "none" []] env + rewriteTermTo (TName "fail") env + +failing_ = FName "failing" +stepFailing = rewriteType "failing" [] diff --git a/cbs/Funcons/Core/Computations/Abnormal/Returning/Returning.hs b/cbs/Funcons/Core/Computations/Abnormal/Returning/Returning.hs new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/Abnormal/Returning/Returning.hs @@ -0,0 +1,73 @@ +-- GeNeRaTeD fOr: ../../CBS-beta/Funcons-beta/Computations/Abnormal/Returning/Returning.cbs +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Computations.Abnormal.Returning.Returning where + +import Funcons.EDSL + +import Funcons.Operations hiding (Values) +entities = [] + +types = typeEnvFromList + [("returning",DataTypeMemberss "returning" [] [DataTypeMemberConstructor "returned" [TName "defined-values"] (Just [])])] + +funcons = libFromList + [("returned",StrictFuncon stepReturned),("finalise-returning",NonStrictFuncon stepFinalise_returning),("return",StrictFuncon stepReturn),("handle-return",NonStrictFuncon stepHandle_return),("returning",NullaryFuncon stepReturning)] + +returned_ fargs = FApp "returned" (fargs) +stepReturned fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPMetaVar "_X1"] env + env <- sideCondition (SCIsInSort (TVar "_X1") (TName "values")) env + rewriteTermTo (TApp "datatype-value" [TFuncon (FValue (ADTVal "list" [FValue (Ascii 'r'),FValue (Ascii 'e'),FValue (Ascii 't'),FValue (Ascii 'u'),FValue (Ascii 'r'),FValue (Ascii 'n'),FValue (Ascii 'e'),FValue (Ascii 'd')])),TVar "_X1"]) env + +finalise_returning_ fargs = FApp "finalise-returning" (fargs) +stepFinalise_returning fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PMetaVar "X"] env + rewriteTermTo (TApp "finalise-abrupting" [TVar "X"]) env + +return_ fargs = FApp "return" (fargs) +stepReturn fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "V") (TName "values")] env + rewriteTermTo (TApp "abrupt" [TApp "returned" [TVar "V"]]) env + +handle_return_ fargs = FApp "handle-return" (fargs) +stepHandle_return fargs = + evalRules [rewrite1] [step1,step2,step3] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PAnnotated (PMetaVar "V") (TName "values")] env + rewriteTermTo (TVar "V") env + step1 = do + let env = emptyEnv + env <- lifted_fsMatch fargs [PMetaVar "X"] env + env <- getControlPatt "abrupted" (Nothing) env + (env,[__varabrupted]) <- receiveSignals ["abrupted"] (withControlTerm "abrupted" (Nothing) env (premise (TVar "X") (PMetaVar "X'") env)) + env <- receiveSignalPatt __varabrupted (Nothing) env + stepTermTo (TApp "handle-return" [TVar "X'"]) env + step2 = do + let env = emptyEnv + env <- lifted_fsMatch fargs [PMetaVar "X"] env + env <- getControlPatt "abrupted" (Nothing) env + (env,[__varabrupted]) <- receiveSignals ["abrupted"] (withControlTerm "abrupted" (Just (TApp "returned" [TVar "V"])) env (premise (TVar "X") (PMetaVar "X'") env)) + env <- receiveSignalPatt __varabrupted (Just (PADT "returned" [VPAnnotated (VPMetaVar "V") (TName "defined-values")])) env + stepTermTo (TVar "V") env + step3 = do + let env = emptyEnv + env <- lifted_fsMatch fargs [PMetaVar "X"] env + env <- getControlPatt "abrupted" (Just (VPMetaVar "V'")) env + (env,[__varabrupted]) <- receiveSignals ["abrupted"] (withControlTerm "abrupted" (Just (TVar "V'")) env (premise (TVar "X") (PMetaVar "X'") env)) + env <- receiveSignalPatt __varabrupted (Just (VPAnnotated (VPMetaVar "V'") (TSortComplement (TName "returning")))) env + raiseTerm "abrupted" (TVar "V'") env + stepTermTo (TApp "handle-return" [TVar "X'"]) env + +returning_ = FName "returning" +stepReturning = rewriteType "returning" [] diff --git a/cbs/Funcons/Core/Computations/Abnormal/Sticking.hs b/cbs/Funcons/Core/Computations/Abnormal/Sticking.hs new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/Abnormal/Sticking.hs @@ -0,0 +1,16 @@ +-- GeNeRaTeD fOr: ../../CBS-beta/Funcons-beta/Computations/Abnormal/Sticking.cbs +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Computations.Abnormal.Sticking where + +import Funcons.EDSL +entities = [] + +types = typeEnvFromList + [] + +funcons = libFromList + [("stuck",NullaryFuncon stepStuck)] + +stuck_ = FName "stuck" +stepStuck = norule (FName "stuck") diff --git a/cbs/Funcons/Core/Computations/Abnormal/Throwing/Throwing.hs b/cbs/Funcons/Core/Computations/Abnormal/Throwing/Throwing.hs new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/Abnormal/Throwing/Throwing.hs @@ -0,0 +1,89 @@ +-- GeNeRaTeD fOr: ../../CBS-beta/Funcons-beta/Computations/Abnormal/Throwing/Throwing.cbs +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Computations.Abnormal.Throwing.Throwing where + +import Funcons.EDSL + +import Funcons.Operations hiding (Values) +entities = [] + +types = typeEnvFromList + [("throwing",DataTypeMemberss "throwing" [] [DataTypeMemberConstructor "thrown" [TName "defined-values"] (Just [])])] + +funcons = libFromList + [("thrown",StrictFuncon stepThrown),("finalise-throwing",NonStrictFuncon stepFinalise_throwing),("throw",StrictFuncon stepThrow),("handle-thrown",NonStrictFuncon stepHandle_thrown),("handle-recursively",NonStrictFuncon stepHandle_recursively),("catch-else-throw",PartiallyStrictFuncon [Strict,NonStrict] NonStrict stepCatch_else_throw),("throwing",NullaryFuncon stepThrowing)] + +thrown_ fargs = FApp "thrown" (fargs) +stepThrown fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPMetaVar "_X1"] env + env <- sideCondition (SCIsInSort (TVar "_X1") (TName "values")) env + rewriteTermTo (TApp "datatype-value" [TFuncon (FValue (ADTVal "list" [FValue (Ascii 't'),FValue (Ascii 'h'),FValue (Ascii 'r'),FValue (Ascii 'o'),FValue (Ascii 'w'),FValue (Ascii 'n')])),TVar "_X1"]) env + +finalise_throwing_ fargs = FApp "finalise-throwing" (fargs) +stepFinalise_throwing fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PMetaVar "X"] env + rewriteTermTo (TApp "finalise-abrupting" [TVar "X"]) env + +throw_ fargs = FApp "throw" (fargs) +stepThrow fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "V") (TName "defined-values")] env + rewriteTermTo (TApp "abrupt" [TApp "thrown" [TVar "V"]]) env + +handle_thrown_ fargs = FApp "handle-thrown" (fargs) +stepHandle_thrown fargs = + evalRules [rewrite1] [step1,step2,step3] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PAnnotated (PMetaVar "V") (TName "values"),PMetaVar "Y"] env + rewriteTermTo (TVar "V") env + step1 = do + let env = emptyEnv + env <- lifted_fsMatch fargs [PMetaVar "X",PMetaVar "Y"] env + env <- getControlPatt "abrupted" (Nothing) env + (env,[__varabrupted]) <- receiveSignals ["abrupted"] (withControlTerm "abrupted" (Nothing) env (premise (TVar "X") (PMetaVar "X'") env)) + env <- receiveSignalPatt __varabrupted (Nothing) env + stepTermTo (TApp "handle-thrown" [TVar "X'",TVar "Y"]) env + step2 = do + let env = emptyEnv + env <- lifted_fsMatch fargs [PMetaVar "X",PMetaVar "Y"] env + env <- getControlPatt "abrupted" (Nothing) env + (env,[__varabrupted]) <- receiveSignals ["abrupted"] (withControlTerm "abrupted" (Just (TApp "thrown" [TVar "V"])) env (premise (TVar "X") (PMetaVar "X'") env)) + env <- receiveSignalPatt __varabrupted (Just (PADT "thrown" [VPAnnotated (VPMetaVar "V") (TName "defined-values")])) env + stepTermTo (TApp "give" [TVar "V",TVar "Y"]) env + step3 = do + let env = emptyEnv + env <- lifted_fsMatch fargs [PMetaVar "X",PMetaVar "Y"] env + env <- getControlPatt "abrupted" (Just (VPMetaVar "V'")) env + (env,[__varabrupted]) <- receiveSignals ["abrupted"] (withControlTerm "abrupted" (Just (TVar "V'")) env (premise (TVar "X") (PMetaVar "X'") env)) + env <- receiveSignalPatt __varabrupted (Just (VPAnnotated (VPMetaVar "V'") (TSortComplement (TName "throwing")))) env + raiseTerm "abrupted" (TVar "V'") env + stepTermTo (TApp "handle-thrown" [TVar "X'",TVar "Y"]) env + +handle_recursively_ fargs = FApp "handle-recursively" (fargs) +stepHandle_recursively fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PMetaVar "X",PMetaVar "Y"] env + rewriteTermTo (TApp "handle-thrown" [TVar "X",TApp "else" [TApp "handle-recursively" [TVar "Y",TVar "Y"],TApp "throw" [TName "given"]]]) env + +catch_else_throw_ fargs = FApp "catch-else-throw" (fargs) +stepCatch_else_throw fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PAnnotated (PMetaVar "P") (TName "defined-values"),PMetaVar "Y"] env + rewriteTermTo (TApp "else" [TApp "case-match" [TVar "P",TVar "Y"],TApp "throw" [TName "given"]]) env + +throwing_ = FName "throwing" +stepThrowing = rewriteType "throwing" [] diff --git a/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/Abort.hs b/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/Abort.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/Abort.hs +++ /dev/null @@ -1,26 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Control flow/Abnormal/Continuations/abort.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Abort where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("abort",StrictFuncon stepAbort)] - --- | --- /abort(V)/ emits a /control-signal/ that, when handled by an enclosing --- /prompt/ , aborts the current computation up to that enclosing /prompt/ , --- returning the value /V/ . -abort_ fargs = FApp "abort" (FTuple fargs) -stepAbort fargs = - evalRules [] [step1] - where step1 = do - let env = emptyEnv - env <- lifted_vsMatch fargs [VPAnnotated (VPMetaVar "V") (TName "values")] env - stepTermTo (TApp "control" (TTuple [TApp "lambda" (TTuple [TVar "V"])])) env diff --git a/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/CallCc.hs b/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/CallCc.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/CallCc.hs +++ /dev/null @@ -1,28 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Control flow/Abnormal/Continuations/call-cc.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.CallCc where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("call-cc",StrictFuncon stepCall_cc)] - --- | --- /call-cc(F)/ emits a /control-signal/ that, when handled by an enclosing --- /prompt/ , applies /F/ to the current continuation. If that current --- continuation argument is invoked, then the current computation will terminate --- up to the enclosing /prompt/ when that continuation terminates. -call_cc_ fargs = FApp "call-cc" (FTuple fargs) -stepCall_cc fargs = - evalRules [] [step1] - where step1 = do - let env = emptyEnv - env <- lifted_vsMatch fargs [VPAnnotated (VPMetaVar "F") (TName "values")] env - env <- premise (TName "fresh-binder") (PMetaVar "K") env - stepTermTo (TApp "control" (TTuple [TApp "binding-lambda" (TTuple [TVar "K",TApp "apply" (TTuple [TApp "bound" (TTuple [TVar "K"]),TApp "apply" (TTuple [TVar "F",TApp "lambda" (TTuple [TApp "abort" (TTuple [TApp "apply" (TTuple [TApp "bound" (TTuple [TVar "K"]),TName "given"])])])])])])])) env diff --git a/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/Control.hs b/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/Control.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/Control.hs +++ /dev/null @@ -1,27 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Control flow/Abnormal/Continuations/control.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Control where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("control",StrictFuncon stepControl)] - --- | --- /control(F)/ emits a /control-signal/ that, when handled by an enclosing --- /prompt/ , will cause /F/ to the current continuation of /control(F)/ , --- instead of continuing the current computation. -control_ fargs = FApp "control" (FTuple fargs) -stepControl fargs = - evalRules [] [step1] - where step1 = do - let env = emptyEnv - env <- lifted_vsMatch fargs [VPAnnotated (VPMetaVar "F") (TName "values")] env - raiseTerm "control-signal" (TTuple [TVar "F"]) env - stepTo (FName "hole") diff --git a/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/ControlSignal.hs b/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/ControlSignal.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/ControlSignal.hs +++ /dev/null @@ -1,14 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Control flow/Abnormal/Continuations/control-signal.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.ControlSignal where - -import Funcons.EDSL - -entities = [DefControl "control-signal"] - -types = typeEnvFromList - [] - -funcons = libFromList - [] diff --git a/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/Hole.hs b/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/Hole.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/Hole.hs +++ /dev/null @@ -1,23 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Control flow/Abnormal/Continuations/hole.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Hole where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("hole",NullaryFuncon stepHole)] - --- | --- A /hole/ in a term cannot proceed until it receives a /resume-signal/ containing a value to fill the hole. -hole_ = FName "hole" -stepHole = evalRules [] [step1] - where step1 = do - let env = emptyEnv - env <- assignInput "resume-signal" "V" env - stepTermTo (TVar "V") env diff --git a/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/Plug.hs b/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/Plug.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/Plug.hs +++ /dev/null @@ -1,27 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Control flow/Abnormal/Continuations/plug.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Plug where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("plug",PartiallyStrictFuncon [NonStrict,Strict] stepPlug)] - --- | --- /plug(E,V)/ plugs the value /V/ into a /hole/ that occurs as a subterm --- within the computation /E/ , provided the /hole/ is in an evaluable position. -plug_ fargs = FApp "plug" (FTuple fargs) -stepPlug fargs@[arg1,arg2] = - evalRules [] [step1] - where step1 = do - let env = emptyEnv - env <- lifted_fsMatch fargs [PMetaVar "E",PAnnotated (PMetaVar "V") (TName "values")] env - env <- withExactInputTerms "resume-signal" [TVar "V"] env (premise (TVar "E") (PMetaVar "E'") env) - stepTermTo (TVar "E'") env -stepPlug fargs = sortErr (FApp "plug" (FTuple fargs)) "invalid number of arguments" diff --git a/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/Prompt.hs b/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/Prompt.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/Prompt.hs +++ /dev/null @@ -1,35 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Control flow/Abnormal/Continuations/prompt.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Prompt where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("prompt",NonStrictFuncon stepPrompt)] - --- | --- /prompt/ is a delimiter for the /control/ and /call-cc/ operators. -prompt_ fargs = FApp "prompt" (FTuple fargs) -stepPrompt fargs = - evalRules [rewrite1] [step1,step2] - where rewrite1 = do - let env = emptyEnv - env <- fsMatch fargs [PAnnotated (PMetaVar "V") (TName "values")] env - rewriteTermTo (TVar "V") env - step1 = do - let env = emptyEnv - env <- lifted_fsMatch fargs [PMetaVar "E"] env - env <- receiveSignalPatt "control-signal" (Nothing) (premise (TVar "E") (PMetaVar "E'") env) - stepTermTo (TApp "prompt" (TTuple [TVar "E'"])) env - step2 = do - let env = emptyEnv - env <- lifted_fsMatch fargs [PMetaVar "E"] env - env <- receiveSignalPatt "control-signal" (Just (VPMetaVar "F")) (premise (TVar "E") (PMetaVar "E'") env) - env <- lifted_sideCondition (SCPatternMatch (TApp "lambda" (TTuple [TApp "plug" (TTuple [TVar "E'",TName "given"])])) (VPMetaVar "K")) env - stepTermTo (TApp "prompt" (TTuple [TApp "apply" (TTuple [TVar "F",TVar "K"])])) env diff --git a/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/Reset.hs b/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/Reset.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/Reset.hs +++ /dev/null @@ -1,27 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Control flow/Abnormal/Continuations/reset.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Reset where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("reset",NonStrictFuncon stepReset)] - --- | --- /reset/ is a delimiter for the /shift/ operator. --- A consequence of our choice of definition of /shift/ is that the semantics of --- /reset/ conincide exactly with those of /prompt/ , and thus the two can be --- used interchangeably. -reset_ fargs = FApp "reset" (FTuple fargs) -stepReset fargs = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- fsMatch fargs [PMetaVar "E"] env - rewriteTermTo (TApp "prompt" (TTuple [TVar "E"])) env diff --git a/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/ResumeSignal.hs b/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/ResumeSignal.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/ResumeSignal.hs +++ /dev/null @@ -1,14 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Control flow/Abnormal/Continuations/resume-signal.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.ResumeSignal where - -import Funcons.EDSL - -entities = [DefInput "resume-signal"] - -types = typeEnvFromList - [] - -funcons = libFromList - [] diff --git a/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/Shift.hs b/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/Shift.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/Shift.hs +++ /dev/null @@ -1,28 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Control flow/Abnormal/Continuations/shift.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Shift where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("shift",StrictFuncon stepShift)] - --- | --- /shift(F)/ emits a /control-signal/ that, when handled by an enclosing --- /reset/ , will cause /F/ to the current continuation of /shift(F)/ , --- Unlike /control/ , any application of the captured continuation delimits --- any control operators in its body. -shift_ fargs = FApp "shift" (FTuple fargs) -stepShift fargs = - evalRules [] [step1] - where step1 = do - let env = emptyEnv - env <- lifted_vsMatch fargs [VPAnnotated (VPMetaVar "F") (TName "values")] env - env <- premise (TName "fresh-binder") (PMetaVar "K") env - stepTermTo (TApp "control" (TTuple [TApp "binding-lambda" (TTuple [TVar "K",TApp "apply" (TTuple [TVar "F",TApp "lambda" (TTuple [TApp "reset" (TTuple [TApp "apply" (TTuple [TApp "bound" (TTuple [TVar "K"]),TName "given"])])])])])])) env diff --git a/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Failing/CheckTrue.hs b/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Failing/CheckTrue.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Failing/CheckTrue.hs +++ /dev/null @@ -1,28 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Control flow/Abnormal/Failing/check-true.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.ControlFlow.Abnormal.Failing.CheckTrue where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("check-true",StrictFuncon stepCheck_true)] - --- | --- /check-true(B)/ fails if /B/ is /false/ . -check_true_ fargs = FApp "check-true" (FTuple fargs) -stepCheck_true fargs = - evalRules [rewrite1,rewrite2] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [PADT "true" []] env - rewriteTo (FTuple []) - rewrite2 = do - let env = emptyEnv - env <- vsMatch fargs [PADT "false" []] env - rewriteTo (FName "fail") diff --git a/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Failing/Dereference.hs b/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Failing/Dereference.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Failing/Dereference.hs +++ /dev/null @@ -1,29 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Control flow/Abnormal/Failing/dereference.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.ControlFlow.Abnormal.Failing.Dereference where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("dereference",StrictFuncon stepDereference)] - --- | --- /dereference(P)/ fails if the pointer /P/ is /null/ , otherwise it returns --- the value referenced by /P/ . -dereference_ fargs = FApp "dereference" (FTuple fargs) -stepDereference fargs = - evalRules [rewrite1,rewrite2] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [PADT "reference" [VPMetaVar "V"]] env - rewriteTermTo (TVar "V") env - rewrite2 = do - let env = emptyEnv - env <- vsMatch fargs [PADT "null" []] env - rewriteTo (FName "fail") diff --git a/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Failing/Else.hs b/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Failing/Else.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Failing/Else.hs +++ /dev/null @@ -1,40 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Control flow/Abnormal/Failing/else.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.ControlFlow.Abnormal.Failing.Else where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("else",NonStrictFuncon stepElse)] - --- | --- /else(X1,X2,...,XN)/ evaluates each computation /X/ in turn, until one does --- *not*fail, returning the result of the successful computation. -else_ fargs = FApp "else" (FTuple fargs) -stepElse fargs = - evalRules [rewrite1] [step1,step2,step3] - where rewrite1 = do - let env = emptyEnv - env <- fsMatch fargs [PAnnotated (PMetaVar "V") (TName "values"),PSeqVar "Y+" PlusOp] env - rewriteTermTo (TVar "V") env - step1 = do - let env = emptyEnv - env <- lifted_fsMatch fargs [PMetaVar "X",PSeqVar "Y+" PlusOp] env - env <- receiveSignalPatt "failed" (Nothing) (premise (TVar "X") (PMetaVar "X'") env) - stepTermTo (TApp "else" (TTuple [TVar "X'",TVar "Y+"])) env - step2 = do - let env = emptyEnv - env <- lifted_fsMatch fargs [PMetaVar "X",PMetaVar "Y"] env - env <- receiveSignalPatt "failed" (Just (PADT "signal" [])) (premise (TVar "X") (PWildCard) env) - stepTermTo (TVar "Y") env - step3 = do - let env = emptyEnv - env <- lifted_fsMatch fargs [PMetaVar "X",PMetaVar "Y",PSeqVar "Z+" PlusOp] env - env <- receiveSignalPatt "failed" (Just (PADT "signal" [])) (premise (TVar "X") (PWildCard) env) - stepTermTo (TApp "else" (TTuple [TVar "Y",TVar "Z+"])) env diff --git a/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Failing/Fail.hs b/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Failing/Fail.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Failing/Fail.hs +++ /dev/null @@ -1,23 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Control flow/Abnormal/Failing/fail.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.ControlFlow.Abnormal.Failing.Fail where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("fail",NullaryFuncon stepFail)] - --- | --- /fail/ terminates abruptly. -fail_ = FName "fail" -stepFail = evalRules [] [step1] - where step1 = do - let env = emptyEnv - raiseTerm "failed" (TTuple [TName "signal"]) env - stepTo (FName "stuck") diff --git a/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Failing/Failed.hs b/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Failing/Failed.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Failing/Failed.hs +++ /dev/null @@ -1,14 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Control flow/Abnormal/Failing/failed.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.ControlFlow.Abnormal.Failing.Failed where - -import Funcons.EDSL - -entities = [DefControl "failed"] - -types = typeEnvFromList - [] - -funcons = libFromList - [] diff --git a/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Failing/Signals.hs b/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Failing/Signals.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Failing/Signals.hs +++ /dev/null @@ -1,18 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Control flow/Abnormal/Failing/signals.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.ControlFlow.Abnormal.Failing.Signals where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [("signals",DataTypeMembers [] [DataTypeConstructor "signal" (TTuple [])])] - -funcons = libFromList - [("signals",NullaryFuncon stepSignals),("signal",NullaryFuncon stepSignal)] - -stepSignal = rewritten (ADTVal "signal" []) - -stepSignals = rewriteType "signals" [] diff --git a/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Stuck.hs b/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Stuck.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Stuck.hs +++ /dev/null @@ -1,19 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Control flow/Abnormal/stuck.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.ControlFlow.Abnormal.Stuck where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("stuck",NullaryFuncon stepStuck)] - --- | --- /stuck/ cannot be evaluated. -stuck_ = FName "stuck" -stepStuck = norule (FName "stuck") diff --git a/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Throwing/Finally.hs b/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Throwing/Finally.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Throwing/Finally.hs +++ /dev/null @@ -1,37 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Control flow/Abnormal/Throwing/finally.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.ControlFlow.Abnormal.Throwing.Finally where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("finally",NonStrictFuncon stepFinally)] - --- | --- /finally(C,F)/ first executes /C/ . --- If /C/ terminates normally, then /F/ executes. --- If /C/ abruptly terminates with a thrown value /V/ , then /F/ executes, --- and then /V/ is rethrown. -finally_ fargs = FApp "finally" (FTuple fargs) -stepFinally fargs = - evalRules [rewrite1] [step1,step2] - where rewrite1 = do - let env = emptyEnv - env <- fsMatch fargs [PValue (PTuple []),PMetaVar "F"] env - rewriteTermTo (TVar "F") env - step1 = do - let env = emptyEnv - env <- lifted_fsMatch fargs [PMetaVar "C",PMetaVar "F"] env - env <- receiveSignalPatt "thrown" (Nothing) (premise (TVar "C") (PMetaVar "C'") env) - stepTermTo (TApp "finally" (TTuple [TVar "C'",TVar "F"])) env - step2 = do - let env = emptyEnv - env <- lifted_fsMatch fargs [PMetaVar "C",PMetaVar "F"] env - env <- receiveSignalPatt "thrown" (Just (VPAnnotated (VPMetaVar "V") (TName "values"))) (premise (TVar "C") (PWildCard) env) - stepTermTo (TApp "sequential" (TTuple [TVar "F",TApp "throw" (TTuple [TVar "V"])])) env diff --git a/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Throwing/HandleRecursively.hs b/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Throwing/HandleRecursively.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Throwing/HandleRecursively.hs +++ /dev/null @@ -1,26 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Control flow/Abnormal/Throwing/handle-recursively.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.ControlFlow.Abnormal.Throwing.HandleRecursively where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("handle-recursively",NonStrictFuncon stepHandle_recursively)] - --- | --- /handle-recursively/ behaves similarly to /handle-thrown/ , except that --- another copy of the handler attempts to handle any values thrown by the --- handler. Thus, many thrown values may get caught by the same handler. -handle_recursively_ fargs = FApp "handle-recursively" (FTuple fargs) -stepHandle_recursively fargs = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- fsMatch fargs [PMetaVar "E",PMetaVar "H"] env - rewriteTermTo (TApp "handle-thrown" (TTuple [TVar "E",TApp "handle-recursively" (TTuple [TVar "H",TVar "H"])])) env diff --git a/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Throwing/HandleThrown.hs b/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Throwing/HandleThrown.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Throwing/HandleThrown.hs +++ /dev/null @@ -1,38 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Control flow/Abnormal/Throwing/handle-thrown.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.ControlFlow.Abnormal.Throwing.HandleThrown where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("handle-thrown",NonStrictFuncon stepHandle_thrown)] - --- | --- /handle-thrown(E,H)/ evaluates /E/ . --- If /E/ terminates normally with value /V/ , --- then /V/ is returned and /H/ is ignored. --- If /E/ terminates abruptly with value /V/ , --- then /H/ is executed with /given-value/ /V/ . -handle_thrown_ fargs = FApp "handle-thrown" (FTuple fargs) -stepHandle_thrown fargs = - evalRules [rewrite1] [step1,step2] - where rewrite1 = do - let env = emptyEnv - env <- fsMatch fargs [PAnnotated (PMetaVar "V") (TName "values"),PWildCard] env - rewriteTermTo (TVar "V") env - step1 = do - let env = emptyEnv - env <- lifted_fsMatch fargs [PMetaVar "E",PMetaVar "H"] env - env <- receiveSignalPatt "thrown" (Nothing) (premise (TVar "E") (PMetaVar "E'") env) - stepTermTo (TApp "handle-thrown" (TTuple [TVar "E'",TVar "H"])) env - step2 = do - let env = emptyEnv - env <- lifted_fsMatch fargs [PMetaVar "E",PMetaVar "H"] env - env <- receiveSignalPatt "thrown" (Just (VPMetaVar "V")) (premise (TVar "E") (PWildCard) env) - stepTermTo (TApp "else" (TTuple [TApp "give" (TTuple [TVar "V",TVar "H"]),TApp "throw" (TTuple [TVar "V"])])) env diff --git a/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Throwing/Throw.hs b/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Throwing/Throw.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Throwing/Throw.hs +++ /dev/null @@ -1,25 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Control flow/Abnormal/Throwing/throw.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.ControlFlow.Abnormal.Throwing.Throw where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("throw",StrictFuncon stepThrow)] - --- | --- /throw(V)/ terminates abruptly with value /V/ . -throw_ fargs = FApp "throw" (FTuple fargs) -stepThrow fargs = - evalRules [] [step1] - where step1 = do - let env = emptyEnv - env <- lifted_vsMatch fargs [VPAnnotated (VPMetaVar "V") (TName "values")] env - raiseTerm "thrown" (TTuple [TVar "V"]) env - stepTo (FName "stuck") diff --git a/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Throwing/Thrown.hs b/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Throwing/Thrown.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Throwing/Thrown.hs +++ /dev/null @@ -1,14 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Control flow/Abnormal/Throwing/thrown.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.ControlFlow.Abnormal.Throwing.Thrown where - -import Funcons.EDSL - -entities = [DefControl "thrown"] - -types = typeEnvFromList - [] - -funcons = libFromList - [] diff --git a/cbs/Funcons/Core/Computations/ControlFlow/Normal/Choosing/IfThenElse.hs b/cbs/Funcons/Core/Computations/ControlFlow/Normal/Choosing/IfThenElse.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/ControlFlow/Normal/Choosing/IfThenElse.hs +++ /dev/null @@ -1,31 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Control flow/Normal/Choosing/if-then-else.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.ControlFlow.Normal.Choosing.IfThenElse where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("if-then-else",PartiallyStrictFuncon [Strict,NonStrict,NonStrict] stepIf_then_else)] - --- | --- /if-then-else(B,X,Y)/ first evaluates /B/ . --- Depending on whether the computed value is /true/ or /false/ , --- it then evaluates /X/ or /Y/ . -if_then_else_ fargs = FApp "if-then-else" (FTuple fargs) -stepIf_then_else fargs@[arg1,arg2,arg3] = - evalRules [rewrite1,rewrite2] [] - where rewrite1 = do - let env = emptyEnv - env <- fsMatch fargs [PValue (PADT "true" []),PMetaVar "X",PWildCard] env - rewriteTermTo (TVar "X") env - rewrite2 = do - let env = emptyEnv - env <- fsMatch fargs [PValue (PADT "false" []),PWildCard,PMetaVar "Y"] env - rewriteTermTo (TVar "Y") env -stepIf_then_else fargs = sortErr (FApp "if-then-else" (FTuple fargs)) "invalid number of arguments" diff --git a/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/FilteringCollections/ListFilter.hs b/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/FilteringCollections/ListFilter.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/FilteringCollections/ListFilter.hs +++ /dev/null @@ -1,30 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Control flow/Normal/Iterating/Definite/Filtering collections/list-filter.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.FilteringCollections.ListFilter where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("list-filter",PartiallyStrictFuncon [NonStrict,Strict] stepList_filter)] - --- | --- /list-filter(P,L)/ discards all elements from the list /L/ that do not --- satisify the predicate /P/ . -list_filter_ fargs = FApp "list-filter" (FTuple fargs) -stepList_filter fargs@[arg1,arg2] = - evalRules [rewrite1,rewrite2] [] - where rewrite1 = do - let env = emptyEnv - env <- fsMatch fargs [PMetaVar "P",PValue (PList [])] env - rewriteTo (FList []) - rewrite2 = do - let env = emptyEnv - env <- fsMatch fargs [PMetaVar "P",PValue (PList [VPMetaVar "V",VPSeqVar "V*" StarOp])] env - rewriteTermTo (TApp "if-then-else" (TTuple [TApp "give" (TTuple [TVar "V",TVar "P"]),TApp "cons" (TTuple [TVar "V",TApp "list-filter" (TTuple [TVar "P",TList [TVar "V*"]])]),TApp "list-filter" (TTuple [TVar "P",TList [TVar "V*"]])])) env -stepList_filter fargs = sortErr (FApp "list-filter" (FTuple fargs)) "invalid number of arguments" diff --git a/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/FilteringCollections/MapFilter.hs b/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/FilteringCollections/MapFilter.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/FilteringCollections/MapFilter.hs +++ /dev/null @@ -1,26 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Control flow/Normal/Iterating/Definite/Filtering collections/map-filter.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.FilteringCollections.MapFilter where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("map-filter",PartiallyStrictFuncon [NonStrict,Strict] stepMap_filter)] - --- | --- /map-filter(P,M)/ discards all entries from the map /M/ that do not --- satisify the predicate /P/ . /P/ is given a key/value pair. -map_filter_ fargs = FApp "map-filter" (FTuple fargs) -stepMap_filter fargs@[arg1,arg2] = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- fsMatch fargs [PMetaVar "F",PAnnotated (PMetaVar "M") (TName "values")] env - rewriteTermTo (TApp "list-to-map" (TTuple [TApp "list-filter" (TTuple [TVar "F",TApp "map-to-list" (TTuple [TVar "M"])])])) env -stepMap_filter fargs = sortErr (FApp "map-filter" (FTuple fargs)) "invalid number of arguments" diff --git a/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/FilteringCollections/MultisetFilter.hs b/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/FilteringCollections/MultisetFilter.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/FilteringCollections/MultisetFilter.hs +++ /dev/null @@ -1,26 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Control flow/Normal/Iterating/Definite/Filtering collections/multiset-filter.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.FilteringCollections.MultisetFilter where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("multiset-filter",PartiallyStrictFuncon [NonStrict,Strict] stepMultiset_filter)] - --- | --- /multiset-filter(P,MS)/ deletes all values from the the multiset /MS/ that do --- not satisfy the predicate /P/ . /P/ is given a /values/ //naturals/ pair. -multiset_filter_ fargs = FApp "multiset-filter" (FTuple fargs) -stepMultiset_filter fargs@[arg1,arg2] = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- fsMatch fargs [PMetaVar "F",PAnnotated (PMetaVar "MS") (TName "values")] env - rewriteTermTo (TApp "list-to-multiset" (TTuple [TApp "list-filter" (TTuple [TVar "F",TApp "multiset-to-list" (TTuple [TVar "MS"])])])) env -stepMultiset_filter fargs = sortErr (FApp "multiset-filter" (FTuple fargs)) "invalid number of arguments" diff --git a/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/FilteringCollections/SetFilter.hs b/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/FilteringCollections/SetFilter.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/FilteringCollections/SetFilter.hs +++ /dev/null @@ -1,26 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Control flow/Normal/Iterating/Definite/Filtering collections/set-filter.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.FilteringCollections.SetFilter where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("set-filter",PartiallyStrictFuncon [NonStrict,Strict] stepSet_filter)] - --- | --- /set-filter(P,S)/ deletes all entries from the the set /S/ that do not --- satisfy the predicate /P/ . -set_filter_ fargs = FApp "set-filter" (FTuple fargs) -stepSet_filter fargs@[arg1,arg2] = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- fsMatch fargs [PMetaVar "F",PAnnotated (PMetaVar "S") (TName "values")] env - rewriteTermTo (TApp "list-to-set" (TTuple [TApp "list-filter" (TTuple [TVar "F",TApp "set-to-list" (TTuple [TVar "S"])])])) env -stepSet_filter fargs = sortErr (FApp "set-filter" (FTuple fargs)) "invalid number of arguments" diff --git a/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/MappingCollections/ListMap.hs b/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/MappingCollections/ListMap.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/MappingCollections/ListMap.hs +++ /dev/null @@ -1,30 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Control flow/Normal/Iterating/Definite/Mapping collections/list-map.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.ListMap where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("list-map",PartiallyStrictFuncon [NonStrict,Strict] stepList_map)] - --- | --- /list-map(F,L)/ maps the computation /F/ over the list /L/ , --- from left to right, evaluating /F/ for each given value in /L/ . -list_map_ fargs = FApp "list-map" (FTuple fargs) -stepList_map fargs@[arg1,arg2] = - evalRules [rewrite1,rewrite2] [] - where rewrite1 = do - let env = emptyEnv - env <- fsMatch fargs [PMetaVar "F",PValue (PList [])] env - rewriteTo (FList []) - rewrite2 = do - let env = emptyEnv - env <- fsMatch fargs [PMetaVar "F",PValue (PList [VPMetaVar "V",VPSeqVar "V*" StarOp])] env - rewriteTermTo (TApp "cons" (TTuple [TApp "left-to-right" (TTuple [TApp "give" (TTuple [TVar "V",TVar "F"]),TApp "list-map" (TTuple [TVar "F",TList [TVar "V*"]])])])) env -stepList_map fargs = sortErr (FApp "list-map" (FTuple fargs)) "invalid number of arguments" diff --git a/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/MappingCollections/ListsMap.hs b/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/MappingCollections/ListsMap.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/MappingCollections/ListsMap.hs +++ /dev/null @@ -1,32 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Control flow/Normal/Iterating/Definite/Mapping collections/lists-map.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.ListsMap where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("lists-map",PartiallyStrictFuncon [NonStrict,Strict] stepLists_map)] - --- | --- /lists-map(F,(List+))/ maps the computation /F/ over N lists of equal length --- L, in parallel from left to right. /F/ is evaluated L times, once for each --- given tuple of argument values, where the Nth component of each tuple is --- drawn from the Nth argument list. -lists_map_ fargs = FApp "lists-map" (FTuple fargs) -stepLists_map fargs@[arg1,arg2] = - evalRules [rewrite1,rewrite2] [] - where rewrite1 = do - let env = emptyEnv - env <- fsMatch fargs [PMetaVar "F",PAnnotated (PMetaVar "L") (TApp "lists" (TTuple [TName "values"]))] env - rewriteTermTo (TApp "list-map" (TTuple [TVar "F",TVar "L"])) env - rewrite2 = do - let env = emptyEnv - env <- fsMatch fargs [PMetaVar "F",PAnnotated (PMetaVar "LS") (TTuple [TApp "lists" (TTuple [TName "values"]),TSortSeq (TApp "lists" (TTuple [TName "values"])) PlusOp])] env - rewriteTermTo (TApp "give" (TTuple [TApp "tuple-map" (TTuple [TApp "is-nil" (TTuple [TName "given"]),TVar "LS"]),TApp "if-then-else" (TTuple [TApp "and" (TTuple [TName "given"]),TName "nil",TApp "if-then-else" (TTuple [TApp "or" (TTuple [TName "given"]),TName "fail",TApp "cons" (TTuple [TApp "left-to-right" (TTuple [TApp "give" (TTuple [TApp "tuple-map" (TTuple [TApp "head" (TTuple [TName "given"]),TVar "LS"]),TVar "F"]),TApp "lists-map" (TTuple [TVar "F",TApp "tuple-map" (TTuple [TApp "tail" (TTuple [TName "given"]),TVar "LS"])])])])])])])) env -stepLists_map fargs = sortErr (FApp "lists-map" (FTuple fargs)) "invalid number of arguments" diff --git a/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/MappingCollections/MapMap.hs b/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/MappingCollections/MapMap.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/MappingCollections/MapMap.hs +++ /dev/null @@ -1,26 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Control flow/Normal/Iterating/Definite/Mapping collections/map-map.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.MapMap where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("map-map",PartiallyStrictFuncon [NonStrict,Strict] stepMap_map)] - --- | --- /map-map(X,M)/ maps the computation /F/ over the map /M/ , interleaved, --- evaluating /F/ for each given key/entry pair in /M/ , uniting the results. -map_map_ fargs = FApp "map-map" (FTuple fargs) -stepMap_map fargs@[arg1,arg2] = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- fsMatch fargs [PMetaVar "F",PAnnotated (PMetaVar "M") (TName "values")] env - rewriteTermTo (TApp "list-to-map" (TTuple [TApp "list-map" (TTuple [TTuple [TName "given1",TVar "F"],TApp "map-to-list" (TTuple [TVar "M"])])])) env -stepMap_map fargs = sortErr (FApp "map-map" (FTuple fargs)) "invalid number of arguments" diff --git a/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/MappingCollections/SetMap.hs b/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/MappingCollections/SetMap.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/MappingCollections/SetMap.hs +++ /dev/null @@ -1,26 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Control flow/Normal/Iterating/Definite/Mapping collections/set-map.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.SetMap where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("set-map",PartiallyStrictFuncon [NonStrict,Strict] stepSet_map)] - --- | --- /set-map(F,S)/ maps the computation /F/ over the set /S/ , interleaved, --- evaluating /F/ for each given value in /S/ , uniting the results. -set_map_ fargs = FApp "set-map" (FTuple fargs) -stepSet_map fargs@[arg1,arg2] = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- fsMatch fargs [PMetaVar "F",PAnnotated (PMetaVar "S") (TName "values")] env - rewriteTermTo (TApp "list-to-set" (TTuple [TApp "list-map" (TTuple [TVar "F",TApp "set-to-list" (TTuple [TVar "S"])])])) env -stepSet_map fargs = sortErr (FApp "set-map" (FTuple fargs)) "invalid number of arguments" diff --git a/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/MappingCollections/TupleMap.hs b/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/MappingCollections/TupleMap.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/MappingCollections/TupleMap.hs +++ /dev/null @@ -1,26 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Control flow/Normal/Iterating/Definite/Mapping collections/tuple-map.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.TupleMap where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("tuple-map",PartiallyStrictFuncon [NonStrict,Strict] stepTuple_map)] - --- | --- /tuple-map(F,Tup)/ maps the computation /F/ over a tuple /Tup/ , --- from left to right, evaluating /F/ for each given value in the /Tup/ . -tuple_map_ fargs = FApp "tuple-map" (FTuple fargs) -stepTuple_map fargs@[arg1,arg2] = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- fsMatch fargs [PMetaVar "F",PAnnotated (PMetaVar "Tup") (TName "values")] env - rewriteTermTo (TApp "list-to-tuple" (TTuple [TApp "list-map" (TTuple [TVar "F",TApp "list" (TTuple [TVar "Tup"])])])) env -stepTuple_map fargs = sortErr (FApp "tuple-map" (FTuple fargs)) "invalid number of arguments" diff --git a/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/MappingCollections/VectorMap.hs b/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/MappingCollections/VectorMap.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/MappingCollections/VectorMap.hs +++ /dev/null @@ -1,26 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Control flow/Normal/Iterating/Definite/Mapping collections/vector-map.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.VectorMap where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("vector-map",PartiallyStrictFuncon [NonStrict,Strict] stepVector_map)] - --- | --- /vector-map(F,V)/ maps the computation /F/ over the vector /V/ , --- from left to right, evaluating /F/ for each given value in /V/ . -vector_map_ fargs = FApp "vector-map" (FTuple fargs) -stepVector_map fargs@[arg1,arg2] = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- fsMatch fargs [PMetaVar "F",PAnnotated (PMetaVar "Vec") (TName "values")] env - rewriteTermTo (TApp "list-to-vector" (TTuple [TApp "list-map" (TTuple [TVar "F",TApp "vector-to-list" (TTuple [TVar "Vec"])])])) env -stepVector_map fargs = sortErr (FApp "vector-map" (FTuple fargs)) "invalid number of arguments" diff --git a/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/ReducingCollections/ListFoldl.hs b/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/ReducingCollections/ListFoldl.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/ReducingCollections/ListFoldl.hs +++ /dev/null @@ -1,33 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Control flow/Normal/Iterating/Definite/Reducing collections/list-foldl.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.ReducingCollections.ListFoldl where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("list-foldl",PartiallyStrictFuncon [NonStrict,Strict,Strict] stepList_foldl)] - --- | --- /list-foldl(F,A,L)/ reduces a list /L/ to a single value by folding it from --- the left, using /A/ as the initial accumulator value, and iteratively --- updating the accumulator by executing the computation /F/ with the --- accumulator value and the head of the remaining list as its pair of --- arguments. -list_foldl_ fargs = FApp "list-foldl" (FTuple fargs) -stepList_foldl fargs@[arg1,arg2,arg3] = - evalRules [rewrite1,rewrite2] [] - where rewrite1 = do - let env = emptyEnv - env <- fsMatch fargs [PWildCard,PMetaVar "A",PValue (PList [])] env - rewriteTermTo (TVar "A") env - rewrite2 = do - let env = emptyEnv - env <- fsMatch fargs [PMetaVar "F",PMetaVar "A",PValue (PList [VPMetaVar "V",VPSeqVar "V*" StarOp])] env - rewriteTermTo (TApp "list-foldl" (TTuple [TVar "F",TApp "give" (TTuple [TTuple [TVar "A",TVar "V"],TVar "F"]),TList [TVar "V*"]])) env -stepList_foldl fargs = sortErr (FApp "list-foldl" (FTuple fargs)) "invalid number of arguments" diff --git a/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/ReducingCollections/ListFoldr.hs b/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/ReducingCollections/ListFoldr.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/ReducingCollections/ListFoldr.hs +++ /dev/null @@ -1,33 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Control flow/Normal/Iterating/Definite/Reducing collections/list-foldr.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.ReducingCollections.ListFoldr where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("list-foldr",PartiallyStrictFuncon [NonStrict,Strict,Strict] stepList_foldr)] - --- | --- /list-foldr(F,A,L)/ reduces a list /L/ to a single value by folding it from --- the right, using /A/ as the initial accumulator value, and iteratively --- updating the accumulator by executing the computation /F/ with the --- the last element of the remaining list and the accumulator value as its pair --- of arguments. -list_foldr_ fargs = FApp "list-foldr" (FTuple fargs) -stepList_foldr fargs@[arg1,arg2,arg3] = - evalRules [rewrite1,rewrite2] [] - where rewrite1 = do - let env = emptyEnv - env <- fsMatch fargs [PWildCard,PValue (PList []),PMetaVar "A"] env - rewriteTermTo (TVar "A") env - rewrite2 = do - let env = emptyEnv - env <- fsMatch fargs [PMetaVar "F",PValue (PList [VPMetaVar "V",VPSeqVar "V*" StarOp]),PMetaVar "A"] env - rewriteTermTo (TApp "give" (TTuple [TTuple [TVar "V",TApp "list-foldr" (TTuple [TVar "F",TList [TVar "V*"],TVar "A"])],TVar "F"])) env -stepList_foldr fargs = sortErr (FApp "list-foldr" (FTuple fargs)) "invalid number of arguments" diff --git a/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Indefinite/DoWhile.hs b/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Indefinite/DoWhile.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Indefinite/DoWhile.hs +++ /dev/null @@ -1,26 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Control flow/Normal/Iterating/Indefinite/do-while.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.ControlFlow.Normal.Iterating.Indefinite.DoWhile where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("do-while",NonStrictFuncon stepDo_while)] - --- | --- /do-while(C,B)/ first executes /C/ . --- Then it evaluates /B/ . Depending on whether the value is /true/ or /false/ , --- it then repeats, or terminates normally. -do_while_ fargs = FApp "do-while" (FTuple fargs) -stepDo_while fargs = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- fsMatch fargs [PMetaVar "C",PMetaVar "B"] env - rewriteTermTo (TApp "sequential" (TTuple [TVar "C",TApp "if-then-else" (TTuple [TVar "B",TApp "do-while" (TTuple [TVar "C",TVar "B"]),TTuple []])])) env diff --git a/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Indefinite/While.hs b/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Indefinite/While.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Indefinite/While.hs +++ /dev/null @@ -1,26 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Control flow/Normal/Iterating/Indefinite/while.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.ControlFlow.Normal.Iterating.Indefinite.While where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("while",NonStrictFuncon stepWhile)] - --- | --- /while(B,C)/ first evaluates /B/ . --- Depending on whether the computed value is /true/ or /false/ , --- it then executes /C/ and repeats, or terminates normally. -while_ fargs = FApp "while" (FTuple fargs) -stepWhile fargs = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- fsMatch fargs [PMetaVar "B",PMetaVar "C"] env - rewriteTermTo (TApp "if-then-else" (TTuple [TVar "B",TApp "sequential" (TTuple [TVar "C",TApp "while" (TTuple [TVar "B",TVar "C"])]),TTuple []])) env diff --git a/cbs/Funcons/Core/Computations/ControlFlow/Normal/Sequencing/Atomic.hs b/cbs/Funcons/Core/Computations/ControlFlow/Normal/Sequencing/Atomic.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/ControlFlow/Normal/Sequencing/Atomic.hs +++ /dev/null @@ -1,31 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Control flow/Normal/Sequencing/atomic.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.ControlFlow.Normal.Sequencing.Atomic where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("atomic",NonStrictFuncon stepAtomic)] - --- | --- /atomic(X)/ treats the complete evaluation of /X/ as one step, --- regardless of how many steps that evaluation actually takes. -atomic_ fargs = FApp "atomic" (FTuple fargs) -stepAtomic fargs = - evalRules [rewrite1] [step1] - where rewrite1 = do - let env = emptyEnv - env <- fsMatch fargs [PAnnotated (PMetaVar "V") (TName "values")] env - rewriteTermTo (TVar "V") env - step1 = do - let env = emptyEnv - env <- lifted_fsMatch fargs [PMetaVar "X"] env - env <- premise (TVar "X") (PMetaVar "X'") env - env <- premise (TApp "atomic" (TTuple [TVar "X'"])) (PMetaVar "V") env - stepTermTo (TVar "V") env diff --git a/cbs/Funcons/Core/Computations/ControlFlow/Normal/Sequencing/LeftToRight.hs b/cbs/Funcons/Core/Computations/ControlFlow/Normal/Sequencing/LeftToRight.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/ControlFlow/Normal/Sequencing/LeftToRight.hs +++ /dev/null @@ -1,30 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Control flow/Normal/Sequencing/left-to-right.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.ControlFlow.Normal.Sequencing.LeftToRight where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("left-to-right",NonStrictFuncon stepLeft_to_right)] - --- | --- /left-to-right(X1,...,Xn)/ executes /X1/ ,...,/Xn/ from left to right, --- computing a tuple of result values /(V1,...,VN)/ . -left_to_right_ fargs = FApp "left-to-right" (FTuple fargs) -stepLeft_to_right fargs = - evalRules [rewrite1] [step1] - where rewrite1 = do - let env = emptyEnv - env <- fsMatch fargs [PAnnotated (PSeqVar "V*" StarOp) (TName "values")] env - rewriteTermTo (TTuple [TVar "V*"]) env - step1 = do - let env = emptyEnv - env <- lifted_fsMatch fargs [PAnnotated (PSeqVar "V*" StarOp) (TName "values"),PMetaVar "Y",PSeqVar "Z*" StarOp] env - env <- premise (TVar "Y") (PMetaVar "Y'") env - stepTermTo (TApp "left-to-right" (TTuple [TVar "V*",TVar "Y'",TVar "Z*"])) env diff --git a/cbs/Funcons/Core/Computations/ControlFlow/Normal/Sequencing/Sequential.hs b/cbs/Funcons/Core/Computations/ControlFlow/Normal/Sequencing/Sequential.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/ControlFlow/Normal/Sequencing/Sequential.hs +++ /dev/null @@ -1,27 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Control flow/Normal/Sequencing/sequential.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.ControlFlow.Normal.Sequencing.Sequential where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("sequential",NonStrictFuncon stepSequential)] - --- | --- /sequential(X1,...,Xn)/ executes /X1/ ,...,/Xn/ from left to right, --- computing a tuple of results. --- Any result values that are the empty tuple /()/ are discarded, --- so the resultant tuple may be smaller. -sequential_ fargs = FApp "sequential" (FTuple fargs) -stepSequential fargs = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- fsMatch fargs [PSeqVar "X*" StarOp] env - rewriteTermTo (TApp "discard-empty-tuples" (TTuple [TApp "left-to-right" (TTuple [TVar "X*"])])) env diff --git a/cbs/Funcons/Core/Computations/DataFlow/Binding/Accumulate.hs b/cbs/Funcons/Core/Computations/DataFlow/Binding/Accumulate.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/DataFlow/Binding/Accumulate.hs +++ /dev/null @@ -1,40 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Data flow/Binding/accumulate.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.DataFlow.Binding.Accumulate where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("accumulate",NonStrictFuncon stepAccumulate)] - --- | --- /accumulate(D1,D*)/ first evaluates /D1/ to /Rho1/ . --- It then lets /Rho1/ override the current environment during the evaluation --- of /accumulate(D*)/ to /Rho2/ , and finally computes /Rho2/ overriding /Rho1/ . --- /accumulate()/ computes /map-empty/ . -accumulate_ fargs = FApp "accumulate" (FTuple fargs) -stepAccumulate fargs = - evalRules [rewrite1,rewrite2,rewrite3] [step1] - where rewrite1 = do - let env = emptyEnv - env <- fsMatch fargs [] env - rewriteTo (FName "map-empty") - rewrite2 = do - let env = emptyEnv - env <- fsMatch fargs [PAnnotated (PMetaVar "Rho") (TName "environments")] env - rewriteTermTo (TVar "Rho") env - rewrite3 = do - let env = emptyEnv - env <- fsMatch fargs [PAnnotated (PMetaVar "Rho") (TName "environments"),PSeqVar "D+" PlusOp] env - rewriteTermTo (TApp "scope" (TTuple [TVar "Rho",TApp "map-override" (TTuple [TApp "accumulate" (TTuple [TVar "D+"]),TVar "Rho"])])) env - step1 = do - let env = emptyEnv - env <- lifted_fsMatch fargs [PMetaVar "D",PSeqVar "D*" StarOp] env - env <- premise (TVar "D") (PMetaVar "D'") env - stepTermTo (TApp "accumulate" (TTuple [TVar "D'",TVar "D*"])) env diff --git a/cbs/Funcons/Core/Computations/DataFlow/Binding/Bind.hs b/cbs/Funcons/Core/Computations/DataFlow/Binding/Bind.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/DataFlow/Binding/Bind.hs +++ /dev/null @@ -1,24 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Data flow/Binding/bind.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.DataFlow.Binding.Bind where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("bind",StrictFuncon stepBind)] - --- | --- /bind(B,V)/ gives the environment binding the binder /B/ to the value /V/ . -bind_ fargs = FApp "bind" (FTuple fargs) -stepBind fargs = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "B") (TName "values"),VPAnnotated (VPMetaVar "V") (TName "values")] env - rewriteTermTo (TMap [TTuple [TVar "B",TVar "V"]]) env diff --git a/cbs/Funcons/Core/Computations/DataFlow/Binding/Bound.hs b/cbs/Funcons/Core/Computations/DataFlow/Binding/Bound.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/DataFlow/Binding/Bound.hs +++ /dev/null @@ -1,32 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Data flow/Binding/bound.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.DataFlow.Binding.Bound where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("bound",StrictFuncon stepBound)] - --- | --- /bound(B)/ returns the value currently bound to the binder /B/ , -bound_ fargs = FApp "bound" (FTuple fargs) -stepBound fargs = - evalRules [] [step1,step2] - where step1 = do - let env = emptyEnv - env <- lifted_vsMatch fargs [VPMetaVar "B"] env - env <- getInhPatt "environment" (VPMetaVar "Rho") env - env <- lifted_sideCondition (SCEquality (TApp "is-in-set" (TTuple [TVar "B",TApp "domain" (TTuple [TVar "Rho"])])) (TName "true")) env - stepTermTo (TApp "lookup" (TTuple [TVar "B",TVar "Rho"])) env - step2 = do - let env = emptyEnv - env <- lifted_vsMatch fargs [VPMetaVar "B"] env - env <- getInhPatt "environment" (VPMetaVar "Rho") env - env <- lifted_sideCondition (SCEquality (TApp "is-in-set" (TTuple [TVar "B",TApp "domain" (TTuple [TVar "Rho"])])) (TName "false")) env - stepTo (FName "fail") diff --git a/cbs/Funcons/Core/Computations/DataFlow/Binding/Environment.hs b/cbs/Funcons/Core/Computations/DataFlow/Binding/Environment.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/DataFlow/Binding/Environment.hs +++ /dev/null @@ -1,14 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Data flow/Binding/environment.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.DataFlow.Binding.Environment where - -import Funcons.EDSL - -entities = [DefInherited "environment" (FName "map-empty")] - -types = typeEnvFromList - [] - -funcons = libFromList - [] diff --git a/cbs/Funcons/Core/Computations/DataFlow/Binding/Environments.hs b/cbs/Funcons/Core/Computations/DataFlow/Binding/Environments.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/DataFlow/Binding/Environments.hs +++ /dev/null @@ -1,31 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Data flow/Binding/environments.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.DataFlow.Binding.Environments where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [("binders",DataTypeMembers [] [DataTypeInclusion (TName "ids"),DataTypeConstructor "id-in-namespace" (TTuple [TName "ids",TName "namespace-names"])])] - -funcons = libFromList - [("environments",NullaryFuncon stepEnvironments),("namespace-names",NullaryFuncon stepNamespace_names),("binders",NullaryFuncon stepBinders),("id-in-namespace",StrictFuncon stepId_in_namespace)] - -environments_ = FName "environments" -stepEnvironments = evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - rewriteTo (FApp "maps" (FTuple [FName "binders",FName "values"])) - -namespace_names_ = FName "namespace-names" -stepNamespace_names = evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - rewriteTo (FName "values") - - -stepId_in_namespace vs = rewritten (ADTVal "id-in-namespace" vs) - -stepBinders = rewriteType "binders" [] diff --git a/cbs/Funcons/Core/Computations/DataFlow/Binding/Recursion/BindRecursively.hs b/cbs/Funcons/Core/Computations/DataFlow/Binding/Recursion/BindRecursively.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/DataFlow/Binding/Recursion/BindRecursively.hs +++ /dev/null @@ -1,26 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Data flow/Binding/Recursion/bind-recursively.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.DataFlow.Binding.Recursion.BindRecursively where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("bind-recursively",PartiallyStrictFuncon [Strict,NonStrict] stepBind_recursively)] - --- | --- /bind-recursively(B,E)/ binds /B/ to the result of evaluating /E/ , which may --- recursively refer to /B/ (using /bound-recursively/ ). -bind_recursively_ fargs = FApp "bind-recursively" (FTuple fargs) -stepBind_recursively fargs@[arg1,arg2] = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- fsMatch fargs [PAnnotated (PMetaVar "B") (TName "values"),PMetaVar "E"] env - rewriteTermTo (TApp "recursive" (TTuple [TSet [TVar "B"],TApp "bind" (TTuple [TVar "B",TVar "E"])])) env -stepBind_recursively fargs = sortErr (FApp "bind-recursively" (FTuple fargs)) "invalid number of arguments" diff --git a/cbs/Funcons/Core/Computations/DataFlow/Binding/Recursion/BoundRecursively.hs b/cbs/Funcons/Core/Computations/DataFlow/Binding/Recursion/BoundRecursively.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/DataFlow/Binding/Recursion/BoundRecursively.hs +++ /dev/null @@ -1,27 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Data flow/Binding/Recursion/bound-recursively.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.DataFlow.Binding.Recursion.BoundRecursively where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("bound-recursively",StrictFuncon stepBound_recursively)] - --- | --- /bound-recursively(B)/ returns the value currently bound to /B/ , unless that --- value is a /links/ , in which case it returns the value linked to by that link. --- This is intended to be used in situations when the binder /B/ may be a --- recursive binding formed using /recursive/ or /bind-recursively/ . -bound_recursively_ fargs = FApp "bound-recursively" (FTuple fargs) -stepBound_recursively fargs = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "B") (TName "values")] env - rewriteTermTo (TApp "follow-if-link" (TTuple [TApp "bound" (TTuple [TVar "B"])])) env diff --git a/cbs/Funcons/Core/Computations/DataFlow/Binding/Recursion/Recursive.hs b/cbs/Funcons/Core/Computations/DataFlow/Binding/Recursion/Recursive.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/DataFlow/Binding/Recursion/Recursive.hs +++ /dev/null @@ -1,51 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Data flow/Binding/Recursion/recursive.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.DataFlow.Binding.Recursion.Recursive where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("recursive",PartiallyStrictFuncon [Strict,NonStrict] stepRecursive),("bind-to-forward-links",StrictFuncon stepBind_to_forward_links),("set-forward-links",StrictFuncon stepSet_forward_links),("reclose",PartiallyStrictFuncon [Strict,NonStrict] stepReclose)] - --- | --- /recursive(Bs,D)/ evaluates /D/ with potential recursion on the binders --- in /Bs/ (which need not be the same as the set of binders bound by /D/ ). -recursive_ fargs = FApp "recursive" (FTuple fargs) -stepRecursive fargs@[arg1,arg2] = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- fsMatch fargs [PAnnotated (PMetaVar "Bs") (TName "values"),PMetaVar "Decl"] env - rewriteTermTo (TApp "reclose" (TTuple [TApp "bind-to-forward-links" (TTuple [TVar "Bs"]),TVar "Decl"])) env -stepRecursive fargs = sortErr (FApp "recursive" (FTuple fargs)) "invalid number of arguments" - -bind_to_forward_links_ fargs = FApp "bind-to-forward-links" (FTuple fargs) -stepBind_to_forward_links fargs = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "Bs") (TName "values")] env - rewriteTermTo (TApp "set-to-map" (TTuple [TApp "set-map" (TTuple [TTuple [TName "given",TApp "allocate-link" (TTuple [TName "values"])],TVar "Bs"])])) env - -set_forward_links_ fargs = FApp "set-forward-links" (FTuple fargs) -stepSet_forward_links fargs = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "M") (TName "values")] env - rewriteTermTo (TApp "effect" (TTuple [TApp "map-map" (TTuple [TApp "set-link" (TTuple [TName "given2",TApp "bound" (TTuple [TName "given1"])]),TVar "M"])])) env - -reclose_ fargs = FApp "reclose" (FTuple fargs) -stepReclose fargs@[arg1,arg2] = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- fsMatch fargs [PAnnotated (PMetaVar "M") (TName "values"),PMetaVar "Decl"] env - rewriteTermTo (TApp "accumulate" (TTuple [TApp "scope" (TTuple [TVar "M",TVar "Decl"]),TApp "sequential" (TTuple [TApp "set-forward-links" (TTuple [TVar "M"]),TName "map-empty"])])) env -stepReclose fargs = sortErr (FApp "reclose" (FTuple fargs)) "invalid number of arguments" diff --git a/cbs/Funcons/Core/Computations/DataFlow/Binding/Scope.hs b/cbs/Funcons/Core/Computations/DataFlow/Binding/Scope.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/DataFlow/Binding/Scope.hs +++ /dev/null @@ -1,32 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Data flow/Binding/scope.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.DataFlow.Binding.Scope where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("scope",PartiallyStrictFuncon [Strict,NonStrict] stepScope)] - --- | --- /scope(Rho,X)/ extends (possibly overriding) the current environment --- with /Rho/ for the execution of /X/ . -scope_ fargs = FApp "scope" (FTuple fargs) -stepScope fargs@[arg1,arg2] = - evalRules [rewrite1] [step1] - where rewrite1 = do - let env = emptyEnv - env <- fsMatch fargs [PAnnotated (PWildCard) (TName "environments"),PAnnotated (PMetaVar "V") (TName "values")] env - rewriteTermTo (TVar "V") env - step1 = do - let env = emptyEnv - env <- lifted_fsMatch fargs [PAnnotated (PMetaVar "Rho1") (TName "environments"),PMetaVar "X"] env - env <- getInhPatt "environment" (VPMetaVar "Rho0") env - env <- withInhTerm "environment" (TTuple [TApp "map-override" (TTuple [TVar "Rho1",TVar "Rho0"])]) env (premise (TVar "X") (PMetaVar "X'") env) - stepTermTo (TApp "scope" (TTuple [TVar "Rho1",TVar "X'"])) env -stepScope fargs = sortErr (FApp "scope" (FTuple fargs)) "invalid number of arguments" diff --git a/cbs/Funcons/Core/Computations/DataFlow/Effect.hs b/cbs/Funcons/Core/Computations/DataFlow/Effect.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/DataFlow/Effect.hs +++ /dev/null @@ -1,24 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Data flow/effect.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.DataFlow.Effect where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("effect",StrictFuncon stepEffect)] - --- | --- /effect(E)/ evaluates /E/ , then discards the computed value. -effect_ fargs = FApp "effect" (FTuple fargs) -stepEffect fargs = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPWildCard) (TName "values")] env - rewriteTo (FTuple []) diff --git a/cbs/Funcons/Core/Computations/DataFlow/Generating/AtomGenerator.hs b/cbs/Funcons/Core/Computations/DataFlow/Generating/AtomGenerator.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/DataFlow/Generating/AtomGenerator.hs +++ /dev/null @@ -1,14 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Data flow/Generating/atom-generator.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.DataFlow.Generating.AtomGenerator where - -import Funcons.EDSL - -entities = [DefMutable "atom-generator" (FName "atom-seed")] - -types = typeEnvFromList - [] - -funcons = libFromList - [] diff --git a/cbs/Funcons/Core/Computations/DataFlow/Generating/FreshAtom.hs b/cbs/Funcons/Core/Computations/DataFlow/Generating/FreshAtom.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/DataFlow/Generating/FreshAtom.hs +++ /dev/null @@ -1,24 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Data flow/Generating/fresh-atom.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.DataFlow.Generating.FreshAtom where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("fresh-atom",NullaryFuncon stepFresh_atom)] - --- | --- /fresh-atom/ computes a fresh atom, distinct from all other /atoms/ previously generated by other occurrences of /fresh-atom/ . -fresh_atom_ = FName "fresh-atom" -stepFresh_atom = evalRules [] [step1] - where step1 = do - let env = emptyEnv - env <- getMutPatt "atom-generator" (VPMetaVar "K") env - putMutTerm "atom-generator" (TTuple [TApp "next-atom" (TTuple [TVar "K"])]) env - stepTermTo (TVar "K") env diff --git a/cbs/Funcons/Core/Computations/DataFlow/Generating/FreshBinder.hs b/cbs/Funcons/Core/Computations/DataFlow/Generating/FreshBinder.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/DataFlow/Generating/FreshBinder.hs +++ /dev/null @@ -1,23 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Data flow/Generating/fresh-binder.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.DataFlow.Generating.FreshBinder where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("fresh-binder",NullaryFuncon stepFresh_binder)] - --- | --- /fresh-binder/ generates a fresh binder, distinct from all identifiers and --- any binders previously generated by other occurrences of /fresh-binder/ . -fresh_binder_ = FName "fresh-binder" -stepFresh_binder = evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - rewriteTo (FApp "id-in-namespace" (FTuple [FValue (String "generated-binder"),FName "fresh-atom"])) diff --git a/cbs/Funcons/Core/Computations/DataFlow/Giving/Give.hs b/cbs/Funcons/Core/Computations/DataFlow/Giving/Give.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/DataFlow/Giving/Give.hs +++ /dev/null @@ -1,31 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Data flow/Giving/give.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.DataFlow.Giving.Give where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("give",PartiallyStrictFuncon [Strict,NonStrict] stepGive)] - --- | --- /give(V,X)/ evaluates /X/ with /V/ as the given value. -give_ fargs = FApp "give" (FTuple fargs) -stepGive fargs@[arg1,arg2] = - evalRules [rewrite1] [step1] - where rewrite1 = do - let env = emptyEnv - env <- fsMatch fargs [PAnnotated (PWildCard) (TName "values"),PAnnotated (PMetaVar "V") (TName "values")] env - rewriteTermTo (TVar "V") env - step1 = do - let env = emptyEnv - env <- lifted_fsMatch fargs [PAnnotated (PMetaVar "V") (TName "values"),PMetaVar "X"] env - env <- getInhPatt "given-value" (VPWildCard) env - env <- withInhTerm "given-value" (TTuple [TVar "V"]) env (premise (TVar "X") (PMetaVar "X'") env) - stepTermTo (TApp "give" (TTuple [TVar "V",TVar "X'"])) env -stepGive fargs = sortErr (FApp "give" (FTuple fargs)) "invalid number of arguments" diff --git a/cbs/Funcons/Core/Computations/DataFlow/Giving/Given.hs b/cbs/Funcons/Core/Computations/DataFlow/Giving/Given.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/DataFlow/Giving/Given.hs +++ /dev/null @@ -1,45 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Data flow/Giving/given.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.DataFlow.Giving.Given where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("given",NullaryFuncon stepGiven),("given1",NullaryFuncon stepGiven1),("given2",NullaryFuncon stepGiven2),("given3",NullaryFuncon stepGiven3)] - --- | --- /given/ returns the current given value. -given_ = FName "given" -stepGiven = evalRules [] [step1] - where step1 = do - let env = emptyEnv - env <- getInhPatt "given-value" (VPMetaVar "V") env - stepTermTo (TVar "V") env - --- | --- /given1/ returns the first component of the currently given tuple. --- /given2/ returns the second component of the currently given tuple. --- /given3/ returns the third component of the currently given tuple. -given1_ = FName "given1" -stepGiven1 = evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - rewriteTo (FApp "tuple-index" (FTuple [FName "given",FValue (Nat 1)])) - -given2_ = FName "given2" -stepGiven2 = evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - rewriteTo (FApp "tuple-index" (FTuple [FName "given",FValue (Nat 2)])) - -given3_ = FName "given3" -stepGiven3 = evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - rewriteTo (FApp "tuple-index" (FTuple [FName "given",FValue (Nat 3)])) diff --git a/cbs/Funcons/Core/Computations/DataFlow/Giving/GivenValue.hs b/cbs/Funcons/Core/Computations/DataFlow/Giving/GivenValue.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/DataFlow/Giving/GivenValue.hs +++ /dev/null @@ -1,14 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Data flow/Giving/given-value.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.DataFlow.Giving.GivenValue where - -import Funcons.EDSL - -entities = [DefInherited "given-value" (FTuple [])] - -types = typeEnvFromList - [] - -funcons = libFromList - [] diff --git a/cbs/Funcons/Core/Computations/DataFlow/Interacting/Print.hs b/cbs/Funcons/Core/Computations/DataFlow/Interacting/Print.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/DataFlow/Interacting/Print.hs +++ /dev/null @@ -1,26 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Data flow/Interacting/print.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.DataFlow.Interacting.Print where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("print",StrictFuncon stepPrint)] - --- | --- /print(E)/ evaluates /E/ and emits the resulting value --- on the /standard-out/ . -print_ fargs = FApp "print" (FTuple fargs) -stepPrint fargs = - evalRules [] [step1] - where step1 = do - let env = emptyEnv - env <- lifted_vsMatch fargs [VPAnnotated (VPMetaVar "V") (TName "values")] env - writeOutTerm "standard-out" (TList [TVar "V"]) env - stepTo (FTuple []) diff --git a/cbs/Funcons/Core/Computations/DataFlow/Interacting/PrintList.hs b/cbs/Funcons/Core/Computations/DataFlow/Interacting/PrintList.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/DataFlow/Interacting/PrintList.hs +++ /dev/null @@ -1,25 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Data flow/Interacting/print-list.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.DataFlow.Interacting.PrintList where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("print-list",StrictFuncon stepPrint_list)] - --- | --- /print-list(L)/ emits the values contained in the list /L/ on the /standard-out/ . -print_list_ fargs = FApp "print-list" (FTuple fargs) -stepPrint_list fargs = - evalRules [] [step1] - where step1 = do - let env = emptyEnv - env <- lifted_vsMatch fargs [VPAnnotated (VPMetaVar "L") (TApp "lists" (TTuple [TName "values"]))] env - writeOutTerm "standard-out" (TTuple [TVar "L"]) env - stepTo (FTuple []) diff --git a/cbs/Funcons/Core/Computations/DataFlow/Interacting/Read.hs b/cbs/Funcons/Core/Computations/DataFlow/Interacting/Read.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/DataFlow/Interacting/Read.hs +++ /dev/null @@ -1,23 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Data flow/Interacting/read.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.DataFlow.Interacting.Read where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("read",NullaryFuncon stepRead)] - --- | --- /read/ consumes a single value from the /standard-in/ , and returns it. -read_ = FName "read" -stepRead = evalRules [] [step1] - where step1 = do - let env = emptyEnv - env <- assignInput "standard-in" "V" env - stepTermTo (TVar "V") env diff --git a/cbs/Funcons/Core/Computations/DataFlow/Interacting/StandardIn.hs b/cbs/Funcons/Core/Computations/DataFlow/Interacting/StandardIn.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/DataFlow/Interacting/StandardIn.hs +++ /dev/null @@ -1,14 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Data flow/Interacting/standard-in.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.DataFlow.Interacting.StandardIn where - -import Funcons.EDSL - -entities = [DefInput "standard-in"] - -types = typeEnvFromList - [] - -funcons = libFromList - [] diff --git a/cbs/Funcons/Core/Computations/DataFlow/Interacting/StandardOut.hs b/cbs/Funcons/Core/Computations/DataFlow/Interacting/StandardOut.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/DataFlow/Interacting/StandardOut.hs +++ /dev/null @@ -1,14 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Data flow/Interacting/standard-out.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.DataFlow.Interacting.StandardOut where - -import Funcons.EDSL - -entities = [DefOutput "standard-out"] - -types = typeEnvFromList - [] - -funcons = libFromList - [] diff --git a/cbs/Funcons/Core/Computations/DataFlow/Linking/AllocateInitialisedLink.hs b/cbs/Funcons/Core/Computations/DataFlow/Linking/AllocateInitialisedLink.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/DataFlow/Linking/AllocateInitialisedLink.hs +++ /dev/null @@ -1,26 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Data flow/Linking/allocate-initialised-link.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.DataFlow.Linking.AllocateInitialisedLink where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("allocate-initialised-link",StrictFuncon stepAllocate_initialised_link)] - --- | --- /allocate-initialised-link(T,V)/ computes a link to values of type /T/ , --- and sets its value to /V/ . --- This /fail/ s if the type of /V/ is not a subtype of /T/ . -allocate_initialised_link_ fargs = FApp "allocate-initialised-link" (FTuple fargs) -stepAllocate_initialised_link fargs = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "T") (TName "values"),VPAnnotated (VPMetaVar "V") (TName "values")] env - rewriteTermTo (TApp "give" (TTuple [TApp "allocate-link" (TTuple [TVar "T"]),TApp "sequential" (TTuple [TApp "set-link" (TTuple [TName "given",TVar "V"]),TName "given"])])) env diff --git a/cbs/Funcons/Core/Computations/DataFlow/Linking/AllocateLink.hs b/cbs/Funcons/Core/Computations/DataFlow/Linking/AllocateLink.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/DataFlow/Linking/AllocateLink.hs +++ /dev/null @@ -1,30 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Data flow/Linking/allocate-link.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.DataFlow.Linking.AllocateLink where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("allocate-link",StrictFuncon stepAllocate_link)] - --- | --- /allocate-link(T)/ computes a link to values of type /T/ . -allocate_link_ fargs = FApp "allocate-link" (FTuple fargs) -stepAllocate_link fargs = - evalRules [] [step1] - where step1 = do - let env = emptyEnv - env <- lifted_vsMatch fargs [VPAnnotated (VPMetaVar "T") (TName "types")] env - env <- getMutPatt "link-store" (VPMetaVar "Sigma") env - putMutTerm "link-store" (TTuple [TVar "Sigma"]) env - env <- premise (TName "fresh-atom") (PMetaVar "K") env - env <- getMutPatt "link-store" (VPMetaVar "Sigma'") env - env <- lifted_sideCondition (SCPatternMatch (TApp "simple-link" (TTuple [TVar "K",TVar "T"])) (VPMetaVar "L")) env - putMutTerm "link-store" (TTuple [TApp "map-unite" (TTuple [TVar "Sigma'",TMap [TTuple [TVar "L",TName "uninitialised"]]])]) env - stepTermTo (TVar "L") env diff --git a/cbs/Funcons/Core/Computations/DataFlow/Linking/FollowIfLink.hs b/cbs/Funcons/Core/Computations/DataFlow/Linking/FollowIfLink.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/DataFlow/Linking/FollowIfLink.hs +++ /dev/null @@ -1,31 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Data flow/Linking/follow-if-link.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.DataFlow.Linking.FollowIfLink where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("follow-if-link",StrictFuncon stepFollow_if_link)] - --- | --- If /V/ is a link, then /follow-if-link(V)/ gives the value --- to which the link /V/ has been set. Otherwise, /V/ is returned. -follow_if_link_ fargs = FApp "follow-if-link" (FTuple fargs) -stepFollow_if_link fargs = - evalRules [rewrite1,rewrite2] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [VPMetaVar "V"] env - env <- sideCondition (SCIsInSort (TVar "V") (TName "all-links")) env - rewriteTermTo (TApp "follow-link" (TTuple [TVar "V"])) env - rewrite2 = do - let env = emptyEnv - env <- vsMatch fargs [VPMetaVar "V"] env - env <- sideCondition (SCNotInSort (TVar "V") (TName "all-links")) env - rewriteTermTo (TVar "V") env diff --git a/cbs/Funcons/Core/Computations/DataFlow/Linking/FollowLink.hs b/cbs/Funcons/Core/Computations/DataFlow/Linking/FollowLink.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/DataFlow/Linking/FollowLink.hs +++ /dev/null @@ -1,43 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Data flow/Linking/follow-link.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.DataFlow.Linking.FollowLink where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("follow-link",StrictFuncon stepFollow_link)] - --- | --- /follow-link(L)/ gives the value linked to by /L/ . --- If this value is /uninitialised/ , then computation /fail/ s. -follow_link_ fargs = FApp "follow-link" (FTuple fargs) -stepFollow_link fargs = - evalRules [] [step1,step2,step3] - where step1 = do - let env = emptyEnv - env <- lifted_vsMatch fargs [VPMetaVar "L"] env - env <- getMutPatt "link-store" (VPMetaVar "Sigma") env - env <- lifted_sideCondition (SCPatternMatch (TApp "lookup" (TTuple [TVar "L",TVar "Sigma"])) (VPMetaVar "V")) env - env <- lifted_sideCondition (SCNotInSort (TVar "V") (TName "uninitialised-values")) env - putMutTerm "link-store" (TTuple [TVar "Sigma"]) env - stepTermTo (TVar "V") env - step2 = do - let env = emptyEnv - env <- lifted_vsMatch fargs [VPMetaVar "L"] env - env <- getMutPatt "link-store" (VPMetaVar "Sigma") env - env <- lifted_sideCondition (SCIsInSort (TApp "lookup" (TTuple [TVar "L",TVar "Sigma"])) (TName "uninitialised-values")) env - putMutTerm "link-store" (TTuple [TVar "Sigma"]) env - stepTo (FName "fail") - step3 = do - let env = emptyEnv - env <- lifted_vsMatch fargs [VPMetaVar "L"] env - env <- getMutPatt "link-store" (VPMetaVar "Sigma") env - env <- lifted_sideCondition (SCEquality (TApp "is-in-set" (TTuple [TVar "L",TApp "domain" (TTuple [TVar "Sigma"])])) (TName "false")) env - putMutTerm "link-store" (TTuple [TVar "Sigma"]) env - stepTo (FName "fail") diff --git a/cbs/Funcons/Core/Computations/DataFlow/Linking/LinkStore.hs b/cbs/Funcons/Core/Computations/DataFlow/Linking/LinkStore.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/DataFlow/Linking/LinkStore.hs +++ /dev/null @@ -1,14 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Data flow/Linking/link-store.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.DataFlow.Linking.LinkStore where - -import Funcons.EDSL - -entities = [DefMutable "link-store" (FName "map-empty")] - -types = typeEnvFromList - [] - -funcons = libFromList - [] diff --git a/cbs/Funcons/Core/Computations/DataFlow/Linking/LinkStores.hs b/cbs/Funcons/Core/Computations/DataFlow/Linking/LinkStores.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/DataFlow/Linking/LinkStores.hs +++ /dev/null @@ -1,20 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Data flow/Linking/link-stores.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.DataFlow.Linking.LinkStores where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("link-stores",NullaryFuncon stepLink_stores)] - -link_stores_ = FName "link-stores" -stepLink_stores = evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - rewriteTo (FApp "maps" (FTuple [FName "all-links",FName "values"])) diff --git a/cbs/Funcons/Core/Computations/DataFlow/Linking/Links.hs b/cbs/Funcons/Core/Computations/DataFlow/Linking/Links.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/DataFlow/Linking/Links.hs +++ /dev/null @@ -1,61 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Data flow/Linking/links.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.DataFlow.Linking.Links where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [("reynolds-links",DataTypeMembers [(Just "Accepting",TName "types"),(Just "Producing",TName "types")] [DataTypeConstructor "simple-link" (TTuple [TName "atoms",TName "types"]),DataTypeConstructor "reynolds-link" (TTuple [TName "atoms",TName "types",TName "types"])])] - -funcons = libFromList - [("links",StrictFuncon stepLinks),("all-links",NullaryFuncon stepAll_links),("link-accepting-type",StrictFuncon stepLink_accepting_type),("link-producing-type",StrictFuncon stepLink_producing_type),("reynolds-links",StrictFuncon stepReynolds_links),("simple-link",StrictFuncon stepSimple_link),("reynolds-link",StrictFuncon stepReynolds_link)] - -links_ fargs = FApp "links" (FTuple fargs) -stepLinks fargs = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "T") (TName "values")] env - rewriteTermTo (TApp "reynolds-links" (TTuple [TVar "T",TVar "T"])) env - -all_links_ = FName "all-links" -stepAll_links = evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - rewriteTo (FApp "reynolds-links" (FTuple [FName "empty-type",FName "values"])) - --- | --- /link-accepting-type(L)/ returns the type of values that /L/ accepts. --- /link-producing-type(L)/ returns the type of values that /L/ can produce. -link_accepting_type_ fargs = FApp "link-accepting-type" (FTuple fargs) -stepLink_accepting_type fargs = - evalRules [rewrite1,rewrite2] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [PADT "simple-link" [VPWildCard,VPMetaVar "T"]] env - rewriteTermTo (TVar "T") env - rewrite2 = do - let env = emptyEnv - env <- vsMatch fargs [PADT "reynolds-link" [VPWildCard,VPMetaVar "Accepting",VPWildCard]] env - rewriteTermTo (TVar "Accepting") env - -link_producing_type_ fargs = FApp "link-producing-type" (FTuple fargs) -stepLink_producing_type fargs = - evalRules [rewrite1,rewrite2] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [PADT "simple-link" [VPWildCard,VPMetaVar "T"]] env - rewriteTermTo (TVar "T") env - rewrite2 = do - let env = emptyEnv - env <- vsMatch fargs [PADT "reynolds-link" [VPWildCard,VPWildCard,VPMetaVar "Producing"]] env - rewriteTermTo (TVar "Producing") env - -stepSimple_link vs = rewritten (ADTVal "simple-link" vs) - -stepReynolds_link vs = rewritten (ADTVal "reynolds-link" vs) - -stepReynolds_links ts = rewriteType "reynolds-links" ts diff --git a/cbs/Funcons/Core/Computations/DataFlow/Linking/SetLink.hs b/cbs/Funcons/Core/Computations/DataFlow/Linking/SetLink.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/DataFlow/Linking/SetLink.hs +++ /dev/null @@ -1,50 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Data flow/Linking/set-link.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.DataFlow.Linking.SetLink where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("set-link",StrictFuncon stepSet_link)] - --- | --- /set-link(L,V)/ sets the value linked to by /L/ to be /V/ . --- If /L/ has already been set, then computation instead /fail/ s. -set_link_ fargs = FApp "set-link" (FTuple fargs) -stepSet_link fargs = - evalRules [] [step1,step2,step3,step4] - where step1 = do - let env = emptyEnv - env <- lifted_vsMatch fargs [VPMetaVar "L",VPMetaVar "V"] env - env <- getMutPatt "link-store" (VPMetaVar "Sigma") env - env <- lifted_sideCondition (SCIsInSort (TApp "lookup" (TTuple [TVar "L",TVar "Sigma"])) (TName "uninitialised-values")) env - env <- lifted_sideCondition (SCIsInSort (TVar "V") (TApp "link-accepting-type" (TTuple [TVar "L"]))) env - putMutTerm "link-store" (TTuple [TApp "map-override" (TTuple [TMap [TTuple [TVar "L",TVar "V"]],TVar "Sigma"])]) env - stepTo (FTuple []) - step2 = do - let env = emptyEnv - env <- lifted_vsMatch fargs [VPMetaVar "L",VPAnnotated (VPMetaVar "V") (TName "values")] env - env <- getMutPatt "link-store" (VPMetaVar "Sigma") env - env <- lifted_sideCondition (SCEquality (TApp "is-in-set" (TTuple [TVar "L",TApp "domain" (TTuple [TVar "Sigma"])])) (TName "false")) env - putMutTerm "link-store" (TTuple [TVar "Sigma"]) env - stepTo (FName "fail") - step3 = do - let env = emptyEnv - env <- lifted_vsMatch fargs [VPMetaVar "L",VPAnnotated (VPMetaVar "V") (TName "values")] env - env <- getMutPatt "link-store" (VPMetaVar "Sigma") env - env <- lifted_sideCondition (SCNotInSort (TApp "lookup" (TTuple [TVar "L",TVar "Sigma"])) (TName "uninitialised-values")) env - putMutTerm "link-store" (TTuple [TVar "Sigma"]) env - stepTo (FName "fail") - step4 = do - let env = emptyEnv - env <- lifted_vsMatch fargs [VPMetaVar "L",VPMetaVar "V"] env - env <- getMutPatt "link-store" (VPMetaVar "Sigma") env - env <- lifted_sideCondition (SCNotInSort (TVar "V") (TApp "link-accepting-type" (TTuple [TVar "L"]))) env - putMutTerm "link-store" (TTuple [TVar "Sigma"]) env - stepTo (FName "fail") diff --git a/cbs/Funcons/Core/Computations/DataFlow/Storing/GeneralVariables/AllocateMap.hs b/cbs/Funcons/Core/Computations/DataFlow/Storing/GeneralVariables/AllocateMap.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/DataFlow/Storing/GeneralVariables/AllocateMap.hs +++ /dev/null @@ -1,25 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Data flow/Storing/General variables/allocate-map.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.DataFlow.Storing.GeneralVariables.AllocateMap where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("allocate-map",StrictFuncon stepAllocate_map)] - --- | --- /allocate-map(M)/ computes a map where the entries are --- uninitialised /variables/ of types given by /M/ . -allocate_map_ fargs = FApp "allocate-map" (FTuple fargs) -stepAllocate_map fargs = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "M") (TName "values")] env - rewriteTermTo (TApp "map-map" (TTuple [TApp "allocate-variable" (TTuple [TName "given2"]),TVar "M"])) env diff --git a/cbs/Funcons/Core/Computations/DataFlow/Storing/GeneralVariables/AllocateVector.hs b/cbs/Funcons/Core/Computations/DataFlow/Storing/GeneralVariables/AllocateVector.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/DataFlow/Storing/GeneralVariables/AllocateVector.hs +++ /dev/null @@ -1,25 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Data flow/Storing/General variables/allocate-vector.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.DataFlow.Storing.GeneralVariables.AllocateVector where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("allocate-vector",StrictFuncon stepAllocate_vector)] - --- | --- /allocate-vector(T,N)/ computes a vector of length /N/ , --- containing uninitialised /variables/ of type /T/ . -allocate_vector_ fargs = FApp "allocate-vector" (FTuple fargs) -stepAllocate_vector fargs = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "T") (TName "values"),VPAnnotated (VPMetaVar "N") (TName "values")] env - rewriteTermTo (TApp "vector-map" (TTuple [TApp "allocate-variable" (TTuple [TName "given"]),TApp "vector-repeat" (TTuple [TVar "N",TVar "T"])])) env diff --git a/cbs/Funcons/Core/Computations/DataFlow/Storing/GeneralVariables/GeneralAssign.hs b/cbs/Funcons/Core/Computations/DataFlow/Storing/GeneralVariables/GeneralAssign.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/DataFlow/Storing/GeneralVariables/GeneralAssign.hs +++ /dev/null @@ -1,67 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Data flow/Storing/General variables/general-assign.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.DataFlow.Storing.GeneralVariables.GeneralAssign where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("general-assign",StrictFuncon stepGeneral_assign)] - --- | --- /general-assign(Var,Val)/ assigns the (potentially composite) value /Val/ to --- the (potentialy composite) variable /Var/ . -general_assign_ fargs = FApp "general-assign" (FTuple fargs) -stepGeneral_assign fargs = - evalRules [rewrite1,rewrite2,rewrite3,rewrite4,rewrite5,rewrite6,rewrite7,rewrite8,rewrite9] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "Var") (TName "all-variables"),VPAnnotated (VPMetaVar "Val") (TName "values")] env - rewriteTermTo (TApp "assign" (TTuple [TVar "Var",TVar "Val"])) env - rewrite2 = do - let env = emptyEnv - env <- vsMatch fargs [VPMetaVar "Var",VPAnnotated (VPMetaVar "Val") (TName "values")] env - env <- sideCondition (SCNotInSort (TVar "Var") (TName "all-variables")) env - env <- sideCondition (SCNotInSort (TVar "Var") (TApp "thunks" (TTuple [TSortComputesFrom (TName "values") (TName "environments")]))) env - env <- sideCondition (SCNotInSort (TVar "Var") (TName "algebraic-datatypes")) env - env <- sideCondition (SCNotInSort (TVar "Var") (TApp "lists" (TTuple [TName "values"]))) env - env <- sideCondition (SCNotInSort (TVar "Var") (TApp "maps" (TTuple [TName "values",TName "values"]))) env - env <- sideCondition (SCNotInSort (TVar "Var") (TApp "tuples" (TTuple [TName "values",TSortSeq (TName "values") PlusOp]))) env - env <- sideCondition (SCNotInSort (TVar "Var") (TApp "vectors" (TTuple [TName "values"]))) env - rewriteTermTo (TApp "check-true" (TTuple [TApp "is-equal" (TTuple [TVar "Var",TVar "Val"])])) env - rewrite3 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "Var") (TName "algebraic-datatypes"),VPAnnotated (VPMetaVar "Val") (TName "values")] env - rewriteTermTo (TApp "sequential" (TTuple [TApp "check-true" (TTuple [TApp "is-in-type" (TTuple [TVar "Val",TName "algebraic-datatypes"])]),TApp "check-true" (TTuple [TApp "is-equal" (TTuple [TApp "algebraic-datatype-constructor" (TTuple [TVar "Var"]),TApp "algebraic-datatype-constructor" (TTuple [TVar "Val"])])]),TApp "general-assign" (TTuple [TApp "algebraic-datatype-value" (TTuple [TVar "Var"]),TApp "algebraic-datatype-value" (TTuple [TVar "Val"])])])) env - rewrite4 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "Var") (TApp "lists" (TTuple [TName "values"])),VPAnnotated (VPMetaVar "Val") (TName "values")] env - rewriteTermTo (TApp "sequential" (TTuple [TApp "check-true" (TTuple [TApp "is-in-type" (TTuple [TVar "Val",TApp "lists" (TTuple [TName "values"])])]),TApp "effect" (TTuple [TApp "lists-map" (TTuple [TApp "general-assign" (TTuple [TName "given"]),TTuple [TVar "Var",TVar "Val"]])])])) env - rewrite5 = do - let env = emptyEnv - env <- vsMatch fargs [VPMetaVar "Var",VPAnnotated (VPMetaVar "Val") (TName "values")] env - env <- sideCondition (SCEquality (TVar "Var") (TName "map-empty")) env - rewriteTermTo (TApp "check-true" (TTuple [TApp "is-equal" (TTuple [TVar "Val",TName "map-empty"])])) env - rewrite6 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "VarM") (TApp "maps" (TTuple [TName "values",TName "values"])),VPAnnotated (VPMetaVar "ValM") (TName "values")] env - env <- sideCondition (SCPatternMatch (TApp "some-element" (TTuple [TApp "domain" (TTuple [TVar "VarM"])])) (VPMetaVar "K")) env - rewriteTermTo (TApp "sequential" (TTuple [TApp "check-true" (TTuple [TApp "is-in-type" (TTuple [TVar "ValM",TApp "maps" (TTuple [TName "values",TName "values"])])]),TApp "check-true" (TTuple [TApp "is-equal" (TTuple [TApp "domain" (TTuple [TVar "VarM"]),TApp "domain" (TTuple [TVar "ValM"])])]),TApp "effect" (TTuple [TApp "general-assign" (TTuple [TApp "lookup" (TTuple [TVar "K",TVar "VarM"]),TApp "lookup" (TTuple [TVar "K",TVar "ValM"])]),TApp "general-assign" (TTuple [TApp "map-delete" (TTuple [TVar "VarM",TSet [TVar "K"]]),TApp "map-delete" (TTuple [TVar "ValM",TSet [TVar "K"]])])])])) env - rewrite7 = do - let env = emptyEnv - env <- vsMatch fargs [PTuple [VPAnnotated (VPMetaVar "Var") (TName "values"),VPAnnotated (VPSeqVar "Var+" PlusOp) (TName "values")],PTuple [VPAnnotated (VPMetaVar "Val") (TName "values"),VPAnnotated (VPSeqVar "Val+" PlusOp) (TName "values")]] env - rewriteTermTo (TApp "effect" (TTuple [TApp "general-assign" (TTuple [TVar "Var",TVar "Val"]),TApp "general-assign" (TTuple [TTuple [TVar "Var+"],TTuple [TVar "Val+"]])])) env - rewrite8 = do - let env = emptyEnv - env <- vsMatch fargs [PTuple [VPAnnotated (VPMetaVar "Var") (TName "values"),VPAnnotated (VPSeqVar "Var+" PlusOp) (TName "values")],VPAnnotated (VPMetaVar "Val") (TName "values")] env - env <- sideCondition (SCNotInSort (TVar "Val") (TApp "tuples" (TTuple [TName "values",TSortSeq (TName "values") PlusOp]))) env - rewriteTo (FName "fail") - rewrite9 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "Var") (TApp "vectors" (TTuple [TName "values"])),VPAnnotated (VPMetaVar "Val") (TName "values")] env - rewriteTermTo (TApp "sequential" (TTuple [TApp "check-true" (TTuple [TApp "is-in-type" (TTuple [TVar "Val",TApp "vectors" (TTuple [TName "values"])])]),TApp "general-assign" (TTuple [TApp "vector-to-list" (TTuple [TVar "Var"]),TApp "vector-to-list" (TTuple [TVar "Val"])])])) env diff --git a/cbs/Funcons/Core/Computations/DataFlow/Storing/GeneralVariables/GeneralAssigned.hs b/cbs/Funcons/Core/Computations/DataFlow/Storing/GeneralVariables/GeneralAssigned.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/DataFlow/Storing/GeneralVariables/GeneralAssigned.hs +++ /dev/null @@ -1,56 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Data flow/Storing/General variables/general-assigned.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.DataFlow.Storing.GeneralVariables.GeneralAssigned where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("general-assigned",StrictFuncon stepGeneral_assigned)] - --- | --- /general-assigned(V)/ takes a (potentially composite) value /V/ , which may --- contain /variables/ , and computes the value of /V/ with all such contained --- variables replaced by the values currently assigned to those variables. -general_assigned_ fargs = FApp "general-assigned" (FTuple fargs) -stepGeneral_assigned fargs = - evalRules [rewrite1,rewrite2,rewrite3,rewrite4,rewrite5,rewrite6,rewrite7] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [VPMetaVar "V"] env - env <- sideCondition (SCNotInSort (TVar "V") (TName "all-variables")) env - env <- sideCondition (SCNotInSort (TVar "V") (TName "algebraic-datatypes")) env - env <- sideCondition (SCNotInSort (TVar "V") (TApp "lists" (TTuple [TName "values"]))) env - env <- sideCondition (SCNotInSort (TVar "V") (TApp "maps" (TTuple [TName "values",TName "values"]))) env - env <- sideCondition (SCNotInSort (TVar "V") (TApp "tuples" (TTuple [TName "values",TSortSeq (TName "values") PlusOp]))) env - env <- sideCondition (SCNotInSort (TVar "V") (TApp "vectors" (TTuple [TName "values"]))) env - rewriteTermTo (TVar "V") env - rewrite2 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "Var") (TName "all-variables")] env - rewriteTermTo (TApp "assigned" (TTuple [TVar "Var"])) env - rewrite3 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "ADT") (TName "algebraic-datatypes")] env - rewriteTermTo (TApp "algebraic-datatype" (TTuple [TApp "algebraic-datatype-constructor" (TTuple [TVar "ADT"]),TApp "general-assigned" (TTuple [TApp "algebraic-datatype-value" (TTuple [TVar "ADT"])])])) env - rewrite4 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "L") (TApp "lists" (TTuple [TName "values"]))] env - rewriteTermTo (TApp "list-map" (TTuple [TApp "general-assigned" (TTuple [TName "given"]),TVar "L"])) env - rewrite5 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "M") (TApp "maps" (TTuple [TName "values",TName "values"]))] env - rewriteTermTo (TApp "map-map" (TTuple [TApp "general-assigned" (TTuple [TName "given2"]),TVar "M"])) env - rewrite6 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "T") (TApp "tuples" (TTuple [TName "values",TSortSeq (TName "values") PlusOp]))] env - rewriteTermTo (TApp "tuple-map" (TTuple [TApp "general-assigned" (TTuple [TName "given"]),TVar "T"])) env - rewrite7 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "Vec") (TApp "vectors" (TTuple [TName "values"]))] env - rewriteTermTo (TApp "vector-map" (TTuple [TApp "general-assigned" (TTuple [TName "given"]),TVar "Vec"])) env diff --git a/cbs/Funcons/Core/Computations/DataFlow/Storing/SimpleVariables/AllocateInitialisedVariable.hs b/cbs/Funcons/Core/Computations/DataFlow/Storing/SimpleVariables/AllocateInitialisedVariable.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/DataFlow/Storing/SimpleVariables/AllocateInitialisedVariable.hs +++ /dev/null @@ -1,26 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Data flow/Storing/Simple variables/allocate-initialised-variable.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.AllocateInitialisedVariable where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("allocate-initialised-variable",StrictFuncon stepAllocate_initialised_variable)] - --- | --- /allocate-initialised-variable(T,V)/ computes a simple variable for storing --- values of type /T/ , and initialises its value to /V/ . --- This /fail/ s if the type of /V/ is not a subtype of /T/ . -allocate_initialised_variable_ fargs = FApp "allocate-initialised-variable" (FTuple fargs) -stepAllocate_initialised_variable fargs = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "T") (TName "values"),VPAnnotated (VPMetaVar "V") (TName "values")] env - rewriteTermTo (TApp "give" (TTuple [TApp "allocate-variable" (TTuple [TVar "T"]),TApp "sequential" (TTuple [TApp "assign" (TTuple [TName "given",TVar "V"]),TName "given"])])) env diff --git a/cbs/Funcons/Core/Computations/DataFlow/Storing/SimpleVariables/AllocateVariable.hs b/cbs/Funcons/Core/Computations/DataFlow/Storing/SimpleVariables/AllocateVariable.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/DataFlow/Storing/SimpleVariables/AllocateVariable.hs +++ /dev/null @@ -1,31 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Data flow/Storing/Simple variables/allocate-variable.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.AllocateVariable where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("allocate-variable",StrictFuncon stepAllocate_variable)] - --- | --- /allocate-variable(T)/ computes an (uninitialised) simple variable for storing --- values of type /T/ . -allocate_variable_ fargs = FApp "allocate-variable" (FTuple fargs) -stepAllocate_variable fargs = - evalRules [] [step1] - where step1 = do - let env = emptyEnv - env <- lifted_vsMatch fargs [VPAnnotated (VPMetaVar "T") (TName "types")] env - env <- getMutPatt "store" (VPMetaVar "Sigma") env - putMutTerm "store" (TTuple [TVar "Sigma"]) env - env <- premise (TName "fresh-atom") (PMetaVar "K") env - env <- getMutPatt "store" (VPMetaVar "Sigma'") env - env <- lifted_sideCondition (SCPatternMatch (TApp "simple-variable" (TTuple [TVar "K",TVar "T"])) (VPMetaVar "Var")) env - putMutTerm "store" (TTuple [TApp "map-unite" (TTuple [TVar "Sigma'",TMap [TTuple [TVar "Var",TName "uninitialised"]]])]) env - stepTermTo (TVar "Var") env diff --git a/cbs/Funcons/Core/Computations/DataFlow/Storing/SimpleVariables/Assign.hs b/cbs/Funcons/Core/Computations/DataFlow/Storing/SimpleVariables/Assign.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/DataFlow/Storing/SimpleVariables/Assign.hs +++ /dev/null @@ -1,43 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Data flow/Storing/Simple variables/assign.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.Assign where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("assign",StrictFuncon stepAssign)] - --- | --- /assign(Var,Val)/ assigns /Val/ to the the variable /Var/ , provided /Var/ has --- not been deallocated and /Val/ is of the appropriate type for storing in /Var/ . -assign_ fargs = FApp "assign" (FTuple fargs) -stepAssign fargs = - evalRules [] [step1,step2,step3] - where step1 = do - let env = emptyEnv - env <- lifted_vsMatch fargs [VPMetaVar "Var",VPMetaVar "Val"] env - env <- getMutPatt "store" (VPMetaVar "Sigma") env - env <- lifted_sideCondition (SCEquality (TApp "is-in-set" (TTuple [TVar "Var",TApp "domain" (TTuple [TVar "Sigma"])])) (TName "true")) env - env <- lifted_sideCondition (SCIsInSort (TVar "Val") (TApp "variable-accepting-type" (TTuple [TVar "Var"]))) env - putMutTerm "store" (TTuple [TApp "map-override" (TTuple [TMap [TTuple [TVar "Var",TVar "Val"]],TVar "Sigma"])]) env - stepTo (FTuple []) - step2 = do - let env = emptyEnv - env <- lifted_vsMatch fargs [VPMetaVar "Var",VPAnnotated (VPMetaVar "Val") (TName "values")] env - env <- getMutPatt "store" (VPMetaVar "Sigma") env - env <- lifted_sideCondition (SCEquality (TApp "is-in-set" (TTuple [TVar "Var",TApp "domain" (TTuple [TVar "Sigma"])])) (TName "false")) env - putMutTerm "store" (TTuple [TVar "Sigma"]) env - stepTo (FName "fail") - step3 = do - let env = emptyEnv - env <- lifted_vsMatch fargs [VPMetaVar "Var",VPMetaVar "Val"] env - env <- getMutPatt "store" (VPMetaVar "Sigma") env - env <- lifted_sideCondition (SCNotInSort (TVar "Val") (TApp "variable-accepting-type" (TTuple [TVar "Var"]))) env - putMutTerm "store" (TTuple [TVar "Sigma"]) env - stepTo (FName "fail") diff --git a/cbs/Funcons/Core/Computations/DataFlow/Storing/SimpleVariables/Assigned.hs b/cbs/Funcons/Core/Computations/DataFlow/Storing/SimpleVariables/Assigned.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/DataFlow/Storing/SimpleVariables/Assigned.hs +++ /dev/null @@ -1,43 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Data flow/Storing/Simple variables/assigned.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.Assigned where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("assigned",StrictFuncon stepAssigned)] - --- | --- /assigned(Var)/ gives the value currently assigned to the variable /Var/ . --- If this value is /uninitialised/ , then computation /fail/ s. -assigned_ fargs = FApp "assigned" (FTuple fargs) -stepAssigned fargs = - evalRules [] [step1,step2,step3] - where step1 = do - let env = emptyEnv - env <- lifted_vsMatch fargs [VPMetaVar "Var"] env - env <- getMutPatt "store" (VPMetaVar "Sigma") env - env <- lifted_sideCondition (SCPatternMatch (TApp "lookup" (TTuple [TVar "Var",TVar "Sigma"])) (VPMetaVar "V")) env - env <- lifted_sideCondition (SCNotInSort (TVar "V") (TName "uninitialised-values")) env - putMutTerm "store" (TTuple [TVar "Sigma"]) env - stepTermTo (TVar "V") env - step2 = do - let env = emptyEnv - env <- lifted_vsMatch fargs [VPMetaVar "Var"] env - env <- getMutPatt "store" (VPMetaVar "Sigma") env - env <- lifted_sideCondition (SCIsInSort (TApp "lookup" (TTuple [TVar "Var",TVar "Sigma"])) (TName "uninitialised-values")) env - putMutTerm "store" (TTuple [TVar "Sigma"]) env - stepTo (FName "fail") - step3 = do - let env = emptyEnv - env <- lifted_vsMatch fargs [VPMetaVar "Var"] env - env <- getMutPatt "store" (VPMetaVar "Sigma") env - env <- lifted_sideCondition (SCEquality (TApp "is-in-set" (TTuple [TVar "Var",TApp "domain" (TTuple [TVar "Sigma"])])) (TName "false")) env - putMutTerm "store" (TTuple [TVar "Sigma"]) env - stepTo (FName "fail") diff --git a/cbs/Funcons/Core/Computations/DataFlow/Storing/SimpleVariables/CurrentValue.hs b/cbs/Funcons/Core/Computations/DataFlow/Storing/SimpleVariables/CurrentValue.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/DataFlow/Storing/SimpleVariables/CurrentValue.hs +++ /dev/null @@ -1,31 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Data flow/Storing/Simple variables/current-value.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.CurrentValue where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("current-value",StrictFuncon stepCurrent_value)] - --- | --- If /V/ is a variable, /current-value(V)/ computes the value currently --- assigned to /V/ . Otherwise it evaluates to /V/ . -current_value_ fargs = FApp "current-value" (FTuple fargs) -stepCurrent_value fargs = - evalRules [rewrite1,rewrite2] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [VPMetaVar "V"] env - env <- sideCondition (SCIsInSort (TVar "V") (TName "all-variables")) env - rewriteTermTo (TApp "assigned" (TTuple [TVar "V"])) env - rewrite2 = do - let env = emptyEnv - env <- vsMatch fargs [VPMetaVar "V"] env - env <- sideCondition (SCNotInSort (TVar "V") (TName "all-variables")) env - rewriteTermTo (TVar "V") env diff --git a/cbs/Funcons/Core/Computations/DataFlow/Storing/SimpleVariables/DeallocateVariable.hs b/cbs/Funcons/Core/Computations/DataFlow/Storing/SimpleVariables/DeallocateVariable.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/DataFlow/Storing/SimpleVariables/DeallocateVariable.hs +++ /dev/null @@ -1,34 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Data flow/Storing/Simple variables/deallocate-variable.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.DeallocateVariable where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("deallocate-variable",StrictFuncon stepDeallocate_variable)] - --- | --- /deallocate-variable(V)/ deletes the variable /V/ from the current /store/ . -deallocate_variable_ fargs = FApp "deallocate-variable" (FTuple fargs) -stepDeallocate_variable fargs = - evalRules [] [step1,step2] - where step1 = do - let env = emptyEnv - env <- lifted_vsMatch fargs [VPMetaVar "Var"] env - env <- getMutPatt "store" (VPMetaVar "Sigma") env - env <- lifted_sideCondition (SCEquality (TApp "is-in-set" (TTuple [TVar "Var",TApp "domain" (TTuple [TVar "Sigma"])])) (TName "true")) env - putMutTerm "store" (TTuple [TApp "map-delete" (TTuple [TVar "Sigma",TSet [TVar "Var"]])]) env - stepTo (FTuple []) - step2 = do - let env = emptyEnv - env <- lifted_vsMatch fargs [VPMetaVar "Var"] env - env <- getMutPatt "store" (VPMetaVar "Sigma") env - env <- lifted_sideCondition (SCEquality (TApp "is-in-set" (TTuple [TVar "Var",TApp "domain" (TTuple [TVar "Sigma"])])) (TName "false")) env - putMutTerm "store" (TTuple [TVar "Sigma"]) env - stepTo (FName "fail") diff --git a/cbs/Funcons/Core/Computations/DataFlow/Storing/Store.hs b/cbs/Funcons/Core/Computations/DataFlow/Storing/Store.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/DataFlow/Storing/Store.hs +++ /dev/null @@ -1,14 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Data flow/Storing/store.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.DataFlow.Storing.Store where - -import Funcons.EDSL - -entities = [DefMutable "store" (FName "map-empty")] - -types = typeEnvFromList - [] - -funcons = libFromList - [] diff --git a/cbs/Funcons/Core/Computations/DataFlow/Storing/Stores.hs b/cbs/Funcons/Core/Computations/DataFlow/Storing/Stores.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/DataFlow/Storing/Stores.hs +++ /dev/null @@ -1,24 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Data flow/Storing/stores.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.DataFlow.Storing.Stores where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [("uninitialised-values",DataTypeMembers [] [DataTypeConstructor "uninitialised" (TTuple [])])] - -funcons = libFromList - [("stores",NullaryFuncon stepStores),("uninitialised-values",NullaryFuncon stepUninitialised_values),("uninitialised",NullaryFuncon stepUninitialised)] - -stores_ = FName "stores" -stepStores = evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - rewriteTo (FApp "maps" (FTuple [FName "all-variables",FName "values"])) - -stepUninitialised = rewritten (ADTVal "uninitialised" []) - -stepUninitialised_values = rewriteType "uninitialised-values" [] diff --git a/cbs/Funcons/Core/Computations/DataFlow/Storing/Variables.hs b/cbs/Funcons/Core/Computations/DataFlow/Storing/Variables.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/DataFlow/Storing/Variables.hs +++ /dev/null @@ -1,61 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/Data flow/Storing/variables.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.DataFlow.Storing.Variables where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [("reynolds-variables",DataTypeMembers [(Just "Accepting",TName "types"),(Just "Producing",TName "types")] [DataTypeConstructor "simple-variable" (TTuple [TName "atoms",TName "types"]),DataTypeConstructor "reynolds-variable" (TTuple [TName "atoms",TName "types",TName "types"])])] - -funcons = libFromList - [("variables",StrictFuncon stepVariables),("all-variables",NullaryFuncon stepAll_variables),("variable-accepting-type",StrictFuncon stepVariable_accepting_type),("variable-producing-type",StrictFuncon stepVariable_producing_type),("reynolds-variables",StrictFuncon stepReynolds_variables),("simple-variable",StrictFuncon stepSimple_variable),("reynolds-variable",StrictFuncon stepReynolds_variable)] - -variables_ fargs = FApp "variables" (FTuple fargs) -stepVariables fargs = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "T") (TName "values")] env - rewriteTermTo (TApp "reynolds-variables" (TTuple [TVar "T",TVar "T"])) env - -all_variables_ = FName "all-variables" -stepAll_variables = evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - rewriteTo (FApp "reynolds-variables" (FTuple [FName "empty-type",FName "values"])) - --- | --- /variable-accepting-type(Var)/ returns the type of values that /Var/ accepts. --- /variable-producing-type(Var)/ returns the type of values that /Var/ can produce. -variable_accepting_type_ fargs = FApp "variable-accepting-type" (FTuple fargs) -stepVariable_accepting_type fargs = - evalRules [rewrite1,rewrite2] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [PADT "simple-variable" [VPWildCard,VPMetaVar "T"]] env - rewriteTermTo (TVar "T") env - rewrite2 = do - let env = emptyEnv - env <- vsMatch fargs [PADT "reynolds-variable" [VPWildCard,VPMetaVar "Accepting",VPWildCard]] env - rewriteTermTo (TVar "Accepting") env - -variable_producing_type_ fargs = FApp "variable-producing-type" (FTuple fargs) -stepVariable_producing_type fargs = - evalRules [rewrite1,rewrite2] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [PADT "simple-variable" [VPWildCard,VPMetaVar "T"]] env - rewriteTermTo (TVar "T") env - rewrite2 = do - let env = emptyEnv - env <- vsMatch fargs [PADT "reynolds-variable" [VPWildCard,VPWildCard,VPMetaVar "Producing"]] env - rewriteTermTo (TVar "Producing") env - -stepSimple_variable vs = rewritten (ADTVal "simple-variable" vs) - -stepReynolds_variable vs = rewritten (ADTVal "reynolds-variable" vs) - -stepReynolds_variables ts = rewriteType "reynolds-variables" ts diff --git a/cbs/Funcons/Core/Computations/Normal/Binding/Binding.hs b/cbs/Funcons/Core/Computations/Normal/Binding/Binding.hs new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/Normal/Binding/Binding.hs @@ -0,0 +1,194 @@ +-- GeNeRaTeD fOr: ../../CBS-beta/Funcons-beta/Computations/Normal/Binding/Binding.cbs +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Computations.Normal.Binding.Binding where + +import Funcons.EDSL + +import Funcons.Operations hiding (Values) +entities = [] + +types = typeEnvFromList + [("identifiers",DataTypeMemberss "identifiers" [] [DataTypeInclusionn (TName "strings"),DataTypeMemberConstructor "identifier-tagged" [TName "identifiers",TName "defined-values"] (Just [])]),("ids",DataTypeMemberss "ids" [] [DataTypeInclusionn (TName "strings"),DataTypeMemberConstructor "identifier-tagged" [TName "identifiers",TName "defined-values"] (Just [])])] + +funcons = libFromList + [("environments",NullaryFuncon stepEnvironments),("env",NullaryFuncon stepEnvironments),("envs",NullaryFuncon stepEnvironments),("identifier-tagged",StrictFuncon stepIdentifier_tagged),("id-tagged",StrictFuncon stepIdentifier_tagged),("fresh-identifier",NullaryFuncon stepFresh_identifier),("initialise-binding",NonStrictFuncon stepInitialise_binding),("bind-value",StrictFuncon stepBind_value),("bind",StrictFuncon stepBind_value),("unbind",StrictFuncon stepUnbind),("bound-directly",StrictFuncon stepBound_directly),("bound-value",StrictFuncon stepBound_value),("bound",StrictFuncon stepBound_value),("closed",NonStrictFuncon stepClosed),("scope",PartiallyStrictFuncon [Strict,NonStrict] NonStrict stepScope),("accumulate",NonStrictFuncon stepAccumulate),("collateral",StrictFuncon stepCollateral),("bind-recursively",PartiallyStrictFuncon [Strict,NonStrict] NonStrict stepBind_recursively),("recursive",PartiallyStrictFuncon [Strict,NonStrict] NonStrict stepRecursive),("re-close",PartiallyStrictFuncon [Strict,NonStrict] NonStrict stepRe_close),("bind-to-forward-links",StrictFuncon stepBind_to_forward_links),("set-forward-links",StrictFuncon stepSet_forward_links),("identifiers",NullaryFuncon stepIdentifiers),("ids",NullaryFuncon stepIdentifiers)] + +environments_ = FName "environments" +env_ = FName "environments" +envs_ = FName "environments" +stepEnvironments = evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + rewriteTermTo (TApp "maps" [TName "identifiers",TName "values"]) env + +identifier_tagged_ fargs = FApp "identifier-tagged" (fargs) +id_tagged_ fargs = FApp "identifier-tagged" (fargs) +stepIdentifier_tagged 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 'i'),FValue (Ascii 'd'),FValue (Ascii 'e'),FValue (Ascii 'n'),FValue (Ascii 't'),FValue (Ascii 'i'),FValue (Ascii 'f'),FValue (Ascii 'i'),FValue (Ascii 'e'),FValue (Ascii 'r'),FValue (Ascii '-'),FValue (Ascii 't'),FValue (Ascii 'a'),FValue (Ascii 'g'),FValue (Ascii 'g'),FValue (Ascii 'e'),FValue (Ascii 'd')])),TVar "_X1",TVar "_X2"]) env + +fresh_identifier_ = FName "fresh-identifier" +stepFresh_identifier = evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + rewriteTermTo (TApp "identifier-tagged" [TFuncon (FValue (ADTVal "list" [FValue (Ascii 'g'),FValue (Ascii 'e'),FValue (Ascii 'n'),FValue (Ascii 'e'),FValue (Ascii 'r'),FValue (Ascii 'a'),FValue (Ascii 't'),FValue (Ascii 'e'),FValue (Ascii 'd')])),TName "fresh-atom"]) env + +initialise_binding_ fargs = FApp "initialise-binding" (fargs) +stepInitialise_binding fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PMetaVar "X"] env + rewriteTermTo (TApp "initialise-linking" [TApp "initialise-generating" [TApp "closed" [TVar "X"]]]) env + +bind_value_ fargs = FApp "bind-value" (fargs) +bind_ fargs = FApp "bind-value" (fargs) +stepBind_value fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "I") (TName "identifiers"),VPAnnotated (VPMetaVar "V") (TName "defined-values")] env + rewriteTermTo (TMap [TVar "I",TVar "V"]) env + +unbind_ fargs = FApp "unbind" (fargs) +stepUnbind fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "I") (TName "identifiers")] env + rewriteTermTo (TMap [TVar "I",TName "none"]) env + +bound_directly_ fargs = FApp "bound-directly" (fargs) +stepBound_directly fargs = + evalRules [] [step1,step2] + where step1 = do + let env = emptyEnv + env <- lifted_vsMatch fargs [VPAnnotated (VPMetaVar "I") (TName "identifiers")] env + env <- getInhPatt "environment" (VPMetaVar "Rho") env + env <- lifted_sideCondition (SCPatternMatch (TApp "lookup" [TVar "Rho",TVar "I"]) (VPAnnotated (VPMetaVar "V") (TName "defined-values"))) env + stepTermTo (TVar "V") env + step2 = do + let env = emptyEnv + env <- lifted_vsMatch fargs [VPAnnotated (VPMetaVar "I") (TName "identifiers")] env + env <- getInhPatt "environment" (VPMetaVar "Rho") env + env <- lifted_sideCondition (SCPatternMatch (TApp "lookup" [TVar "Rho",TVar "I"]) (PADT "none" [])) env + stepTermTo (TName "fail") env + +bound_value_ fargs = FApp "bound-value" (fargs) +bound_ fargs = FApp "bound-value" (fargs) +stepBound_value fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "I") (TName "identifiers")] env + rewriteTermTo (TApp "follow-if-link" [TApp "bound-directly" [TVar "I"]]) env + +closed_ fargs = FApp "closed" (fargs) +stepClosed fargs = + evalRules [rewrite1] [step1] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PAnnotated (PMetaVar "V") (TName "values")] env + rewriteTermTo (TVar "V") env + step1 = do + let env = emptyEnv + env <- lifted_fsMatch fargs [PMetaVar "X"] env + env <- getInhPatt "environment" (VPWildCard) env + env <- withInhTerm "environment" (TApp "map" []) env (premise (TVar "X") (PMetaVar "X'") env) + stepTermTo (TApp "closed" [TVar "X'"]) env + +scope_ fargs = FApp "scope" (fargs) +stepScope fargs = + evalRules [rewrite1] [step1] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PAnnotated PWildCard (TName "environments"),PAnnotated (PMetaVar "V") (TName "values")] env + rewriteTermTo (TVar "V") env + step1 = do + let env = emptyEnv + env <- lifted_fsMatch fargs [PAnnotated (PMetaVar "Rho1") (TName "environments"),PMetaVar "X"] env + env <- getInhPatt "environment" (VPMetaVar "Rho0") env + env <- withInhTerm "environment" (TApp "map-override" [TVar "Rho1",TVar "Rho0"]) env (premise (TVar "X") (PMetaVar "X'") env) + stepTermTo (TApp "scope" [TVar "Rho1",TVar "X'"]) env + +accumulate_ fargs = FApp "accumulate" (fargs) +stepAccumulate fargs = + evalRules [rewrite1,rewrite2,rewrite3,rewrite4] [step1] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PAnnotated (PMetaVar "Rho1") (TName "environments"),PMetaVar "D2"] env + rewriteTermTo (TApp "scope" [TVar "Rho1",TApp "map-override" [TVar "D2",TVar "Rho1"]]) env + rewrite2 = do + let env = emptyEnv + env <- fsMatch fargs [] env + rewriteTermTo (TApp "map" []) env + rewrite3 = do + let env = emptyEnv + env <- fsMatch fargs [PMetaVar "D1"] env + rewriteTermTo (TVar "D1") env + rewrite4 = do + let env = emptyEnv + env <- fsMatch fargs [PMetaVar "D1",PMetaVar "D2",PSeqVar "D+" PlusOp] env + rewriteTermTo (TApp "accumulate" [TVar "D1",TApp "accumulate" [TVar "D2",TVar "D+"]]) env + step1 = do + let env = emptyEnv + env <- lifted_fsMatch fargs [PMetaVar "D1",PMetaVar "D2"] env + env <- premise (TVar "D1") (PMetaVar "D1'") env + stepTermTo (TApp "accumulate" [TVar "D1'",TVar "D2"]) env + +collateral_ fargs = FApp "collateral" (fargs) +stepCollateral fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPSeqVar "Rho*" StarOp) (TSortSeq (TName "environments") StarOp)] env + rewriteTermTo (TApp "def" [TApp "map-unite" [TVar "Rho*"]]) env + +bind_recursively_ fargs = FApp "bind-recursively" (fargs) +stepBind_recursively fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PAnnotated (PMetaVar "I") (TName "identifiers"),PMetaVar "E"] env + rewriteTermTo (TApp "recursive" [TSet [TVar "I"],TApp "bind-value" [TVar "I",TVar "E"]]) env + +recursive_ fargs = FApp "recursive" (fargs) +stepRecursive fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PAnnotated (PMetaVar "SI") (TApp "sets" [TName "identifiers"]),PMetaVar "D"] env + rewriteTermTo (TApp "re-close" [TApp "bind-to-forward-links" [TVar "SI"],TVar "D"]) env + +re_close_ fargs = FApp "re-close" (fargs) +stepRe_close fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PAnnotated (PMetaVar "M") (TApp "maps" [TName "identifiers",TName "links"]),PMetaVar "D"] env + rewriteTermTo (TApp "accumulate" [TApp "scope" [TVar "M",TVar "D"],TApp "sequential" [TApp "set-forward-links" [TVar "M"],TApp "map" []]]) env + +bind_to_forward_links_ fargs = FApp "bind-to-forward-links" (fargs) +stepBind_to_forward_links fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "SI") (TApp "sets" [TName "identifiers"])] env + rewriteTermTo (TApp "map-unite" [TApp "interleave-map" [TApp "bind-value" [TName "given",TApp "fresh-link" [TName "defined-values"]],TApp "set-elements" [TVar "SI"]]]) env + +set_forward_links_ fargs = FApp "set-forward-links" (fargs) +stepSet_forward_links fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "M") (TApp "maps" [TName "identifiers",TName "links"])] env + rewriteTermTo (TApp "effect" [TApp "interleave-map" [TApp "set-link" [TApp "lookup" [TVar "M",TName "given"],TApp "bound-value" [TName "given"]],TApp "set-elements" [TApp "map-domain" [TVar "M"]]]]) env + +identifiers_ = FName "identifiers" +stepIdentifiers = rewriteType "identifiers" [] diff --git a/cbs/Funcons/Core/Computations/Normal/Flowing/Flowing.hs b/cbs/Funcons/Core/Computations/Normal/Flowing/Flowing.hs new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/Normal/Flowing/Flowing.hs @@ -0,0 +1,167 @@ +-- GeNeRaTeD fOr: ../../CBS-beta/Funcons-beta/Computations/Normal/Flowing/Flowing.cbs +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Computations.Normal.Flowing.Flowing where + +import Funcons.EDSL + +import Funcons.Operations hiding (Values) +entities = [] + +types = typeEnvFromList + [("yielding",DataTypeMemberss "yielding" [] [DataTypeMemberConstructor "signal" [] (Just [])])] + +funcons = libFromList + [("interleave",StrictFuncon stepInterleave),("signal",NullaryFuncon stepSignal),("yield",NullaryFuncon stepYield),("yield-on-value",StrictFuncon stepYield_on_value),("yield-on-abrupt",NonStrictFuncon stepYield_on_abrupt),("left-to-right",NonStrictFuncon stepLeft_to_right),("l-to-r",NonStrictFuncon stepLeft_to_right),("right-to-left",NonStrictFuncon stepRight_to_left),("r-to-l",NonStrictFuncon stepRight_to_left),("sequential",NonStrictFuncon stepSequential),("seq",NonStrictFuncon stepSequential),("effect",StrictFuncon stepEffect),("choice",NonStrictFuncon stepChoice),("if-true-else",PartiallyStrictFuncon [Strict,NonStrict,NonStrict] NonStrict stepIf_true_else),("if-else",PartiallyStrictFuncon [Strict,NonStrict,NonStrict] NonStrict stepIf_true_else),("while-true",NonStrictFuncon stepWhile_true),("while",NonStrictFuncon stepWhile_true),("do-while-true",NonStrictFuncon stepDo_while_true),("do-while",NonStrictFuncon stepDo_while_true),("yielding",NullaryFuncon stepYielding)] + +interleave_ fargs = FApp "interleave" (fargs) +stepInterleave fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPSeqVar "V*" StarOp) (TSortSeq (TName "values") StarOp)] env + rewriteTermTo (TVar "V*") env + +signal_ = FName "signal" +stepSignal = evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + rewriteTermTo (TApp "datatype-value" [TFuncon (FValue (ADTVal "list" [FValue (Ascii 's'),FValue (Ascii 'i'),FValue (Ascii 'g'),FValue (Ascii 'n'),FValue (Ascii 'a'),FValue (Ascii 'l')]))]) env + +yield_ = FName "yield" +stepYield = evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + rewriteTermTo (TApp "yield-on-value" [TName "none"]) env + +yield_on_value_ fargs = FApp "yield-on-value" (fargs) +stepYield_on_value fargs = + evalRules [] [step1] + where step1 = do + let env = emptyEnv + env <- lifted_vsMatch fargs [VPAnnotated (VPMetaVar "V") (TName "values")] env + env <- getControlPatt "yielded" (Just (PADT "signal" [])) env + raiseTerm "yielded" (TName "signal") env + stepTermTo (TVar "V") env + +yield_on_abrupt_ fargs = FApp "yield-on-abrupt" (fargs) +stepYield_on_abrupt fargs = + evalRules [rewrite1] [step1,step2] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PAnnotated (PMetaVar "V") (TName "values")] env + rewriteTermTo (TVar "V") env + step1 = do + let env = emptyEnv + env <- lifted_fsMatch fargs [PMetaVar "X"] env + env <- getControlPatt "abrupt" (Just (VPMetaVar "V")) env + env <- getControlPatt "yielded" (Just (PADT "signal" [])) env + (env,[__varabrupt,__varyielded]) <- receiveSignals ["abrupt","yielded"] (withControlTerm "abrupt" (Just (TVar "V")) env (withControlTerm "yielded" (Just (TVar "___")) env (premise (TVar "X") (PMetaVar "X'") env))) + env <- receiveSignalPatt __varabrupt (Just (VPAnnotated (VPMetaVar "V") (TName "values"))) env + env <- receiveSignalPatt __varyielded (Just (VPSeqVar "___" QuestionMarkOp)) env + raiseTerm "abrupt" (TVar "V") env + raiseTerm "yielded" (TName "signal") env + stepTermTo (TApp "yield-on-abrupt" [TVar "X'"]) env + step2 = do + let env = emptyEnv + env <- lifted_fsMatch fargs [PMetaVar "X"] env + env <- getControlPatt "abrupt" (Nothing) env + (env,[__varabrupt]) <- receiveSignals ["abrupt"] (withControlTerm "abrupt" (Nothing) env (premise (TVar "X") (PMetaVar "X'") env)) + env <- receiveSignalPatt __varabrupt (Nothing) env + stepTermTo (TApp "yield-on-abrupt" [TVar "X'"]) env + +left_to_right_ fargs = FApp "left-to-right" (fargs) +l_to_r_ fargs = FApp "left-to-right" (fargs) +stepLeft_to_right fargs = + evalRules [rewrite1] [step1] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PAnnotated (PSeqVar "V*" StarOp) (TSortSeq (TName "values") StarOp)] env + rewriteTermTo (TVar "V*") env + step1 = do + let env = emptyEnv + env <- lifted_fsMatch fargs [PAnnotated (PSeqVar "V*" StarOp) (TSortSeq (TName "values") StarOp),PMetaVar "Y",PSeqVar "Z*" StarOp] env + env <- premise (TVar "Y") (PMetaVar "Y'") env + stepTermTo (TApp "left-to-right" [TVar "V*",TVar "Y'",TVar "Z*"]) env + +right_to_left_ fargs = FApp "right-to-left" (fargs) +r_to_l_ fargs = FApp "right-to-left" (fargs) +stepRight_to_left fargs = + evalRules [rewrite1] [step1] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PAnnotated (PSeqVar "V*" StarOp) (TSortSeq (TName "values") StarOp)] env + rewriteTermTo (TVar "V*") env + step1 = do + let env = emptyEnv + env <- lifted_fsMatch fargs [PSeqVar "X*" StarOp,PMetaVar "Y",PAnnotated (PSeqVar "V*" StarOp) (TSortSeq (TName "values") StarOp)] env + env <- premise (TVar "Y") (PMetaVar "Y'") env + stepTermTo (TApp "right-to-left" [TVar "X*",TVar "Y'",TVar "V*"]) env + +sequential_ fargs = FApp "sequential" (fargs) +seq_ fargs = FApp "sequential" (fargs) +stepSequential fargs = + evalRules [rewrite1,rewrite2] [step1] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PValue (PADT "none" []),PSeqVar "Y+" PlusOp] env + rewriteTermTo (TApp "sequential" [TVar "Y+"]) env + rewrite2 = do + let env = emptyEnv + env <- fsMatch fargs [PMetaVar "Y"] env + rewriteTermTo (TVar "Y") env + step1 = do + let env = emptyEnv + env <- lifted_fsMatch fargs [PMetaVar "X",PSeqVar "Y+" PlusOp] env + env <- premise (TVar "X") (PMetaVar "X'") env + stepTermTo (TApp "sequential" [TVar "X'",TVar "Y+"]) env + +effect_ fargs = FApp "effect" (fargs) +stepEffect fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPSeqVar "V*" StarOp) (TSortSeq (TName "values") StarOp)] env + rewriteTermTo (TName "none") env + +choice_ fargs = FApp "choice" (fargs) +stepChoice fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PSeqVar "X*" StarOp,PMetaVar "Y",PSeqVar "Z*" StarOp] env + rewriteTermTo (TVar "Y") env + +if_true_else_ fargs = FApp "if-true-else" (fargs) +if_else_ fargs = FApp "if-true-else" (fargs) +stepIf_true_else fargs = + evalRules [rewrite1,rewrite2] [] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PValue (PADT "true" []),PMetaVar "X",PMetaVar "Y"] env + rewriteTermTo (TVar "X") env + rewrite2 = do + let env = emptyEnv + env <- fsMatch fargs [PValue (PADT "false" []),PMetaVar "X",PMetaVar "Y"] env + rewriteTermTo (TVar "Y") env + +while_true_ fargs = FApp "while-true" (fargs) +while_ fargs = FApp "while-true" (fargs) +stepWhile_true fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PMetaVar "B",PMetaVar "X"] env + rewriteTermTo (TApp "if-true-else" [TVar "B",TApp "sequential" [TVar "X",TApp "while-true" [TVar "B",TVar "X"]],TName "none"]) env + +do_while_true_ fargs = FApp "do-while-true" (fargs) +do_while_ fargs = FApp "do-while-true" (fargs) +stepDo_while_true fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PMetaVar "X",PMetaVar "B"] env + rewriteTermTo (TApp "sequential" [TVar "X",TApp "if-true-else" [TVar "B",TApp "do-while-true" [TVar "X",TVar "B"],TName "none"]]) env + +yielding_ = FName "yielding" +stepYielding = rewriteType "yielding" [] diff --git a/cbs/Funcons/Core/Computations/Normal/Generating/Generating.hs b/cbs/Funcons/Core/Computations/Normal/Generating/Generating.hs new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/Normal/Generating/Generating.hs @@ -0,0 +1,35 @@ +-- GeNeRaTeD fOr: ../../CBS-beta/Funcons-beta/Computations/Normal/Generating/Generating.cbs +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Computations.Normal.Generating.Generating where + +import Funcons.EDSL + +import Funcons.Operations hiding (Values) +entities = [] + +types = typeEnvFromList + [] + +funcons = libFromList + [("fresh-atom",NullaryFuncon stepFresh_atom),("use-atom-not-in",StrictFuncon stepUse_atom_not_in)] + +fresh_atom_ = FName "fresh-atom" +stepFresh_atom = evalRules [] [step1] + where step1 = do + let env = emptyEnv + env <- getMutPatt "used-atom-set" (VPMetaVar "SA") env + env <- lifted_sideCondition (SCPatternMatch (TApp "element-not-in" [TName "atoms",TVar "SA"]) (VPMetaVar "A")) env + putMutTerm "used-atom-set" (TApp "set-insert" [TVar "A",TVar "SA"]) env + stepTermTo (TVar "A") env + +use_atom_not_in_ fargs = FApp "use-atom-not-in" (fargs) +stepUse_atom_not_in fargs = + evalRules [] [step1] + where step1 = do + let env = emptyEnv + env <- lifted_vsMatch fargs [VPAnnotated (VPMetaVar "SA") (TApp "sets" [TName "atoms"])] env + env <- getMutPatt "used-atom-set" (VPMetaVar "SA'") env + env <- lifted_sideCondition (SCPatternMatch (TApp "element-not-in" [TName "atoms",TVar "SA"]) (VPMetaVar "A")) env + putMutTerm "used-atom-set" (TApp "set-insert" [TVar "A",TVar "SA'"]) env + stepTermTo (TVar "A") env diff --git a/cbs/Funcons/Core/Computations/Normal/Giving/Giving.hs b/cbs/Funcons/Core/Computations/Normal/Giving/Giving.hs new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/Normal/Giving/Giving.hs @@ -0,0 +1,154 @@ +-- GeNeRaTeD fOr: ../../CBS-beta/Funcons-beta/Computations/Normal/Giving/Giving.cbs +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Computations.Normal.Giving.Giving where + +import Funcons.EDSL + +import Funcons.Operations hiding (Values) +entities = [] + +types = typeEnvFromList + [] + +funcons = libFromList + [("initialise-giving",NonStrictFuncon stepInitialise_giving),("give",PartiallyStrictFuncon [Strict,NonStrict] NonStrict stepGive),("given",NullaryFuncon stepGiven),("no-given",NonStrictFuncon stepNo_given),("left-to-right-map",PartiallyStrictFuncon [NonStrict] Strict stepLeft_to_right_map),("interleave-map",PartiallyStrictFuncon [NonStrict] Strict stepInterleave_map),("left-to-right-repeat",PartiallyStrictFuncon [NonStrict,Strict,Strict] NonStrict stepLeft_to_right_repeat),("interleave-repeat",PartiallyStrictFuncon [NonStrict,Strict,Strict] NonStrict stepInterleave_repeat),("left-to-right-filter",PartiallyStrictFuncon [NonStrict] Strict stepLeft_to_right_filter),("interleave-filter",PartiallyStrictFuncon [NonStrict] Strict stepInterleave_filter),("fold-left",PartiallyStrictFuncon [NonStrict,Strict] Strict stepFold_left),("fold-right",PartiallyStrictFuncon [NonStrict,Strict] Strict stepFold_right)] + +initialise_giving_ fargs = FApp "initialise-giving" (fargs) +stepInitialise_giving fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PMetaVar "X"] env + rewriteTermTo (TApp "no-given" [TVar "X"]) env + +give_ fargs = FApp "give" (fargs) +stepGive fargs = + evalRules [rewrite1] [step1] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PAnnotated (PMetaVar "V") (TName "defined-values"),PAnnotated (PMetaVar "W") (TName "values")] env + rewriteTermTo (TVar "W") env + step1 = do + let env = emptyEnv + env <- lifted_fsMatch fargs [PAnnotated (PMetaVar "V") (TName "defined-values"),PMetaVar "Y"] env + env <- getInhPatt "given-value" (VPWildCard) env + env <- withInhTerm "given-value" (TVar "V") env (premise (TVar "Y") (PMetaVar "Y'") env) + stepTermTo (TApp "give" [TVar "V",TVar "Y'"]) env + +given_ = FName "given" +stepGiven = evalRules [] [step1,step2] + where step1 = do + let env = emptyEnv + env <- getInhPatt "given-value" (VPAnnotated (VPMetaVar "V") (TName "defined-values")) env + stepTermTo (TVar "V") env + step2 = do + let env = emptyEnv + env <- getInhPatt "given-value" (PADT "none" []) env + stepTermTo (TName "fail") env + +no_given_ fargs = FApp "no-given" (fargs) +stepNo_given fargs = + evalRules [rewrite1] [step1] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PAnnotated (PMetaVar "U") (TName "values")] env + rewriteTermTo (TVar "U") env + step1 = do + let env = emptyEnv + env <- lifted_fsMatch fargs [PMetaVar "X"] env + env <- getInhPatt "given-value" (VPWildCard) env + env <- withInhTerm "given-value" (TName "none") env (premise (TVar "X") (PMetaVar "X'") env) + stepTermTo (TApp "no-given" [TVar "X'"]) env + +left_to_right_map_ fargs = FApp "left-to-right-map" (fargs) +stepLeft_to_right_map fargs = + evalRules [rewrite1,rewrite2] [] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PMetaVar "F",PAnnotated (PMetaVar "V") (TName "defined-values"),PAnnotated (PSeqVar "V*" StarOp) (TSortSeq (TName "defined-values") StarOp)] env + rewriteTermTo (TApp "left-to-right" [TApp "give" [TVar "V",TVar "F"],TApp "left-to-right-map" [TVar "F",TVar "V*"]]) env + rewrite2 = do + let env = emptyEnv + env <- fsMatch fargs [PMetaVar "F"] env + rewriteTermTo (TSeq []) env + +interleave_map_ fargs = FApp "interleave-map" (fargs) +stepInterleave_map fargs = + evalRules [rewrite1,rewrite2] [] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PMetaVar "F",PAnnotated (PMetaVar "V") (TName "defined-values"),PAnnotated (PSeqVar "V*" StarOp) (TSortSeq (TName "defined-values") StarOp)] env + rewriteTermTo (TApp "interleave" [TApp "give" [TVar "V",TVar "F"],TApp "interleave-map" [TVar "F",TVar "V*"]]) env + rewrite2 = do + let env = emptyEnv + env <- fsMatch fargs [PMetaVar "F"] env + rewriteTermTo (TSeq []) env + +left_to_right_repeat_ fargs = FApp "left-to-right-repeat" (fargs) +stepLeft_to_right_repeat fargs = + evalRules [rewrite1,rewrite2] [] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PMetaVar "F",PAnnotated (PMetaVar "M") (TName "ints"),PAnnotated (PMetaVar "N") (TName "ints")] env + env <- sideCondition (SCEquality (TApp "is-less-or-equal" [TVar "M",TVar "N"]) (TName "true")) env + rewriteTermTo (TApp "left-to-right" [TApp "give" [TVar "M",TVar "F"],TApp "left-to-right-repeat" [TVar "F",TApp "int-add" [TVar "M",TFuncon (FValue (Nat 1))],TVar "N"]]) env + rewrite2 = do + let env = emptyEnv + env <- fsMatch fargs [PMetaVar "F",PAnnotated (PMetaVar "M") (TName "ints"),PAnnotated (PMetaVar "N") (TName "ints")] env + env <- sideCondition (SCEquality (TApp "is-less-or-equal" [TVar "M",TVar "N"]) (TName "false")) env + rewriteTermTo (TSeq []) env + +interleave_repeat_ fargs = FApp "interleave-repeat" (fargs) +stepInterleave_repeat fargs = + evalRules [rewrite1,rewrite2] [] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PMetaVar "F",PAnnotated (PMetaVar "M") (TName "ints"),PAnnotated (PMetaVar "N") (TName "ints")] env + env <- sideCondition (SCEquality (TApp "is-less-or-equal" [TVar "M",TVar "N"]) (TName "true")) env + rewriteTermTo (TApp "interleave" [TApp "give" [TVar "M",TVar "F"],TApp "interleave-repeat" [TVar "F",TApp "int-add" [TVar "M",TFuncon (FValue (Nat 1))],TVar "N"]]) env + rewrite2 = do + let env = emptyEnv + env <- fsMatch fargs [PMetaVar "F",PAnnotated (PMetaVar "M") (TName "ints"),PAnnotated (PMetaVar "N") (TName "ints")] env + env <- sideCondition (SCEquality (TApp "is-less-or-equal" [TVar "M",TVar "N"]) (TName "false")) env + rewriteTermTo (TSeq []) env + +left_to_right_filter_ fargs = FApp "left-to-right-filter" (fargs) +stepLeft_to_right_filter fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PMetaVar "P",PAnnotated (PSeqVar "V*" StarOp) (TSortSeq (TName "defined-values") StarOp)] env + rewriteTermTo (TApp "filter-defined" [TApp "left-to-right-map" [TApp "if-true-else" [TVar "P",TName "given",TName "none"],TVar "V*"]]) env + +interleave_filter_ fargs = FApp "interleave-filter" (fargs) +stepInterleave_filter fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PMetaVar "P",PAnnotated (PSeqVar "V*" StarOp) (TSortSeq (TName "defined-values") StarOp)] env + rewriteTermTo (TApp "filter-defined" [TApp "interleave-map" [TApp "if-true-else" [TVar "P",TName "given",TName "none"],TVar "V*"]]) env + +fold_left_ fargs = FApp "fold-left" (fargs) +stepFold_left fargs = + evalRules [rewrite1,rewrite2] [] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PMetaVar "F",PAnnotated (PMetaVar "A") (TName "values")] env + rewriteTermTo (TVar "A") env + rewrite2 = do + let env = emptyEnv + env <- fsMatch fargs [PMetaVar "F",PAnnotated (PMetaVar "A") (TName "values"),PAnnotated (PMetaVar "V") (TName "values"),PAnnotated (PSeqVar "V*" StarOp) (TSortSeq (TName "values") StarOp)] env + rewriteTermTo (TApp "fold-left" [TVar "F",TApp "give" [TApp "tuple" [TVar "A",TVar "V"],TVar "F"],TVar "V*"]) env + +fold_right_ fargs = FApp "fold-right" (fargs) +stepFold_right fargs = + evalRules [rewrite1,rewrite2] [] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PWildCard,PAnnotated (PMetaVar "A") (TName "values")] env + rewriteTermTo (TVar "A") env + rewrite2 = do + let env = emptyEnv + env <- fsMatch fargs [PMetaVar "F",PAnnotated (PMetaVar "A") (TName "values"),PAnnotated (PSeqVar "V*" StarOp) (TSortSeq (TName "values") StarOp),PAnnotated (PMetaVar "V") (TName "values")] env + rewriteTermTo (TApp "give" [TApp "tuple" [TVar "V",TApp "fold-right" [TVar "F",TVar "A",TVar "V*"]],TVar "F"]) env diff --git a/cbs/Funcons/Core/Computations/Normal/Interacting/Interacting.hs b/cbs/Funcons/Core/Computations/Normal/Interacting/Interacting.hs new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/Normal/Interacting/Interacting.hs @@ -0,0 +1,35 @@ +-- GeNeRaTeD fOr: ../../CBS-beta/Funcons-beta/Computations/Normal/Interacting/Interacting.cbs +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Computations.Normal.Interacting.Interacting where + +import Funcons.EDSL + +import Funcons.Operations hiding (Values) +entities = [] + +types = typeEnvFromList + [] + +funcons = libFromList + [("print",StrictFuncon stepPrint),("read",NullaryFuncon stepRead)] + +print_ fargs = FApp "print" (fargs) +stepPrint fargs = + evalRules [] [step1] + where step1 = do + let env = emptyEnv + env <- lifted_vsMatch fargs [VPAnnotated (VPSeqVar "V*" StarOp) (TSortSeq (TName "defined-values") StarOp)] env + writeOutTerm "standard-out" (TVar "V*") env + stepTermTo (TName "none") env + +read_ = FName "read" +stepRead = evalRules [] [step1,step2] + where step1 = do + let env = emptyEnv + env <- matchInput "standard-in" (VPAnnotated (VPMetaVar "V") (TName "defined-values")) env + stepTermTo (TVar "V") env + step2 = do + let env = emptyEnv + env <- matchInput "standard-in" (PADT "none" []) env + stepTermTo (TName "fail") env diff --git a/cbs/Funcons/Core/Computations/Normal/Linking/Linking.hs b/cbs/Funcons/Core/Computations/Normal/Linking/Linking.hs new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/Normal/Linking/Linking.hs @@ -0,0 +1,81 @@ +-- GeNeRaTeD fOr: ../../CBS-beta/Funcons-beta/Computations/Normal/Linking/Linking.cbs +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Computations.Normal.Linking.Linking where + +import Funcons.EDSL + +import Funcons.Operations hiding (Values) +entities = [] + +types = typeEnvFromList + [("links",DataTypeMemberss "links" [] [DataTypeMemberConstructor "link" [TName "variables"] (Just [])])] + +funcons = libFromList + [("link",StrictFuncon stepLink),("initialise-linking",NonStrictFuncon stepInitialise_linking),("fresh-link",NonStrictFuncon stepFresh_link),("fresh-initialised-link",PartiallyStrictFuncon [NonStrict,Strict] NonStrict stepFresh_initialised_link),("fresh-init-link",PartiallyStrictFuncon [NonStrict,Strict] NonStrict stepFresh_initialised_link),("set-link",StrictFuncon stepSet_link),("follow-link",StrictFuncon stepFollow_link),("follow-if-link",StrictFuncon stepFollow_if_link),("links",NullaryFuncon stepLinks)] + +link_ fargs = FApp "link" (fargs) +stepLink fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPMetaVar "_X1"] env + env <- sideCondition (SCIsInSort (TVar "_X1") (TName "values")) env + rewriteTermTo (TApp "datatype-value" [TFuncon (FValue (ADTVal "list" [FValue (Ascii 'l'),FValue (Ascii 'i'),FValue (Ascii 'n'),FValue (Ascii 'k')])),TVar "_X1"]) env + +initialise_linking_ fargs = FApp "initialise-linking" (fargs) +stepInitialise_linking fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PMetaVar "X"] env + rewriteTermTo (TApp "initialise-storing" [TVar "X"]) env + +fresh_link_ fargs = FApp "fresh-link" (fargs) +stepFresh_link fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PMetaVar "VT"] env + rewriteTermTo (TApp "link" [TApp "allocate-variable" [TVar "VT"]]) env + +fresh_initialised_link_ fargs = FApp "fresh-initialised-link" (fargs) +fresh_init_link_ fargs = FApp "fresh-initialised-link" (fargs) +stepFresh_initialised_link fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PMetaVar "VT",PAnnotated (PMetaVar "V") (TVar "VT")] env + rewriteTermTo (TApp "link" [TApp "allocate-initialised-variable" [TVar "VT",TVar "V"]]) env + +set_link_ fargs = FApp "set-link" (fargs) +stepSet_link fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "link" [VPAnnotated (VPMetaVar "Var") (TName "variables")],VPAnnotated (VPMetaVar "V") (TName "defined-values")] env + rewriteTermTo (TApp "initialise-variable" [TVar "Var",TVar "V"]) env + +follow_link_ fargs = FApp "follow-link" (fargs) +stepFollow_link fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "link" [VPAnnotated (VPMetaVar "Var") (TName "variables")]] env + rewriteTermTo (TApp "assigned" [TVar "Var"]) env + +follow_if_link_ fargs = FApp "follow-if-link" (fargs) +stepFollow_if_link fargs = + evalRules [rewrite1,rewrite2] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "link" [VPAnnotated (VPMetaVar "Var") (TName "variables")]] env + rewriteTermTo (TApp "assigned" [TVar "Var"]) env + rewrite2 = do + let env = emptyEnv + env <- vsMatch fargs [VPMetaVar "V"] env + env <- sideCondition (SCIsInSort (TVar "V") (TSortComplement (TSortUnion (TName "links") (TName "nothing")))) env + rewriteTermTo (TVar "V") env + +links_ = FName "links" +stepLinks = rewriteType "links" [] diff --git a/cbs/Funcons/Core/Computations/Normal/Storing/Storing.hs b/cbs/Funcons/Core/Computations/Normal/Storing/Storing.hs new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/Normal/Storing/Storing.hs @@ -0,0 +1,237 @@ +-- GeNeRaTeD fOr: ../../CBS-beta/Funcons-beta/Computations/Normal/Storing/Storing.cbs +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Computations.Normal.Storing.Storing where + +import Funcons.EDSL + +import Funcons.Operations hiding (Values) +entities = [] + +types = typeEnvFromList + [("variables",DataTypeMemberss "variables" [] [DataTypeMemberConstructor "variable" [TName "locations",TName "value-types"] (Just [])]),("vars",DataTypeMemberss "vars" [] [DataTypeMemberConstructor "variable" [TName "locations",TName "value-types"] (Just [])])] + +funcons = libFromList + [("locations",NullaryFuncon stepLocations),("locs",NullaryFuncon stepLocations),("stores",NullaryFuncon stepStores),("store-clear",NullaryFuncon stepStore_clear),("initialise-storing",NonStrictFuncon stepInitialise_storing),("init-storing",NonStrictFuncon stepInitialise_storing),("variable",StrictFuncon stepVariable),("var",StrictFuncon stepVariable),("allocate-variable",NonStrictFuncon stepAllocate_variable),("alloc",NonStrictFuncon stepAllocate_variable),("recycle-variables",StrictFuncon stepRecycle_variables),("recycle",StrictFuncon stepRecycle_variables),("initialise-variable",StrictFuncon stepInitialise_variable),("init",StrictFuncon stepInitialise_variable),("allocate-initialised-variable",PartiallyStrictFuncon [NonStrict,Strict] NonStrict stepAllocate_initialised_variable),("alloc-init",PartiallyStrictFuncon [NonStrict,Strict] NonStrict stepAllocate_initialised_variable),("assign",StrictFuncon stepAssign),("assigned",StrictFuncon stepAssigned),("un-assign",StrictFuncon stepUn_assign),("structural-assign",StrictFuncon stepStructural_assign),("structural-assigned",StrictFuncon stepStructural_assigned),("current-value",StrictFuncon stepCurrent_value),("variables",NullaryFuncon stepVariables),("vars",NullaryFuncon stepVariables)] + +locations_ = FName "locations" +locs_ = FName "locations" +stepLocations = evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + rewriteTermTo (TName "atoms") env + +stores_ = FName "stores" +stepStores = evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + rewriteTermTo (TApp "maps" [TName "locations",TName "values"]) env + +store_clear_ = FName "store-clear" +stepStore_clear = evalRules [] [step1] + where step1 = do + let env = emptyEnv + env <- getMutPatt "store" (VPWildCard) env + putMutTerm "store" (TApp "map" []) env + stepTermTo (TName "none") env + +initialise_storing_ fargs = FApp "initialise-storing" (fargs) +init_storing_ fargs = FApp "initialise-storing" (fargs) +stepInitialise_storing fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PMetaVar "X"] env + rewriteTermTo (TApp "sequential" [TName "store-clear",TApp "initialise-giving" [TApp "initialise-generating" [TVar "X"]]]) env + +variable_ fargs = FApp "variable" (fargs) +var_ fargs = FApp "variable" (fargs) +stepVariable 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 'b'),FValue (Ascii 'l'),FValue (Ascii 'e')])),TVar "_X1",TVar "_X2"]) env + +allocate_variable_ fargs = FApp "allocate-variable" (fargs) +alloc_ fargs = FApp "allocate-variable" (fargs) +stepAllocate_variable fargs = + evalRules [] [step1] + where step1 = do + let env = emptyEnv + env <- lifted_fsMatch fargs [PAnnotated (PMetaVar "VT") (TName "types")] env + env <- getMutPatt "store" (VPMetaVar "Sigma") env + putMutTerm "store" (TVar "Sigma") env + env <- premise (TApp "use-atom-not-in" [TApp "dom" [TVar "Sigma"]]) (PMetaVar "L") env + env <- getMutPatt "store" (VPMetaVar "Sigma'") env + env <- lifted_sideCondition (SCPatternMatch (TApp "map-override" [TMap [TVar "L",TName "none"],TVar "Sigma'"]) (VPMetaVar "Sigma''")) env + putMutTerm "store" (TVar "Sigma''") env + stepTermTo (TApp "variable" [TVar "L",TVar "VT"]) env + +recycle_variables_ fargs = FApp "recycle-variables" (fargs) +recycle_ fargs = FApp "recycle-variables" (fargs) +stepRecycle_variables fargs = + evalRules [rewrite1] [step1,step2] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "Var") (TName "variables"),VPAnnotated (VPSeqVar "Var+" PlusOp) (TSortSeq (TName "variables") PlusOp)] env + rewriteTermTo (TApp "sequential" [TApp "recycle-variables" [TVar "Var"],TApp "recycle-variables" [TVar "Var+"]]) env + step1 = do + let env = emptyEnv + env <- lifted_vsMatch fargs [PADT "variable" [VPAnnotated (VPMetaVar "L") (TName "locations"),VPAnnotated (VPMetaVar "VT") (TName "types")]] env + env <- getMutPatt "store" (VPMetaVar "Sigma") env + env <- lifted_sideCondition (SCEquality (TApp "is-in-set" [TVar "L",TApp "dom" [TVar "Sigma"]]) (TName "true")) env + putMutTerm "store" (TApp "map-delete" [TVar "Sigma",TSet [TVar "L"]]) env + stepTermTo (TName "none") env + step2 = do + let env = emptyEnv + env <- lifted_vsMatch fargs [PADT "variable" [VPAnnotated (VPMetaVar "L") (TName "locations"),VPAnnotated (VPMetaVar "VT") (TName "types")]] env + env <- getMutPatt "store" (VPMetaVar "Sigma") env + env <- lifted_sideCondition (SCEquality (TApp "is-in-set" [TVar "L",TApp "dom" [TVar "Sigma"]]) (TName "false")) env + putMutTerm "store" (TVar "Sigma") env + stepTermTo (TName "fail") env + +initialise_variable_ fargs = FApp "initialise-variable" (fargs) +init_ fargs = FApp "initialise-variable" (fargs) +stepInitialise_variable fargs = + evalRules [] [step1,step2] + where step1 = do + let env = emptyEnv + env <- lifted_vsMatch fargs [PADT "variable" [VPAnnotated (VPMetaVar "L") (TName "locations"),VPAnnotated (VPMetaVar "VT") (TName "types")],VPAnnotated (VPMetaVar "Val") (TName "defined-values")] env + env <- getMutPatt "store" (VPMetaVar "Sigma") env + env <- lifted_sideCondition (SCEquality (TApp "and" [TApp "is-in-set" [TVar "L",TApp "dom" [TVar "Sigma"]],TApp "not" [TApp "is-defined" [TApp "lookup" [TVar "Sigma",TVar "L"]]],TApp "is-in-type" [TVar "Val",TVar "VT"]]) (TName "true")) env + putMutTerm "store" (TApp "map-override" [TMap [TVar "L",TVar "Val"],TVar "Sigma"]) env + stepTermTo (TName "none") env + step2 = do + let env = emptyEnv + env <- lifted_vsMatch fargs [PADT "variable" [VPAnnotated (VPMetaVar "L") (TName "locations"),VPAnnotated (VPMetaVar "VT") (TName "types")],VPAnnotated (VPMetaVar "Val") (TName "defined-values")] env + env <- getMutPatt "store" (VPMetaVar "Sigma") env + env <- lifted_sideCondition (SCEquality (TApp "and" [TApp "is-in-set" [TVar "L",TApp "dom" [TVar "Sigma"]],TApp "not" [TApp "is-defined" [TApp "lookup" [TVar "Sigma",TVar "L"]]],TApp "is-in-type" [TVar "Val",TVar "VT"]]) (TName "false")) env + putMutTerm "store" (TVar "Sigma") env + stepTermTo (TName "fail") env + +allocate_initialised_variable_ fargs = FApp "allocate-initialised-variable" (fargs) +alloc_init_ fargs = FApp "allocate-initialised-variable" (fargs) +stepAllocate_initialised_variable fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PMetaVar "VT",PAnnotated (PMetaVar "Val") (TVar "VT")] env + rewriteTermTo (TApp "give" [TApp "allocate-variable" [TVar "VT"],TApp "sequential" [TApp "initialise-variable" [TName "given",TVar "Val"],TName "given"]]) env + +assign_ fargs = FApp "assign" (fargs) +stepAssign fargs = + evalRules [] [step1,step2] + where step1 = do + let env = emptyEnv + env <- lifted_vsMatch fargs [PADT "variable" [VPAnnotated (VPMetaVar "L") (TName "locations"),VPAnnotated (VPMetaVar "VT") (TName "types")],VPAnnotated (VPMetaVar "Val") (TName "defined-values")] env + env <- getMutPatt "store" (VPMetaVar "Sigma") env + env <- lifted_sideCondition (SCEquality (TApp "and" [TApp "is-in-set" [TVar "L",TApp "dom" [TVar "Sigma"]],TApp "is-in-type" [TVar "Val",TVar "VT"]]) (TName "true")) env + putMutTerm "store" (TApp "map-override" [TMap [TVar "L",TVar "Val"],TVar "Sigma"]) env + stepTermTo (TName "none") env + step2 = do + let env = emptyEnv + env <- lifted_vsMatch fargs [PADT "variable" [VPAnnotated (VPMetaVar "L") (TName "locations"),VPAnnotated (VPMetaVar "VT") (TName "types")],VPAnnotated (VPMetaVar "Val") (TName "defined-values")] env + env <- getMutPatt "store" (VPMetaVar "Sigma") env + env <- lifted_sideCondition (SCEquality (TApp "and" [TApp "is-in-set" [TVar "L",TApp "dom" [TVar "Sigma"]],TApp "is-in-type" [TVar "Val",TVar "VT"]]) (TName "false")) env + putMutTerm "store" (TVar "Sigma") env + stepTermTo (TName "fail") env + +assigned_ fargs = FApp "assigned" (fargs) +stepAssigned fargs = + evalRules [] [step1,step2] + where step1 = do + let env = emptyEnv + env <- lifted_vsMatch fargs [PADT "variable" [VPAnnotated (VPMetaVar "L") (TName "locations"),VPAnnotated (VPMetaVar "VT") (TName "types")]] env + env <- getMutPatt "store" (VPMetaVar "Sigma") env + env <- lifted_sideCondition (SCPatternMatch (TApp "lookup" [TVar "Sigma",TVar "L"]) (VPAnnotated (VPMetaVar "Val") (TName "defined-values"))) env + putMutTerm "store" (TVar "Sigma") env + stepTermTo (TVar "Val") env + step2 = do + let env = emptyEnv + env <- lifted_vsMatch fargs [PADT "variable" [VPAnnotated (VPMetaVar "L") (TName "locations"),VPAnnotated (VPMetaVar "VT") (TName "types")]] env + env <- getMutPatt "store" (VPMetaVar "Sigma") env + env <- lifted_sideCondition (SCEquality (TApp "lookup" [TVar "Sigma",TVar "L"]) (TName "none")) env + putMutTerm "store" (TVar "Sigma") env + stepTermTo (TName "fail") env + +un_assign_ fargs = FApp "un-assign" (fargs) +stepUn_assign fargs = + evalRules [] [step1,step2] + where step1 = do + let env = emptyEnv + env <- lifted_vsMatch fargs [PADT "variable" [VPAnnotated (VPMetaVar "L") (TName "locations"),VPAnnotated (VPMetaVar "VT") (TName "types")]] env + env <- getMutPatt "store" (VPMetaVar "Sigma") env + env <- lifted_sideCondition (SCEquality (TApp "is-in-set" [TVar "L",TApp "dom" [TVar "Sigma"]]) (TName "true")) env + putMutTerm "store" (TApp "map-override" [TMap [TVar "L",TName "none"],TVar "Sigma"]) env + stepTermTo (TName "none") env + step2 = do + let env = emptyEnv + env <- lifted_vsMatch fargs [PADT "variable" [VPAnnotated (VPMetaVar "L") (TName "locations"),VPAnnotated (VPMetaVar "VT") (TName "types")]] env + env <- getMutPatt "store" (VPMetaVar "Sigma") env + env <- lifted_sideCondition (SCEquality (TApp "is-in-set" [TVar "L",TApp "dom" [TVar "Sigma"]]) (TName "false")) env + putMutTerm "store" (TVar "Sigma") env + stepTermTo (TName "fail") env + +structural_assign_ fargs = FApp "structural-assign" (fargs) +stepStructural_assign fargs = + evalRules [rewrite1,rewrite2,rewrite3,rewrite4,rewrite5] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "V1") (TName "variables"),VPAnnotated (VPMetaVar "V2") (TName "defined-values")] env + rewriteTermTo (TApp "assign" [TVar "V1",TVar "V2"]) env + rewrite2 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "datatype-value" [VPAnnotated (VPMetaVar "I1") (TName "ids"),VPAnnotated (VPSeqVar "V1*" StarOp) (TSortSeq (TName "defined-values") StarOp)],PADT "datatype-value" [VPAnnotated (VPMetaVar "I2") (TName "ids"),VPAnnotated (VPSeqVar "V2*" StarOp) (TSortSeq (TName "defined-values") StarOp)]] env + env <- sideCondition (SCInequality (TVar "I1") (TFuncon (FValue (ADTVal "list" [FValue (Ascii 'v'),FValue (Ascii 'a'),FValue (Ascii 'r'),FValue (Ascii 'i'),FValue (Ascii 'a'),FValue (Ascii 'b'),FValue (Ascii 'l'),FValue (Ascii 'e')])))) env + rewriteTermTo (TApp "sequential" [TApp "check-true" [TApp "is-equal" [TVar "I1",TVar "I2"]],TApp "effect" [TApp "tuple" [TApp "interleave-map" [TApp "structural-assign" [TApp "tuple-elements" [TName "given"]],TApp "tuple-zip" [TApp "tuple" [TVar "V1*"],TApp "tuple" [TVar "V2*"]]]]],TName "none"]) env + rewrite3 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "M1") (TApp "maps" [TName "values",TName "values"]),VPAnnotated (VPMetaVar "M2") (TApp "maps" [TName "values",TName "values"])] env + env <- sideCondition (SCEquality (TApp "dom" [TVar "M1"]) (TSet [])) env + rewriteTermTo (TApp "check-true" [TApp "is-equal" [TApp "dom" [TVar "M2"],TSet []]]) env + rewrite4 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "M1") (TApp "maps" [TName "values",TName "values"]),VPAnnotated (VPMetaVar "M2") (TApp "maps" [TName "values",TName "values"])] env + env <- sideCondition (SCPatternMatch (TApp "some-element" [TApp "dom" [TVar "M1"]]) (VPMetaVar "K")) env + rewriteTermTo (TApp "sequential" [TApp "check-true" [TApp "is-in-set" [TVar "K",TApp "dom" [TVar "M2"]]],TApp "structural-assign" [TApp "lookup" [TVar "M1",TVar "K"],TApp "lookup" [TVar "M2",TVar "K"]],TApp "structural-assign" [TApp "map-delete" [TVar "M1",TSet [TVar "K"]],TApp "map-delete" [TVar "M2",TSet [TVar "K"]]]]) env + rewrite5 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "V1") (TName "defined-values"),VPAnnotated (VPMetaVar "V2") (TName "defined-values")] env + env <- sideCondition (SCIsInSort (TVar "V1") (TSortComplement (TSortUnion (TName "variables") (TApp "maps" [TName "values",TName "values"])))) env + rewriteTermTo (TApp "check-true" [TApp "is-equal" [TVar "V1",TVar "V2"]]) env + +structural_assigned_ fargs = FApp "structural-assigned" (fargs) +stepStructural_assigned fargs = + evalRules [rewrite1,rewrite2,rewrite3,rewrite4] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "Var") (TName "variables")] env + rewriteTermTo (TApp "assigned" [TVar "Var"]) env + rewrite2 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "datatype-value" [VPAnnotated (VPMetaVar "I") (TName "ids"),VPAnnotated (VPSeqVar "V*" StarOp) (TSortSeq (TName "defined-values") StarOp)]] env + env <- sideCondition (SCInequality (TVar "I") (TFuncon (FValue (ADTVal "list" [FValue (Ascii 'v'),FValue (Ascii 'a'),FValue (Ascii 'r'),FValue (Ascii 'i'),FValue (Ascii 'a'),FValue (Ascii 'b'),FValue (Ascii 'l'),FValue (Ascii 'e')])))) env + rewriteTermTo (TApp "datatype-value" [TVar "I",TApp "interleave-map" [TApp "structural-assigned" [TName "given"],TVar "V*"]]) env + rewrite3 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "M") (TApp "maps" [TName "values",TName "values"])] env + rewriteTermTo (TApp "map" [TApp "interleave-map" [TApp "structural-assigned" [TName "given"],TApp "map-elements" [TVar "M"]]]) env + rewrite4 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "U") (TName "values")] env + env <- sideCondition (SCIsInSort (TVar "U") (TSortComplement (TSortUnion (TName "variables") (TApp "maps" [TName "values",TName "values"])))) env + rewriteTermTo (TVar "U") env + +current_value_ fargs = FApp "current-value" (fargs) +stepCurrent_value fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "V") (TName "defined-values")] env + rewriteTermTo (TApp "def" [TApp "structural-assigned" [TVar "V"]]) env + +variables_ = FName "variables" +stepVariables = rewriteType "variables" [] diff --git a/cbs/Funcons/Core/Computations/Sorts.hs b/cbs/Funcons/Core/Computations/Sorts.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Computations/Sorts.hs +++ /dev/null @@ -1,17 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Computations/sorts.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.Sorts where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("sorts",NullaryFuncon stepSorts)] - -sorts_ = FName "sorts" -stepSorts = norule (FName "sorts") diff --git a/cbs/Funcons/Core/Library.hs b/cbs/Funcons/Core/Library.hs --- a/cbs/Funcons/Core/Library.hs +++ b/cbs/Funcons/Core/Library.hs @@ -1,709 +1,247 @@ module Funcons.Core.Library ( funcons, entities, types, - module Funcons.Core.Computations.Sorts, - module Funcons.Core.Computations.ControlFlow.Normal.Sequencing.LeftToRight, - module Funcons.Core.Computations.ControlFlow.Normal.Sequencing.Atomic, - module Funcons.Core.Computations.ControlFlow.Normal.Sequencing.Sequential, - module Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.VectorMap, - module Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.SetMap, - module Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.ListMap, - module Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.TupleMap, - module Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.MapMap, - module Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.ListsMap, - module Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.FilteringCollections.MultisetFilter, - module Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.FilteringCollections.SetFilter, - module Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.FilteringCollections.MapFilter, - module Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.FilteringCollections.ListFilter, - module Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.ReducingCollections.ListFoldl, - module Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.ReducingCollections.ListFoldr, - module Funcons.Core.Computations.ControlFlow.Normal.Iterating.Indefinite.While, - module Funcons.Core.Computations.ControlFlow.Normal.Iterating.Indefinite.DoWhile, - module Funcons.Core.Computations.ControlFlow.Normal.Choosing.IfThenElse, - module Funcons.Core.Computations.ControlFlow.Abnormal.Stuck, - module Funcons.Core.Computations.ControlFlow.Abnormal.Throwing.Thrown, - module Funcons.Core.Computations.ControlFlow.Abnormal.Throwing.HandleThrown, - module Funcons.Core.Computations.ControlFlow.Abnormal.Throwing.Finally, - module Funcons.Core.Computations.ControlFlow.Abnormal.Throwing.Throw, - module Funcons.Core.Computations.ControlFlow.Abnormal.Throwing.HandleRecursively, - module Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Plug, - module Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.ResumeSignal, - module Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Shift, - module Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Prompt, - module Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Control, - module Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.CallCc, - module Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Reset, - module Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Hole, - module Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Abort, - module Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.ControlSignal, - module Funcons.Core.Computations.ControlFlow.Abnormal.Failing.Else, - module Funcons.Core.Computations.ControlFlow.Abnormal.Failing.CheckTrue, - module Funcons.Core.Computations.ControlFlow.Abnormal.Failing.Fail, - module Funcons.Core.Computations.ControlFlow.Abnormal.Failing.Signals, - module Funcons.Core.Computations.ControlFlow.Abnormal.Failing.Dereference, - module Funcons.Core.Computations.ControlFlow.Abnormal.Failing.Failed, - module Funcons.Core.Computations.DataFlow.Interacting.PrintList, - module Funcons.Core.Computations.DataFlow.Interacting.Print, - module Funcons.Core.Computations.DataFlow.Interacting.StandardOut, - module Funcons.Core.Computations.DataFlow.Interacting.Read, - module Funcons.Core.Computations.DataFlow.Interacting.StandardIn, - module Funcons.Core.Computations.DataFlow.Effect, - module Funcons.Core.Computations.DataFlow.Storing.GeneralVariables.AllocateMap, - module Funcons.Core.Computations.DataFlow.Storing.GeneralVariables.GeneralAssign, - module Funcons.Core.Computations.DataFlow.Storing.GeneralVariables.GeneralAssigned, - module Funcons.Core.Computations.DataFlow.Storing.GeneralVariables.AllocateVector, - module Funcons.Core.Computations.DataFlow.Storing.Stores, - module Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.CurrentValue, - module Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.Assigned, - module Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.AllocateInitialisedVariable, - module Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.AllocateVariable, - module Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.DeallocateVariable, - module Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.Assign, - module Funcons.Core.Computations.DataFlow.Storing.Store, - module Funcons.Core.Computations.DataFlow.Storing.Variables, - module Funcons.Core.Computations.DataFlow.Linking.AllocateInitialisedLink, - module Funcons.Core.Computations.DataFlow.Linking.AllocateLink, - module Funcons.Core.Computations.DataFlow.Linking.FollowIfLink, - module Funcons.Core.Computations.DataFlow.Linking.LinkStore, - module Funcons.Core.Computations.DataFlow.Linking.Links, - module Funcons.Core.Computations.DataFlow.Linking.FollowLink, - module Funcons.Core.Computations.DataFlow.Linking.LinkStores, - module Funcons.Core.Computations.DataFlow.Linking.SetLink, - module Funcons.Core.Computations.DataFlow.Giving.Given, - module Funcons.Core.Computations.DataFlow.Giving.Give, - module Funcons.Core.Computations.DataFlow.Giving.GivenValue, - module Funcons.Core.Computations.DataFlow.Generating.AtomGenerator, - module Funcons.Core.Computations.DataFlow.Generating.FreshAtom, - module Funcons.Core.Computations.DataFlow.Generating.FreshBinder, - module Funcons.Core.Computations.DataFlow.Binding.Recursion.Recursive, - module Funcons.Core.Computations.DataFlow.Binding.Recursion.BindRecursively, - module Funcons.Core.Computations.DataFlow.Binding.Recursion.BoundRecursively, - module Funcons.Core.Computations.DataFlow.Binding.Bound, - module Funcons.Core.Computations.DataFlow.Binding.Environments, - module Funcons.Core.Computations.DataFlow.Binding.Scope, - module Funcons.Core.Computations.DataFlow.Binding.Accumulate, - module Funcons.Core.Computations.DataFlow.Binding.Bind, - module Funcons.Core.Computations.DataFlow.Binding.Environment, - module Funcons.Core.Values.Types, - module Funcons.Core.Values.CompositeValues.Collections.DirectedGraphs, - module Funcons.Core.Values.CompositeValues.Collections.Tuples, - module Funcons.Core.Values.CompositeValues.AlgebraicDatatypeValues.Variants, - module Funcons.Core.Values.CompositeValues.AlgebraicDatatypeValues.Records, - module Funcons.Core.Values.CompositeValues.AlgebraicDatatypeValues.References, - module Funcons.Core.Values.PrimitiveValues.UnitType, - module Funcons.Core.Values.PrimitiveValues.UnicodeCharacters, - module Funcons.Core.Values.PrimitiveValues.Bits, - module Funcons.Core.Values.PrimitiveValues.Strings, - module Funcons.Core.Values.PrimitiveValues.Numbers.Integers, - module Funcons.Core.Values.PrimitiveValues.Numbers.Rationals, - module Funcons.Core.Values.PrimitiveValues.Numbers.IeeeFloats, - module Funcons.Core.Values.PrimitiveValues.Booleans, - module Funcons.Core.Abstractions.Closures.Close, - module Funcons.Core.Abstractions.Closures.Closure, - module Funcons.Core.Abstractions.Patterns.PatternPrefer, - module Funcons.Core.Abstractions.Patterns.Match, - module Funcons.Core.Abstractions.Patterns.Patterns, - module Funcons.Core.Abstractions.Patterns.PatternUnite, - module Funcons.Core.Abstractions.Patterns.PatternAny, - module Funcons.Core.Abstractions.Patterns.Case, - module Funcons.Core.Abstractions.Patterns.MatchLoosely, - module Funcons.Core.Abstractions.Patterns.PatternBind, - module Funcons.Core.Abstractions.IsGroundValue, - module Funcons.Core.Abstractions.Functions.Apply, - module Funcons.Core.Abstractions.Functions.Supply, - module Funcons.Core.Abstractions.Functions.BindingLambda, - module Funcons.Core.Abstractions.Functions.Curry, - module Funcons.Core.Abstractions.Functions.Lambda, - module Funcons.Core.Abstractions.Functions.Uncurry, - module Funcons.Core.Abstractions.Functions.PartialApply, - module Funcons.Core.Abstractions.Functions.Compose, - ) where + module Funcons.Core.Computations.Normal.Interacting.Interacting, + module Funcons.Core.Computations.Normal.Flowing.Flowing, + module Funcons.Core.Computations.Normal.Storing.Storing, + module Funcons.Core.Computations.Normal.Linking.Linking, + module Funcons.Core.Computations.Normal.Giving.Giving, + module Funcons.Core.Computations.Normal.Generating.Generating, + module Funcons.Core.Computations.Normal.Binding.Binding, + module Funcons.Core.Computations.Abnormal.Abrupting.Abrupting, + module Funcons.Core.Computations.Abnormal.Returning.Returning, + module Funcons.Core.Computations.Abnormal.Throwing.Throwing, + module Funcons.Core.Computations.Abnormal.Failing.Failing, + module Funcons.Core.Computations.Abnormal.Sticking, + module Funcons.Core.Computations.Abnormal.Breaking.Breaking, + module Funcons.Core.Computations.Abnormal.Continuing.Continuing, + module Funcons.Core.Computations.Abnormal.Controlling.Controlling, + module Funcons.Core.Values.ValueTypes.ValueTypes, +-- module Funcons.Core.Values.Composite.Sets, + module Funcons.Core.Values.Composite.Bits.Bits, + module Funcons.Core.Values.Composite.Strings.Strings, + module Funcons.Core.Values.Composite.Datatypes.Datatypes, + module Funcons.Core.Values.Composite.Lists.Lists, +-- module Funcons.Core.Values.Composite.Multisets, + module Funcons.Core.Values.Composite.Sequences.Sequences, + module Funcons.Core.Values.Composite.Variants.Variants, + module Funcons.Core.Values.Composite.Records.Records, +-- module Funcons.Core.Values.Composite.Maps, + module Funcons.Core.Values.Composite.Vectors.Vectors, + module Funcons.Core.Values.Composite.Tuples.Tuples, + module Funcons.Core.Values.Composite.References.References, + module Funcons.Core.Values.Composite.Graphs.Graphs, + module Funcons.Core.Values.Primitive.Floats.Floats, + module Funcons.Core.Values.Primitive.Integers.Integers, + module Funcons.Core.Values.Primitive.Unit.Unit, + module Funcons.Core.Values.Primitive.Booleans.Booleans, + module Funcons.Core.Values.Primitive.Characters.Characters, + module Funcons.Core.Values.Abstraction.Functions.Functions, + module Funcons.Core.Values.Abstraction.Patterns.Patterns, + module Funcons.Core.Values.Abstraction.Generic.Generic, + module Funcons.Core.Values.Abstraction.Thunks.Thunks, + ) where import Funcons.EDSL -import Funcons.Core.Computations.Sorts hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.Sorts -import Funcons.Core.Computations.ControlFlow.Normal.Sequencing.LeftToRight hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.ControlFlow.Normal.Sequencing.LeftToRight -import Funcons.Core.Computations.ControlFlow.Normal.Sequencing.Atomic hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.ControlFlow.Normal.Sequencing.Atomic -import Funcons.Core.Computations.ControlFlow.Normal.Sequencing.Sequential hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.ControlFlow.Normal.Sequencing.Sequential -import Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.VectorMap hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.VectorMap -import Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.SetMap hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.SetMap -import Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.ListMap hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.ListMap -import Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.TupleMap hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.TupleMap -import Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.MapMap hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.MapMap -import Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.ListsMap hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.ListsMap -import Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.FilteringCollections.MultisetFilter hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.FilteringCollections.MultisetFilter -import Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.FilteringCollections.SetFilter hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.FilteringCollections.SetFilter -import Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.FilteringCollections.MapFilter hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.FilteringCollections.MapFilter -import Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.FilteringCollections.ListFilter hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.FilteringCollections.ListFilter -import Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.ReducingCollections.ListFoldl hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.ReducingCollections.ListFoldl -import Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.ReducingCollections.ListFoldr hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.ReducingCollections.ListFoldr -import Funcons.Core.Computations.ControlFlow.Normal.Iterating.Indefinite.While hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.ControlFlow.Normal.Iterating.Indefinite.While -import Funcons.Core.Computations.ControlFlow.Normal.Iterating.Indefinite.DoWhile hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.ControlFlow.Normal.Iterating.Indefinite.DoWhile -import Funcons.Core.Computations.ControlFlow.Normal.Choosing.IfThenElse hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.ControlFlow.Normal.Choosing.IfThenElse -import Funcons.Core.Computations.ControlFlow.Abnormal.Stuck hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.ControlFlow.Abnormal.Stuck -import Funcons.Core.Computations.ControlFlow.Abnormal.Throwing.Thrown hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.ControlFlow.Abnormal.Throwing.Thrown -import Funcons.Core.Computations.ControlFlow.Abnormal.Throwing.HandleThrown hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.ControlFlow.Abnormal.Throwing.HandleThrown -import Funcons.Core.Computations.ControlFlow.Abnormal.Throwing.Finally hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.ControlFlow.Abnormal.Throwing.Finally -import Funcons.Core.Computations.ControlFlow.Abnormal.Throwing.Throw hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.ControlFlow.Abnormal.Throwing.Throw -import Funcons.Core.Computations.ControlFlow.Abnormal.Throwing.HandleRecursively hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.ControlFlow.Abnormal.Throwing.HandleRecursively -import Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Plug hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Plug -import Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.ResumeSignal hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.ResumeSignal -import Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Shift hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Shift -import Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Prompt hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Prompt -import Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Control hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Control -import Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.CallCc hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.CallCc -import Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Reset hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Reset -import Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Hole hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Hole -import Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Abort hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Abort -import Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.ControlSignal hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.ControlSignal -import Funcons.Core.Computations.ControlFlow.Abnormal.Failing.Else hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.ControlFlow.Abnormal.Failing.Else -import Funcons.Core.Computations.ControlFlow.Abnormal.Failing.CheckTrue hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.ControlFlow.Abnormal.Failing.CheckTrue -import Funcons.Core.Computations.ControlFlow.Abnormal.Failing.Fail hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.ControlFlow.Abnormal.Failing.Fail -import Funcons.Core.Computations.ControlFlow.Abnormal.Failing.Signals hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.ControlFlow.Abnormal.Failing.Signals -import Funcons.Core.Computations.ControlFlow.Abnormal.Failing.Dereference hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.ControlFlow.Abnormal.Failing.Dereference -import Funcons.Core.Computations.ControlFlow.Abnormal.Failing.Failed hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.ControlFlow.Abnormal.Failing.Failed -import Funcons.Core.Computations.DataFlow.Interacting.PrintList hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.DataFlow.Interacting.PrintList -import Funcons.Core.Computations.DataFlow.Interacting.Print hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.DataFlow.Interacting.Print -import Funcons.Core.Computations.DataFlow.Interacting.StandardOut hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.DataFlow.Interacting.StandardOut -import Funcons.Core.Computations.DataFlow.Interacting.Read hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.DataFlow.Interacting.Read -import Funcons.Core.Computations.DataFlow.Interacting.StandardIn hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.DataFlow.Interacting.StandardIn -import Funcons.Core.Computations.DataFlow.Effect hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.DataFlow.Effect -import Funcons.Core.Computations.DataFlow.Storing.GeneralVariables.AllocateMap hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.DataFlow.Storing.GeneralVariables.AllocateMap -import Funcons.Core.Computations.DataFlow.Storing.GeneralVariables.GeneralAssign hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.DataFlow.Storing.GeneralVariables.GeneralAssign -import Funcons.Core.Computations.DataFlow.Storing.GeneralVariables.GeneralAssigned hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.DataFlow.Storing.GeneralVariables.GeneralAssigned -import Funcons.Core.Computations.DataFlow.Storing.GeneralVariables.AllocateVector hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.DataFlow.Storing.GeneralVariables.AllocateVector -import Funcons.Core.Computations.DataFlow.Storing.Stores hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.DataFlow.Storing.Stores -import Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.CurrentValue hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.CurrentValue -import Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.Assigned hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.Assigned -import Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.AllocateInitialisedVariable hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.AllocateInitialisedVariable -import Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.AllocateVariable hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.AllocateVariable -import Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.DeallocateVariable hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.DeallocateVariable -import Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.Assign hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.Assign -import Funcons.Core.Computations.DataFlow.Storing.Store hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.DataFlow.Storing.Store -import Funcons.Core.Computations.DataFlow.Storing.Variables hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.DataFlow.Storing.Variables -import Funcons.Core.Computations.DataFlow.Linking.AllocateInitialisedLink hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.DataFlow.Linking.AllocateInitialisedLink -import Funcons.Core.Computations.DataFlow.Linking.AllocateLink hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.DataFlow.Linking.AllocateLink -import Funcons.Core.Computations.DataFlow.Linking.FollowIfLink hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.DataFlow.Linking.FollowIfLink -import Funcons.Core.Computations.DataFlow.Linking.LinkStore hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.DataFlow.Linking.LinkStore -import Funcons.Core.Computations.DataFlow.Linking.Links hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.DataFlow.Linking.Links -import Funcons.Core.Computations.DataFlow.Linking.FollowLink hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.DataFlow.Linking.FollowLink -import Funcons.Core.Computations.DataFlow.Linking.LinkStores hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.DataFlow.Linking.LinkStores -import Funcons.Core.Computations.DataFlow.Linking.SetLink hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.DataFlow.Linking.SetLink -import Funcons.Core.Computations.DataFlow.Giving.Given hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.DataFlow.Giving.Given -import Funcons.Core.Computations.DataFlow.Giving.Give hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.DataFlow.Giving.Give -import Funcons.Core.Computations.DataFlow.Giving.GivenValue hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.DataFlow.Giving.GivenValue -import Funcons.Core.Computations.DataFlow.Generating.AtomGenerator hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.DataFlow.Generating.AtomGenerator -import Funcons.Core.Computations.DataFlow.Generating.FreshAtom hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.DataFlow.Generating.FreshAtom -import Funcons.Core.Computations.DataFlow.Generating.FreshBinder hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.DataFlow.Generating.FreshBinder -import Funcons.Core.Computations.DataFlow.Binding.Recursion.Recursive hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.DataFlow.Binding.Recursion.Recursive -import Funcons.Core.Computations.DataFlow.Binding.Recursion.BindRecursively hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.DataFlow.Binding.Recursion.BindRecursively -import Funcons.Core.Computations.DataFlow.Binding.Recursion.BoundRecursively hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.DataFlow.Binding.Recursion.BoundRecursively -import Funcons.Core.Computations.DataFlow.Binding.Bound hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.DataFlow.Binding.Bound -import Funcons.Core.Computations.DataFlow.Binding.Environments hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.DataFlow.Binding.Environments -import Funcons.Core.Computations.DataFlow.Binding.Scope hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.DataFlow.Binding.Scope -import Funcons.Core.Computations.DataFlow.Binding.Accumulate hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.DataFlow.Binding.Accumulate -import Funcons.Core.Computations.DataFlow.Binding.Bind hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.DataFlow.Binding.Bind -import Funcons.Core.Computations.DataFlow.Binding.Environment hiding (funcons,types,entities) -import qualified Funcons.Core.Computations.DataFlow.Binding.Environment -import Funcons.Core.Values.Types hiding (funcons,types,entities) -import qualified Funcons.Core.Values.Types -import Funcons.Core.Values.CompositeValues.Collections.DirectedGraphs hiding (funcons,types,entities) -import qualified Funcons.Core.Values.CompositeValues.Collections.DirectedGraphs -import Funcons.Core.Values.CompositeValues.Collections.Tuples hiding (funcons,types,entities) -import qualified Funcons.Core.Values.CompositeValues.Collections.Tuples -import Funcons.Core.Values.CompositeValues.AlgebraicDatatypeValues.Variants hiding (funcons,types,entities) -import qualified Funcons.Core.Values.CompositeValues.AlgebraicDatatypeValues.Variants -import Funcons.Core.Values.CompositeValues.AlgebraicDatatypeValues.Records hiding (funcons,types,entities) -import qualified Funcons.Core.Values.CompositeValues.AlgebraicDatatypeValues.Records -import Funcons.Core.Values.CompositeValues.AlgebraicDatatypeValues.References hiding (funcons,types,entities) -import qualified Funcons.Core.Values.CompositeValues.AlgebraicDatatypeValues.References -import Funcons.Core.Values.PrimitiveValues.UnitType hiding (funcons,types,entities) -import qualified Funcons.Core.Values.PrimitiveValues.UnitType -import Funcons.Core.Values.PrimitiveValues.UnicodeCharacters hiding (funcons,types,entities) -import qualified Funcons.Core.Values.PrimitiveValues.UnicodeCharacters -import Funcons.Core.Values.PrimitiveValues.Bits hiding (funcons,types,entities) -import qualified Funcons.Core.Values.PrimitiveValues.Bits -import Funcons.Core.Values.PrimitiveValues.Strings hiding (funcons,types,entities) -import qualified Funcons.Core.Values.PrimitiveValues.Strings -import Funcons.Core.Values.PrimitiveValues.Numbers.Integers hiding (funcons,types,entities) -import qualified Funcons.Core.Values.PrimitiveValues.Numbers.Integers -import Funcons.Core.Values.PrimitiveValues.Numbers.Rationals hiding (funcons,types,entities) -import qualified Funcons.Core.Values.PrimitiveValues.Numbers.Rationals -import Funcons.Core.Values.PrimitiveValues.Numbers.IeeeFloats hiding (funcons,types,entities) -import qualified Funcons.Core.Values.PrimitiveValues.Numbers.IeeeFloats -import Funcons.Core.Values.PrimitiveValues.Booleans hiding (funcons,types,entities) -import qualified Funcons.Core.Values.PrimitiveValues.Booleans -import Funcons.Core.Abstractions.Closures.Close hiding (funcons,types,entities) -import qualified Funcons.Core.Abstractions.Closures.Close -import Funcons.Core.Abstractions.Closures.Closure hiding (funcons,types,entities) -import qualified Funcons.Core.Abstractions.Closures.Closure -import Funcons.Core.Abstractions.Patterns.PatternPrefer hiding (funcons,types,entities) -import qualified Funcons.Core.Abstractions.Patterns.PatternPrefer -import Funcons.Core.Abstractions.Patterns.Match hiding (funcons,types,entities) -import qualified Funcons.Core.Abstractions.Patterns.Match -import Funcons.Core.Abstractions.Patterns.Patterns hiding (funcons,types,entities) -import qualified Funcons.Core.Abstractions.Patterns.Patterns -import Funcons.Core.Abstractions.Patterns.PatternUnite hiding (funcons,types,entities) -import qualified Funcons.Core.Abstractions.Patterns.PatternUnite -import Funcons.Core.Abstractions.Patterns.PatternAny hiding (funcons,types,entities) -import qualified Funcons.Core.Abstractions.Patterns.PatternAny -import Funcons.Core.Abstractions.Patterns.Case hiding (funcons,types,entities) -import qualified Funcons.Core.Abstractions.Patterns.Case -import Funcons.Core.Abstractions.Patterns.MatchLoosely hiding (funcons,types,entities) -import qualified Funcons.Core.Abstractions.Patterns.MatchLoosely -import Funcons.Core.Abstractions.Patterns.PatternBind hiding (funcons,types,entities) -import qualified Funcons.Core.Abstractions.Patterns.PatternBind -import Funcons.Core.Abstractions.IsGroundValue hiding (funcons,types,entities) -import qualified Funcons.Core.Abstractions.IsGroundValue -import Funcons.Core.Abstractions.Functions.Apply hiding (funcons,types,entities) -import qualified Funcons.Core.Abstractions.Functions.Apply -import Funcons.Core.Abstractions.Functions.Supply hiding (funcons,types,entities) -import qualified Funcons.Core.Abstractions.Functions.Supply -import Funcons.Core.Abstractions.Functions.BindingLambda hiding (funcons,types,entities) -import qualified Funcons.Core.Abstractions.Functions.BindingLambda -import Funcons.Core.Abstractions.Functions.Curry hiding (funcons,types,entities) -import qualified Funcons.Core.Abstractions.Functions.Curry -import Funcons.Core.Abstractions.Functions.Lambda hiding (funcons,types,entities) -import qualified Funcons.Core.Abstractions.Functions.Lambda -import Funcons.Core.Abstractions.Functions.Uncurry hiding (funcons,types,entities) -import qualified Funcons.Core.Abstractions.Functions.Uncurry -import Funcons.Core.Abstractions.Functions.PartialApply hiding (funcons,types,entities) -import qualified Funcons.Core.Abstractions.Functions.PartialApply -import Funcons.Core.Abstractions.Functions.Compose hiding (funcons,types,entities) -import qualified Funcons.Core.Abstractions.Functions.Compose +import Funcons.Core.Computations.Normal.Interacting.Interacting hiding (funcons,types,entities) +import qualified Funcons.Core.Computations.Normal.Interacting.Interacting +import Funcons.Core.Computations.Normal.Flowing.Flowing hiding (funcons,types,entities) +import qualified Funcons.Core.Computations.Normal.Flowing.Flowing +import Funcons.Core.Computations.Normal.Storing.Storing hiding (funcons,types,entities) +import qualified Funcons.Core.Computations.Normal.Storing.Storing +import Funcons.Core.Computations.Normal.Linking.Linking hiding (funcons,types,entities) +import qualified Funcons.Core.Computations.Normal.Linking.Linking +import Funcons.Core.Computations.Normal.Giving.Giving hiding (funcons,types,entities) +import qualified Funcons.Core.Computations.Normal.Giving.Giving +import Funcons.Core.Computations.Normal.Generating.Generating hiding (funcons,types,entities) +import qualified Funcons.Core.Computations.Normal.Generating.Generating +import Funcons.Core.Computations.Normal.Binding.Binding hiding (funcons,types,entities) +import qualified Funcons.Core.Computations.Normal.Binding.Binding +import Funcons.Core.Computations.Abnormal.Abrupting.Abrupting hiding (funcons,types,entities) +import qualified Funcons.Core.Computations.Abnormal.Abrupting.Abrupting +import Funcons.Core.Computations.Abnormal.Returning.Returning hiding (funcons,types,entities) +import qualified Funcons.Core.Computations.Abnormal.Returning.Returning +import Funcons.Core.Computations.Abnormal.Throwing.Throwing hiding (funcons,types,entities) +import qualified Funcons.Core.Computations.Abnormal.Throwing.Throwing +import Funcons.Core.Computations.Abnormal.Failing.Failing hiding (funcons,types,entities) +import qualified Funcons.Core.Computations.Abnormal.Failing.Failing +import Funcons.Core.Computations.Abnormal.Sticking hiding (funcons,types,entities) +import qualified Funcons.Core.Computations.Abnormal.Sticking +import Funcons.Core.Computations.Abnormal.Breaking.Breaking hiding (funcons,types,entities) +import qualified Funcons.Core.Computations.Abnormal.Breaking.Breaking +import Funcons.Core.Computations.Abnormal.Continuing.Continuing hiding (funcons,types,entities) +import qualified Funcons.Core.Computations.Abnormal.Continuing.Continuing +import Funcons.Core.Computations.Abnormal.Controlling.Controlling hiding (funcons,types,entities) +import qualified Funcons.Core.Computations.Abnormal.Controlling.Controlling +import Funcons.Core.Values.ValueTypes.ValueTypes hiding (funcons,types,entities) +import qualified Funcons.Core.Values.ValueTypes.ValueTypes +--import Funcons.Core.Values.Composite.Sets hiding (funcons,types,entities) +--import qualified Funcons.Core.Values.Composite.Sets +import Funcons.Core.Values.Composite.Bits.Bits hiding (funcons,types,entities) +import qualified Funcons.Core.Values.Composite.Bits.Bits +import Funcons.Core.Values.Composite.Strings.Strings hiding (funcons,types,entities) +import qualified Funcons.Core.Values.Composite.Strings.Strings +import Funcons.Core.Values.Composite.Datatypes.Datatypes hiding (funcons,types,entities) +import qualified Funcons.Core.Values.Composite.Datatypes.Datatypes +import Funcons.Core.Values.Composite.Lists.Lists hiding (funcons,types,entities) +import qualified Funcons.Core.Values.Composite.Lists.Lists +--import Funcons.Core.Values.Composite.Multisets hiding (funcons,types,entities) +--import qualified Funcons.Core.Values.Composite.Multisets +--import Funcons.Core.Values.Composite.Sequences.Sequences hiding (funcons,types,entities) +import qualified Funcons.Core.Values.Composite.Sequences.Sequences +import Funcons.Core.Values.Composite.Variants.Variants hiding (funcons,types,entities) +import qualified Funcons.Core.Values.Composite.Variants.Variants +import Funcons.Core.Values.Composite.Records.Records hiding (funcons,types,entities) +import qualified Funcons.Core.Values.Composite.Records.Records +--import Funcons.Core.Values.Composite.Maps hiding (funcons,types,entities) +--import qualified Funcons.Core.Values.Composite.Maps +import Funcons.Core.Values.Composite.Vectors.Vectors hiding (funcons,types,entities) +import qualified Funcons.Core.Values.Composite.Vectors.Vectors +import Funcons.Core.Values.Composite.Tuples.Tuples hiding (funcons,types,entities) +import qualified Funcons.Core.Values.Composite.Tuples.Tuples +import Funcons.Core.Values.Composite.References.References hiding (funcons,types,entities) +import qualified Funcons.Core.Values.Composite.References.References +import Funcons.Core.Values.Composite.Graphs.Graphs hiding (funcons,types,entities) +import qualified Funcons.Core.Values.Composite.Graphs.Graphs +import Funcons.Core.Values.Primitive.Floats.Floats hiding (funcons,types,entities) +import qualified Funcons.Core.Values.Primitive.Floats.Floats +import Funcons.Core.Values.Primitive.Integers.Integers hiding (funcons,types,entities) +import qualified Funcons.Core.Values.Primitive.Integers.Integers +import Funcons.Core.Values.Primitive.Unit.Unit hiding (funcons,types,entities) +import qualified Funcons.Core.Values.Primitive.Unit.Unit +import Funcons.Core.Values.Primitive.Booleans.Booleans hiding (funcons,types,entities) +import qualified Funcons.Core.Values.Primitive.Booleans.Booleans +import Funcons.Core.Values.Primitive.Characters.Characters hiding (funcons,types,entities) +import qualified Funcons.Core.Values.Primitive.Characters.Characters +import Funcons.Core.Values.Abstraction.Functions.Functions hiding (funcons,types,entities) +import qualified Funcons.Core.Values.Abstraction.Functions.Functions +import Funcons.Core.Values.Abstraction.Patterns.Patterns hiding (funcons,types,entities) +import qualified Funcons.Core.Values.Abstraction.Patterns.Patterns +import Funcons.Core.Values.Abstraction.Generic.Generic hiding (funcons,types,entities) +import qualified Funcons.Core.Values.Abstraction.Generic.Generic +import Funcons.Core.Values.Abstraction.Thunks.Thunks hiding (funcons,types,entities) +import qualified Funcons.Core.Values.Abstraction.Thunks.Thunks funcons = libUnions [ - Funcons.Core.Computations.Sorts.funcons - , Funcons.Core.Computations.ControlFlow.Normal.Sequencing.LeftToRight.funcons - , Funcons.Core.Computations.ControlFlow.Normal.Sequencing.Atomic.funcons - , Funcons.Core.Computations.ControlFlow.Normal.Sequencing.Sequential.funcons - , Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.VectorMap.funcons - , Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.SetMap.funcons - , Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.ListMap.funcons - , Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.TupleMap.funcons - , Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.MapMap.funcons - , Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.ListsMap.funcons - , Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.FilteringCollections.MultisetFilter.funcons - , Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.FilteringCollections.SetFilter.funcons - , Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.FilteringCollections.MapFilter.funcons - , Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.FilteringCollections.ListFilter.funcons - , Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.ReducingCollections.ListFoldl.funcons - , Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.ReducingCollections.ListFoldr.funcons - , Funcons.Core.Computations.ControlFlow.Normal.Iterating.Indefinite.While.funcons - , Funcons.Core.Computations.ControlFlow.Normal.Iterating.Indefinite.DoWhile.funcons - , Funcons.Core.Computations.ControlFlow.Normal.Choosing.IfThenElse.funcons - , Funcons.Core.Computations.ControlFlow.Abnormal.Stuck.funcons - , Funcons.Core.Computations.ControlFlow.Abnormal.Throwing.Thrown.funcons - , Funcons.Core.Computations.ControlFlow.Abnormal.Throwing.HandleThrown.funcons - , Funcons.Core.Computations.ControlFlow.Abnormal.Throwing.Finally.funcons - , Funcons.Core.Computations.ControlFlow.Abnormal.Throwing.Throw.funcons - , Funcons.Core.Computations.ControlFlow.Abnormal.Throwing.HandleRecursively.funcons - , Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Plug.funcons - , Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.ResumeSignal.funcons - , Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Shift.funcons - , Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Prompt.funcons - , Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Control.funcons - , Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.CallCc.funcons - , Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Reset.funcons - , Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Hole.funcons - , Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Abort.funcons - , Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.ControlSignal.funcons - , Funcons.Core.Computations.ControlFlow.Abnormal.Failing.Else.funcons - , Funcons.Core.Computations.ControlFlow.Abnormal.Failing.CheckTrue.funcons - , Funcons.Core.Computations.ControlFlow.Abnormal.Failing.Fail.funcons - , Funcons.Core.Computations.ControlFlow.Abnormal.Failing.Signals.funcons - , Funcons.Core.Computations.ControlFlow.Abnormal.Failing.Dereference.funcons - , Funcons.Core.Computations.ControlFlow.Abnormal.Failing.Failed.funcons - , Funcons.Core.Computations.DataFlow.Interacting.PrintList.funcons - , Funcons.Core.Computations.DataFlow.Interacting.Print.funcons - , Funcons.Core.Computations.DataFlow.Interacting.StandardOut.funcons - , Funcons.Core.Computations.DataFlow.Interacting.Read.funcons - , Funcons.Core.Computations.DataFlow.Interacting.StandardIn.funcons - , Funcons.Core.Computations.DataFlow.Effect.funcons - , Funcons.Core.Computations.DataFlow.Storing.GeneralVariables.AllocateMap.funcons - , Funcons.Core.Computations.DataFlow.Storing.GeneralVariables.GeneralAssign.funcons - , Funcons.Core.Computations.DataFlow.Storing.GeneralVariables.GeneralAssigned.funcons - , Funcons.Core.Computations.DataFlow.Storing.GeneralVariables.AllocateVector.funcons - , Funcons.Core.Computations.DataFlow.Storing.Stores.funcons - , Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.CurrentValue.funcons - , Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.Assigned.funcons - , Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.AllocateInitialisedVariable.funcons - , Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.AllocateVariable.funcons - , Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.DeallocateVariable.funcons - , Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.Assign.funcons - , Funcons.Core.Computations.DataFlow.Storing.Store.funcons - , Funcons.Core.Computations.DataFlow.Storing.Variables.funcons - , Funcons.Core.Computations.DataFlow.Linking.AllocateInitialisedLink.funcons - , Funcons.Core.Computations.DataFlow.Linking.AllocateLink.funcons - , Funcons.Core.Computations.DataFlow.Linking.FollowIfLink.funcons - , Funcons.Core.Computations.DataFlow.Linking.LinkStore.funcons - , Funcons.Core.Computations.DataFlow.Linking.Links.funcons - , Funcons.Core.Computations.DataFlow.Linking.FollowLink.funcons - , Funcons.Core.Computations.DataFlow.Linking.LinkStores.funcons - , Funcons.Core.Computations.DataFlow.Linking.SetLink.funcons - , Funcons.Core.Computations.DataFlow.Giving.Given.funcons - , Funcons.Core.Computations.DataFlow.Giving.Give.funcons - , Funcons.Core.Computations.DataFlow.Giving.GivenValue.funcons - , Funcons.Core.Computations.DataFlow.Generating.AtomGenerator.funcons - , Funcons.Core.Computations.DataFlow.Generating.FreshAtom.funcons - , Funcons.Core.Computations.DataFlow.Generating.FreshBinder.funcons - , Funcons.Core.Computations.DataFlow.Binding.Recursion.Recursive.funcons - , Funcons.Core.Computations.DataFlow.Binding.Recursion.BindRecursively.funcons - , Funcons.Core.Computations.DataFlow.Binding.Recursion.BoundRecursively.funcons - , Funcons.Core.Computations.DataFlow.Binding.Bound.funcons - , Funcons.Core.Computations.DataFlow.Binding.Environments.funcons - , Funcons.Core.Computations.DataFlow.Binding.Scope.funcons - , Funcons.Core.Computations.DataFlow.Binding.Accumulate.funcons - , Funcons.Core.Computations.DataFlow.Binding.Bind.funcons - , Funcons.Core.Computations.DataFlow.Binding.Environment.funcons - , Funcons.Core.Values.Types.funcons - , Funcons.Core.Values.CompositeValues.Collections.DirectedGraphs.funcons - , Funcons.Core.Values.CompositeValues.Collections.Tuples.funcons - , Funcons.Core.Values.CompositeValues.AlgebraicDatatypeValues.Variants.funcons - , Funcons.Core.Values.CompositeValues.AlgebraicDatatypeValues.Records.funcons - , Funcons.Core.Values.CompositeValues.AlgebraicDatatypeValues.References.funcons - , Funcons.Core.Values.PrimitiveValues.UnitType.funcons - , Funcons.Core.Values.PrimitiveValues.UnicodeCharacters.funcons - , Funcons.Core.Values.PrimitiveValues.Bits.funcons - , Funcons.Core.Values.PrimitiveValues.Strings.funcons - , Funcons.Core.Values.PrimitiveValues.Numbers.Integers.funcons - , Funcons.Core.Values.PrimitiveValues.Numbers.Rationals.funcons - , Funcons.Core.Values.PrimitiveValues.Numbers.IeeeFloats.funcons - , Funcons.Core.Values.PrimitiveValues.Booleans.funcons - , Funcons.Core.Abstractions.Closures.Close.funcons - , Funcons.Core.Abstractions.Closures.Closure.funcons - , Funcons.Core.Abstractions.Patterns.PatternPrefer.funcons - , Funcons.Core.Abstractions.Patterns.Match.funcons - , Funcons.Core.Abstractions.Patterns.Patterns.funcons - , Funcons.Core.Abstractions.Patterns.PatternUnite.funcons - , Funcons.Core.Abstractions.Patterns.PatternAny.funcons - , Funcons.Core.Abstractions.Patterns.Case.funcons - , Funcons.Core.Abstractions.Patterns.MatchLoosely.funcons - , Funcons.Core.Abstractions.Patterns.PatternBind.funcons - , Funcons.Core.Abstractions.IsGroundValue.funcons - , Funcons.Core.Abstractions.Functions.Apply.funcons - , Funcons.Core.Abstractions.Functions.Supply.funcons - , Funcons.Core.Abstractions.Functions.BindingLambda.funcons - , Funcons.Core.Abstractions.Functions.Curry.funcons - , Funcons.Core.Abstractions.Functions.Lambda.funcons - , Funcons.Core.Abstractions.Functions.Uncurry.funcons - , Funcons.Core.Abstractions.Functions.PartialApply.funcons - , Funcons.Core.Abstractions.Functions.Compose.funcons + Funcons.Core.Computations.Normal.Interacting.Interacting.funcons + , Funcons.Core.Computations.Normal.Flowing.Flowing.funcons + , Funcons.Core.Computations.Normal.Storing.Storing.funcons + , Funcons.Core.Computations.Normal.Linking.Linking.funcons + , Funcons.Core.Computations.Normal.Giving.Giving.funcons + , Funcons.Core.Computations.Normal.Generating.Generating.funcons + , Funcons.Core.Computations.Normal.Binding.Binding.funcons + , Funcons.Core.Computations.Abnormal.Abrupting.Abrupting.funcons + , Funcons.Core.Computations.Abnormal.Returning.Returning.funcons + , Funcons.Core.Computations.Abnormal.Throwing.Throwing.funcons + , Funcons.Core.Computations.Abnormal.Failing.Failing.funcons + , Funcons.Core.Computations.Abnormal.Sticking.funcons + , Funcons.Core.Computations.Abnormal.Breaking.Breaking.funcons + , Funcons.Core.Computations.Abnormal.Continuing.Continuing.funcons + , Funcons.Core.Computations.Abnormal.Controlling.Controlling.funcons + , Funcons.Core.Values.ValueTypes.ValueTypes.funcons +-- , Funcons.Core.Values.Composite.Sets.funcons + , Funcons.Core.Values.Composite.Bits.Bits.funcons + , Funcons.Core.Values.Composite.Strings.Strings.funcons + , Funcons.Core.Values.Composite.Datatypes.Datatypes.funcons + , Funcons.Core.Values.Composite.Lists.Lists.funcons +-- , Funcons.Core.Values.Composite.Multisets.funcons + , Funcons.Core.Values.Composite.Sequences.Sequences.funcons + , Funcons.Core.Values.Composite.Variants.Variants.funcons + , Funcons.Core.Values.Composite.Records.Records.funcons +-- , Funcons.Core.Values.Composite.Maps.funcons + , Funcons.Core.Values.Composite.Vectors.Vectors.funcons + , Funcons.Core.Values.Composite.Tuples.Tuples.funcons + , Funcons.Core.Values.Composite.References.References.funcons + , Funcons.Core.Values.Composite.Graphs.Graphs.funcons + , Funcons.Core.Values.Primitive.Floats.Floats.funcons + , Funcons.Core.Values.Primitive.Integers.Integers.funcons + , Funcons.Core.Values.Primitive.Unit.Unit.funcons + , Funcons.Core.Values.Primitive.Booleans.Booleans.funcons + , Funcons.Core.Values.Primitive.Characters.Characters.funcons + , Funcons.Core.Values.Abstraction.Functions.Functions.funcons + , Funcons.Core.Values.Abstraction.Patterns.Patterns.funcons + , Funcons.Core.Values.Abstraction.Generic.Generic.funcons + , Funcons.Core.Values.Abstraction.Thunks.Thunks.funcons ] -entities = concat +entities = concat [ - Funcons.Core.Computations.Sorts.entities - , Funcons.Core.Computations.ControlFlow.Normal.Sequencing.LeftToRight.entities - , Funcons.Core.Computations.ControlFlow.Normal.Sequencing.Atomic.entities - , Funcons.Core.Computations.ControlFlow.Normal.Sequencing.Sequential.entities - , Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.VectorMap.entities - , Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.SetMap.entities - , Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.ListMap.entities - , Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.TupleMap.entities - , Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.MapMap.entities - , Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.ListsMap.entities - , Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.FilteringCollections.MultisetFilter.entities - , Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.FilteringCollections.SetFilter.entities - , Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.FilteringCollections.MapFilter.entities - , Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.FilteringCollections.ListFilter.entities - , Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.ReducingCollections.ListFoldl.entities - , Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.ReducingCollections.ListFoldr.entities - , Funcons.Core.Computations.ControlFlow.Normal.Iterating.Indefinite.While.entities - , Funcons.Core.Computations.ControlFlow.Normal.Iterating.Indefinite.DoWhile.entities - , Funcons.Core.Computations.ControlFlow.Normal.Choosing.IfThenElse.entities - , Funcons.Core.Computations.ControlFlow.Abnormal.Stuck.entities - , Funcons.Core.Computations.ControlFlow.Abnormal.Throwing.Thrown.entities - , Funcons.Core.Computations.ControlFlow.Abnormal.Throwing.HandleThrown.entities - , Funcons.Core.Computations.ControlFlow.Abnormal.Throwing.Finally.entities - , Funcons.Core.Computations.ControlFlow.Abnormal.Throwing.Throw.entities - , Funcons.Core.Computations.ControlFlow.Abnormal.Throwing.HandleRecursively.entities - , Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Plug.entities - , Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.ResumeSignal.entities - , Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Shift.entities - , Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Prompt.entities - , Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Control.entities - , Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.CallCc.entities - , Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Reset.entities - , Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Hole.entities - , Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Abort.entities - , Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.ControlSignal.entities - , Funcons.Core.Computations.ControlFlow.Abnormal.Failing.Else.entities - , Funcons.Core.Computations.ControlFlow.Abnormal.Failing.CheckTrue.entities - , Funcons.Core.Computations.ControlFlow.Abnormal.Failing.Fail.entities - , Funcons.Core.Computations.ControlFlow.Abnormal.Failing.Signals.entities - , Funcons.Core.Computations.ControlFlow.Abnormal.Failing.Dereference.entities - , Funcons.Core.Computations.ControlFlow.Abnormal.Failing.Failed.entities - , Funcons.Core.Computations.DataFlow.Interacting.PrintList.entities - , Funcons.Core.Computations.DataFlow.Interacting.Print.entities - , Funcons.Core.Computations.DataFlow.Interacting.StandardOut.entities - , Funcons.Core.Computations.DataFlow.Interacting.Read.entities - , Funcons.Core.Computations.DataFlow.Interacting.StandardIn.entities - , Funcons.Core.Computations.DataFlow.Effect.entities - , Funcons.Core.Computations.DataFlow.Storing.GeneralVariables.AllocateMap.entities - , Funcons.Core.Computations.DataFlow.Storing.GeneralVariables.GeneralAssign.entities - , Funcons.Core.Computations.DataFlow.Storing.GeneralVariables.GeneralAssigned.entities - , Funcons.Core.Computations.DataFlow.Storing.GeneralVariables.AllocateVector.entities - , Funcons.Core.Computations.DataFlow.Storing.Stores.entities - , Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.CurrentValue.entities - , Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.Assigned.entities - , Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.AllocateInitialisedVariable.entities - , Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.AllocateVariable.entities - , Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.DeallocateVariable.entities - , Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.Assign.entities - , Funcons.Core.Computations.DataFlow.Storing.Store.entities - , Funcons.Core.Computations.DataFlow.Storing.Variables.entities - , Funcons.Core.Computations.DataFlow.Linking.AllocateInitialisedLink.entities - , Funcons.Core.Computations.DataFlow.Linking.AllocateLink.entities - , Funcons.Core.Computations.DataFlow.Linking.FollowIfLink.entities - , Funcons.Core.Computations.DataFlow.Linking.LinkStore.entities - , Funcons.Core.Computations.DataFlow.Linking.Links.entities - , Funcons.Core.Computations.DataFlow.Linking.FollowLink.entities - , Funcons.Core.Computations.DataFlow.Linking.LinkStores.entities - , Funcons.Core.Computations.DataFlow.Linking.SetLink.entities - , Funcons.Core.Computations.DataFlow.Giving.Given.entities - , Funcons.Core.Computations.DataFlow.Giving.Give.entities - , Funcons.Core.Computations.DataFlow.Giving.GivenValue.entities - , Funcons.Core.Computations.DataFlow.Generating.AtomGenerator.entities - , Funcons.Core.Computations.DataFlow.Generating.FreshAtom.entities - , Funcons.Core.Computations.DataFlow.Generating.FreshBinder.entities - , Funcons.Core.Computations.DataFlow.Binding.Recursion.Recursive.entities - , Funcons.Core.Computations.DataFlow.Binding.Recursion.BindRecursively.entities - , Funcons.Core.Computations.DataFlow.Binding.Recursion.BoundRecursively.entities - , Funcons.Core.Computations.DataFlow.Binding.Bound.entities - , Funcons.Core.Computations.DataFlow.Binding.Environments.entities - , Funcons.Core.Computations.DataFlow.Binding.Scope.entities - , Funcons.Core.Computations.DataFlow.Binding.Accumulate.entities - , Funcons.Core.Computations.DataFlow.Binding.Bind.entities - , Funcons.Core.Computations.DataFlow.Binding.Environment.entities - , Funcons.Core.Values.Types.entities - , Funcons.Core.Values.CompositeValues.Collections.DirectedGraphs.entities - , Funcons.Core.Values.CompositeValues.Collections.Tuples.entities - , Funcons.Core.Values.CompositeValues.AlgebraicDatatypeValues.Variants.entities - , Funcons.Core.Values.CompositeValues.AlgebraicDatatypeValues.Records.entities - , Funcons.Core.Values.CompositeValues.AlgebraicDatatypeValues.References.entities - , Funcons.Core.Values.PrimitiveValues.UnitType.entities - , Funcons.Core.Values.PrimitiveValues.UnicodeCharacters.entities - , Funcons.Core.Values.PrimitiveValues.Bits.entities - , Funcons.Core.Values.PrimitiveValues.Strings.entities - , Funcons.Core.Values.PrimitiveValues.Numbers.Integers.entities - , Funcons.Core.Values.PrimitiveValues.Numbers.Rationals.entities - , Funcons.Core.Values.PrimitiveValues.Numbers.IeeeFloats.entities - , Funcons.Core.Values.PrimitiveValues.Booleans.entities - , Funcons.Core.Abstractions.Closures.Close.entities - , Funcons.Core.Abstractions.Closures.Closure.entities - , Funcons.Core.Abstractions.Patterns.PatternPrefer.entities - , Funcons.Core.Abstractions.Patterns.Match.entities - , Funcons.Core.Abstractions.Patterns.Patterns.entities - , Funcons.Core.Abstractions.Patterns.PatternUnite.entities - , Funcons.Core.Abstractions.Patterns.PatternAny.entities - , Funcons.Core.Abstractions.Patterns.Case.entities - , Funcons.Core.Abstractions.Patterns.MatchLoosely.entities - , Funcons.Core.Abstractions.Patterns.PatternBind.entities - , Funcons.Core.Abstractions.IsGroundValue.entities - , Funcons.Core.Abstractions.Functions.Apply.entities - , Funcons.Core.Abstractions.Functions.Supply.entities - , Funcons.Core.Abstractions.Functions.BindingLambda.entities - , Funcons.Core.Abstractions.Functions.Curry.entities - , Funcons.Core.Abstractions.Functions.Lambda.entities - , Funcons.Core.Abstractions.Functions.Uncurry.entities - , Funcons.Core.Abstractions.Functions.PartialApply.entities - , Funcons.Core.Abstractions.Functions.Compose.entities + Funcons.Core.Computations.Normal.Interacting.Interacting.entities + , Funcons.Core.Computations.Normal.Flowing.Flowing.entities + , Funcons.Core.Computations.Normal.Storing.Storing.entities + , Funcons.Core.Computations.Normal.Linking.Linking.entities + , Funcons.Core.Computations.Normal.Giving.Giving.entities + , Funcons.Core.Computations.Normal.Generating.Generating.entities + , Funcons.Core.Computations.Normal.Binding.Binding.entities + , Funcons.Core.Computations.Abnormal.Abrupting.Abrupting.entities + , Funcons.Core.Computations.Abnormal.Returning.Returning.entities + , Funcons.Core.Computations.Abnormal.Throwing.Throwing.entities + , Funcons.Core.Computations.Abnormal.Failing.Failing.entities + , Funcons.Core.Computations.Abnormal.Sticking.entities + , Funcons.Core.Computations.Abnormal.Breaking.Breaking.entities + , Funcons.Core.Computations.Abnormal.Continuing.Continuing.entities + , Funcons.Core.Computations.Abnormal.Controlling.Controlling.entities + , Funcons.Core.Values.ValueTypes.ValueTypes.entities +-- , Funcons.Core.Values.Composite.Sets.entities + , Funcons.Core.Values.Composite.Bits.Bits.entities + , Funcons.Core.Values.Composite.Strings.Strings.entities + , Funcons.Core.Values.Composite.Datatypes.Datatypes.entities + , Funcons.Core.Values.Composite.Lists.Lists.entities +-- , Funcons.Core.Values.Composite.Multisets.entities + , Funcons.Core.Values.Composite.Sequences.Sequences.entities + , Funcons.Core.Values.Composite.Variants.Variants.entities + , Funcons.Core.Values.Composite.Records.Records.entities +-- , Funcons.Core.Values.Composite.Maps.entities + , Funcons.Core.Values.Composite.Vectors.Vectors.entities + , Funcons.Core.Values.Composite.Tuples.Tuples.entities + , Funcons.Core.Values.Composite.References.References.entities + , Funcons.Core.Values.Composite.Graphs.Graphs.entities + , Funcons.Core.Values.Primitive.Floats.Floats.entities + , Funcons.Core.Values.Primitive.Integers.Integers.entities + , Funcons.Core.Values.Primitive.Unit.Unit.entities + , Funcons.Core.Values.Primitive.Booleans.Booleans.entities + , Funcons.Core.Values.Primitive.Characters.Characters.entities + , Funcons.Core.Values.Abstraction.Functions.Functions.entities + , Funcons.Core.Values.Abstraction.Patterns.Patterns.entities + , Funcons.Core.Values.Abstraction.Generic.Generic.entities + , Funcons.Core.Values.Abstraction.Thunks.Thunks.entities ] -types = typeEnvUnions +types = typeEnvUnions [ - Funcons.Core.Computations.Sorts.types - , Funcons.Core.Computations.ControlFlow.Normal.Sequencing.LeftToRight.types - , Funcons.Core.Computations.ControlFlow.Normal.Sequencing.Atomic.types - , Funcons.Core.Computations.ControlFlow.Normal.Sequencing.Sequential.types - , Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.VectorMap.types - , Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.SetMap.types - , Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.ListMap.types - , Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.TupleMap.types - , Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.MapMap.types - , Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.ListsMap.types - , Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.FilteringCollections.MultisetFilter.types - , Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.FilteringCollections.SetFilter.types - , Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.FilteringCollections.MapFilter.types - , Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.FilteringCollections.ListFilter.types - , Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.ReducingCollections.ListFoldl.types - , Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.ReducingCollections.ListFoldr.types - , Funcons.Core.Computations.ControlFlow.Normal.Iterating.Indefinite.While.types - , Funcons.Core.Computations.ControlFlow.Normal.Iterating.Indefinite.DoWhile.types - , Funcons.Core.Computations.ControlFlow.Normal.Choosing.IfThenElse.types - , Funcons.Core.Computations.ControlFlow.Abnormal.Stuck.types - , Funcons.Core.Computations.ControlFlow.Abnormal.Throwing.Thrown.types - , Funcons.Core.Computations.ControlFlow.Abnormal.Throwing.HandleThrown.types - , Funcons.Core.Computations.ControlFlow.Abnormal.Throwing.Finally.types - , Funcons.Core.Computations.ControlFlow.Abnormal.Throwing.Throw.types - , Funcons.Core.Computations.ControlFlow.Abnormal.Throwing.HandleRecursively.types - , Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Plug.types - , Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.ResumeSignal.types - , Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Shift.types - , Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Prompt.types - , Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Control.types - , Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.CallCc.types - , Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Reset.types - , Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Hole.types - , Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Abort.types - , Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.ControlSignal.types - , Funcons.Core.Computations.ControlFlow.Abnormal.Failing.Else.types - , Funcons.Core.Computations.ControlFlow.Abnormal.Failing.CheckTrue.types - , Funcons.Core.Computations.ControlFlow.Abnormal.Failing.Fail.types - , Funcons.Core.Computations.ControlFlow.Abnormal.Failing.Signals.types - , Funcons.Core.Computations.ControlFlow.Abnormal.Failing.Dereference.types - , Funcons.Core.Computations.ControlFlow.Abnormal.Failing.Failed.types - , Funcons.Core.Computations.DataFlow.Interacting.PrintList.types - , Funcons.Core.Computations.DataFlow.Interacting.Print.types - , Funcons.Core.Computations.DataFlow.Interacting.StandardOut.types - , Funcons.Core.Computations.DataFlow.Interacting.Read.types - , Funcons.Core.Computations.DataFlow.Interacting.StandardIn.types - , Funcons.Core.Computations.DataFlow.Effect.types - , Funcons.Core.Computations.DataFlow.Storing.GeneralVariables.AllocateMap.types - , Funcons.Core.Computations.DataFlow.Storing.GeneralVariables.GeneralAssign.types - , Funcons.Core.Computations.DataFlow.Storing.GeneralVariables.GeneralAssigned.types - , Funcons.Core.Computations.DataFlow.Storing.GeneralVariables.AllocateVector.types - , Funcons.Core.Computations.DataFlow.Storing.Stores.types - , Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.CurrentValue.types - , Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.Assigned.types - , Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.AllocateInitialisedVariable.types - , Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.AllocateVariable.types - , Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.DeallocateVariable.types - , Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.Assign.types - , Funcons.Core.Computations.DataFlow.Storing.Store.types - , Funcons.Core.Computations.DataFlow.Storing.Variables.types - , Funcons.Core.Computations.DataFlow.Linking.AllocateInitialisedLink.types - , Funcons.Core.Computations.DataFlow.Linking.AllocateLink.types - , Funcons.Core.Computations.DataFlow.Linking.FollowIfLink.types - , Funcons.Core.Computations.DataFlow.Linking.LinkStore.types - , Funcons.Core.Computations.DataFlow.Linking.Links.types - , Funcons.Core.Computations.DataFlow.Linking.FollowLink.types - , Funcons.Core.Computations.DataFlow.Linking.LinkStores.types - , Funcons.Core.Computations.DataFlow.Linking.SetLink.types - , Funcons.Core.Computations.DataFlow.Giving.Given.types - , Funcons.Core.Computations.DataFlow.Giving.Give.types - , Funcons.Core.Computations.DataFlow.Giving.GivenValue.types - , Funcons.Core.Computations.DataFlow.Generating.AtomGenerator.types - , Funcons.Core.Computations.DataFlow.Generating.FreshAtom.types - , Funcons.Core.Computations.DataFlow.Generating.FreshBinder.types - , Funcons.Core.Computations.DataFlow.Binding.Recursion.Recursive.types - , Funcons.Core.Computations.DataFlow.Binding.Recursion.BindRecursively.types - , Funcons.Core.Computations.DataFlow.Binding.Recursion.BoundRecursively.types - , Funcons.Core.Computations.DataFlow.Binding.Bound.types - , Funcons.Core.Computations.DataFlow.Binding.Environments.types - , Funcons.Core.Computations.DataFlow.Binding.Scope.types - , Funcons.Core.Computations.DataFlow.Binding.Accumulate.types - , Funcons.Core.Computations.DataFlow.Binding.Bind.types - , Funcons.Core.Computations.DataFlow.Binding.Environment.types - , Funcons.Core.Values.Types.types - , Funcons.Core.Values.CompositeValues.Collections.DirectedGraphs.types - , Funcons.Core.Values.CompositeValues.Collections.Tuples.types - , Funcons.Core.Values.CompositeValues.AlgebraicDatatypeValues.Variants.types - , Funcons.Core.Values.CompositeValues.AlgebraicDatatypeValues.Records.types - , Funcons.Core.Values.CompositeValues.AlgebraicDatatypeValues.References.types - , Funcons.Core.Values.PrimitiveValues.UnitType.types - , Funcons.Core.Values.PrimitiveValues.UnicodeCharacters.types - , Funcons.Core.Values.PrimitiveValues.Bits.types - , Funcons.Core.Values.PrimitiveValues.Strings.types - , Funcons.Core.Values.PrimitiveValues.Numbers.Integers.types - , Funcons.Core.Values.PrimitiveValues.Numbers.Rationals.types - , Funcons.Core.Values.PrimitiveValues.Numbers.IeeeFloats.types - , Funcons.Core.Values.PrimitiveValues.Booleans.types - , Funcons.Core.Abstractions.Closures.Close.types - , Funcons.Core.Abstractions.Closures.Closure.types - , Funcons.Core.Abstractions.Patterns.PatternPrefer.types - , Funcons.Core.Abstractions.Patterns.Match.types - , Funcons.Core.Abstractions.Patterns.Patterns.types - , Funcons.Core.Abstractions.Patterns.PatternUnite.types - , Funcons.Core.Abstractions.Patterns.PatternAny.types - , Funcons.Core.Abstractions.Patterns.Case.types - , Funcons.Core.Abstractions.Patterns.MatchLoosely.types - , Funcons.Core.Abstractions.Patterns.PatternBind.types - , Funcons.Core.Abstractions.IsGroundValue.types - , Funcons.Core.Abstractions.Functions.Apply.types - , Funcons.Core.Abstractions.Functions.Supply.types - , Funcons.Core.Abstractions.Functions.BindingLambda.types - , Funcons.Core.Abstractions.Functions.Curry.types - , Funcons.Core.Abstractions.Functions.Lambda.types - , Funcons.Core.Abstractions.Functions.Uncurry.types - , Funcons.Core.Abstractions.Functions.PartialApply.types - , Funcons.Core.Abstractions.Functions.Compose.types + Funcons.Core.Computations.Normal.Interacting.Interacting.types + , Funcons.Core.Computations.Normal.Flowing.Flowing.types + , Funcons.Core.Computations.Normal.Storing.Storing.types + , Funcons.Core.Computations.Normal.Linking.Linking.types + , Funcons.Core.Computations.Normal.Giving.Giving.types + , Funcons.Core.Computations.Normal.Generating.Generating.types + , Funcons.Core.Computations.Normal.Binding.Binding.types + , Funcons.Core.Computations.Abnormal.Abrupting.Abrupting.types + , Funcons.Core.Computations.Abnormal.Returning.Returning.types + , Funcons.Core.Computations.Abnormal.Throwing.Throwing.types + , Funcons.Core.Computations.Abnormal.Failing.Failing.types + , Funcons.Core.Computations.Abnormal.Sticking.types + , Funcons.Core.Computations.Abnormal.Breaking.Breaking.types + , Funcons.Core.Computations.Abnormal.Continuing.Continuing.types + , Funcons.Core.Computations.Abnormal.Controlling.Controlling.types + , Funcons.Core.Values.ValueTypes.ValueTypes.types +-- , Funcons.Core.Values.Composite.Sets.types + , Funcons.Core.Values.Composite.Bits.Bits.types + , Funcons.Core.Values.Composite.Strings.Strings.types + , Funcons.Core.Values.Composite.Datatypes.Datatypes.types + , Funcons.Core.Values.Composite.Lists.Lists.types +-- , Funcons.Core.Values.Composite.Multisets.types + , Funcons.Core.Values.Composite.Sequences.Sequences.types + , Funcons.Core.Values.Composite.Variants.Variants.types + , Funcons.Core.Values.Composite.Records.Records.types +-- , Funcons.Core.Values.Composite.Maps.types + , Funcons.Core.Values.Composite.Vectors.Vectors.types + , Funcons.Core.Values.Composite.Tuples.Tuples.types + , Funcons.Core.Values.Composite.References.References.types + , Funcons.Core.Values.Composite.Graphs.Graphs.types + , Funcons.Core.Values.Primitive.Floats.Floats.types + , Funcons.Core.Values.Primitive.Integers.Integers.types + , Funcons.Core.Values.Primitive.Unit.Unit.types + , Funcons.Core.Values.Primitive.Booleans.Booleans.types + , Funcons.Core.Values.Primitive.Characters.Characters.types + , Funcons.Core.Values.Abstraction.Functions.Functions.types + , Funcons.Core.Values.Abstraction.Patterns.Patterns.types + , Funcons.Core.Values.Abstraction.Generic.Generic.types + , Funcons.Core.Values.Abstraction.Thunks.Thunks.types ] diff --git a/cbs/Funcons/Core/Values/Abstraction/Functions/Functions.hs b/cbs/Funcons/Core/Values/Abstraction/Functions/Functions.hs new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Values/Abstraction/Functions/Functions.hs @@ -0,0 +1,75 @@ +-- GeNeRaTeD fOr: ../../CBS-beta/Funcons-beta/Values/Abstraction/Functions/Functions.cbs +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Values.Abstraction.Functions.Functions where + +import Funcons.EDSL + +import Funcons.Operations hiding (Values) +entities = [] + +types = typeEnvFromList + [("functions",DataTypeMemberss "functions" [TPVar "DT",TPVar "T"] [DataTypeMemberConstructor "function" [TApp "abstractions" [TSortComputesFrom (TVar "DT") (TVar "T")]] (Just [TPVar "DT",TPVar "T"])])] + +funcons = libFromList + [("function",StrictFuncon stepFunction),("apply",StrictFuncon stepApply),("supply",StrictFuncon stepSupply),("compose",StrictFuncon stepCompose),("uncurry",StrictFuncon stepUncurry),("curry",StrictFuncon stepCurry),("partial-apply",StrictFuncon stepPartial_apply),("functions",StrictFuncon stepFunctions)] + +function_ fargs = FApp "function" (fargs) +stepFunction fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPMetaVar "_X1"] env + env <- sideCondition (SCIsInSort (TVar "_X1") (TName "values")) env + rewriteTermTo (TApp "datatype-value" [TFuncon (FValue (ADTVal "list" [FValue (Ascii 'f'),FValue (Ascii 'u'),FValue (Ascii 'n'),FValue (Ascii 'c'),FValue (Ascii 't'),FValue (Ascii 'i'),FValue (Ascii 'o'),FValue (Ascii 'n')])),TVar "_X1"]) env + +apply_ fargs = FApp "apply" (fargs) +stepApply fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "function" [PADT "abstraction" [VPMetaVar "X"]],VPAnnotated (VPMetaVar "V") (TName "defined-values")] env + rewriteTermTo (TApp "give" [TVar "V",TVar "X"]) env + +supply_ fargs = FApp "supply" (fargs) +stepSupply fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "function" [PADT "abstraction" [VPMetaVar "X"]],VPAnnotated (VPMetaVar "V") (TName "defined-values")] env + rewriteTermTo (TApp "thunk" [TApp "abstraction" [TApp "give" [TVar "V",TVar "X"]]]) env + +compose_ fargs = FApp "compose" (fargs) +stepCompose fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "function" [PADT "abstraction" [VPMetaVar "Y"]],PADT "function" [PADT "abstraction" [VPMetaVar "X"]]] env + rewriteTermTo (TApp "function" [TApp "abstraction" [TApp "give" [TVar "X",TVar "Y"]]]) env + +uncurry_ fargs = FApp "uncurry" (fargs) +stepUncurry fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "F") (TApp "functions" [TName "defined-values",TApp "functions" [TName "defined-values",TName "values"]])] env + rewriteTermTo (TApp "function" [TApp "abstraction" [TApp "apply" [TApp "apply" [TVar "F",TApp "def" [TApp "index" [TFuncon (FValue (Nat 1)),TApp "tuple-elements" [TName "given"]]]],TApp "def" [TApp "index" [TFuncon (FValue (Nat 2)),TApp "tuple-elements" [TName "given"]]]]]]) env + +curry_ fargs = FApp "curry" (fargs) +stepCurry fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "F") (TApp "functions" [TApp "tuples" [TName "defined-values",TName "defined-values"],TName "values"])] env + rewriteTermTo (TApp "function" [TApp "abstraction" [TApp "partial-apply" [TVar "F",TName "given"]]]) env + +partial_apply_ fargs = FApp "partial-apply" (fargs) +stepPartial_apply fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "F") (TApp "functions" [TApp "tuples" [TName "defined-values",TName "defined-values"],TName "values"]),VPAnnotated (VPMetaVar "V") (TName "defined-values")] env + rewriteTermTo (TApp "function" [TApp "abstraction" [TApp "apply" [TVar "F",TApp "tuple" [TVar "V",TName "given"]]]]) env + +functions_ = FApp "functions" +stepFunctions ts = rewriteType "functions" ts diff --git a/cbs/Funcons/Core/Values/Abstraction/Generic/Generic.hs b/cbs/Funcons/Core/Values/Abstraction/Generic/Generic.hs new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Values/Abstraction/Generic/Generic.hs @@ -0,0 +1,43 @@ +-- GeNeRaTeD fOr: ../../CBS-beta/Funcons-beta/Values/Abstraction/Generic/Generic.cbs +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Values.Abstraction.Generic.Generic where + +import Funcons.EDSL + +import Funcons.Operations hiding (Values) +entities = [] + +types = typeEnvFromList + [("abstractions",DataTypeMemberss "abstractions" [TPWildCard] [DataTypeMemberConstructor "abstraction" [TSortComputesFrom (TVar "DT") (TVar "T")] (Just [TPComputesFrom (TPVar "DT") (TPVar "T")])])] + +funcons = libFromList + [("abstraction",NonStrictFuncon stepAbstraction),("closure",NonStrictFuncon stepClosure),("enact",StrictFuncon stepEnact),("abstractions",StrictFuncon stepAbstractions)] + +abstraction_ fargs = FApp "abstraction" (fargs) +stepAbstraction fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PMetaVar "_X1"] env + rewriteTermTo (TApp "non-strict-datatype-value" [TFuncon (FValue (ADTVal "list" [FValue (Ascii 'a'),FValue (Ascii 'b'),FValue (Ascii 's'),FValue (Ascii 't'),FValue (Ascii 'r'),FValue (Ascii 'a'),FValue (Ascii 'c'),FValue (Ascii 't'),FValue (Ascii 'i'),FValue (Ascii 'o'),FValue (Ascii 'n')])),TVar "_X1"]) env + +closure_ fargs = FApp "closure" (fargs) +stepClosure fargs = + evalRules [] [step1] + where step1 = do + let env = emptyEnv + env <- lifted_fsMatch fargs [PMetaVar "X"] env + env <- getInhPatt "environment" (VPMetaVar "Rho") env + stepTermTo (TApp "abstraction" [TApp "closed" [TApp "scope" [TVar "Rho",TVar "X"]]]) env + +enact_ fargs = FApp "enact" (fargs) +stepEnact fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "abstraction" [VPMetaVar "X"]] env + rewriteTermTo (TVar "X") env + +abstractions_ = FApp "abstractions" +stepAbstractions ts = rewriteType "abstractions" ts diff --git a/cbs/Funcons/Core/Values/Abstraction/Patterns/Patterns.hs b/cbs/Funcons/Core/Values/Abstraction/Patterns/Patterns.hs new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Values/Abstraction/Patterns/Patterns.hs @@ -0,0 +1,147 @@ +-- GeNeRaTeD fOr: ../../CBS-beta/Funcons-beta/Values/Abstraction/Patterns/Patterns.cbs +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Values.Abstraction.Patterns.Patterns where + +import Funcons.EDSL + +import Funcons.Operations hiding (Values) +entities = [] + +types = typeEnvFromList + [("patterns",DataTypeMemberss "patterns" [] [DataTypeMemberConstructor "pattern" [TApp "abstractions" [TSortComputesFrom (TName "defined-values") (TName "environments")]] (Just [])])] + +funcons = libFromList + [("pattern",StrictFuncon stepPattern),("pattern-any",NullaryFuncon stepPattern_any),("pattern-bind",StrictFuncon stepPattern_bind),("pattern-type",NonStrictFuncon stepPattern_type),("pattern-else",StrictFuncon stepPattern_else),("pattern-unite",StrictFuncon stepPattern_unite),("match",StrictFuncon stepMatch),("match-loosely",StrictFuncon stepMatch_loosely),("case-match",PartiallyStrictFuncon [Strict,NonStrict] NonStrict stepCase_match),("case-match-loosely",PartiallyStrictFuncon [Strict,NonStrict] NonStrict stepCase_match_loosely),("case-variant-value",StrictFuncon stepCase_variant_value),("patterns",NullaryFuncon stepPatterns)] + +pattern_ fargs = FApp "pattern" (fargs) +stepPattern fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPMetaVar "_X1"] env + env <- sideCondition (SCIsInSort (TVar "_X1") (TName "values")) env + rewriteTermTo (TApp "datatype-value" [TFuncon (FValue (ADTVal "list" [FValue (Ascii 'p'),FValue (Ascii 'a'),FValue (Ascii 't'),FValue (Ascii 't'),FValue (Ascii 'e'),FValue (Ascii 'r'),FValue (Ascii 'n')])),TVar "_X1"]) env + +pattern_any_ = FName "pattern-any" +stepPattern_any = evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + rewriteTermTo (TApp "pattern" [TApp "abstraction" [TApp "map" []]]) env + +pattern_bind_ fargs = FApp "pattern-bind" (fargs) +stepPattern_bind fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "I") (TName "ids")] env + rewriteTermTo (TApp "pattern" [TApp "abstraction" [TApp "bind" [TVar "I",TName "given"]]]) env + +pattern_type_ fargs = FApp "pattern-type" (fargs) +stepPattern_type fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PMetaVar "DT"] env + rewriteTermTo (TApp "pattern" [TApp "abstraction" [TApp "if-true-else" [TApp "is-in-type" [TName "given",TVar "DT"],TApp "map" [],TName "fail"]]]) env + +pattern_else_ fargs = FApp "pattern-else" (fargs) +stepPattern_else fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "P1") (TName "defined-values"),VPAnnotated (VPMetaVar "P2") (TName "defined-values")] env + rewriteTermTo (TApp "pattern" [TApp "abstraction" [TApp "else" [TApp "match" [TName "given",TVar "P1"],TApp "match" [TName "given",TVar "P2"]]]]) env + +pattern_unite_ fargs = FApp "pattern-unite" (fargs) +stepPattern_unite fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "P1") (TName "defined-values"),VPAnnotated (VPMetaVar "P2") (TName "defined-values")] env + rewriteTermTo (TApp "pattern" [TApp "abstraction" [TApp "collateral" [TApp "match" [TName "given",TVar "P1"],TApp "match" [TName "given",TVar "P2"]]]]) env + +match_ fargs = FApp "match" (fargs) +stepMatch fargs = + evalRules [rewrite1,rewrite2,rewrite3,rewrite4,rewrite5] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "DV") (TName "defined-values"),PADT "pattern" [PADT "abstraction" [VPMetaVar "X"]]] env + rewriteTermTo (TApp "give" [TVar "DV",TVar "X"]) env + rewrite2 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "datatype-value" [VPAnnotated (VPMetaVar "I1") (TName "ids"),VPAnnotated (VPSeqVar "V1*" StarOp) (TSortSeq (TName "values") StarOp)],PADT "datatype-value" [VPAnnotated (VPMetaVar "I2") (TName "ids"),VPAnnotated (VPSeqVar "V2*" StarOp) (TSortSeq (TName "values") StarOp)]] env + env <- sideCondition (SCInequality (TVar "I2") (TFuncon (FValue (ADTVal "list" [FValue (Ascii 'p'),FValue (Ascii 'a'),FValue (Ascii 't'),FValue (Ascii 't'),FValue (Ascii 'e'),FValue (Ascii 'r'),FValue (Ascii 'n')])))) env + rewriteTermTo (TApp "sequential" [TApp "check-true" [TApp "is-equal" [TVar "I1",TVar "I2"]],TApp "check-true" [TApp "is-equal" [TApp "length" [TVar "V1*"],TApp "length" [TVar "V2*"]]],TApp "collateral" [TApp "interleave-map" [TApp "match" [TApp "tuple-elements" [TName "given"]],TApp "tuple-zip" [TApp "tuple" [TVar "V1*"],TApp "tuple" [TVar "V2*"]]]]]) env + rewrite3 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "M1") (TApp "maps" [TName "values",TName "values"]),VPAnnotated (VPMetaVar "M2") (TApp "maps" [TName "values",TName "values"])] env + env <- sideCondition (SCEquality (TApp "dom" [TVar "M2"]) (TSet [])) env + rewriteTermTo (TApp "if-true-else" [TApp "is-equal" [TApp "dom" [TVar "M1"],TSet []],TApp "map" [],TName "fail"]) env + rewrite4 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "M1") (TApp "maps" [TName "values",TName "values"]),VPAnnotated (VPMetaVar "M2") (TApp "maps" [TName "values",TName "values"])] env + env <- sideCondition (SCInequality (TApp "dom" [TVar "M2"]) (TSet [])) env + env <- sideCondition (SCPatternMatch (TApp "some-element" [TApp "dom" [TVar "M2"]]) (VPMetaVar "K")) env + rewriteTermTo (TApp "if-true-else" [TApp "is-in-set" [TVar "K",TApp "dom" [TVar "M1"]],TApp "collateral" [TApp "match" [TApp "lookup" [TVar "M1",TVar "K"],TApp "lookup" [TVar "M2",TVar "K"]],TApp "match" [TApp "map-delete" [TVar "M1",TSet [TVar "K"]],TApp "map-delete" [TVar "M2",TSet [TVar "K"]]]],TName "fail"]) env + rewrite5 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "DV") (TName "defined-values"),VPAnnotated (VPMetaVar "P") (TName "defined-values")] env + env <- sideCondition (SCIsInSort (TVar "P") (TSortComplement (TSortUnion (TName "datatype-values") (TApp "maps" [TName "values",TName "values"])))) env + rewriteTermTo (TApp "if-true-else" [TApp "is-equal" [TVar "DV",TVar "P"],TApp "map" [],TName "fail"]) env + +match_loosely_ fargs = FApp "match-loosely" (fargs) +stepMatch_loosely fargs = + evalRules [rewrite1,rewrite2,rewrite3,rewrite4,rewrite5] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "DV") (TName "defined-values"),PADT "pattern" [PADT "abstraction" [VPMetaVar "X"]]] env + rewriteTermTo (TApp "give" [TVar "DV",TVar "X"]) env + rewrite2 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "datatype-value" [VPAnnotated (VPMetaVar "I1") (TName "ids"),VPAnnotated (VPSeqVar "V1*" StarOp) (TSortSeq (TName "values") StarOp)],PADT "datatype-value" [VPAnnotated (VPMetaVar "I2") (TName "ids"),VPAnnotated (VPSeqVar "V2*" StarOp) (TSortSeq (TName "values") StarOp)]] env + env <- sideCondition (SCInequality (TVar "I2") (TFuncon (FValue (ADTVal "list" [FValue (Ascii 'p'),FValue (Ascii 'a'),FValue (Ascii 't'),FValue (Ascii 't'),FValue (Ascii 'e'),FValue (Ascii 'r'),FValue (Ascii 'n')])))) env + rewriteTermTo (TApp "sequential" [TApp "check-true" [TApp "is-equal" [TVar "I1",TVar "I2"]],TApp "check-true" [TApp "is-equal" [TApp "length" [TVar "V1*"],TApp "length" [TVar "V2*"]]],TApp "collateral" [TApp "interleave-map" [TApp "match-loosely" [TApp "tuple-elements" [TName "given"]],TApp "tuple-zip" [TApp "tuple" [TVar "V1*"],TApp "tuple" [TVar "V2*"]]]]]) env + rewrite3 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "M1") (TApp "maps" [TName "values",TName "values"]),VPAnnotated (VPMetaVar "M2") (TApp "maps" [TName "values",TName "values"])] env + env <- sideCondition (SCEquality (TApp "dom" [TVar "M2"]) (TSet [])) env + rewriteTermTo (TApp "map" []) env + rewrite4 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "M1") (TApp "maps" [TName "values",TName "values"]),VPAnnotated (VPMetaVar "M2") (TApp "maps" [TName "values",TName "values"])] env + env <- sideCondition (SCInequality (TApp "dom" [TVar "M2"]) (TSet [])) env + env <- sideCondition (SCPatternMatch (TApp "some-element" [TApp "dom" [TVar "M2"]]) (VPMetaVar "K")) env + rewriteTermTo (TApp "if-true-else" [TApp "is-in-set" [TVar "K",TApp "dom" [TVar "M1"]],TApp "collateral" [TApp "match-loosely" [TApp "lookup" [TVar "M1",TVar "K"],TApp "lookup" [TVar "M2",TVar "K"]],TApp "match-loosely" [TApp "map-delete" [TVar "M1",TSet [TVar "K"]],TApp "map-delete" [TVar "M2",TSet [TVar "K"]]]],TName "fail"]) env + rewrite5 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "DV") (TName "defined-values"),VPAnnotated (VPMetaVar "P") (TName "defined-values")] env + env <- sideCondition (SCIsInSort (TVar "P") (TSortComplement (TSortUnion (TName "datatype-values") (TApp "maps" [TName "values",TName "values"])))) env + rewriteTermTo (TApp "if-true-else" [TApp "is-equal" [TVar "DV",TVar "P"],TApp "map" [],TName "fail"]) env + +case_match_ fargs = FApp "case-match" (fargs) +stepCase_match fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PAnnotated (PMetaVar "P") (TName "defined-values"),PMetaVar "X"] env + rewriteTermTo (TApp "scope" [TApp "match" [TName "given",TVar "P"],TVar "X"]) env + +case_match_loosely_ fargs = FApp "case-match-loosely" (fargs) +stepCase_match_loosely fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PAnnotated (PMetaVar "P") (TName "defined-values"),PMetaVar "X"] env + rewriteTermTo (TApp "scope" [TApp "match-loosely" [TName "given",TVar "P"],TVar "X"]) env + +case_variant_value_ fargs = FApp "case-variant-value" (fargs) +stepCase_variant_value fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "I") (TName "ids")] env + rewriteTermTo (TApp "case-match" [TApp "variant" [TVar "I",TName "pattern-any"],TApp "variant-value" [TName "given"]]) env + +patterns_ = FName "patterns" +stepPatterns = rewriteType "patterns" [] diff --git a/cbs/Funcons/Core/Values/Abstraction/Thunks/Thunks.hs b/cbs/Funcons/Core/Values/Abstraction/Thunks/Thunks.hs new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Values/Abstraction/Thunks/Thunks.hs @@ -0,0 +1,35 @@ +-- GeNeRaTeD fOr: ../../CBS-beta/Funcons-beta/Values/Abstraction/Thunks/Thunks.cbs +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Values.Abstraction.Thunks.Thunks where + +import Funcons.EDSL + +import Funcons.Operations hiding (Values) +entities = [] + +types = typeEnvFromList + [("thunks",DataTypeMemberss "thunks" [TPVar "T"] [DataTypeMemberConstructor "thunk" [TApp "abstractions" [TSortComputesFrom (TName "nothing") (TVar "T")]] (Just [TPVar "T"])])] + +funcons = libFromList + [("thunk",StrictFuncon stepThunk),("force",StrictFuncon stepForce),("thunks",StrictFuncon stepThunks)] + +thunk_ fargs = FApp "thunk" (fargs) +stepThunk fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPMetaVar "_X1"] env + env <- sideCondition (SCIsInSort (TVar "_X1") (TName "values")) env + rewriteTermTo (TApp "datatype-value" [TFuncon (FValue (ADTVal "list" [FValue (Ascii 't'),FValue (Ascii 'h'),FValue (Ascii 'u'),FValue (Ascii 'n'),FValue (Ascii 'k')])),TVar "_X1"]) env + +force_ fargs = FApp "force" (fargs) +stepForce fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "thunk" [PADT "abstraction" [VPMetaVar "X"]]] env + rewriteTermTo (TVar "X") env + +thunks_ = FApp "thunks" +stepThunks ts = rewriteType "thunks" ts diff --git a/cbs/Funcons/Core/Values/Composite/Bits/Bits.hs b/cbs/Funcons/Core/Values/Composite/Bits/Bits.hs new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Values/Composite/Bits/Bits.hs @@ -0,0 +1,80 @@ +-- GeNeRaTeD fOr: ../../CBS-beta/Funcons-beta/Values/Composite/Bits/Bits.cbs +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Values.Composite.Bits.Bits where + +import Funcons.EDSL + +import Funcons.Operations hiding (Values) +entities = [] + +types = typeEnvFromList + [("bit-vectors",DataTypeMemberss "bit-vectors" [TPVar "N"] [DataTypeMemberConstructor "bit-vector" [TSortPower (TName "bits") (TVar "N")] (Just [TPVar "N"])])] + +funcons = libFromList + [("bits",NullaryFuncon stepBits),("bit-vector",StrictFuncon stepBit_vector),("bytes",NullaryFuncon stepBytes),("octets",NullaryFuncon stepBytes),("unsigned-bit-vector-maximum",StrictFuncon stepUnsigned_bit_vector_maximum),("signed-bit-vector-maximum",StrictFuncon stepSigned_bit_vector_maximum),("signed-bit-vector-minimum",StrictFuncon stepSigned_bit_vector_minimum),("is-in-signed-bit-vector",StrictFuncon stepIs_in_signed_bit_vector),("is-in-unsigned-bit-vector",StrictFuncon stepIs_in_unsigned_bit_vector),("bit-vectors",StrictFuncon stepBit_vectors)] + +bits_ = FName "bits" +stepBits = evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + rewriteTermTo (TName "bools") env + +bit_vector_ fargs = FApp "bit-vector" (fargs) +stepBit_vector fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPSeqVar "_X1*" StarOp] env + env <- sideCondition (SCIsInSort (TVar "_X1*") (TSortSeq (TName "values") StarOp)) env + rewriteTermTo (TApp "datatype-value" [TFuncon (FValue (ADTVal "list" [FValue (Ascii 'b'),FValue (Ascii 'i'),FValue (Ascii 't'),FValue (Ascii '-'),FValue (Ascii 'v'),FValue (Ascii 'e'),FValue (Ascii 'c'),FValue (Ascii 't'),FValue (Ascii 'o'),FValue (Ascii 'r')])),TVar "_X1*"]) env + +bytes_ = FName "bytes" +octets_ = FName "bytes" +stepBytes = evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + rewriteTermTo (TApp "bit-vectors" [TFuncon (FValue (Nat 8))]) env + +unsigned_bit_vector_maximum_ fargs = FApp "unsigned-bit-vector-maximum" (fargs) +stepUnsigned_bit_vector_maximum fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "N") (TName "nats")] env + rewriteTermTo (TApp "integer-subtract" [TApp "integer-power" [TFuncon (FValue (Nat 2)),TVar "N"],TFuncon (FValue (Nat 1))]) env + +signed_bit_vector_maximum_ fargs = FApp "signed-bit-vector-maximum" (fargs) +stepSigned_bit_vector_maximum fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "N") (TName "nats")] env + rewriteTermTo (TApp "integer-subtract" [TApp "integer-power" [TFuncon (FValue (Nat 2)),TApp "integer-subtract" [TVar "N",TFuncon (FValue (Nat 1))]],TFuncon (FValue (Nat 1))]) env + +signed_bit_vector_minimum_ fargs = FApp "signed-bit-vector-minimum" (fargs) +stepSigned_bit_vector_minimum fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "N") (TName "nats")] env + rewriteTermTo (TApp "integer-negate" [TApp "integer-power" [TFuncon (FValue (Nat 2)),TApp "integer-subtract" [TVar "N",TFuncon (FValue (Nat 1))]]]) env + +is_in_signed_bit_vector_ fargs = FApp "is-in-signed-bit-vector" (fargs) +stepIs_in_signed_bit_vector fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "M") (TName "integers"),VPAnnotated (VPMetaVar "N") (TName "nats")] env + rewriteTermTo (TApp "and" [TApp "integer-is-less-or-equal" [TVar "M",TApp "signed-bit-vector-maximum" [TVar "N"]],TApp "integer-is-greater-or-equal" [TVar "M",TApp "signed-bit-vector-minimum" [TVar "N"]]]) env + +is_in_unsigned_bit_vector_ fargs = FApp "is-in-unsigned-bit-vector" (fargs) +stepIs_in_unsigned_bit_vector fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "M") (TName "integers"),VPAnnotated (VPMetaVar "N") (TName "nats")] env + rewriteTermTo (TApp "and" [TApp "integer-is-less-or-equal" [TVar "M",TApp "unsigned-bit-vector-maximum" [TVar "N"]],TApp "integer-is-greater-or-equal" [TVar "M",TFuncon (FValue (Nat 0))]]) env + +bit_vectors_ = FApp "bit-vectors" +stepBit_vectors ts = rewriteType "bit-vectors" ts diff --git a/cbs/Funcons/Core/Values/Composite/Datatypes/Datatypes.hs b/cbs/Funcons/Core/Values/Composite/Datatypes/Datatypes.hs new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Values/Composite/Datatypes/Datatypes.hs @@ -0,0 +1,31 @@ +-- GeNeRaTeD fOr: ../../CBS-beta/Funcons-beta/Values/Composite/Datatypes/Datatypes.cbs +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Values.Composite.Datatypes.Datatypes where + +import Funcons.EDSL + +import Funcons.Operations hiding (Values) +entities = [] + +types = typeEnvFromList + [] + +funcons = libFromList + [("datatype-value-id",StrictFuncon stepDatatype_value_id),("datatype-value-elements",StrictFuncon stepDatatype_value_elements)] + +datatype_value_id_ fargs = FApp "datatype-value-id" (fargs) +stepDatatype_value_id fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "datatype-value" [VPAnnotated (VPMetaVar "I") (TName "ids"),VPAnnotated (VPSeqVar "V*" StarOp) (TSortSeq (TName "values") StarOp)]] env + rewriteTermTo (TVar "I") env + +datatype_value_elements_ fargs = FApp "datatype-value-elements" (fargs) +stepDatatype_value_elements fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "datatype-value" [VPAnnotated (VPMetaVar "I") (TName "ids"),VPAnnotated (VPSeqVar "V*" StarOp) (TSortSeq (TName "values") StarOp)]] env + rewriteTermTo (TVar "V*") env diff --git a/cbs/Funcons/Core/Values/Composite/Graphs/Graphs.hs b/cbs/Funcons/Core/Values/Composite/Graphs/Graphs.hs new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Values/Composite/Graphs/Graphs.hs @@ -0,0 +1,23 @@ +-- GeNeRaTeD fOr: ../../CBS-beta/Funcons-beta/Values/Composite/Graphs/Graphs.cbs +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Values.Composite.Graphs.Graphs where + +import Funcons.EDSL + +import Funcons.Operations hiding (Values) +entities = [] + +types = typeEnvFromList + [] + +funcons = libFromList + [("directed-graphs",NonStrictFuncon stepDirected_graphs)] + +directed_graphs_ fargs = FApp "directed-graphs" (fargs) +stepDirected_graphs fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PMetaVar "GVT"] env + rewriteTermTo (TApp "maps" [TVar "GVT",TApp "sets" [TVar "GVT"]]) env diff --git a/cbs/Funcons/Core/Values/Composite/Lists/Lists.hs b/cbs/Funcons/Core/Values/Composite/Lists/Lists.hs new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Values/Composite/Lists/Lists.hs @@ -0,0 +1,105 @@ +-- GeNeRaTeD fOr: ../../CBS-beta/Funcons-beta/Values/Composite/Lists/Lists.cbs +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Values.Composite.Lists.Lists where + +import Funcons.EDSL + +import Funcons.Operations hiding (Values) +entities = [] + +types = typeEnvFromList + [("lists",DataTypeMemberss "lists" [TPVar "T"] [DataTypeMemberConstructor "list" [TSortSeq (TVar "T") StarOp] (Just [TPVar "T"])])] + +funcons = libFromList + [("list",StrictFuncon stepList),("list-elements",StrictFuncon stepList_elements),("list-nil",NullaryFuncon stepList_nil),("nil",NullaryFuncon stepList_nil),("list-cons",StrictFuncon stepList_cons),("cons",StrictFuncon stepList_cons),("list-head",StrictFuncon stepList_head),("head",StrictFuncon stepList_head),("list-tail",StrictFuncon stepList_tail),("tail",StrictFuncon stepList_tail),("list-length",StrictFuncon stepList_length),("list-append",StrictFuncon stepList_append),("lists",StrictFuncon stepLists)] + +list_ fargs = FApp "list" (fargs) +stepList fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPSeqVar "_X1*" StarOp] env + env <- sideCondition (SCIsInSort (TVar "_X1*") (TSortSeq (TName "values") StarOp)) env + rewriteTermTo (TApp "datatype-value" [TFuncon (FValue (ADTVal "list" [FValue (Ascii 'l'),FValue (Ascii 'i'),FValue (Ascii 's'),FValue (Ascii 't')])),TVar "_X1*"]) env + +list_elements_ fargs = FApp "list-elements" (fargs) +stepList_elements fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "list" [VPAnnotated (VPSeqVar "V*" StarOp) (TSortSeq (TName "values") StarOp)]] env + rewriteTermTo (TVar "V*") env + +list_nil_ = FName "list-nil" +nil_ = FName "list-nil" +stepList_nil = evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + rewriteTermTo (TApp "list" []) env + +list_cons_ fargs = FApp "list-cons" (fargs) +cons_ fargs = FApp "list-cons" (fargs) +stepList_cons fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "V") (TName "values"),PADT "datatype-value" [VPLit (ADTVal "list" [FValue (Ascii 'l'),FValue (Ascii 'i'),FValue (Ascii 's'),FValue (Ascii 't')]),VPAnnotated (VPSeqVar "V*" StarOp) (TSortSeq (TName "values") StarOp)]] env + rewriteTermTo (TApp "list" [TVar "V",TVar "V*"]) env + +list_head_ fargs = FApp "list-head" (fargs) +head_ fargs = FApp "list-head" (fargs) +stepList_head fargs = + evalRules [rewrite1,rewrite2] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "datatype-value" [VPLit (ADTVal "list" [FValue (Ascii 'l'),FValue (Ascii 'i'),FValue (Ascii 's'),FValue (Ascii 't')]),VPAnnotated (VPMetaVar "V") (TName "values"),VPAnnotated (VPSeqVar "V*" StarOp) (TSortSeq (TName "values") StarOp)]] env + rewriteTermTo (TVar "V") env + rewrite2 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "datatype-value" [VPLit (ADTVal "list" [FValue (Ascii 'l'),FValue (Ascii 'i'),FValue (Ascii 's'),FValue (Ascii 't')])]] env + rewriteTermTo (TName "none") env + +list_tail_ fargs = FApp "list-tail" (fargs) +tail_ fargs = FApp "list-tail" (fargs) +stepList_tail fargs = + evalRules [rewrite1,rewrite2] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "datatype-value" [VPLit (ADTVal "list" [FValue (Ascii 'l'),FValue (Ascii 'i'),FValue (Ascii 's'),FValue (Ascii 't')]),VPAnnotated (VPMetaVar "V") (TName "values"),VPAnnotated (VPSeqVar "V*" StarOp) (TSortSeq (TName "values") StarOp)]] env + rewriteTermTo (TApp "list" [TVar "V*"]) env + rewrite2 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "datatype-value" [VPLit (ADTVal "list" [FValue (Ascii 'l'),FValue (Ascii 'i'),FValue (Ascii 's'),FValue (Ascii 't')])]] env + rewriteTermTo (TName "none") env + +list_length_ fargs = FApp "list-length" (fargs) +stepList_length fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "datatype-value" [VPLit (ADTVal "list" [FValue (Ascii 'l'),FValue (Ascii 'i'),FValue (Ascii 's'),FValue (Ascii 't')]),VPAnnotated (VPSeqVar "V*" StarOp) (TSortSeq (TName "values") StarOp)]] env + rewriteTermTo (TApp "length" [TVar "V*"]) env + +list_append_ fargs = FApp "list-append" (fargs) +stepList_append fargs = + evalRules [rewrite1,rewrite2,rewrite3,rewrite4] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "datatype-value" [VPLit (ADTVal "list" [FValue (Ascii 'l'),FValue (Ascii 'i'),FValue (Ascii 's'),FValue (Ascii 't')]),VPAnnotated (VPSeqVar "V1*" StarOp) (TSortSeq (TName "values") StarOp)],PADT "datatype-value" [VPLit (ADTVal "list" [FValue (Ascii 'l'),FValue (Ascii 'i'),FValue (Ascii 's'),FValue (Ascii 't')]),VPAnnotated (VPSeqVar "V2*" StarOp) (TSortSeq (TName "values") StarOp)]] env + rewriteTermTo (TApp "list" [TVar "V1*",TVar "V2*"]) env + rewrite2 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "L1") (TApp "lists" [TName "values"]),VPAnnotated (VPMetaVar "L2") (TApp "lists" [TName "values"]),VPAnnotated (VPMetaVar "L3") (TApp "lists" [TName "values"]),VPAnnotated (VPSeqVar "L*" StarOp) (TSortSeq (TApp "lists" [TName "values"]) StarOp)] env + rewriteTermTo (TApp "list-append" [TVar "L1",TApp "list-append" [TVar "L2",TVar "L3",TVar "L*"]]) env + rewrite3 = do + let env = emptyEnv + env <- vsMatch fargs [] env + rewriteTermTo (TApp "list" []) env + rewrite4 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "L") (TApp "lists" [TName "values"])] env + rewriteTermTo (TVar "L") env + +lists_ = FApp "lists" +stepLists ts = rewriteType "lists" ts diff --git a/cbs/Funcons/Core/Values/Composite/Records/Records.hs b/cbs/Funcons/Core/Values/Composite/Records/Records.hs new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Values/Composite/Records/Records.hs @@ -0,0 +1,35 @@ +-- GeNeRaTeD fOr: ../../CBS-beta/Funcons-beta/Values/Composite/Records/Records.cbs +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Values.Composite.Records.Records where + +import Funcons.EDSL + +import Funcons.Operations hiding (Values) +entities = [] + +types = typeEnvFromList + [("records",DataTypeMemberss "records" [TPVar "MIT"] [DataTypeMemberConstructor "record" [TApp "maps" [TName "ids",TName "values"]] (Just [TPVar "MIT"])])] + +funcons = libFromList + [("record",StrictFuncon stepRecord),("record-select",StrictFuncon stepRecord_select),("records",StrictFuncon stepRecords)] + +record_ fargs = FApp "record" (fargs) +stepRecord fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPMetaVar "_X1"] env + env <- sideCondition (SCIsInSort (TVar "_X1") (TName "values")) env + rewriteTermTo (TApp "datatype-value" [TFuncon (FValue (ADTVal "list" [FValue (Ascii 'r'),FValue (Ascii 'e'),FValue (Ascii 'c'),FValue (Ascii 'o'),FValue (Ascii 'r'),FValue (Ascii 'd')])),TVar "_X1"]) env + +record_select_ fargs = FApp "record-select" (fargs) +stepRecord_select fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "record" [VPAnnotated (VPMetaVar "MIV") (TApp "maps" [TName "ids",TName "values"])],VPAnnotated (VPMetaVar "I") (TName "ids")] env + rewriteTermTo (TApp "lookup" [TVar "MIV",TVar "I"]) env + +records_ = FApp "records" +stepRecords ts = rewriteType "records" ts diff --git a/cbs/Funcons/Core/Values/Composite/References/References.hs b/cbs/Funcons/Core/Values/Composite/References/References.hs new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Values/Composite/References/References.hs @@ -0,0 +1,47 @@ +-- GeNeRaTeD fOr: ../../CBS-beta/Funcons-beta/Values/Composite/References/References.cbs +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Values.Composite.References.References where + +import Funcons.EDSL + +import Funcons.Operations hiding (Values) +entities = [] + +types = typeEnvFromList + [("references",DataTypeMemberss "references" [TPVar "VT"] [DataTypeMemberConstructor "reference" [TVar "VT"] (Just [TPVar "VT"])])] + +funcons = libFromList + [("reference",StrictFuncon stepReference),("pointers",NonStrictFuncon stepPointers),("dereference",StrictFuncon stepDereference),("references",StrictFuncon stepReferences)] + +reference_ fargs = FApp "reference" (fargs) +stepReference fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPMetaVar "_X1"] env + env <- sideCondition (SCIsInSort (TVar "_X1") (TName "values")) env + rewriteTermTo (TApp "datatype-value" [TFuncon (FValue (ADTVal "list" [FValue (Ascii 'r'),FValue (Ascii 'e'),FValue (Ascii 'f'),FValue (Ascii 'e'),FValue (Ascii 'r'),FValue (Ascii 'e'),FValue (Ascii 'n'),FValue (Ascii 'c'),FValue (Ascii 'e')])),TVar "_X1"]) env + +pointers_ fargs = FApp "pointers" (fargs) +stepPointers fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- fsMatch fargs [PMetaVar "VT"] env + rewriteTermTo (TSortUnion (TName "unit-type") (TApp "references" [TVar "VT"])) env + +dereference_ fargs = FApp "dereference" (fargs) +stepDereference fargs = + evalRules [rewrite1,rewrite2] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "reference" [VPAnnotated (VPMetaVar "DV") (TName "defined-values")]] env + rewriteTermTo (TVar "DV") env + rewrite2 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "null-value" []] env + rewriteTermTo (TName "none") env + +references_ = FApp "references" +stepReferences ts = rewriteType "references" ts diff --git a/cbs/Funcons/Core/Values/Composite/Sequences/Sequences.hs b/cbs/Funcons/Core/Values/Composite/Sequences/Sequences.hs new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Values/Composite/Sequences/Sequences.hs @@ -0,0 +1,175 @@ +-- GeNeRaTeD fOr: ../../CBS-beta/Funcons-beta/Values/Composite/Sequences/Sequences.cbs +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Values.Composite.Sequences.Sequences where + +import Funcons.EDSL + +import Funcons.Operations hiding (Values) +entities = [] + +types = typeEnvFromList + [] + +funcons = libFromList + [("length",StrictFuncon stepLength),("index",StrictFuncon stepIndex),("first",StrictFuncon stepFirst),("second",StrictFuncon stepSecond),("third",StrictFuncon stepThird),("is-in",StrictFuncon stepIs_in),("first-n",StrictFuncon stepFirst_n),("drop-first-n",StrictFuncon stepDrop_first_n),("reverse",StrictFuncon stepReverse),("n-of",StrictFuncon stepN_of),("intersperse",StrictFuncon stepIntersperse),("filter-defined",StrictFuncon stepFilter_defined)] + +length_ fargs = FApp "length" (fargs) +stepLength fargs = + evalRules [rewrite1,rewrite2] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [] env + rewriteTermTo (TFuncon (FValue (Nat 0))) env + rewrite2 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "V") (TName "values"),VPAnnotated (VPSeqVar "V*" StarOp) (TSortSeq (TName "values") StarOp)] env + rewriteTermTo (TApp "nat-succ" [TApp "length" [TVar "V*"]]) env + +index_ fargs = FApp "index" (fargs) +stepIndex fargs = + evalRules [rewrite1,rewrite2,rewrite3,rewrite4] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPLit (Nat 1),VPAnnotated (VPMetaVar "V") (TName "values"),VPAnnotated (VPSeqVar "V*" StarOp) (TSortSeq (TName "values") StarOp)] env + rewriteTermTo (TVar "V") env + rewrite2 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "N") (TName "pos-ints"),VPAnnotated (VPMetaVar "V") (TName "values"),VPAnnotated (VPSeqVar "V*" StarOp) (TSortSeq (TName "values") StarOp)] env + env <- sideCondition (SCPatternMatch (TApp "nat-pred" [TVar "N"]) (VPMetaVar "N'")) env + rewriteTermTo (TApp "index" [TVar "N'",TVar "V*"]) env + rewrite3 = do + let env = emptyEnv + env <- vsMatch fargs [VPLit (Nat 0),VPAnnotated (VPSeqVar "V*" StarOp) (TSortSeq (TName "values") StarOp)] env + rewriteTermTo (TName "none") env + rewrite4 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "P") (TName "pos-ints")] env + rewriteTermTo (TName "none") env + +first_ fargs = FApp "first" (fargs) +stepFirst fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "V1") (TName "values"),VPAnnotated (VPSeqVar "V*" StarOp) (TSortSeq (TName "values") StarOp)] env + rewriteTermTo (TVar "V1") env + +second_ fargs = FApp "second" (fargs) +stepSecond fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "V1") (TName "values"),VPAnnotated (VPMetaVar "V2") (TName "values"),VPAnnotated (VPSeqVar "V*" StarOp) (TSortSeq (TName "values") StarOp)] env + rewriteTermTo (TVar "V2") env + +third_ fargs = FApp "third" (fargs) +stepThird fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "V1") (TName "values"),VPAnnotated (VPMetaVar "V2") (TName "values"),VPAnnotated (VPMetaVar "V3") (TName "values"),VPAnnotated (VPSeqVar "V*" StarOp) (TSortSeq (TName "values") StarOp)] env + rewriteTermTo (TVar "V3") env + +is_in_ fargs = FApp "is-in" (fargs) +stepIs_in fargs = + evalRules [rewrite1,rewrite2] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "V") (TName "values"),VPAnnotated (VPMetaVar "V'") (TName "values"),VPAnnotated (VPSeqVar "V*" StarOp) (TSortSeq (TName "values") StarOp)] env + rewriteTermTo (TApp "or" [TApp "is-equal" [TVar "V",TVar "V'"],TApp "is-in" [TVar "V",TVar "V*"]]) env + rewrite2 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "V") (TName "values")] env + rewriteTermTo (TName "false") env + +first_n_ fargs = FApp "first-n" (fargs) +stepFirst_n fargs = + evalRules [rewrite1,rewrite2,rewrite3] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPLit (Nat 0),VPAnnotated (VPSeqVar "V*" StarOp) (TSortSeq (TName "values") StarOp)] env + rewriteTermTo (TSeq []) env + rewrite2 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "N") (TName "pos-ints"),VPAnnotated (VPMetaVar "V") (TName "values"),VPAnnotated (VPSeqVar "V*" StarOp) (TSortSeq (TName "values") StarOp)] env + env <- sideCondition (SCPatternMatch (TApp "nat-pred" [TVar "N"]) (VPMetaVar "N'")) env + rewriteTermTo (TApp "first-n" [TVar "N'",TVar "V*"]) env + rewrite3 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "N") (TName "pos-ints")] env + rewriteTermTo (TName "none") env + +drop_first_n_ fargs = FApp "drop-first-n" (fargs) +stepDrop_first_n fargs = + evalRules [rewrite1,rewrite2,rewrite3] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPLit (Nat 0),VPAnnotated (VPSeqVar "V*" StarOp) (TSortSeq (TName "values") StarOp)] env + rewriteTermTo (TVar "V*") env + rewrite2 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "N") (TName "pos-ints"),VPAnnotated (VPMetaVar "V") (TName "values"),VPAnnotated (VPSeqVar "V*" StarOp) (TSortSeq (TName "values") StarOp)] env + env <- sideCondition (SCPatternMatch (TApp "nat-pred" [TVar "N"]) (VPMetaVar "N'")) env + rewriteTermTo (TApp "drop-first-n" [TVar "N'",TVar "V*"]) env + rewrite3 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "N") (TName "pos-ints")] env + rewriteTermTo (TName "none") env + +reverse_ fargs = FApp "reverse" (fargs) +stepReverse fargs = + evalRules [rewrite1,rewrite2] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [] env + rewriteTermTo (TSeq []) env + rewrite2 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "V") (TName "values"),VPAnnotated (VPSeqVar "V*" StarOp) (TSortSeq (TName "values") StarOp)] env + rewriteTermTo (TSeq [TApp "reverse" [TVar "V*"],TVar "V"]) env + +n_of_ fargs = FApp "n-of" (fargs) +stepN_of fargs = + evalRules [rewrite1,rewrite2] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPLit (Nat 0),VPMetaVar "V"] env + rewriteTermTo (TSeq []) env + rewrite2 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "N") (TName "pos-ints"),VPAnnotated (VPMetaVar "V") (TName "values")] env + env <- sideCondition (SCPatternMatch (TApp "nat-pred" [TVar "N"]) (VPMetaVar "N'")) env + rewriteTermTo (TSeq [TVar "V",TApp "n-of" [TVar "N'",TVar "V"]]) env + +intersperse_ fargs = FApp "intersperse" (fargs) +stepIntersperse fargs = + evalRules [rewrite1,rewrite2,rewrite3] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "V'") (TName "values")] env + rewriteTermTo (TSeq []) env + rewrite2 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "V'") (TName "values"),VPMetaVar "V"] env + rewriteTermTo (TVar "V") env + rewrite3 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "V'") (TName "values"),VPAnnotated (VPMetaVar "V1") (TName "values"),VPAnnotated (VPMetaVar "V2") (TName "values"),VPAnnotated (VPSeqVar "V*" StarOp) (TSortSeq (TName "values") StarOp)] env + rewriteTermTo (TSeq [TVar "V1",TVar "V'",TApp "intersperse" [TVar "V'",TVar "V2",TVar "V*"]]) env + +filter_defined_ fargs = FApp "filter-defined" (fargs) +stepFilter_defined fargs = + evalRules [rewrite1,rewrite2,rewrite3] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "V") (TName "defined-values"),VPAnnotated (VPSeqVar "V*" StarOp) (TSortSeq (TName "values") StarOp)] env + rewriteTermTo (TSeq [TVar "V",TApp "filter-defined" [TVar "V*"]]) env + rewrite2 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "none" [],VPAnnotated (VPSeqVar "V*" StarOp) (TSortSeq (TName "values") StarOp)] env + rewriteTermTo (TApp "filter-defined" [TVar "V*"]) env + rewrite3 = do + let env = emptyEnv + env <- vsMatch fargs [] env + rewriteTermTo (TSeq []) env diff --git a/cbs/Funcons/Core/Values/Composite/Strings/Strings.hs b/cbs/Funcons/Core/Values/Composite/Strings/Strings.hs new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Values/Composite/Strings/Strings.hs @@ -0,0 +1,37 @@ +-- GeNeRaTeD fOr: ../../CBS-beta/Funcons-beta/Values/Composite/Strings/Strings.cbs +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Values.Composite.Strings.Strings where + +import Funcons.EDSL + +import Funcons.Operations hiding (Values) +entities = [] + +types = typeEnvFromList + [] + +funcons = libFromList + [("strings",NullaryFuncon stepStrings),("string",StrictFuncon stepString),("string-append",StrictFuncon stepString_append)] + +strings_ = FName "strings" +stepStrings = evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + rewriteTermTo (TApp "lists" [TName "characters"]) env + +string_ fargs = FApp "string" (fargs) +stepString fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPSeqVar "C*" StarOp) (TSortSeq (TName "characters") StarOp)] env + rewriteTermTo (TApp "list" [TVar "C*"]) env + +string_append_ fargs = FApp "string-append" (fargs) +stepString_append fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPSeqVar "S*" StarOp) (TSortSeq (TName "strings") StarOp)] env + rewriteTermTo (TApp "list-append" [TVar "S*"]) env diff --git a/cbs/Funcons/Core/Values/Composite/Tuples/Tuples.hs b/cbs/Funcons/Core/Values/Composite/Tuples/Tuples.hs new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Values/Composite/Tuples/Tuples.hs @@ -0,0 +1,55 @@ +-- GeNeRaTeD fOr: ../../CBS-beta/Funcons-beta/Values/Composite/Tuples/Tuples.cbs +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Values.Composite.Tuples.Tuples where + +import Funcons.EDSL + +import Funcons.Operations hiding (Values) +entities = [] + +types = typeEnvFromList + [("tuples",DataTypeMemberss "tuples" [TPSeqVar "T*" StarOp] [DataTypeMemberConstructor "tuple" [TVar "T*"] (Just [TPSeqVar "T*" StarOp])])] + +funcons = libFromList + [("tuple",StrictFuncon stepTuple),("tuple-elements",StrictFuncon stepTuple_elements),("tuple-zip",StrictFuncon stepTuple_zip),("tuples",StrictFuncon stepTuples)] + +tuple_ fargs = FApp "tuple" (fargs) +stepTuple fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPSeqVar "_X1*" StarOp] env + env <- sideCondition (SCIsInSort (TVar "_X1*") (TSortSeq (TName "values") StarOp)) env + rewriteTermTo (TApp "datatype-value" [TFuncon (FValue (ADTVal "list" [FValue (Ascii 't'),FValue (Ascii 'u'),FValue (Ascii 'p'),FValue (Ascii 'l'),FValue (Ascii 'e')])),TVar "_X1*"]) env + +tuple_elements_ fargs = FApp "tuple-elements" (fargs) +stepTuple_elements fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "tuple" [VPAnnotated (VPSeqVar "V*" StarOp) (TSortSeq (TName "values") StarOp)]] env + rewriteTermTo (TVar "V*") env + +tuple_zip_ fargs = FApp "tuple-zip" (fargs) +stepTuple_zip fargs = + evalRules [rewrite1,rewrite2,rewrite3,rewrite4] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "tuple" [VPAnnotated (VPMetaVar "V1") (TName "values"),VPAnnotated (VPSeqVar "V1*" StarOp) (TSortSeq (TName "values") StarOp)],PADT "tuple" [VPAnnotated (VPMetaVar "V2") (TName "values"),VPAnnotated (VPSeqVar "V2*" StarOp) (TSortSeq (TName "values") StarOp)]] env + rewriteTermTo (TSeq [TApp "tuple" [TVar "V1",TVar "V2"],TApp "tuple-zip" [TApp "tuple" [TVar "V1*"],TApp "tuple" [TVar "V2*"]]]) env + rewrite2 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "tuple" [],PADT "tuple" []] env + rewriteTermTo (TSeq []) env + rewrite3 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "tuple" [VPAnnotated (VPSeqVar "V1+" PlusOp) (TSortSeq (TName "values") PlusOp)],PADT "tuple" []] env + rewriteTermTo (TName "none") env + rewrite4 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "tuple" [],PADT "tuple" [VPAnnotated (VPSeqVar "V2+" PlusOp) (TSortSeq (TName "values") PlusOp)]] env + rewriteTermTo (TName "none") env + +tuples_ = FApp "tuples" +stepTuples ts = rewriteType "tuples" ts diff --git a/cbs/Funcons/Core/Values/Composite/Variants/Variants.hs b/cbs/Funcons/Core/Values/Composite/Variants/Variants.hs new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Values/Composite/Variants/Variants.hs @@ -0,0 +1,44 @@ +-- GeNeRaTeD fOr: ../../CBS-beta/Funcons-beta/Values/Composite/Variants/Variants.cbs +{-# 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 diff --git a/cbs/Funcons/Core/Values/Composite/Vectors/Vectors.hs b/cbs/Funcons/Core/Values/Composite/Vectors/Vectors.hs new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Values/Composite/Vectors/Vectors.hs @@ -0,0 +1,35 @@ +-- GeNeRaTeD fOr: ../../CBS-beta/Funcons-beta/Values/Composite/Vectors/Vectors.cbs +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Values.Composite.Vectors.Vectors where + +import Funcons.EDSL + +import Funcons.Operations hiding (Values) +entities = [] + +types = typeEnvFromList + [("vectors",DataTypeMemberss "vectors" [TPVar "T"] [DataTypeMemberConstructor "vector" [TSortSeq (TVar "T") StarOp] (Just [TPVar "T"])])] + +funcons = libFromList + [("vector",StrictFuncon stepVector),("vector-elements",StrictFuncon stepVector_elements),("vectors",StrictFuncon stepVectors)] + +vector_ fargs = FApp "vector" (fargs) +stepVector fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPSeqVar "_X1*" StarOp] env + env <- sideCondition (SCIsInSort (TVar "_X1*") (TSortSeq (TName "values") StarOp)) env + rewriteTermTo (TApp "datatype-value" [TFuncon (FValue (ADTVal "list" [FValue (Ascii 'v'),FValue (Ascii 'e'),FValue (Ascii 'c'),FValue (Ascii 't'),FValue (Ascii 'o'),FValue (Ascii 'r')])),TVar "_X1*"]) env + +vector_elements_ fargs = FApp "vector-elements" (fargs) +stepVector_elements fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "vector" [VPAnnotated (VPSeqVar "V*" StarOp) (TSortSeq (TName "values") StarOp)]] env + rewriteTermTo (TVar "V*") env + +vectors_ = FApp "vectors" +stepVectors ts = rewriteType "vectors" ts diff --git a/cbs/Funcons/Core/Values/CompositeValues/AlgebraicDatatypeValues/Records.hs b/cbs/Funcons/Core/Values/CompositeValues/AlgebraicDatatypeValues/Records.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Values/CompositeValues/AlgebraicDatatypeValues/Records.hs +++ /dev/null @@ -1,34 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Values/Composite values/Algebraic datatype values/records.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Values.CompositeValues.AlgebraicDatatypeValues.Records where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [("records",DataTypeMembers [(Nothing,TApp "maps" (TTuple [TName "values",TName "types"]))] [DataTypeConstructor "record" (TTuple [TApp "maps" (TTuple [TName "values",TName "values"])])])] - -funcons = libFromList - [("record-field-map",StrictFuncon stepRecord_field_map),("record-select",StrictFuncon stepRecord_select),("records",StrictFuncon stepRecords),("record",StrictFuncon stepRecord)] - -record_field_map_ fargs = FApp "record-field-map" (FTuple fargs) -stepRecord_field_map fargs = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [PADT "record" [VPMetaVar "M"]] env - rewriteTermTo (TVar "M") env - -record_select_ fargs = FApp "record-select" (FTuple fargs) -stepRecord_select fargs = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "R") (TName "values"),VPAnnotated (VPMetaVar "K") (TName "values")] env - rewriteTermTo (TApp "lookup" (TTuple [TVar "K",TApp "record-field-map" (TTuple [TVar "R"])])) env - -stepRecord vs = rewritten (ADTVal "record" vs) - -stepRecords ts = rewriteType "records" ts diff --git a/cbs/Funcons/Core/Values/CompositeValues/AlgebraicDatatypeValues/References.hs b/cbs/Funcons/Core/Values/CompositeValues/AlgebraicDatatypeValues/References.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Values/CompositeValues/AlgebraicDatatypeValues/References.hs +++ /dev/null @@ -1,26 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Values/Composite values/Algebraic datatype values/references.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Values.CompositeValues.AlgebraicDatatypeValues.References where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [("references",DataTypeMembers [(Just "T",TName "types")] [DataTypeConstructor "reference" (TTuple [TVar "T"])])] - -funcons = libFromList - [("pointers",StrictFuncon stepPointers),("references",StrictFuncon stepReferences),("reference",StrictFuncon stepReference)] - -pointers_ fargs = FApp "pointers" (FTuple fargs) -stepPointers fargs = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "T") (TName "values")] env - rewriteTermTo (TSortUnion (TName "unit-type") (TApp "references" (TTuple [TVar "T"]))) env - -stepReference vs = rewritten (ADTVal "reference" vs) - -stepReferences ts = rewriteType "references" ts diff --git a/cbs/Funcons/Core/Values/CompositeValues/AlgebraicDatatypeValues/Variants.hs b/cbs/Funcons/Core/Values/CompositeValues/AlgebraicDatatypeValues/Variants.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Values/CompositeValues/AlgebraicDatatypeValues/Variants.hs +++ /dev/null @@ -1,37 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Values/Composite values/Algebraic datatype values/variants.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Values.CompositeValues.AlgebraicDatatypeValues.Variants where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [("variants",DataTypeMembers [(Nothing,TApp "maps" (TTuple [TName "values",TName "types"]))] [DataTypeConstructor "variant" (TTuple [TName "values",TName "values"])])] - -funcons = libFromList - [("variant-tag",StrictFuncon stepVariant_tag),("variant-value",StrictFuncon stepVariant_value),("variants",StrictFuncon stepVariants),("variant",StrictFuncon stepVariant)] - --- | --- /variants(M)/ is the type of tagged values /variant(K,V)/ where /V/ . --- /variant-tag(V)/ returns the tag of a variant /V/ /variant-value(V)/ returns the tagged value of a variant /V/ -variant_tag_ fargs = FApp "variant-tag" (FTuple fargs) -stepVariant_tag fargs = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [PADT "variant" [VPMetaVar "K",VPWildCard]] env - rewriteTermTo (TVar "K") env - -variant_value_ fargs = FApp "variant-value" (FTuple fargs) -stepVariant_value fargs = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [PADT "variant" [VPWildCard,VPMetaVar "V"]] env - rewriteTermTo (TVar "V") env - -stepVariant vs = rewritten (ADTVal "variant" vs) - -stepVariants ts = rewriteType "variants" ts diff --git a/cbs/Funcons/Core/Values/CompositeValues/Collections/DirectedGraphs.hs b/cbs/Funcons/Core/Values/CompositeValues/Collections/DirectedGraphs.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Values/CompositeValues/Collections/DirectedGraphs.hs +++ /dev/null @@ -1,22 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Values/Composite values/Collections/directed-graphs.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Values.CompositeValues.Collections.DirectedGraphs where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("directed-graphs",StrictFuncon stepDirected_graphs)] - -directed_graphs_ fargs = FApp "directed-graphs" (FTuple fargs) -stepDirected_graphs fargs = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "T") (TName "values")] env - rewriteTermTo (TApp "maps" (TTuple [TVar "T",TApp "sets" (TTuple [TVar "T"])])) env diff --git a/cbs/Funcons/Core/Values/CompositeValues/Collections/Tuples.hs b/cbs/Funcons/Core/Values/CompositeValues/Collections/Tuples.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Values/CompositeValues/Collections/Tuples.hs +++ /dev/null @@ -1,22 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Values/Composite values/Collections/tuples.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Values.CompositeValues.Collections.Tuples where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("tuples",StrictFuncon stepTuples)] - -tuples_ fargs = FApp "tuples" (FTuple fargs) -stepTuples fargs = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPSeqVar "T*" StarOp) (TName "values")] env - rewriteTermTo (TTuple [TVar "T*"]) env diff --git a/cbs/Funcons/Core/Values/Primitive/Booleans/Booleans.hs b/cbs/Funcons/Core/Values/Primitive/Booleans/Booleans.hs new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Values/Primitive/Booleans/Booleans.hs @@ -0,0 +1,115 @@ +-- GeNeRaTeD fOr: ../../CBS-beta/Funcons-beta/Values/Primitive/Booleans/Booleans.cbs +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Values.Primitive.Booleans.Booleans where + +import Funcons.EDSL + +import Funcons.Operations hiding (Values) +entities = [] + +types = typeEnvFromList + [("booleans",DataTypeMemberss "booleans" [] [DataTypeMemberConstructor "true" [] (Just []),DataTypeMemberConstructor "false" [] (Just [])]),("bools",DataTypeMemberss "bools" [] [DataTypeMemberConstructor "true" [] (Just []),DataTypeMemberConstructor "false" [] (Just [])])] + +funcons = libFromList + [("true",NullaryFuncon stepTrue),("false",NullaryFuncon stepFalse),("not",StrictFuncon stepNot),("implies",StrictFuncon stepImplies),("and",StrictFuncon stepAnd),("or",StrictFuncon stepOr),("exclusive-or",StrictFuncon stepExclusive_or),("xor",StrictFuncon stepExclusive_or),("booleans",NullaryFuncon stepBooleans),("bools",NullaryFuncon stepBooleans)] + +true_ = FName "true" +stepTrue = evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + rewriteTermTo (TApp "datatype-value" [TFuncon (FValue (ADTVal "list" [FValue (Ascii 't'),FValue (Ascii 'r'),FValue (Ascii 'u'),FValue (Ascii 'e')]))]) env + +false_ = FName "false" +stepFalse = evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + rewriteTermTo (TApp "datatype-value" [TFuncon (FValue (ADTVal "list" [FValue (Ascii 'f'),FValue (Ascii 'a'),FValue (Ascii 'l'),FValue (Ascii 's'),FValue (Ascii 'e')]))]) env + +not_ fargs = FApp "not" (fargs) +stepNot fargs = + evalRules [rewrite1,rewrite2] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "false" []] env + rewriteTermTo (TName "true") env + rewrite2 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "true" []] env + rewriteTermTo (TName "false") env + +implies_ fargs = FApp "implies" (fargs) +stepImplies fargs = + evalRules [rewrite1,rewrite2,rewrite3,rewrite4] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "false" [],PADT "false" []] env + rewriteTermTo (TName "true") env + rewrite2 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "false" [],PADT "true" []] env + rewriteTermTo (TName "true") env + rewrite3 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "true" [],PADT "true" []] env + rewriteTermTo (TName "true") env + rewrite4 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "true" [],PADT "false" []] env + rewriteTermTo (TName "false") env + +and_ fargs = FApp "and" (fargs) +stepAnd fargs = + evalRules [rewrite1,rewrite2,rewrite3] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [] env + rewriteTermTo (TName "true") env + rewrite2 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "false" [],VPAnnotated (VPSeqVar "B*" StarOp) (TSortSeq (TName "booleans") StarOp)] env + rewriteTermTo (TName "false") env + rewrite3 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "true" [],VPAnnotated (VPSeqVar "B*" StarOp) (TSortSeq (TName "booleans") StarOp)] env + rewriteTermTo (TApp "and" [TVar "B*"]) env + +or_ fargs = FApp "or" (fargs) +stepOr fargs = + evalRules [rewrite1,rewrite2,rewrite3] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [] env + rewriteTermTo (TName "false") env + rewrite2 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "true" [],VPAnnotated (VPSeqVar "B*" StarOp) (TSortSeq (TName "booleans") StarOp)] env + rewriteTermTo (TName "true") env + rewrite3 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "false" [],VPAnnotated (VPSeqVar "B*" StarOp) (TSortSeq (TName "booleans") StarOp)] env + rewriteTermTo (TApp "or" [TVar "B*"]) env + +exclusive_or_ fargs = FApp "exclusive-or" (fargs) +xor_ fargs = FApp "exclusive-or" (fargs) +stepExclusive_or fargs = + evalRules [rewrite1,rewrite2,rewrite3,rewrite4] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "false" [],PADT "false" []] env + rewriteTermTo (TName "false") env + rewrite2 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "false" [],PADT "true" []] env + rewriteTermTo (TName "true") env + rewrite3 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "true" [],PADT "false" []] env + rewriteTermTo (TName "true") env + rewrite4 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "true" [],PADT "true" []] env + rewriteTermTo (TName "false") env + +booleans_ = FName "booleans" +stepBooleans = rewriteType "booleans" [] diff --git a/cbs/Funcons/Core/Values/Primitive/Characters/Characters.hs b/cbs/Funcons/Core/Values/Primitive/Characters/Characters.hs new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Values/Primitive/Characters/Characters.hs @@ -0,0 +1,102 @@ +-- GeNeRaTeD fOr: ../../CBS-beta/Funcons-beta/Values/Primitive/Characters/Characters.cbs +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Values.Primitive.Characters.Characters where + +import Funcons.EDSL + +import Funcons.Operations hiding (Values) +entities = [] + +types = typeEnvFromList + [] + +funcons = libFromList + [("unicode-point",StrictFuncon stepUnicode_point),("unicode",StrictFuncon stepUnicode_point),("iso-latin-1-points",NullaryFuncon stepIso_latin_1_points),("ascii-points",NullaryFuncon stepAscii_points),("ascii-character",StrictFuncon stepAscii_character),("backspace",NullaryFuncon stepBackspace),("horizontal-tab",NullaryFuncon stepHorizontal_tab),("line-feed",NullaryFuncon stepLine_feed),("form-feed",NullaryFuncon stepForm_feed),("carriage-return",NullaryFuncon stepCarriage_return),("double-quote",NullaryFuncon stepDouble_quote),("single-quote",NullaryFuncon stepSingle_quote),("backslash",NullaryFuncon stepBackslash)] + +unicode_point_ fargs = FApp "unicode-point" (fargs) +unicode_ fargs = FApp "unicode-point" (fargs) +stepUnicode_point fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "unicode-character" [VPAnnotated (VPMetaVar "UP") (TName "unicode-points")]] env + rewriteTermTo (TVar "UP") env + +iso_latin_1_points_ = FName "iso-latin-1-points" +stepIso_latin_1_points = evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + rewriteTermTo (TApp "bounded-integers" [TFuncon (FValue (Nat 0)),TApp "unsigned-bit-vector-maximum" [TFuncon (FValue (Nat 8))]]) env + +ascii_points_ = FName "ascii-points" +stepAscii_points = evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + rewriteTermTo (TApp "bounded-integers" [TFuncon (FValue (Nat 0)),TApp "unsigned-bit-vector-maximum" [TFuncon (FValue (Nat 7))]]) env + +ascii_character_ fargs = FApp "ascii-character" (fargs) +stepAscii_character fargs = + evalRules [rewrite1,rewrite2,rewrite3] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "datatype-value" [VPLit (ADTVal "list" [FValue (Ascii 'l'),FValue (Ascii 'i'),FValue (Ascii 's'),FValue (Ascii 't')]),VPAnnotated (VPMetaVar "C") (TName "ascii-characters")]] env + rewriteTermTo (TVar "C") env + rewrite2 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "datatype-value" [VPLit (ADTVal "list" [FValue (Ascii 'l'),FValue (Ascii 'i'),FValue (Ascii 's'),FValue (Ascii 't')]),VPAnnotated (VPMetaVar "C") (TName "characters")]] env + env <- sideCondition (SCIsInSort (TVar "C") (TSortComplement (TName "ascii-characters"))) env + rewriteTermTo (TName "none") env + rewrite3 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "datatype-value" [VPLit (ADTVal "list" [FValue (Ascii 'l'),FValue (Ascii 'i'),FValue (Ascii 's'),FValue (Ascii 't')]),VPAnnotated (VPSeqVar "C*" StarOp) (TSortSeq (TName "characters") StarOp)]] env + env <- sideCondition (SCInequality (TApp "length" [TVar "C*"]) (TFuncon (FValue (Nat 1)))) env + rewriteTermTo (TName "none") env + +backspace_ = FName "backspace" +stepBackspace = evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + rewriteTermTo (TApp "unicode-character" [TApp "hexadecimal-natural" [TFuncon (FValue (ADTVal "list" [FValue (Ascii '0'),FValue (Ascii '0'),FValue (Ascii '0'),FValue (Ascii '8')]))]]) env + +horizontal_tab_ = FName "horizontal-tab" +stepHorizontal_tab = evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + rewriteTermTo (TApp "unicode-character" [TApp "hexadecimal-natural" [TFuncon (FValue (ADTVal "list" [FValue (Ascii '0'),FValue (Ascii '0'),FValue (Ascii '0'),FValue (Ascii '9')]))]]) env + +line_feed_ = FName "line-feed" +stepLine_feed = evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + rewriteTermTo (TApp "unicode-character" [TApp "hexadecimal-natural" [TFuncon (FValue (ADTVal "list" [FValue (Ascii '0'),FValue (Ascii '0'),FValue (Ascii '0'),FValue (Ascii 'a')]))]]) env + +form_feed_ = FName "form-feed" +stepForm_feed = evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + rewriteTermTo (TApp "unicode-character" [TApp "hexadecimal-natural" [TFuncon (FValue (ADTVal "list" [FValue (Ascii '0'),FValue (Ascii '0'),FValue (Ascii '0'),FValue (Ascii 'c')]))]]) env + +carriage_return_ = FName "carriage-return" +stepCarriage_return = evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + rewriteTermTo (TApp "unicode-character" [TApp "hexadecimal-natural" [TFuncon (FValue (ADTVal "list" [FValue (Ascii '0'),FValue (Ascii '0'),FValue (Ascii '0'),FValue (Ascii 'd')]))]]) env + +double_quote_ = FName "double-quote" +stepDouble_quote = evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + rewriteTermTo (TApp "unicode-character" [TApp "hexadecimal-natural" [TFuncon (FValue (ADTVal "list" [FValue (Ascii '0'),FValue (Ascii '0'),FValue (Ascii '2'),FValue (Ascii '2')]))]]) env + +single_quote_ = FName "single-quote" +stepSingle_quote = evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + rewriteTermTo (TApp "unicode-character" [TApp "hexadecimal-natural" [TFuncon (FValue (ADTVal "list" [FValue (Ascii '0'),FValue (Ascii '0'),FValue (Ascii '2'),FValue (Ascii '7')]))]]) env + +backslash_ = FName "backslash" +stepBackslash = evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + rewriteTermTo (TApp "unicode-character" [TApp "hexadecimal-natural" [TFuncon (FValue (ADTVal "list" [FValue (Ascii '0'),FValue (Ascii '0'),FValue (Ascii '5'),FValue (Ascii 'c')]))]]) env diff --git a/cbs/Funcons/Core/Values/Primitive/Floats/Floats.hs b/cbs/Funcons/Core/Values/Primitive/Floats/Floats.hs new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Values/Primitive/Floats/Floats.hs @@ -0,0 +1,48 @@ +-- GeNeRaTeD fOr: ../../CBS-beta/Funcons-beta/Values/Primitive/Floats/Floats.cbs +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Values.Primitive.Floats.Floats where + +import Funcons.EDSL + +import Funcons.Operations hiding (Values) +entities = [] + +types = typeEnvFromList + [("float-formats",DataTypeMemberss "float-formats" [] [DataTypeMemberConstructor "binary32" [] (Just []),DataTypeMemberConstructor "binary64" [] (Just []),DataTypeMemberConstructor "binary128" [] (Just []),DataTypeMemberConstructor "decimal64" [] (Just []),DataTypeMemberConstructor "decimal128" [] (Just [])])] + +funcons = libFromList + [("binary32",NullaryFuncon stepBinary32),("binary64",NullaryFuncon stepBinary64),("binary128",NullaryFuncon stepBinary128),("decimal64",NullaryFuncon stepDecimal64),("decimal128",NullaryFuncon stepDecimal128),("float-formats",NullaryFuncon stepFloat_formats)] + +binary32_ = FName "binary32" +stepBinary32 = evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + rewriteTermTo (TApp "datatype-value" [TFuncon (FValue (ADTVal "list" [FValue (Ascii 'b'),FValue (Ascii 'i'),FValue (Ascii 'n'),FValue (Ascii 'a'),FValue (Ascii 'r'),FValue (Ascii 'y'),FValue (Ascii '3'),FValue (Ascii '2')]))]) env + +binary64_ = FName "binary64" +stepBinary64 = evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + rewriteTermTo (TApp "datatype-value" [TFuncon (FValue (ADTVal "list" [FValue (Ascii 'b'),FValue (Ascii 'i'),FValue (Ascii 'n'),FValue (Ascii 'a'),FValue (Ascii 'r'),FValue (Ascii 'y'),FValue (Ascii '6'),FValue (Ascii '4')]))]) env + +binary128_ = FName "binary128" +stepBinary128 = evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + rewriteTermTo (TApp "datatype-value" [TFuncon (FValue (ADTVal "list" [FValue (Ascii 'b'),FValue (Ascii 'i'),FValue (Ascii 'n'),FValue (Ascii 'a'),FValue (Ascii 'r'),FValue (Ascii 'y'),FValue (Ascii '1'),FValue (Ascii '2'),FValue (Ascii '8')]))]) env + +decimal64_ = FName "decimal64" +stepDecimal64 = evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + rewriteTermTo (TApp "datatype-value" [TFuncon (FValue (ADTVal "list" [FValue (Ascii 'd'),FValue (Ascii 'e'),FValue (Ascii 'c'),FValue (Ascii 'i'),FValue (Ascii 'm'),FValue (Ascii 'a'),FValue (Ascii 'l'),FValue (Ascii '6'),FValue (Ascii '4')]))]) env + +decimal128_ = FName "decimal128" +stepDecimal128 = evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + rewriteTermTo (TApp "datatype-value" [TFuncon (FValue (ADTVal "list" [FValue (Ascii 'd'),FValue (Ascii 'e'),FValue (Ascii 'c'),FValue (Ascii 'i'),FValue (Ascii 'm'),FValue (Ascii 'a'),FValue (Ascii 'l'),FValue (Ascii '1'),FValue (Ascii '2'),FValue (Ascii '8')]))]) env + +float_formats_ = FName "float-formats" +stepFloat_formats = rewriteType "float-formats" [] diff --git a/cbs/Funcons/Core/Values/Primitive/Integers/Integers.hs b/cbs/Funcons/Core/Values/Primitive/Integers/Integers.hs new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Values/Primitive/Integers/Integers.hs @@ -0,0 +1,68 @@ +-- GeNeRaTeD fOr: ../../CBS-beta/Funcons-beta/Values/Primitive/Integers/Integers.cbs +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Values.Primitive.Integers.Integers where + +import Funcons.EDSL + +import Funcons.Operations hiding (Values) +entities = [] + +types = typeEnvFromList + [] + +funcons = libFromList + [("bounded-integers",StrictFuncon stepBounded_integers),("bounded-ints",StrictFuncon stepBounded_integers),("positive-integers",NullaryFuncon stepPositive_integers),("pos-ints",NullaryFuncon stepPositive_integers),("negative-integers",NullaryFuncon stepNegative_integers),("neg-ints",NullaryFuncon stepNegative_integers),("natural-numbers",NullaryFuncon stepNatural_numbers),("nats",NullaryFuncon stepNatural_numbers),("integer-negate",StrictFuncon stepInteger_negate),("int-neg",StrictFuncon stepInteger_negate),("integer-sequence",StrictFuncon stepInteger_sequence)] + +bounded_integers_ fargs = FApp "bounded-integers" (fargs) +bounded_ints_ fargs = FApp "bounded-integers" (fargs) +stepBounded_integers fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "M") (TName "integers"),VPAnnotated (VPMetaVar "N") (TName "integers")] env + rewriteTermTo (TSortInter (TApp "integers-from" [TVar "M"]) (TApp "integers-up-to" [TVar "N"])) env + +positive_integers_ = FName "positive-integers" +pos_ints_ = FName "positive-integers" +stepPositive_integers = evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + rewriteTermTo (TApp "integers-from" [TFuncon (FValue (Nat 1))]) env + +negative_integers_ = FName "negative-integers" +neg_ints_ = FName "negative-integers" +stepNegative_integers = evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + rewriteTermTo (TApp "integers-up-to" [TFuncon (FValue (Nat (-1)))]) env + +natural_numbers_ = FName "natural-numbers" +nats_ = FName "natural-numbers" +stepNatural_numbers = evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + rewriteTermTo (TApp "integers-from" [TFuncon (FValue (Nat 0))]) env + +integer_negate_ fargs = FApp "integer-negate" (fargs) +int_neg_ fargs = FApp "integer-negate" (fargs) +stepInteger_negate fargs = + evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "N") (TName "integers")] env + rewriteTermTo (TApp "integer-subtract" [TFuncon (FValue (Nat 0)),TVar "N"]) env + +integer_sequence_ fargs = FApp "integer-sequence" (fargs) +stepInteger_sequence fargs = + evalRules [rewrite1,rewrite2] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "M") (TName "integers"),VPAnnotated (VPMetaVar "N") (TName "integers")] env + env <- sideCondition (SCEquality (TApp "is-greater" [TVar "M",TVar "N"]) (TName "false")) env + rewriteTermTo (TSeq [TVar "M",TApp "integer-sequence" [TApp "integer-add" [TVar "M",TFuncon (FValue (Nat 1))],TVar "N"]]) env + rewrite2 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "M") (TName "integers"),VPAnnotated (VPMetaVar "N") (TName "integers")] env + env <- sideCondition (SCEquality (TApp "is-greater" [TVar "M",TVar "N"]) (TName "true")) env + rewriteTermTo (TSeq []) env diff --git a/cbs/Funcons/Core/Values/Primitive/Unit/Unit.hs b/cbs/Funcons/Core/Values/Primitive/Unit/Unit.hs new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Values/Primitive/Unit/Unit.hs @@ -0,0 +1,25 @@ +-- GeNeRaTeD fOr: ../../CBS-beta/Funcons-beta/Values/Primitive/Unit/Unit.cbs +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Values.Primitive.Unit.Unit where + +import Funcons.EDSL + +import Funcons.Operations hiding (Values) +entities = [] + +types = typeEnvFromList + [("unit-type",DataTypeMemberss "unit-type" [] [DataTypeMemberConstructor "null-value" [] (Just [])])] + +funcons = libFromList + [("null-value",NullaryFuncon stepNull_value),("null",NullaryFuncon stepNull_value),("unit-type",NullaryFuncon stepUnit_type)] + +null_value_ = FName "null-value" +null_ = FName "null-value" +stepNull_value = evalRules [rewrite1] [] + where rewrite1 = do + let env = emptyEnv + rewriteTermTo (TApp "datatype-value" [TFuncon (FValue (ADTVal "list" [FValue (Ascii 'n'),FValue (Ascii 'u'),FValue (Ascii 'l'),FValue (Ascii 'l'),FValue (Ascii '-'),FValue (Ascii 'v'),FValue (Ascii 'a'),FValue (Ascii 'l'),FValue (Ascii 'u'),FValue (Ascii 'e')]))]) env + +unit_type_ = FName "unit-type" +stepUnit_type = rewriteType "unit-type" [] diff --git a/cbs/Funcons/Core/Values/PrimitiveValues/Bits.hs b/cbs/Funcons/Core/Values/PrimitiveValues/Bits.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Values/PrimitiveValues/Bits.hs +++ /dev/null @@ -1,60 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Values/Primitive values/bits.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Values.PrimitiveValues.Bits where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("bytes",NullaryFuncon stepBytes),("unsigned-bits-maximum",StrictFuncon stepUnsigned_bits_maximum),("signed-bits-maximum",StrictFuncon stepSigned_bits_maximum),("signed-bits-minimum",StrictFuncon stepSigned_bits_minimum),("is-in-signed-bits",StrictFuncon stepIs_in_signed_bits),("is-in-unsigned-bits",StrictFuncon stepIs_in_unsigned_bits)] - -bytes_ = FName "bytes" -stepBytes = evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - rewriteTo (FApp "bits" (FTuple [FValue (Nat 8)])) - -unsigned_bits_maximum_ fargs = FApp "unsigned-bits-maximum" (FTuple fargs) -stepUnsigned_bits_maximum fargs = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "N") (TName "values")] env - rewriteTermTo (TApp "integer-subtract" (TTuple [TApp "integer-power" (TTuple [TFuncon (FValue (Nat 2)),TVar "N"]),TFuncon (FValue (Nat 1))])) env - -signed_bits_maximum_ fargs = FApp "signed-bits-maximum" (FTuple fargs) -stepSigned_bits_maximum fargs = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "N") (TName "values")] env - rewriteTermTo (TApp "integer-subtract" (TTuple [TApp "integer-power" (TTuple [TFuncon (FValue (Nat 2)),TApp "integer-subtract" (TTuple [TVar "N",TFuncon (FValue (Nat 1))])]),TFuncon (FValue (Nat 1))])) env - -signed_bits_minimum_ fargs = FApp "signed-bits-minimum" (FTuple fargs) -stepSigned_bits_minimum fargs = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "N") (TName "values")] env - rewriteTermTo (TApp "integer-negate" (TTuple [TApp "integer-power" (TTuple [TFuncon (FValue (Nat 2)),TApp "integer-subtract" (TTuple [TVar "N",TFuncon (FValue (Nat 1))])])])) env - -is_in_signed_bits_ fargs = FApp "is-in-signed-bits" (FTuple fargs) -stepIs_in_signed_bits fargs = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "N") (TName "values"),VPAnnotated (VPMetaVar "I") (TName "values")] env - rewriteTermTo (TApp "and" (TTuple [TApp "is-less-or-equal" (TTuple [TVar "I",TApp "signed-bits-maximum" (TTuple [TVar "N"])]),TApp "is-greater-or-equal" (TTuple [TVar "I",TApp "signed-bits-minimum" (TTuple [TVar "N"])])])) env - -is_in_unsigned_bits_ fargs = FApp "is-in-unsigned-bits" (FTuple fargs) -stepIs_in_unsigned_bits fargs = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "N") (TName "values"),VPAnnotated (VPMetaVar "I") (TName "values")] env - rewriteTermTo (TApp "and" (TTuple [TApp "is-less-or-equal" (TTuple [TVar "I",TApp "unsigned-bits-maximum" (TTuple [TVar "N"])]),TApp "is-greater-or-equal" (TTuple [TVar "I",TFuncon (FValue (Nat 0))])])) env diff --git a/cbs/Funcons/Core/Values/PrimitiveValues/Booleans.hs b/cbs/Funcons/Core/Values/PrimitiveValues/Booleans.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Values/PrimitiveValues/Booleans.hs +++ /dev/null @@ -1,126 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Values/Primitive values/booleans.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Values.PrimitiveValues.Booleans where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [("booleans",DataTypeMembers [] [DataTypeConstructor "false" (TTuple []),DataTypeConstructor "true" (TTuple [])])] - -funcons = libFromList - [("not",StrictFuncon stepNot),("implies",StrictFuncon stepImplies),("and",StrictFuncon stepAnd),("or",StrictFuncon stepOr),("xor",StrictFuncon stepXor),("is-equal",StrictFuncon stepIs_equal),("booleans",NullaryFuncon stepBooleans),("false",NullaryFuncon stepFalse),("true",NullaryFuncon stepTrue)] - --- | --- /booleans/ is the type of truth-values. --- /not(_)/ is logical negation. --- /and(...)/ is logical conjunction of a tuple of /booleans/ . --- /or(...)/ is logical disjunction of a tuple of /booleans/ . --- /xor(_,_)/ is exclusive disjunction of two /booleans/ . --- /implies(_,_)/ is logical implication between two /booleans/ . --- /is-equal(_,_)/ tests equality of arbitrary /values/ . -not_ fargs = FApp "not" (FTuple fargs) -stepNot fargs = - evalRules [rewrite1,rewrite2] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [PADT "false" []] env - rewriteTo (FName "true") - rewrite2 = do - let env = emptyEnv - env <- vsMatch fargs [PADT "true" []] env - rewriteTo (FName "false") - -implies_ fargs = FApp "implies" (FTuple fargs) -stepImplies fargs = - evalRules [rewrite1,rewrite2,rewrite3,rewrite4] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [PADT "false" [],PADT "false" []] env - rewriteTo (FName "true") - rewrite2 = do - let env = emptyEnv - env <- vsMatch fargs [PADT "false" [],PADT "true" []] env - rewriteTo (FName "true") - rewrite3 = do - let env = emptyEnv - env <- vsMatch fargs [PADT "true" [],PADT "true" []] env - rewriteTo (FName "true") - rewrite4 = do - let env = emptyEnv - env <- vsMatch fargs [PADT "true" [],PADT "false" []] env - rewriteTo (FName "false") - -and_ fargs = FApp "and" (FTuple fargs) -stepAnd fargs = - evalRules [rewrite1,rewrite2,rewrite3] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [] env - rewriteTo (FName "true") - rewrite2 = do - let env = emptyEnv - env <- vsMatch fargs [PADT "false" [],VPAnnotated (VPSeqVar "B*" StarOp) (TName "booleans")] env - rewriteTo (FName "false") - rewrite3 = do - let env = emptyEnv - env <- vsMatch fargs [PADT "true" [],VPAnnotated (VPSeqVar "B*" StarOp) (TName "booleans")] env - rewriteTermTo (TApp "and" (TTuple [TVar "B*"])) env - -or_ fargs = FApp "or" (FTuple fargs) -stepOr fargs = - evalRules [rewrite1,rewrite2,rewrite3] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [] env - rewriteTo (FName "false") - rewrite2 = do - let env = emptyEnv - env <- vsMatch fargs [PADT "true" [],VPAnnotated (VPSeqVar "B*" StarOp) (TName "booleans")] env - rewriteTo (FName "true") - rewrite3 = do - let env = emptyEnv - env <- vsMatch fargs [PADT "false" [],VPAnnotated (VPSeqVar "B*" StarOp) (TName "booleans")] env - rewriteTermTo (TApp "or" (TTuple [TVar "B*"])) env - -xor_ fargs = FApp "xor" (FTuple fargs) -stepXor fargs = - evalRules [rewrite1,rewrite2,rewrite3,rewrite4] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [PADT "false" [],PADT "false" []] env - rewriteTo (FName "false") - rewrite2 = do - let env = emptyEnv - env <- vsMatch fargs [PADT "false" [],PADT "true" []] env - rewriteTo (FName "true") - rewrite3 = do - let env = emptyEnv - env <- vsMatch fargs [PADT "true" [],PADT "false" []] env - rewriteTo (FName "true") - rewrite4 = do - let env = emptyEnv - env <- vsMatch fargs [PADT "true" [],PADT "true" []] env - rewriteTo (FName "false") - -is_equal_ fargs = FApp "is-equal" (FTuple fargs) -stepIs_equal fargs = - evalRules [rewrite1,rewrite2] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [VPMetaVar "V1",VPMetaVar "V2"] env - env <- sideCondition (SCEquality (TVar "V1") (TVar "V2")) env - rewriteTo (FName "true") - rewrite2 = do - let env = emptyEnv - env <- vsMatch fargs [VPMetaVar "V1",VPMetaVar "V2"] env - env <- sideCondition (SCInequality (TVar "V1") (TVar "V2")) env - rewriteTo (FName "false") - -stepFalse = rewritten (ADTVal "false" []) - -stepTrue = rewritten (ADTVal "true" []) - -stepBooleans = rewriteType "booleans" [] diff --git a/cbs/Funcons/Core/Values/PrimitiveValues/Numbers/IeeeFloats.hs b/cbs/Funcons/Core/Values/PrimitiveValues/Numbers/IeeeFloats.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Values/PrimitiveValues/Numbers/IeeeFloats.hs +++ /dev/null @@ -1,49 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Values/Primitive values/Numbers/ieee-floats.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Values.PrimitiveValues.Numbers.IeeeFloats where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [("ieee-formats",DataTypeMembers [] [DataTypeConstructor "binary32" (TTuple []),DataTypeConstructor "binary64" (TTuple []),DataTypeConstructor "binary128" (TTuple []),DataTypeConstructor "decimal64" (TTuple []),DataTypeConstructor "decimal128" (TTuple [])])] - -funcons = libFromList - [("quiet-not-a-number",StrictFuncon stepQuiet_not_a_number),("signals-not-a-number",StrictFuncon stepSignals_not_a_number),("positive-infinity",StrictFuncon stepPositive_infinity),("negative-infinity",StrictFuncon stepNegative_infinity),("ieee-formats",NullaryFuncon stepIeee_formats),("binary32",NullaryFuncon stepBinary32),("binary64",NullaryFuncon stepBinary64),("binary128",NullaryFuncon stepBinary128),("decimal64",NullaryFuncon stepDecimal64),("decimal128",NullaryFuncon stepDecimal128)] - --- | --- An /ieee-floats/ is either one of four special values: --- /quiet-not-a-number/ , /signals-not-a-number/ , /positive-infinity/ , /negative-infinity/ or is represented (internally) as a triple (S,C,Q). --- S is a sign bit: 0 denotes "+" and 1 denotes "-". --- C and Q determine the value. --- - In binary format the value is: C x 2^Q --- - In decimal format the value is: C x 10^Q -quiet_not_a_number_ fargs = FApp "quiet-not-a-number" (FTuple fargs) -stepQuiet_not_a_number fargs = - norule (FApp "quiet-not-a-number" (FTuple (map FValue fargs))) - -signals_not_a_number_ fargs = FApp "signals-not-a-number" (FTuple fargs) -stepSignals_not_a_number fargs = - norule (FApp "signals-not-a-number" (FTuple (map FValue fargs))) - -positive_infinity_ fargs = FApp "positive-infinity" (FTuple fargs) -stepPositive_infinity fargs = - norule (FApp "positive-infinity" (FTuple (map FValue fargs))) - -negative_infinity_ fargs = FApp "negative-infinity" (FTuple fargs) -stepNegative_infinity fargs = - norule (FApp "negative-infinity" (FTuple (map FValue fargs))) - -stepBinary32 = rewritten (ADTVal "binary32" []) - -stepBinary64 = rewritten (ADTVal "binary64" []) - -stepBinary128 = rewritten (ADTVal "binary128" []) - -stepDecimal64 = rewritten (ADTVal "decimal64" []) - -stepDecimal128 = rewritten (ADTVal "decimal128" []) - -stepIeee_formats = rewriteType "ieee-formats" [] diff --git a/cbs/Funcons/Core/Values/PrimitiveValues/Numbers/Integers.hs b/cbs/Funcons/Core/Values/PrimitiveValues/Numbers/Integers.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Values/PrimitiveValues/Numbers/Integers.hs +++ /dev/null @@ -1,22 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Values/Primitive values/Numbers/integers.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Values.PrimitiveValues.Numbers.Integers where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("integer-negate",StrictFuncon stepInteger_negate)] - -integer_negate_ fargs = FApp "integer-negate" (FTuple fargs) -stepInteger_negate fargs = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "I") (TName "values")] env - rewriteTermTo (TApp "integer-subtract" (TTuple [TFuncon (FValue (Nat 0)),TVar "I"])) env diff --git a/cbs/Funcons/Core/Values/PrimitiveValues/Numbers/Rationals.hs b/cbs/Funcons/Core/Values/PrimitiveValues/Numbers/Rationals.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Values/PrimitiveValues/Numbers/Rationals.hs +++ /dev/null @@ -1,30 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Values/Primitive values/Numbers/rationals.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Values.PrimitiveValues.Numbers.Rationals where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("negate",StrictFuncon stepNegate),("exponent-notation",StrictFuncon stepExponent_notation)] - -negate_ fargs = FApp "negate" (FTuple fargs) -stepNegate fargs = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "R") (TName "values")] env - rewriteTermTo (TApp "subtract" (TTuple [TFuncon (FValue (Nat 0)),TVar "R"])) env - -exponent_notation_ fargs = FApp "exponent-notation" (FTuple fargs) -stepExponent_notation fargs = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "R") (TName "values"),VPAnnotated (VPMetaVar "I") (TName "values")] env - rewriteTermTo (TApp "multiply" (TTuple [TVar "R",TApp "power" (TTuple [TFuncon (FValue (Nat 10)),TVar "I"])])) env diff --git a/cbs/Funcons/Core/Values/PrimitiveValues/Strings.hs b/cbs/Funcons/Core/Values/PrimitiveValues/Strings.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Values/PrimitiveValues/Strings.hs +++ /dev/null @@ -1,28 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Values/Primitive values/strings.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Values.PrimitiveValues.Strings where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("ids",NullaryFuncon stepIds),("newline",NullaryFuncon stepNewline)] - -ids_ = FName "ids" -stepIds = evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - rewriteTo (FName "strings") - --- | --- /newline/ is the string containing only a line feed character ("LF" or "\n"). -newline_ = FName "newline" -stepNewline = evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - rewriteTo (FApp "to-string" (FTuple [FApp "ascii-character" (FTuple [FValue (String "\n")])])) diff --git a/cbs/Funcons/Core/Values/PrimitiveValues/UnicodeCharacters.hs b/cbs/Funcons/Core/Values/PrimitiveValues/UnicodeCharacters.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Values/PrimitiveValues/UnicodeCharacters.hs +++ /dev/null @@ -1,38 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Values/Primitive values/unicode-characters.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Values.PrimitiveValues.UnicodeCharacters where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("unicode-character",StrictFuncon stepUnicode_character),("unicode-codes",NullaryFuncon stepUnicode_codes),("utf-32",StrictFuncon stepUtf_32)] - -unicode_character_ fargs = FApp "unicode-character" (FTuple fargs) -stepUnicode_character fargs = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [VPMetaVar "Str"] env - env <- sideCondition (SCPatternMatch (TApp "string-to-list" (TTuple [TVar "Str"])) (VPMetaVar "Cs")) env - env <- sideCondition (SCEquality (TApp "list-prefix" (TTuple [TFuncon (FValue (Nat 2)),TVar "Cs"])) (TFuncon (FValue (String "U+")))) env - rewriteTermTo (TApp "unicode" (TTuple [TApp "hexadecimal-natural" (TTuple [TApp "list-to-string" (TTuple [TApp "list-suffix" (TTuple [TFuncon (FValue (Nat 2)),TVar "Cs"])])])])) env - -unicode_codes_ = FName "unicode-codes" -stepUnicode_codes = evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - rewriteTo (FApp "bounded-integers" (FTuple [FValue (Nat 0),FApp "integer-subtract" (FTuple [FApp "integer-power" (FTuple [FValue (Nat 2),FValue (Nat 32)]),FValue (Nat 1)])])) - -utf_32_ fargs = FApp "utf-32" (FTuple fargs) -stepUtf_32 fargs = - evalRules [rewrite1] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [VPAnnotated (VPMetaVar "C") (TName "values")] env - rewriteTermTo (TApp "integer-to-bits" (TTuple [TFuncon (FValue (Nat 32)),TApp "unicode-character-code" (TTuple [TVar "C"])])) env diff --git a/cbs/Funcons/Core/Values/PrimitiveValues/UnitType.hs b/cbs/Funcons/Core/Values/PrimitiveValues/UnitType.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Values/PrimitiveValues/UnitType.hs +++ /dev/null @@ -1,33 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Values/Primitive values/unit-type.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Values.PrimitiveValues.UnitType where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [("unit-type",DataTypeMembers [] [DataTypeConstructor "null" (TTuple [])])] - -funcons = libFromList - [("is-null",StrictFuncon stepIs_null),("unit-type",NullaryFuncon stepUnit_type),("null",NullaryFuncon stepNull)] - --- | --- /is-null/ tests an arbitrary value to determine if it is equal to /null/ . -is_null_ fargs = FApp "is-null" (FTuple fargs) -stepIs_null fargs = - evalRules [rewrite1,rewrite2] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [PADT "null" []] env - rewriteTo (FName "true") - rewrite2 = do - let env = emptyEnv - env <- vsMatch fargs [VPMetaVar "V"] env - env <- sideCondition (SCNotInSort (TVar "V") (TName "unit-type")) env - rewriteTo (FName "false") - -stepNull = rewritten (ADTVal "null" []) - -stepUnit_type = rewriteType "unit-type" [] diff --git a/cbs/Funcons/Core/Values/Types.hs b/cbs/Funcons/Core/Values/Types.hs deleted file mode 100644 --- a/cbs/Funcons/Core/Values/Types.hs +++ /dev/null @@ -1,30 +0,0 @@ --- GeNeRaTeD fOr: ../../CBS/Funcons/Values/types.aterm -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Values.Types where - -import Funcons.EDSL - -entities = [] - -types = typeEnvFromList - [] - -funcons = libFromList - [("is-in-type",StrictFuncon stepIs_in_type)] - --- | --- /is-in-type(V,T)/ tests membership of a value in a type. -is_in_type_ fargs = FApp "is-in-type" (FTuple fargs) -stepIs_in_type fargs = - evalRules [rewrite1,rewrite2] [] - where rewrite1 = do - let env = emptyEnv - env <- vsMatch fargs [VPMetaVar "V",VPMetaVar "T"] env - env <- sideCondition (SCIsInSort (TVar "V") (TVar "T")) env - rewriteTo (FName "true") - rewrite2 = do - let env = emptyEnv - env <- vsMatch fargs [VPMetaVar "V",VPMetaVar "T"] env - env <- sideCondition (SCNotInSort (TVar "V") (TVar "T")) env - rewriteTo (FName "false") diff --git a/cbs/Funcons/Core/Values/ValueTypes/ValueTypes.hs b/cbs/Funcons/Core/Values/ValueTypes/ValueTypes.hs new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Values/ValueTypes/ValueTypes.hs @@ -0,0 +1,81 @@ +-- GeNeRaTeD fOr: ../../CBS-beta/Funcons-beta/Values/Value-Types/Value-Types.cbs +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Values.ValueTypes.ValueTypes where + +import Funcons.EDSL + +import Funcons.Operations hiding (Values) +entities = [] + +types = typeEnvFromList + [] + +funcons = libFromList + [("is-in-type",StrictFuncon stepIs_in_type),("is",StrictFuncon stepIs_in_type),("cast-to-type",StrictFuncon stepCast_to_type),("cast",StrictFuncon stepCast_to_type),("is-defined",StrictFuncon stepIs_defined),("is-def",StrictFuncon stepIs_defined),("is-equal",StrictFuncon stepIs_equal),("is-eq",StrictFuncon stepIs_equal)] + +is_in_type_ fargs = FApp "is-in-type" (fargs) +is_ fargs = FApp "is-in-type" (fargs) +stepIs_in_type fargs = + evalRules [rewrite1,rewrite2] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "V") (TName "values"),VPAnnotated (VPMetaVar "T'") (TName "types")] env + env <- sideCondition (SCIsInSort (TVar "V") (TVar "T'")) env + rewriteTermTo (TName "true") env + rewrite2 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "V") (TName "values"),VPAnnotated (VPMetaVar "T'") (TName "types")] env + env <- sideCondition (SCIsInSort (TVar "V") (TSortComplement (TVar "T'"))) env + rewriteTermTo (TName "false") env + +cast_to_type_ fargs = FApp "cast-to-type" (fargs) +cast_ fargs = FApp "cast-to-type" (fargs) +stepCast_to_type fargs = + evalRules [rewrite1,rewrite2] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "V") (TName "values"),VPAnnotated (VPMetaVar "T'") (TName "types")] env + env <- sideCondition (SCIsInSort (TVar "V") (TVar "T'")) env + rewriteTermTo (TVar "V") env + rewrite2 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "V") (TName "values"),VPAnnotated (VPMetaVar "T'") (TName "types")] env + env <- sideCondition (SCIsInSort (TVar "V") (TSortComplement (TVar "T'"))) env + rewriteTermTo (TName "none") env + +is_defined_ fargs = FApp "is-defined" (fargs) +is_def_ fargs = FApp "is-defined" (fargs) +stepIs_defined fargs = + evalRules [rewrite1,rewrite2] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "V") (TName "defined-values")] env + rewriteTermTo (TName "true") env + rewrite2 = do + let env = emptyEnv + env <- vsMatch fargs [PADT "none" []] env + rewriteTermTo (TName "false") env + +is_equal_ fargs = FApp "is-equal" (fargs) +is_eq_ fargs = FApp "is-equal" (fargs) +stepIs_equal fargs = + evalRules [rewrite1,rewrite2,rewrite3,rewrite4] [] + where rewrite1 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "V") (TName "ground-values"),VPAnnotated (VPMetaVar "W") (TName "ground-values")] env + env <- sideCondition (SCEquality (TVar "V") (TVar "W")) env + rewriteTermTo (TName "true") env + rewrite2 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "V") (TName "ground-values"),VPAnnotated (VPMetaVar "W") (TName "ground-values")] env + env <- sideCondition (SCInequality (TVar "V") (TVar "W")) env + rewriteTermTo (TName "false") env + rewrite3 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "V") (TSortComplement (TName "ground-values")),VPAnnotated (VPMetaVar "W") (TName "values")] env + rewriteTermTo (TName "false") env + rewrite4 = do + let env = emptyEnv + env <- vsMatch fargs [VPAnnotated (VPMetaVar "V") (TName "values"),VPAnnotated (VPMetaVar "W") (TSortComplement (TName "ground-values"))] env + rewriteTermTo (TName "false") env diff --git a/funcons-tools.cabal b/funcons-tools.cabal --- a/funcons-tools.cabal +++ b/funcons-tools.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: funcons-tools -version: 0.1.0.0 +version: 0.2.0.1 synopsis: A modular interpreter for executing funcons description: The PLanCompS project has developed a component-based approach to formal semantics. @@ -10,7 +10,7 @@ of `fundamental constructs' called /funcons/. . Read more about the project here: . - Read more about funcons and their specification in CBS here: . + Read more about funcons and their specification in CBS here: . . This package provides a collection of highly reusable funcons in "Funcons.Core", an interpreter for these funcons and means for defining new funcons. @@ -34,161 +34,126 @@ copyright: Copyright (C) 2015 L. Thomas van Binsbergen and Neil Sculthorpe category: Compilers/Interpreters build-type: Simple -stability: experimental +stability: unstable -- extra-source-files: cabal-version: >=1.10 library - exposed-modules: Funcons.EDSL, Funcons.Tools, Funcons.Core - build-depends: base >=4.3 && <4.9, text, containers, vector, bv, parsec, multiset, split, directory, mtl >= 2.0 + exposed-modules: Funcons.EDSL + , Funcons.Tools + Funcons.Core + , Funcons.ValueOperations + , Funcons.Core.Manual + , Funcons.MetaProgramming + , Funcons.GLLParser + , Funcons.RunOptions + build-depends: base >=4.3 && <= 5 + ,text + ,containers + ,vector>=0.12.0.0 + ,bv >= 0.5 + ,multiset + ,split + ,directory + ,mtl >= 2.0 + ,gll >= 0.4.0.2 + ,TypeCompose>=0.9.10 + ,regex-applicative + ,random-strings + ,funcons-values hs-source-dirs: src, cbs, manual default-language: Haskell2010 other-extensions: OverloadedStrings ghc-options: -fwarn-incomplete-patterns -fwarn-monomorphism-restriction -fwarn-unused-imports - other-modules: Funcons.MSOS, Funcons.Parser, Funcons.Lexer, Funcons.Substitution, Funcons.Patterns, Funcons.Entities, Funcons.Simulation, Funcons.RunOptions, Funcons.Exceptions, Funcons.Types, Funcons.Core.Library, Funcons.Printer, - Funcons.Core.Computations.ControlFlow.Normal.Sequencing.LeftToRight, - Funcons.Core.Computations.ControlFlow.Normal.Sequencing.Atomic, - Funcons.Core.Computations.ControlFlow.Normal.Sequencing.Sequential, - Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.VectorMap, - Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.SetMap, - Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.ListMap, - Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.TupleMap, - Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.MapMap, - Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.MappingCollections.ListsMap, - Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.FilteringCollections.MultisetFilter, - Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.FilteringCollections.SetFilter, - Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.FilteringCollections.MapFilter, - Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.FilteringCollections.ListFilter, - Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.ReducingCollections.ListFoldl, - Funcons.Core.Computations.ControlFlow.Normal.Iterating.Definite.ReducingCollections.ListFoldr, - Funcons.Core.Computations.ControlFlow.Normal.Iterating.Indefinite.While, - Funcons.Core.Computations.ControlFlow.Normal.Iterating.Indefinite.DoWhile, - Funcons.Core.Computations.ControlFlow.Normal.Choosing.IfThenElse, - Funcons.Core.Computations.ControlFlow.Abnormal.Stuck, - Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Control, - Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Hole, - Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.CallCc, - Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Abort, - Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Shift, - Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Prompt, - Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Reset, - Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.ControlSignal, - Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.Plug, - Funcons.Core.Computations.ControlFlow.Abnormal.Continuations.ResumeSignal, - Funcons.Core.Computations.ControlFlow.Abnormal.Throwing.Thrown, - Funcons.Core.Computations.ControlFlow.Abnormal.Throwing.HandleThrown, - Funcons.Core.Computations.ControlFlow.Abnormal.Throwing.Finally, - Funcons.Core.Computations.ControlFlow.Abnormal.Throwing.Throw, - Funcons.Core.Computations.ControlFlow.Abnormal.Throwing.HandleRecursively, - Funcons.Core.Computations.ControlFlow.Abnormal.Failing.Else, - Funcons.Core.Computations.ControlFlow.Abnormal.Failing.CheckTrue, - Funcons.Core.Computations.ControlFlow.Abnormal.Failing.Fail, - Funcons.Core.Computations.ControlFlow.Abnormal.Failing.Signals, - Funcons.Core.Computations.ControlFlow.Abnormal.Failing.Dereference, - Funcons.Core.Computations.ControlFlow.Abnormal.Failing.Failed, - Funcons.Core.Computations.DataFlow.Interacting.PrintList, - Funcons.Core.Computations.DataFlow.Interacting.Print, - Funcons.Core.Computations.DataFlow.Interacting.StandardOut, - Funcons.Core.Computations.DataFlow.Interacting.Read, - Funcons.Core.Computations.DataFlow.Interacting.StandardIn, - Funcons.Core.Computations.DataFlow.Effect, - Funcons.Core.Computations.DataFlow.Storing.GeneralVariables.AllocateMap, - Funcons.Core.Computations.DataFlow.Storing.GeneralVariables.GeneralAssign, - Funcons.Core.Computations.DataFlow.Storing.GeneralVariables.GeneralAssigned, - Funcons.Core.Computations.DataFlow.Storing.GeneralVariables.AllocateVector, - Funcons.Core.Computations.DataFlow.Storing.Stores, - Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.CurrentValue, - Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.Assigned, - Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.AllocateInitialisedVariable, - Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.AllocateVariable, - Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.DeallocateVariable, - Funcons.Core.Computations.DataFlow.Storing.SimpleVariables.Assign, - Funcons.Core.Computations.DataFlow.Storing.Store, - Funcons.Core.Computations.DataFlow.Storing.Variables, - Funcons.Core.Computations.DataFlow.Linking.AllocateInitialisedLink, - Funcons.Core.Computations.DataFlow.Linking.AllocateLink, - Funcons.Core.Computations.DataFlow.Linking.FollowIfLink, - Funcons.Core.Computations.DataFlow.Linking.LinkStore, - Funcons.Core.Computations.DataFlow.Linking.Links, - Funcons.Core.Computations.DataFlow.Linking.FollowLink, - Funcons.Core.Computations.DataFlow.Linking.LinkStores, - Funcons.Core.Computations.DataFlow.Linking.SetLink, - Funcons.Core.Computations.DataFlow.Giving.Given, - Funcons.Core.Computations.DataFlow.Giving.Give, - Funcons.Core.Computations.DataFlow.Giving.GivenValue, - Funcons.Core.Computations.DataFlow.Generating.AtomGenerator, - Funcons.Core.Computations.DataFlow.Generating.FreshAtom, - Funcons.Core.Computations.DataFlow.Generating.FreshBinder, - Funcons.Core.Computations.DataFlow.Binding.Recursion.Recursive, - Funcons.Core.Computations.DataFlow.Binding.Recursion.BindRecursively, - Funcons.Core.Computations.DataFlow.Binding.Recursion.BoundRecursively, - Funcons.Core.Computations.DataFlow.Binding.Bound, - Funcons.Core.Computations.DataFlow.Binding.Environments, - Funcons.Core.Computations.DataFlow.Binding.Scope, - Funcons.Core.Computations.DataFlow.Binding.Accumulate, - Funcons.Core.Computations.DataFlow.Binding.Bind, - Funcons.Core.Computations.DataFlow.Binding.Environment, - Funcons.Core.Computations.Sorts, - Funcons.Core.Values.Types, - Funcons.Core.Values.CompositeValues.Collections.DirectedGraphs, - Funcons.Core.Values.CompositeValues.Collections.Tuples, - Funcons.Core.Values.CompositeValues.AlgebraicDatatypeValues.Variants, - Funcons.Core.Values.CompositeValues.AlgebraicDatatypeValues.Records, - Funcons.Core.Values.CompositeValues.AlgebraicDatatypeValues.References, - Funcons.Core.Values.PrimitiveValues.UnitType, - Funcons.Core.Values.PrimitiveValues.UnicodeCharacters, - Funcons.Core.Values.PrimitiveValues.Bits, - Funcons.Core.Values.PrimitiveValues.Strings, - Funcons.Core.Values.PrimitiveValues.Numbers.Integers, - Funcons.Core.Values.PrimitiveValues.Numbers.Rationals, - Funcons.Core.Values.PrimitiveValues.Numbers.IeeeFloats, - Funcons.Core.Values.PrimitiveValues.Booleans, - Funcons.Core.Abstractions.Closures.Close, - Funcons.Core.Abstractions.Closures.Closure, - Funcons.Core.Abstractions.Patterns.PatternPrefer, - Funcons.Core.Abstractions.Patterns.Match, - Funcons.Core.Abstractions.Patterns.Patterns, - Funcons.Core.Abstractions.Patterns.PatternUnite, - Funcons.Core.Abstractions.Patterns.PatternAny, - Funcons.Core.Abstractions.Patterns.Case, - Funcons.Core.Abstractions.Patterns.MatchLoosely, - Funcons.Core.Abstractions.Patterns.PatternBind, - Funcons.Core.Abstractions.IsGroundValue, - Funcons.Core.Abstractions.Functions.Apply, - Funcons.Core.Abstractions.Functions.BindingLambda, - Funcons.Core.Abstractions.Functions.Supply, - Funcons.Core.Abstractions.Functions.Curry, - Funcons.Core.Abstractions.Functions.Lambda, - Funcons.Core.Abstractions.Functions.Uncurry, - Funcons.Core.Abstractions.Functions.PartialApply, - Funcons.Core.Abstractions.Functions.Compose, - -- manual - Funcons.Core.Computations.DataFlow.Generating.AtomSeed - , Funcons.Core.Computations.DataFlow.Generating.NextAtom - , Funcons.Core.Values.Composite.Collections.Sets - , Funcons.Core.Values.Composite.Collections.Multisets - , Funcons.Core.Values.Composite.Collections.Lists - , Funcons.Core.Values.Composite.Collections.Maps - , Funcons.Core.Values.Composite.Collections.Vectors - , Funcons.Core.Values.Composite.AlgebraicDatatypeValues.AlgebraicDatatypes - , Funcons.Core.Values.Composite.Collections.TuplesBuiltin - , Funcons.Core.Values.Primitive.StringsBuiltin - , Funcons.Core.Values.Primitive.BitsBuiltin - , Funcons.Core.Values.Primitive.Numbers.IeeeFloatsBuiltin - , Funcons.Core.Values.Primitive.Numbers.Integers - , Funcons.Core.Values.Primitive.Numbers.RationalsBuiltin - , Funcons.Core.Values.Primitive.Atoms - , Funcons.Core.Values.Primitive.Characters - , Funcons.Core.Values.Primitive.BoolBuiltin - , Funcons.Core.Abstractions.Thunk - , Funcons.Core.Abstractions.Force - , Funcons.Core.Manual - - + other-modules: + Funcons.MSOS, + Funcons.TypeSubstitution, + Funcons.Substitution, + Funcons.Parser, + Funcons.Patterns, + Funcons.Entities, + Funcons.Simulation, + Funcons.Exceptions, + Funcons.Types, + Funcons.Printer + -- generated + Funcons.Core.Library, + Funcons.Core.Computations.Normal.Interacting.Interacting, + Funcons.Core.Computations.Normal.Flowing.Flowing, + Funcons.Core.Computations.Normal.Storing.Storing, + Funcons.Core.Computations.Normal.Linking.Linking, + Funcons.Core.Computations.Normal.Giving.Giving, + Funcons.Core.Computations.Normal.Generating.Generating, + Funcons.Core.Computations.Normal.Binding.Binding, + Funcons.Core.Computations.Abnormal.Abrupting.Abrupting, + Funcons.Core.Computations.Abnormal.Returning.Returning, + Funcons.Core.Computations.Abnormal.Throwing.Throwing, + Funcons.Core.Computations.Abnormal.Failing.Failing, + Funcons.Core.Computations.Abnormal.Sticking, + Funcons.Core.Computations.Abnormal.Breaking.Breaking, + Funcons.Core.Computations.Abnormal.Continuing.Continuing, + Funcons.Core.Computations.Abnormal.Controlling.Controlling, + Funcons.Core.Values.ValueTypes.ValueTypes, +-- Funcons.Core.Values.Composite.Sets, + Funcons.Core.Values.Composite.Bits.Bits, + Funcons.Core.Values.Composite.Strings.Strings, + Funcons.Core.Values.Composite.Datatypes.Datatypes, + Funcons.Core.Values.Composite.Lists.Lists, +-- Funcons.Core.Values.Composite.Multisets, + Funcons.Core.Values.Composite.Sequences.Sequences, + Funcons.Core.Values.Composite.Variants.Variants, + Funcons.Core.Values.Composite.Records.Records, +-- Funcons.Core.Values.Composite.Maps, + Funcons.Core.Values.Composite.Vectors.Vectors, + Funcons.Core.Values.Composite.Tuples.Tuples, + Funcons.Core.Values.Composite.References.References, + Funcons.Core.Values.Composite.Graphs.Graphs, + Funcons.Core.Values.Primitive.Floats.Floats, + Funcons.Core.Values.Primitive.Integers.Integers, + Funcons.Core.Values.Primitive.Unit.Unit, + Funcons.Core.Values.Primitive.Booleans.Booleans, + Funcons.Core.Values.Primitive.Characters.Characters, + Funcons.Core.Values.Abstraction.Functions.Functions, + Funcons.Core.Values.Abstraction.Patterns.Patterns, + Funcons.Core.Values.Abstraction.Generic.Generic, + Funcons.Core.Values.Abstraction.Thunks.Thunks + -- manual + , Funcons.Core.Computations.Normal.GeneratingBuiltin + , Funcons.Core.Values.Composite.SetsBuiltin + , Funcons.Core.Values.Composite.MultisetsBuiltin +-- , Funcons.Core.Values.Composite.ListsBuiltin + , Funcons.Core.Values.Composite.MapsBuiltin +-- , Funcons.Core.Values.Composite.VectorsBuiltin + , Funcons.Core.Values.Composite.DatatypesBuiltin +-- , Funcons.Core.Values.Composite.TuplesBuiltin + , Funcons.Core.Values.Primitive.StringsBuiltin + , Funcons.Core.Values.Primitive.BitsBuiltin + , Funcons.Core.Values.Primitive.FloatsBuiltin + , Funcons.Core.Values.Primitive.IntegersBuiltin + , Funcons.Core.Values.Primitive.Atoms + , Funcons.Core.Values.Primitive.CharactersBuiltin + , Funcons.Core.Values.Primitive.BoolBuiltin + , Funcons.Core.Values.TypesBuiltin + , Funcons.Core.Computations.TypesBuiltin executable runfct - main-is: Main.hs - other-extensions: OverloadedStrings - build-depends: base >=4.3 && <4.9, text, containers, vector, bv, parsec, funcons-tools, multiset, split, directory, mtl >= 2.0 - hs-source-dirs: src, manual, cbs - default-language: Haskell2010 + main-is: Main.hs + other-extensions: OverloadedStrings + build-depends: base >=4.3 && <= 5 + ,text + ,containers + ,vector + ,bv >= 0.5 + ,funcons-tools + ,multiset + ,split + ,directory + ,mtl >= 2.0 + ,gll >= 0.3.0.9 + ,TypeCompose>=0.9.10 + ,regex-applicative + ,random-strings + ,funcons-values + hs-source-dirs: src, manual, cbs + default-language: Haskell2010 + -- ghc-options: -rtsopts diff --git a/manual/Funcons/Core/Abstractions/Force.hs b/manual/Funcons/Core/Abstractions/Force.hs deleted file mode 100644 --- a/manual/Funcons/Core/Abstractions/Force.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Abstractions.Force where - -import Funcons.EDSL -import Funcons.Types - -library = libFromList [ - ("force", StrictFuncon stepForce) - ] - -force_ = applyFuncon "force" -stepForce [Thunk f] = compstep (stepTo f) -stepForce vs = sortErr (force_ (fvalues vs)) "cannot force a non-thunk" - diff --git a/manual/Funcons/Core/Abstractions/Thunk.hs b/manual/Funcons/Core/Abstractions/Thunk.hs deleted file mode 100644 --- a/manual/Funcons/Core/Abstractions/Thunk.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Abstractions.Thunk where - -import Funcons.EDSL -import Funcons.Types - -library = libFromList [ - ("thunk", NonStrictFuncon stepThunk) - , ("thunks", StrictFuncon stepThunks) - ] - -thunk_ :: [Funcons] -> Funcons -thunk_ fargs = applyFuncon "thunk" fargs -stepThunk [f] = rewriteTo $ FValue $ Thunk f -stepThunk fs = sortErr (applyFuncon "thunk" fs) "thunk not applied to a single funcon" - -stepThunks [ComputationType ct] = rewriteTo $ type_ $ Thunks ct -stepThunks vs = sortErr (applyFuncon "thunks" (fvalues vs)) - "thunks not applied to computation-type" diff --git a/manual/Funcons/Core/Computations/DataFlow/Generating/AtomSeed.hs b/manual/Funcons/Core/Computations/DataFlow/Generating/AtomSeed.hs deleted file mode 100644 --- a/manual/Funcons/Core/Computations/DataFlow/Generating/AtomSeed.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.DataFlow.Generating.AtomSeed where - -import Funcons.EDSL - -library = libFromList [ ("atom-seed", NullaryFuncon (rewriteTo (FValue (Atom "0")))) ] - diff --git a/manual/Funcons/Core/Computations/DataFlow/Generating/NextAtom.hs b/manual/Funcons/Core/Computations/DataFlow/Generating/NextAtom.hs deleted file mode 100644 --- a/manual/Funcons/Core/Computations/DataFlow/Generating/NextAtom.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Computations.DataFlow.Generating.NextAtom where - -import Funcons.EDSL - -library = libFromList [ - ("next-atom", ValueOp next_atom) - ] - -next_atom [Atom k] = rewriteTo (FValue $ Atom (show (k'+1))) - where k' :: Int - k' = read k -next_atom vs = sortErr (applyFuncon "next-atom" (map FValue vs)) "next-atom not applied to an atom" diff --git a/manual/Funcons/Core/Computations/Normal/GeneratingBuiltin.hs b/manual/Funcons/Core/Computations/Normal/GeneratingBuiltin.hs new file mode 100644 --- /dev/null +++ b/manual/Funcons/Core/Computations/Normal/GeneratingBuiltin.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Computations.Normal.GeneratingBuiltin where + +import Funcons.EDSL +import Funcons.Operations hiding (Values,tobool) + +import Data.Set (fromList) + +library = libFromList [ + ("initialise-generating", NonStrictFuncon stepInitialise_generating) + ] + +initialise_generating_ = FName "initialise-generating" +stepInitialise_generating fargs = + evalRules [] [step1] + where step1 = do + let env = emptyEnv + env <- lifted_fsMatch fargs [PMetaVar "P"] env + env <- getMutPatt "used-atom-set" (VPWildCard) env + putMut "used-atom-set" reserved_atoms + stepTermTo (TVar "P") env + reserved_atoms = Set (fromList []) + diff --git a/manual/Funcons/Core/Computations/TypesBuiltin.hs b/manual/Funcons/Core/Computations/TypesBuiltin.hs new file mode 100644 --- /dev/null +++ b/manual/Funcons/Core/Computations/TypesBuiltin.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Computations.TypesBuiltin where + +import Funcons.EDSL +import Funcons.Types +import Funcons.Operations (Types(ComputationTypes)) + +library = libFromList [ + ("computation-types", NullaryFuncon stepComputation_Types) + ] + +computation_types_ = applyFuncon "computation-types" +stepComputation_Types = rewritten $ typeVal ComputationTypes diff --git a/manual/Funcons/Core/Manual.hs b/manual/Funcons/Core/Manual.hs --- a/manual/Funcons/Core/Manual.hs +++ b/manual/Funcons/Core/Manual.hs @@ -1,82 +1,74 @@ module Funcons.Core.Manual ( Funcons.Core.Manual.library - , module Funcons.Core.Computations.DataFlow.Generating.AtomSeed - , module Funcons.Core.Computations.DataFlow.Generating.NextAtom - , module Funcons.Core.Values.Composite.Collections.Sets - , module Funcons.Core.Values.Composite.Collections.Multisets - , module Funcons.Core.Values.Composite.Collections.Lists - , module Funcons.Core.Values.Composite.Collections.Maps - , module Funcons.Core.Values.Composite.Collections.Vectors - , module Funcons.Core.Values.Composite.AlgebraicDatatypeValues.AlgebraicDatatypes + , module Funcons.Core.Computations.Normal.GeneratingBuiltin + , module Funcons.Core.Values.Composite.SetsBuiltin + , module Funcons.Core.Values.Composite.MultisetsBuiltin +-- , module Funcons.Core.Values.Composite.ListsBuiltin + , module Funcons.Core.Values.Composite.MapsBuiltin +-- , module Funcons.Core.Values.Composite.VectorsBuiltin + , module Funcons.Core.Values.Composite.DatatypesBuiltin , module Funcons.Core.Values.Primitive.StringsBuiltin , module Funcons.Core.Values.Primitive.BitsBuiltin - , module Funcons.Core.Values.Primitive.Numbers.Integers - , module Funcons.Core.Values.Primitive.Numbers.IeeeFloatsBuiltin - , module Funcons.Core.Values.Primitive.Numbers.RationalsBuiltin + , module Funcons.Core.Values.Primitive.IntegersBuiltin + , module Funcons.Core.Values.Primitive.FloatsBuiltin , module Funcons.Core.Values.Primitive.Atoms - , module Funcons.Core.Values.Primitive.Characters - , module Funcons.Core.Abstractions.Thunk - , module Funcons.Core.Abstractions.Force - , module Funcons.Core.Values.Composite.Collections.TuplesBuiltin + , module Funcons.Core.Values.Primitive.BoolBuiltin + , module Funcons.Core.Values.Primitive.CharactersBuiltin +-- , module Funcons.Core.Values.Composite.TuplesBuiltin + , module Funcons.Core.Values.TypesBuiltin )where import Funcons.EDSL -import Funcons.Core.Computations.DataFlow.Generating.AtomSeed hiding (library) -import Funcons.Core.Computations.DataFlow.Generating.NextAtom hiding (library) -import Funcons.Core.Values.Composite.Collections.Sets hiding (library) -import Funcons.Core.Values.Composite.Collections.Multisets hiding (library) -import Funcons.Core.Values.Composite.Collections.Lists hiding (library) -import Funcons.Core.Values.Composite.Collections.Maps hiding (library) -import Funcons.Core.Values.Composite.Collections.Vectors hiding (library) -import Funcons.Core.Values.Composite.AlgebraicDatatypeValues.AlgebraicDatatypes hiding (library) +import Funcons.Core.Values.Composite.SetsBuiltin hiding (library) +import Funcons.Core.Values.Composite.MultisetsBuiltin hiding (library) +--import Funcons.Core.Values.Composite.ListsBuiltin hiding (library) +import Funcons.Core.Values.Composite.MapsBuiltin hiding (library) +--import Funcons.Core.Values.Composite.VectorsBuiltin hiding (library) +import Funcons.Core.Values.Composite.DatatypesBuiltin hiding (library) import Funcons.Core.Values.Primitive.StringsBuiltin hiding (library) import Funcons.Core.Values.Primitive.BitsBuiltin hiding (library) -import Funcons.Core.Values.Primitive.Numbers.Integers hiding (library) -import Funcons.Core.Values.Primitive.Numbers.IeeeFloatsBuiltin hiding (library) -import Funcons.Core.Values.Primitive.Numbers.RationalsBuiltin hiding (library) +import Funcons.Core.Values.Primitive.IntegersBuiltin hiding (library) +import Funcons.Core.Values.Primitive.FloatsBuiltin hiding (library) import Funcons.Core.Values.Primitive.Atoms hiding (library) -import Funcons.Core.Values.Primitive.Characters hiding (library) -import Funcons.Core.Abstractions.Thunk hiding (library) -import Funcons.Core.Abstractions.Force hiding (library) -import Funcons.Core.Values.Composite.Collections.TuplesBuiltin hiding (library) +import Funcons.Core.Values.Primitive.BoolBuiltin hiding (library) +import Funcons.Core.Values.Primitive.CharactersBuiltin hiding (library) +--import Funcons.Core.Values.Composite.TuplesBuiltin hiding (library) -import qualified Funcons.Core.Computations.DataFlow.Generating.AtomSeed -import qualified Funcons.Core.Computations.DataFlow.Generating.NextAtom -import qualified Funcons.Core.Values.Composite.Collections.Sets -import qualified Funcons.Core.Values.Composite.Collections.Multisets -import qualified Funcons.Core.Values.Composite.Collections.Lists -import qualified Funcons.Core.Values.Composite.Collections.Maps -import qualified Funcons.Core.Values.Composite.Collections.Vectors -import qualified Funcons.Core.Values.Composite.AlgebraicDatatypeValues.AlgebraicDatatypes +import qualified Funcons.Core.Computations.Normal.GeneratingBuiltin +import qualified Funcons.Core.Values.Composite.SetsBuiltin +import qualified Funcons.Core.Values.Composite.MultisetsBuiltin +--import qualified Funcons.Core.Values.Composite.ListsBuiltin +import qualified Funcons.Core.Values.Composite.MapsBuiltin +--import qualified Funcons.Core.Values.Composite.VectorsBuiltin +import qualified Funcons.Core.Values.Composite.DatatypesBuiltin import qualified Funcons.Core.Values.Primitive.StringsBuiltin import qualified Funcons.Core.Values.Primitive.BitsBuiltin -import qualified Funcons.Core.Values.Primitive.Numbers.Integers -import qualified Funcons.Core.Values.Primitive.Numbers.IeeeFloatsBuiltin -import qualified Funcons.Core.Values.Primitive.Numbers.RationalsBuiltin +import qualified Funcons.Core.Values.Primitive.IntegersBuiltin +import qualified Funcons.Core.Values.Primitive.FloatsBuiltin import qualified Funcons.Core.Values.Primitive.Atoms -import qualified Funcons.Core.Values.Primitive.Characters -import qualified Funcons.Core.Abstractions.Thunk -import qualified Funcons.Core.Abstractions.Force -import qualified Funcons.Core.Values.Composite.Collections.TuplesBuiltin +import qualified Funcons.Core.Values.Primitive.BoolBuiltin +import qualified Funcons.Core.Values.Primitive.CharactersBuiltin +--import qualified Funcons.Core.Values.Composite.TuplesBuiltin +import qualified Funcons.Core.Values.TypesBuiltin +import qualified Funcons.Core.Computations.TypesBuiltin library = libUnions [ - Funcons.Core.Computations.DataFlow.Generating.AtomSeed.library - , Funcons.Core.Computations.DataFlow.Generating.NextAtom.library - , Funcons.Core.Values.Composite.Collections.Sets.library - , Funcons.Core.Values.Composite.Collections.Multisets.library - , Funcons.Core.Values.Composite.Collections.Lists.library - , Funcons.Core.Values.Composite.Collections.Maps.library - , Funcons.Core.Values.Composite.Collections.Vectors.library - , Funcons.Core.Values.Composite.AlgebraicDatatypeValues.AlgebraicDatatypes.library + Funcons.Core.Computations.Normal.GeneratingBuiltin.library + , Funcons.Core.Values.Composite.SetsBuiltin.library + , Funcons.Core.Values.Composite.MultisetsBuiltin.library +-- , Funcons.Core.Values.Composite.ListsBuiltin.library + , Funcons.Core.Values.Composite.MapsBuiltin.library +-- , Funcons.Core.Values.Composite.VectorsBuiltin.library + , Funcons.Core.Values.Composite.DatatypesBuiltin.library , Funcons.Core.Values.Primitive.StringsBuiltin.library , Funcons.Core.Values.Primitive.BitsBuiltin.library - , Funcons.Core.Values.Primitive.Numbers.Integers.library - , Funcons.Core.Values.Primitive.Numbers.IeeeFloatsBuiltin.library - , Funcons.Core.Values.Primitive.Numbers.RationalsBuiltin.library + , Funcons.Core.Values.Primitive.IntegersBuiltin.library + , Funcons.Core.Values.Primitive.FloatsBuiltin.library , Funcons.Core.Values.Primitive.Atoms.library - , Funcons.Core.Values.Primitive.Characters.library - , Funcons.Core.Abstractions.Thunk.library - , Funcons.Core.Abstractions.Force.library - , Funcons.Core.Values.Composite.Collections.TuplesBuiltin.library + , Funcons.Core.Values.Primitive.BoolBuiltin.library + , Funcons.Core.Values.Primitive.CharactersBuiltin.library +-- , Funcons.Core.Values.Composite.TuplesBuiltin.library + , Funcons.Core.Values.TypesBuiltin.library + , Funcons.Core.Computations.TypesBuiltin.library ] diff --git a/manual/Funcons/Core/Values/Composite/AlgebraicDatatypeValues/AlgebraicDatatypes.hs b/manual/Funcons/Core/Values/Composite/AlgebraicDatatypeValues/AlgebraicDatatypes.hs deleted file mode 100644 --- a/manual/Funcons/Core/Values/Composite/AlgebraicDatatypeValues/AlgebraicDatatypes.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Values.Composite.AlgebraicDatatypeValues.AlgebraicDatatypes where - -import Funcons.EDSL -import Funcons.Types - -import Data.Text (unpack, pack) - -library = libFromList [ - ("algebraic-datatype", ValueOp evalADT) - , ("algebraic-datatype-constructor", ValueOp evalADT_Con) - , ("algebraic-datatype-value", ValueOp getADT_Values) - ] - -evalADT [Atom con, v] = rewritten $ ADTVal (pack con) (tuple_unval v) -evalADT vs = sortErr (applyFuncon "algebraic-datatype" (fvalues vs)) - "algebraic-datatype not applied to correct arguments" - -evalADT_Con [ADTVal con _] = rewritten $ Atom (unpack con) -evalADT_Con vs = sortErr (applyFuncon "algebraid-datatype-constructor" (fvalues vs)) - "algebraic-datatype-constructor not applied to an ADT" - -getADT_Values [ADTVal _ vs] = rewritten (safe_tuple_val vs) -getADT_Values vs = sortErr (applyFuncon "algebraic-datatype-value" (fvalues vs)) - "algebraic-datatype-value not applied to an ADT" - - diff --git a/manual/Funcons/Core/Values/Composite/Collections/Lists.hs b/manual/Funcons/Core/Values/Composite/Collections/Lists.hs deleted file mode 100644 --- a/manual/Funcons/Core/Values/Composite/Collections/Lists.hs +++ /dev/null @@ -1,96 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Values.Composite.Collections.Lists where - -import Funcons.EDSL -import Funcons.Types -import Funcons.Core.Values.Primitive.BoolBuiltin - -import Data.List - -library = libFromList [ - ("list-length", ValueOp stepList_Length) - , ("list", ValueOp stepList) - , ("tail", ValueOp stepTail) - , ("head", ValueOp stepHead) - , ("cons", ValueOp stepCons) - , ("nil", NullaryFuncon (rewritten (List []))) - , ("is-in-list", ValueOp stepIs_In_List) - , ("is-nil", ValueOp stepIs_Nil) - , ("list-append", ValueOp list_append_op) - , ("list-to-tuple", ValueOp stepList_To_Tuple) - , ("list-intersperse", ValueOp stepList_Intersperse) - , ("list-repeat", ValueOp stepList_Repeat) - , ("list-reverse", ValueOp stepList_Reverse) - , ("list-suffix", ValueOp stepList_Suffix) - , ("list-prefix", ValueOp stepList_Prefix) - ] - -stepList vs = rewriteTo $ FValue $ List vs - -stepList_Length [List l] = rewriteTo $ int_ (length l) -stepList_Length v = sortErr (applyFuncon "list-length" (fvalues v)) - "list-length not applied to a list" - -stepHead [List []] = partialOp (applyFuncon "head" [FValue $ List []]) "head of empty list" -stepHead [List (h:_)] = rewriteTo $ FValue h -stepHead v = sortErr (applyFuncon "head" (fvalues v)) "head not applied to a list" - -stepTail [List []] = partialOp (applyFuncon "tail" [FValue $ List []]) "tail of empty list" -stepTail [List (_:tl)] = rewriteTo $ FValue $ List tl -stepTail v = sortErr (applyFuncon "tail" (fvalues v)) - "tail not applied to a list" - --- | Funcons for inserting a value to a list. -cons_ :: [Funcons] -> Funcons -cons_ = applyFuncon "cons" - --- | Funcons representing the empty list. -nil_ :: Funcons -nil_ = applyFuncon "nil" [] - -stepCons [h, List t] = rewriteTo $ FValue $ List (h:t) -stepCons v = sortErr (applyFuncon "cons" (fvalues v)) - "cons should add a value to a list of values" -stepIs_In_List [e, List xs] = rewriteTo $ FValue $ tobool (e `elem` xs) -stepIs_In_List v = sortErr (applyFuncon "is-in-list" (fvalues v)) - "sort check: is-in-list(X,XS)" - -stepIs_Nil [List vs] = rewriteTo $ FValue $ tobool (null vs) -stepIs_Nil v = sortErr (applyFuncon "is-nil" (fvalues v)) - "is-nil not applied to a list" -stepList_Suffix [vn, List ls] - | Nat n <- upcastNaturals vn = rewriteTo $ listval (drop (fromInteger n) ls) -stepList_Suffix vn = sortErr (applyFuncon "list-suffix" (fvalues vn)) "sort check" - -stepList_Prefix [vn, List ls] - | Nat n <- upcastNaturals vn = rewriteTo $ listval (take (fromInteger n) ls) -stepList_Prefix vn = sortErr (applyFuncon "list-prefix" (fvalues vn)) "sort check" - -list_to_tuple_ :: [Funcons] -> Funcons -list_to_tuple_ = applyFuncon "list-to-tuple" -stepList_To_Tuple vs = list_to_tuple_op vs - -stepList_Intersperse [v,List l] = rewriteTo $ listval (intersperse v l) -stepList_Intersperse v = sortErr (applyFuncon "list-intersperse" (fvalues v)) "list-intersperse not applied to a value and a list" - -stepList_Repeat [m,v] - | Nat n <- upcastNaturals m = rewriteTo $ listval (replicate (fromInteger n) v) -stepList_Repeat v = sortErr (applyFuncon "list-repeat" (fvalues v)) "list-repeat not applied to a nat and a value" - -stepList_Reverse [List l] = rewriteTo $ listval (reverse l) -stepList_Reverse v = sortErr (applyFuncon "list-reverse" (fvalues v)) "list-reverse not applied to a list" - - -list_to_tuple_op [List xs] = rewriteTo $ FValue $ safe_tuple_val xs -list_to_tuple_op v = sortErr (applyFuncon "list-to-tuple" (fvalues v)) - "list-to-tuple not applied to list" - -list_append_op :: [Values] -> Rewrite Rewritten -list_append_op vs | all isList_ vs = rewriteTo $ FValue $ List (concatMap toList vs) - | otherwise = sortErr (applyFuncon "list-append" [FValue $ safe_tuple_val vs]) - "list-append not applied to a sequence of lists" - where toList (List l) = l - toList _ = error "list-append not applied to lists" - isList_ (List _) = True - isList_ _ = False diff --git a/manual/Funcons/Core/Values/Composite/Collections/Maps.hs b/manual/Funcons/Core/Values/Composite/Collections/Maps.hs deleted file mode 100644 --- a/manual/Funcons/Core/Values/Composite/Collections/Maps.hs +++ /dev/null @@ -1,103 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Values.Composite.Collections.Maps where - -import Funcons.EDSL -import Funcons.Types -import Funcons.Core.Values.Primitive.BoolBuiltin - -import qualified Data.Set as S -import qualified Data.Map as M - -library = libFromList [ - ("map-empty", NullaryFuncon (rewritten (Map M.empty))) - , ("lookup", ValueOp lookup_op) - , ("domain", ValueOp stepDomain) - , ("map-override", ValueOp stepMapOverride) - , ("map-unite", ValueOp unite_maps) - , ("map-delete", ValueOp stepMapDelete) - , ("map-to-list", ValueOp stepMapToList) - , ("is-map-empty", ValueOp stepIsMapEmpty) - , ("list-to-map", ValueOp list_to_map_op) - , ("set-to-map", ValueOp set_to_map_op) - ] - -is_map_empty = applyFuncon "is-map-empty" -stepIsMapEmpty [Map m] = rewriteTo $ FValue $ tobool (null m) -stepIsMapEmpty vs = sortErr (is_map_empty (fvalues vs)) "is-map-empty not applied to a map" - -map_to_list = applyFuncon "map-to-list" -stepMapToList [Map m] = rewriteTo $ FValue $ List $ map toTup $ M.assocs m - where toTup (k,v) = NonEmptyTuple k v [] -stepMapToList vs = sortErr (map_to_list (fvalues vs)) "map-to-list not applied to a map" - -map_delete = applyFuncon "map-delete" -stepMapDelete [Map m, Set s] = rewriteTo $ FValue $ Map (foldr M.delete m s) -stepMapDelete vs = sortErr (map_delete (fvalues vs)) - "map-delete not applied to a map and set of values" - --- | --- Computes the union over a sequence of maps. --- If the maps do not have disjoint domains a failure signal is raised. -map_unite_ = FApp "map-unite" . FTuple - -unite_maps vs - | not (all isMap vs) = sortErr (map_unite_ (fvalues vs)) - "map-unite not applied to a sequence of maps" - | otherwise = - let maps = map toMap vs - domains = map (M.keysSet) maps - in if S.null (foldr S.intersection S.empty domains) - then rewriteTo $ FValue $ Map $ M.unions maps - else partialOp (map_unite_ (fvalues vs)) - "map-unite not applied to maps with disjoint domains" - where toMap (Map m) = m - toMap _ = error "unite-maps, toMap" - isMap (Map m) = True - isMap _ = False - -lookup_ = applyFuncon "lookup" - -lookup_op v@[k, Map m] = case M.lookup k m of - Nothing -> partialOp (lookup_ (fvalues v)) "failed to lookup" - Just v -> rewriteTo $ FValue v -lookup_op vs = sortErr (lookup_ (fvalues vs)) "lookup not given a key and a map" - --- | --- Computes the left-biased union over two maps. -map_override_ :: [Funcons] -> Funcons -map_override_ = applyFuncon "map-override" -stepMapOverride [x,y] = rewriteTo =<< map_override_op x y - where - map_override_op :: Values -> Values -> Rewrite Funcons - map_override_op (Map m1) (Map m2) = return (FValue $ Map $ M.union m1 m2) - map_override_op v1 v2 = sortErr (applyFuncon "map-override" [FValue v1, FValue v2]) "map-override not applied to maps" -stepMapOverride vs = sortErr (applyFuncon "map-override" (fvalues vs)) "map-override(M1,M2)" - -stepDomain m = rewriteTo =<< domain m - where - domain :: [Values] -> Rewrite Funcons - domain [Map m] = return $ FValue $ Set $ S.fromList $ M.keys m - domain vs = sortErr (applyFuncon "domain" (fvalues vs)) "domain not given a map" - -set_to_map = applyFuncon "set-to-map" -set_to_map_op :: [Values] -> Rewrite Rewritten -set_to_map_op [Set vs] - | all isPair_ vs = rewriteTo $ FValue $ Map $ M.fromList $ map unPair $ S.toList vs - where isPair_ (NonEmptyTuple _ _ []) = True - isPair_ _ = False - unPair (NonEmptyTuple k v []) = (k,v) - unPair _ = error "set-to-map not applied to a set of key-value pairs" -set_to_map_op vs = sortErr (set_to_map (fvalues vs)) - "set-to-map not applied to a set of key-value pairs" - -list_to_map = applyFuncon "list-to-map" -list_to_map_op :: [Values] -> Rewrite Rewritten -list_to_map_op [List vs] - | all isPair_ vs = rewriteTo $ FValue $ Map $ M.fromList $ map unPair $ vs - where isPair_ (NonEmptyTuple _ _ []) = True - isPair_ _ = False - unPair (NonEmptyTuple k v []) = (k,v) - unPair _ = error "set-to-map not applied to a set of key-value pairs" -list_to_map_op vs = sortErr (list_to_map (fvalues vs)) - "list-to-map not applied a lit of key-value pairs" diff --git a/manual/Funcons/Core/Values/Composite/Collections/Multisets.hs b/manual/Funcons/Core/Values/Composite/Collections/Multisets.hs deleted file mode 100644 --- a/manual/Funcons/Core/Values/Composite/Collections/Multisets.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Values.Composite.Collections.Multisets where - -import Funcons.EDSL -import Funcons.Core.Values.Primitive.BoolBuiltin - -import qualified Data.MultiSet as MS - -library = libFromList [ - ("multiset-empty", NullaryFuncon (rewritten (Multiset MS.empty))) - , ("sets-to-multisets", ValueOp stepSetsToMultisets) - , ("multiset-to-set", ValueOp stepMultisetToSet) - , ("multiset-occurrences", ValueOp stepMultisetOccurrences) - , ("multiset-insert", ValueOp stepMultisetInsert) - , ("multiset-delete", ValueOp stepMultisetDelete) - , ("is-submultiset", ValueOp stepIsSubMultiset) - ] - -is_sub_multiset = applyFuncon "is-sub-multiset" -stepIsSubMultiset [Multiset s1, Multiset s2] = - rewriteTo $ FValue $ tobool (s1 `MS.isSubsetOf`s2) -stepIsSubMultiset vs = sortErr (is_sub_multiset (map FValue vs)) - "is-sub-multiset not applied to two multisets" - -multiset_delete = applyFuncon "multiset-delete" -stepMultisetDelete [Multiset ms, v, vn] - | Nat n <- upcastNaturals vn = rewriteTo $ FValue $ Multiset (MS.deleteMany v (fromInteger n) ms) -stepMultisetDelete vs = sortErr (multiset_delete (map FValue vs)) - "multiset-delete not applied to a multiset, value and natural number" - -multiset_insert = applyFuncon "multiset-insert" -stepMultisetInsert [v, vn, Multiset ms] - | Nat n <- upcastNaturals vn = rewriteTo $ FValue $ Multiset (MS.insertMany v (fromInteger n) ms) -stepMultisetInsert vs = sortErr (multiset_insert (map FValue vs)) - "multiset-insert not applied to a value, natural number and multiset" - -multiset_occurrences = applyFuncon "multiset-occurrences" -stepMultisetOccurrences [v, Multiset ms] = rewriteTo $ int_ (MS.occur v ms) -stepMultisetOccurrences vs = sortErr (multiset_occurrences (map FValue vs)) - "multiset-occurrences not applied to a value and a multiset" - -multiset_to_set = applyFuncon "multiset-to-set" -stepMultisetToSet [Multiset ms] = rewriteTo $ FValue $ Set (MS.toSet ms) -stepMultisetToSet vs = sortErr (multiset_to_set (map FValue vs)) - "multiset-to-set not applied to a multiset" - -sets_to_multiset = applyFuncon "sets-to-multiset" -stepSetsToMultisets vs - | all isSet_ vs = rewriteTo $ FValue $ Multiset (MS.unions (map toMS vs)) - | otherwise = sortErr (sets_to_multiset (map FValue vs)) - "sets-to-multiset not applied to sets" - where isSet_ (Set _) = True - isSet_ _ = False - toMS (Set s) = MS.fromSet s - toMS _ = error "sets-to-multiset" diff --git a/manual/Funcons/Core/Values/Composite/Collections/Sets.hs b/manual/Funcons/Core/Values/Composite/Collections/Sets.hs deleted file mode 100644 --- a/manual/Funcons/Core/Values/Composite/Collections/Sets.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Values.Composite.Collections.Sets where - -import Funcons.EDSL -import Funcons.Core.Values.Primitive.BoolBuiltin - -import qualified Data.Set as S - -library = libFromList [ - ("set", ValueOp stepSet) - , ("set-empty", NullaryFuncon (rewritten (Set S.empty))) - , ("set-insert", ValueOp stepSet_Insert) - , ("set-unite", ValueOp set_unite_op) - , ("set-intersect", ValueOp set_intersect_op) - , ("set-difference", ValueOp set_difference_op) - , ("set-size", ValueOp set_size_op) - , ("is-in-set", ValueOp stepIsInSet) - , ("some-element", ValueOp stepSome_Element) - , ("is-set-empty", ValueOp is_set_empty_op) - , ("set-to-list", ValueOp stepSetToList) - , ("list-to-set", ValueOp stepList_To_Set) - , ("is-subset", ValueOp stepIs_Subset) - ] - -set_to_list = applyFuncon "set-to-list" -stepSetToList [Set s] = rewriteTo $ FValue $ List (S.toList s) -stepSetToList vs = sortErr (set_to_list (map FValue vs)) "set-to-list not applied to a set" - -is_set_empty = applyFuncon "is-set-empty" -is_set_empty_op [Set s] = rewriteTo $ FValue $ tobool (null s) -is_set_empty_op vs = sortErr (is_set_empty (map FValue vs)) "is-set-empty not applied to a set" - -set_size = applyFuncon "set-size" -set_size_op [Set s] = rewriteTo $ int_ (S.size s) -set_size_op vs = sortErr (set_size (map FValue vs)) "set-size not applied to a set" - -set_intersect = applyFuncon "set-intersect" -set_intersect_op [] = rewriteTo $ FValue $ Set S.empty -set_intersect_op vs - | all isSet_ vs = rewriteTo $ FValue $ Set (foldr1 S.intersection (map toSet vs)) - | otherwise = sortErr (set_intersect (map FValue vs)) "set-intersect not applied to sets" - where isSet_ (Set _) = True - isSet_ _ = False - toSet (Set s) = s - toSet _ = error "set-intersect toSet" - -set_difference = applyFuncon "set-difference" -set_difference_op [Set s1, Set s2] = rewriteTo $ FValue $ Set (s1 `S.difference` s2) -set_difference_op vs = sortErr (set_difference (map FValue vs)) - "set-difference not applied to two sets" - -some_element = applyFuncon "some-element" -stepSome_Element [Set s] | not (null s) = rewriteTo $ FValue $ S.findMax s -stepSome_Element vs = sortErr (some_element (map FValue vs)) "some-element not applied to a set" - -is_subset = applyFuncon "is-subset" -stepIs_Subset [Set s1, Set s2] = rewriteTo $ FValue $ tobool (s1 `S.isSubsetOf` s2) -stepIs_Subset vs = sortErr (is_subset (map FValue vs)) "is-subset not applied to two sets" - -stepSet :: [Values] -> Rewrite Rewritten -stepSet vs = rewriteTo $ FValue $ Set (S.fromList vs) - -stepIsInSet [e,Set s] = rewriteTo $ FValue $ tobool (e `S.member` s) - -stepIsInSet vs = sortErr (applyFuncon "is-in-set" (map FValue vs)) "sort check: is-in-set(_,_)" - -set_unite = applyFuncon "set-unite" -set_unite_op :: [Values] -> Rewrite Rewritten -set_unite_op vs | all isSet_ vs = rewriteTo $ FValue $ Set $ S.unions $ map unSet vs - | otherwise = sortErr (set_unite (map FValue vs)) "set-unite not applied to sets" - where isSet_ (Set s) = True - isSet_ _ = False - unSet (Set s) = s - unSet _ = error "set-unite not applied to sets only" - - -set_insert = applyFuncon "set-insert" -stepSet_Insert [e,Set s] = rewriteTo $ FValue $ Set (e `S.insert` s) -stepSet_Insert vs = sortErr (set_insert (map FValue vs)) "sort check: set-insert(_,_)" - -list_to_set = applyFuncon "list-to-set" -stepList_To_Set [List l] = rewriteTo $ FValue $ Set $ S.fromList l -stepList_To_Set vs = sortErr (list_to_set (map FValue vs)) "list-to-set not applied to a list" - diff --git a/manual/Funcons/Core/Values/Composite/Collections/TuplesBuiltin.hs b/manual/Funcons/Core/Values/Composite/Collections/TuplesBuiltin.hs deleted file mode 100644 --- a/manual/Funcons/Core/Values/Composite/Collections/TuplesBuiltin.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Values.Composite.Collections.TuplesBuiltin where - -import Funcons.EDSL -import Funcons.Types - -library = libFromList [ - ("discard-empty-tuples", ValueOp discard_empty_tuples_op) - , ("tuple-index", ValueOp stepTupleIndex) - ] - -discard_empty_tuples_ = FApp "discard-empty-tuples" . FTuple -discard_empty_tuples_op vs = rewriteTo $ FValue $ safe_tuple_val (filter (/= EmptyTuple) vs) - --- | /tuple-index(_,N)/ selects the /N/th component of a tuple. --- e.g. /tuple-index((true,"hello",'B'),2)/ = `"hello" -tuple_index_ :: [Funcons] -> Funcons -tuple_index_ = applyFuncon "tuple-index" - -stepTupleIndex args@[NonEmptyTuple v1 v2 vs, vn] - | Nat n <- upcastNaturals vn = - let vals = v1:v2:vs - i = fromInteger n - in if i > 0 && i <= length vals - then rewriteTo (FValue (vals !! (i-1))) - else partialOp (tuple_index_ (fvalues args)) "index out of range" -stepTupleIndex args = sortErr (tuple_index_ (fvalues args)) "tuple-index must be applied to a (non-empty) tuple and a natural number" diff --git a/manual/Funcons/Core/Values/Composite/Collections/Vectors.hs b/manual/Funcons/Core/Values/Composite/Collections/Vectors.hs deleted file mode 100644 --- a/manual/Funcons/Core/Values/Composite/Collections/Vectors.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Values.Composite.Collections.Vectors where - -import Funcons.Types -import Funcons.EDSL -import qualified Data.Vector as V - -library = libFromList [ - ("vector-repeat", ValueOp stepVector_Repeat) - , ("vector-length", ValueOp vector_length_op) - , ("vector-index", ValueOp stepVector_Index) - , ("vector-append", ValueOp vector_append_op) - , ("vector", ValueOp stepVector) - , ("list-to-vector", ValueOp list_to_vector_op) - , ("vector-to-list", ValueOp stepVector_To_List) - ] - -stepVector_Repeat [m,v] - | Nat n <- upcastNaturals m = rewriteTo $ FValue $ Vector $ V.replicate (fromInteger n) v -stepVector_Repeat v = sortErr (applyFuncon "vector-repeat" (fvalues v)) "vector-repeat not applied to a nat and value" - -stepVector_To_List [Vector v] = rewriteTo $ listval $ V.toList v -stepVector_To_List v = sortErr (applyFuncon "vector-to-list" (fvalues v)) "vector-to-list not applied to a vector" - -vector_empty :: Rewrite Rewritten -vector_empty = rewritten (Vector V.empty) - -vector_length_op [Vector v] = rewriteTo $ int_ (V.length v) -vector_length_op vs = sortErr (applyFuncon "vector-length" (fvalues vs)) - "vector-length not applied to vector" - -stepVector_Index :: [Values] -> Rewrite Rewritten -stepVector_Index [v,n] = vector_index_op v n - where - vector_index_op :: Values -> Values -> Rewrite Rewritten - vector_index_op (Vector v) vn | Nat n <- upcastNaturals vn = - case v V.!? (fromInteger n) of - Nothing -> partialOp (applyFuncon "vector-index" [FValue (Vector v), FValue vn]) "vector-index out of range" - Just r -> rewriteTo $ FValue $ r - vector_index_op v vn = sortErr (applyFuncon "vector-index" [FValue v, FValue vn]) "vector-index not applied to a vector and a natural number" -stepVector_Index vs = sortErr (applyFuncon "vector-index" (fvalues vs)) "vector-index not applied to a vector and a natural number" - -vector_append = applyFuncon "vector-append" -vector_append_op :: [Values] -> Rewrite Rewritten -vector_append_op vs - | all isVec vs = rewriteTo $ FValue $ Vector $ foldr ((V.++) . toVec) V.empty vs - where toVec (Vector v) = v - toVec _ = error "vector-append not applied to vectors" - isVec (Vector v) = True - isVec _ = False -vector_append_op vs = sortErr (vector_append (fvalues vs)) - "vector-append not applied to a sequence of vectors" - -stepVector vs = rewriteTo $ FValue (Vector (V.fromList vs)) - -vector_repeat = applyFuncon "vector-repeat" - -list_to_vector = applyFuncon "list-to-vector" -list_to_vector_op :: [Values] -> Rewrite Rewritten -list_to_vector_op [List l] = rewriteTo $ FValue $ Vector $ V.fromList l -list_to_vector_op vs = sortErr (list_to_vector (fvalues vs)) - "list-to-vector not applied to a list" diff --git a/manual/Funcons/Core/Values/Composite/DatatypesBuiltin.hs b/manual/Funcons/Core/Values/Composite/DatatypesBuiltin.hs new file mode 100644 --- /dev/null +++ b/manual/Funcons/Core/Values/Composite/DatatypesBuiltin.hs @@ -0,0 +1,67 @@ +{-# 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 = libFromList [ + ("datatype-value", NonStrictFuncon evalADT) + , ("non-strict-datatype-value", NonStrictFuncon evalLazyADT) + -- backwards compatibility + , ("adt-construct", StrictFuncon adtConstruct) + , ("adt-type-construct", StrictFuncon adtTypeConstruct) + , ("adt-constructor", StrictFuncon adtConstructor) + , ("adt-fields", StrictFuncon adtFields) + ] + +datatype_value_ = applyFuncon "datatype-value" +adt_val_ = datatype_value_ + +evalADT (f:fs) = evalStrictSequence (f:fs) cont adt_val_ + where + cont [] = error "eval-adt assert" + cont (v:vs) = case v of + ADTVal "list" s | all isAscii s + -> rewritten $ ADTVal (pack (map (\(FValue (Ascii c)) -> c) s)) $ map FValue vs + _ -> sortErr (adt_val_ (map FValue (v:vs))) ("first argument of datatype-value not a string") +evalADT [] = sortErr (adt_val_ []) + "algebraic-datatype not applied to a string and a sequence of fields" + +lazy_adt_val_ = applyFuncon "non-strict-datatype-value" +evalLazyADT (f:fs) = evalSequence (Strict : replicate (length fs) NonStrict) + (f:fs) cont lazy_adt_val_ + where + cont [] = error "lazy-eval-adt assert" + cont (v:vs) = case v of + FValue (ADTVal "list" s) | all isAscii s + -> rewritten $ ADTVal (pack (map (\(FValue (Ascii c)) -> c) s)) vs + _ -> sortErr (lazy_adt_val_ (v:vs)) ("first argument of value constructor not a string") +evalLazyADT [] = sortErr (lazy_adt_val_ []) + "value constructor not applied to a string and a sequence of computations" + +adt_construct_ = applyFuncon "adt-construct" +adtConstruct (v:vs) = case v of + ADTVal "list" s | all isAscii s + -> rewritten $ ADTVal (pack (map (\(FValue (Ascii c)) -> c) s)) $ map FValue vs + _ -> sortErr (adt_val_ (map FValue (v:vs))) ("first argument of adt-construct not a string") +adtConstruct [] = sortErr (adt_val_ []) + "adt-construct not applied to a string and a sequence of fields" + +adt_type_construct_ = applyFuncon "adt-type-construct" +adtTypeConstruct (v:vs) + | isString_ v = rewritten $ ComputationType $ Type $ ADT (pack (unString v)) fs + | otherwise = sortErr (adt_val_ (FValue v : fs)) ("first argument of adt-type-construct not a string") + where fs = map FValue vs +adtTypeConstruct [] = sortErr (adt_val_ []) + "adt-type-construct not applied to a string and a sequence of type arguments (values)" + +adt_constructor_ = applyFuncon "adt-constructor" +adtConstructor [ADTVal cons _] = rewritten $ string__ (unpack cons) +adtConstructor vs = sortErr (adt_constructor_ (map FValue vs)) "argument of adt-constructor not an adt value" + +adt_fields_ = applyFuncon "adt-fields" +adtFields [ADTVal _ fs] = rewritten $ ADTVal "list" fs +adtFields vs = sortErr (adt_fields_ (map FValue vs)) "argument of adt-fields not an adt value" diff --git a/manual/Funcons/Core/Values/Composite/MapsBuiltin.hs b/manual/Funcons/Core/Values/Composite/MapsBuiltin.hs new file mode 100644 --- /dev/null +++ b/manual/Funcons/Core/Values/Composite/MapsBuiltin.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Values.Composite.MapsBuiltin where + +import Control.Applicative ((<$>)) + +import Funcons.EDSL hiding (map_) +import Funcons.MSOS (rewrittens) +import Funcons.Core.Values.Primitive.BoolBuiltin +import Funcons.Core.Values.Composite.SetsBuiltin + +import qualified Funcons.Operations as VAL + +import qualified Data.Set as S +import qualified Data.Map as M + +import Data.Foldable (foldrM) + +library = libFromList [ + ("map-empty", fromNullaryValOp map_empty_ VAL.map_empty_) + , ("is-map-empty", fromValOp is_map_empty_ VAL.is_map_empty_) + , ("map-insert", fromValOp map_insert_ VAL.map_insert_) + , ("map-lookup", fromValOp map_lookup_ VAL.map_lookup_) + , ("lookup", fromValOp map_lookup_ VAL.map_lookup_) + , ("map-domain", fromValOp map_domain_ VAL.domain_) + , ("domain", fromValOp map_domain_ VAL.domain_) + , ("dom", fromValOp map_domain_ VAL.domain_) + , ("map-delete", fromValOp map_delete_ VAL.map_delete_) + , ("is-in-domain", fromValOp is_in_domain_ VAL.is_in_domain_) + , ("map-unite", fromValOp map_unite_ VAL.map_unite_) + , ("map-override", fromValOp map_override_ VAL.map_override_) + , ("maps", fromValOp maps_ VAL.maps_) + , ("map", fromValOp map_ VAL.map_) + , ("map-elements", fromSeqValOp map_elements_ VAL.map_elements_) + , ("map-points", fromSeqValOp map_points_ VAL.map_points_) + ] + +map_ = applyFuncon "map" +maps_ = applyFuncon "maps" +map_empty_ = applyFuncon "map-empty" +is_map_empty_ = applyFuncon "is-map-empty" +is_in_domain_ = applyFuncon "is-in-domain" +map_insert_ = applyFuncon "map-insert" +map_delete_ = applyFuncon "map-delete" +-- | +-- Computes the union over a sequence of maps. +-- If the maps do not have disjoint domains a failure signal is raised. +map_unite_ = FApp "map-unite" +lookup_ = applyFuncon "lookup" +map_lookup_ = applyFuncon "lookup" +map_override_ = applyFuncon "map-override" +domain_ = applyFuncon "domain" +dom_ = applyFuncon "domain" +map_domain_ = applyFuncon "domain" +map_elements_ = applyFuncon "map-elements" +map_points_ = applyFuncon "map-points" diff --git a/manual/Funcons/Core/Values/Composite/MultisetsBuiltin.hs b/manual/Funcons/Core/Values/Composite/MultisetsBuiltin.hs new file mode 100644 --- /dev/null +++ b/manual/Funcons/Core/Values/Composite/MultisetsBuiltin.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Values.Composite.MultisetsBuiltin where + +import Funcons.EDSL +import Funcons.Operations hiding (Values) +import Funcons.Core.Values.Primitive.BoolBuiltin + +import qualified Data.MultiSet as MS + +library = libFromList [ + ("multiset-empty", NullaryFuncon (rewritten (Multiset MS.empty))) + , ("sets-to-multiset", ValueOp stepSetsToMultiset) + , ("multiset-to-set", ValueOp stepMultisetToSet) +-- , ("multiset-to-list", ValueOp stepMultisetToList) +-- , ("list-to-multiset", ValueOp list_to_multiset_op) + , ("multiset-occurrences", ValueOp stepMultisetOccurrences) + , ("multiset-insert", ValueOp stepMultisetInsert) + , ("multiset-delete", ValueOp stepMultisetDelete) + , ("is-submultiset", ValueOp stepIsSubMultiset) + ] + +is_sub_multiset = applyFuncon "is-sub-multiset" +stepIsSubMultiset [Multiset s1, Multiset s2] = + rewriteTo $ FValue $ tobool (s1 `MS.isSubsetOf`s2) +stepIsSubMultiset vs = sortErr (is_sub_multiset (map FValue vs)) + "is-sub-multiset not applied to two multisets" + +multiset_delete = applyFuncon "multiset-delete" +stepMultisetDelete [Multiset ms, v, vn] + | Nat n <- upcastNaturals vn = rewriteTo $ FValue $ Multiset (MS.deleteMany v (fromInteger n) ms) +stepMultisetDelete vs = sortErr (multiset_delete (map FValue vs)) + "multiset-delete not applied to a multiset, value and natural number" + +multiset_insert = applyFuncon "multiset-insert" +stepMultisetInsert [v, vn, Multiset ms] + | Nat n <- upcastNaturals vn = rewriteTo $ FValue $ Multiset (MS.insertMany v (fromInteger n) ms) +stepMultisetInsert vs = sortErr (multiset_insert (map FValue vs)) + "multiset-insert not applied to a value, natural number and multiset" + +multiset_occurrences = applyFuncon "multiset-occurrences" +stepMultisetOccurrences [v, Multiset ms] = rewriteTo $ int_ (MS.occur v ms) +stepMultisetOccurrences vs = sortErr (multiset_occurrences (map FValue vs)) + "multiset-occurrences not applied to a value and a multiset" + +multiset_to_set = applyFuncon "multiset-to-set" +stepMultisetToSet [Multiset ms] = rewriteTo $ FValue $ Set (MS.toSet ms) +stepMultisetToSet vs = sortErr (multiset_to_set (map FValue vs)) + "multiset-to-set not applied to a multiset" + +{- +multiset_to_list = applyFuncon "multiset-to-list" +stepMultisetToList [Multiset ms] = rewriteTo $ FValue $ List $ map intPairToNatTuple (MS.toOccurList ms) + where + intPairToNatTuple :: (Values,Int) -> Values + intPairToNatTuple (v,i) = NonEmptyTuple v (Nat $ toInteger i) [] +stepMultisetToList vs = sortErr (multiset_to_list (map FValue vs)) + "multiset-to-list not applied to a multiset" + +list_to_multiset_op vs@[List xs] = do ps <- mapM natTupleToIntPair xs + rewriteTo $ FValue $ Multiset $ MS.fromOccurList ps + where + natTupleToIntPair :: Values -> Rewrite (Values,Int) + natTupleToIntPair (NonEmptyTuple v m []) | Nat n <- upcastNaturals m = return (v,fromIntegral n) + natTupleToIntPair _ = sortErr (applyFuncon "list-to-multiset" (fvalues vs)) + "list-to-multiset not applied to a list of tuples of values and naturals" +list_to_multiset_op vs = sortErr (applyFuncon "list-to-multiset" (fvalues vs)) + "list-to-multiset not applied to a list" +-} + + +sets_to_multiset = applyFuncon "sets-to-multiset" +stepSetsToMultiset vs + | all isSet_ vs = rewriteTo $ FValue $ Multiset (MS.unions (map toMS vs)) + | otherwise = sortErr (sets_to_multiset (map FValue vs)) + "sets-to-multiset not applied to sets" + where isSet_ (Set _) = True + isSet_ _ = False + toMS (Set s) = MS.fromSet s + toMS _ = error "sets-to-multiset" diff --git a/manual/Funcons/Core/Values/Composite/SetsBuiltin.hs b/manual/Funcons/Core/Values/Composite/SetsBuiltin.hs new file mode 100644 --- /dev/null +++ b/manual/Funcons/Core/Values/Composite/SetsBuiltin.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Values.Composite.SetsBuiltin where + +import Funcons.EDSL hiding (set_) +import qualified Funcons.Operations as VAL +import Funcons.Core.Values.Primitive.BoolBuiltin + +import qualified Data.Set as S + +import Test.RandomStrings (randomString', randomASCII) +import System.IO.Unsafe (unsafePerformIO) + +library = libFromList [ + ("set", fromValOp set_ VAL.set_) + , ("set-empty", fromNullaryValOp set_empty_ VAL.set_empty_) + , ("sets", fromValOp sets_ VAL.sets_) + , ("is-in-set", fromValOp is_in_set_ VAL.is_in_set_) + , ("set-elements", fromSeqValOp set_elements_ VAL.set_elements_) + , ("is-subset", fromValOp is_subset_ VAL.is_subset_) + , ("set-insert", fromValOp set_insert_ VAL.set_insert_) + , ("set-unite", fromValOp set_unite_ VAL.set_unite_) + , ("set-intersect", fromValOp set_intersect_ VAL.set_intersect_) + , ("set-difference", fromValOp set_difference_ VAL.set_difference_) + , ("set-size", fromValOp set_size_ VAL.set_size_) + , ("some-element", fromValOp some_element_ VAL.some_element_) + , ("element-not-in", fromValOp element_not_in_ VAL.element_not_in_) +-- , ("is-set-empty", fromValOp is_set_empty_ VAL.is_set_empty_) +{- , ("is-set-empty", ValueOp is_set_empty_op) + , ("set-to-list", ValueOp stepSetToList) + , ("list-to-set", ValueOp stepList_To_Set)-} + ] + +sets_ = applyFuncon "sets" +set_elements_ = applyFuncon "set-elements" +set_size_= applyFuncon "set-size" +set_intersect_= applyFuncon "set-intersect" +set_difference_ = applyFuncon "set-difference" +some_element_ = applyFuncon "some-element" +is_subset_ = applyFuncon "is-subset" +set_ = applyFuncon "set" +is_in_set_ = applyFuncon "is-in-set" +set_unite_ = applyFuncon "set-unite" +set_insert_ = applyFuncon "set-insert" +element_not_in_ = applyFuncon "element-not-in" +set_empty_ = applyFuncon "set-empty" +--is_set_empty_ = applyFuncon "is-set-empty" +--set_to_list_ = applyFuncon "set-to-list" + diff --git a/manual/Funcons/Core/Values/Primitive/Atoms.hs b/manual/Funcons/Core/Values/Primitive/Atoms.hs --- a/manual/Funcons/Core/Values/Primitive/Atoms.hs +++ b/manual/Funcons/Core/Values/Primitive/Atoms.hs @@ -2,12 +2,12 @@ module Funcons.Core.Values.Primitive.Atoms where -import Funcons.EDSL -import Funcons.Types +import Funcons.EDSL hiding (atom_) +import qualified Funcons.Operations as VAL library = libFromList [ - ("atom", ValueOp stepAtom) + ("atom", fromValOp atom_ VAL.atom_) ] -stepAtom [String s] = rewriteTo $ FValue $ Atom s -stepAtom vs = sortErr (applyFuncon "atom" (fvalues vs)) "atom not applied to a string" +atom_ = applyFuncon "atom" + diff --git a/manual/Funcons/Core/Values/Primitive/BoolBuiltin.hs b/manual/Funcons/Core/Values/Primitive/BoolBuiltin.hs --- a/manual/Funcons/Core/Values/Primitive/BoolBuiltin.hs +++ b/manual/Funcons/Core/Values/Primitive/BoolBuiltin.hs @@ -3,8 +3,9 @@ module Funcons.Core.Values.Primitive.BoolBuiltin where import Funcons.EDSL +import Funcons.Operations hiding (Values) -tobool :: Bool -> Values -tobool True = ADTVal "true" [] -tobool False = ADTVal "false" [] +library = libFromList [] +bool_ :: Bool -> Funcons +bool_ = FValue . tobool diff --git a/manual/Funcons/Core/Values/Primitive/Characters.hs b/manual/Funcons/Core/Values/Primitive/Characters.hs deleted file mode 100644 --- a/manual/Funcons/Core/Values/Primitive/Characters.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Values.Primitive.Characters where - -import Funcons.EDSL -import Funcons.Types - -library = libFromList [ - ("ascii-characters", NullaryFuncon (rewriteTo $ type_ AsciiCharacters)) - , ("ascii-character", ValueOp stepAscii_Character) - ] - -ascii_character = applyFuncon "ascii-character" -stepAscii_Character [String [c]] = rewriteTo $ FValue $ Ascii $ fromEnum c -stepAscii_Character vs = sortErr (ascii_character (fvalues vs)) - "ascii-character not applied to a string (of 1 ascii character long)" - diff --git a/manual/Funcons/Core/Values/Primitive/CharactersBuiltin.hs b/manual/Funcons/Core/Values/Primitive/CharactersBuiltin.hs new file mode 100644 --- /dev/null +++ b/manual/Funcons/Core/Values/Primitive/CharactersBuiltin.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Values.Primitive.CharactersBuiltin where + +import Funcons.EDSL +import qualified Funcons.Operations as VAL + +library = libFromList [ + ("ascii-characters", fromValOp ascii_characters_ VAL.ascii_characters_) + , ("ascii-characters", fromValOp ascii_character_ VAL.ascii_character_) + , ("unicode", fromValOp unicode_ VAL.unicode_) + , ("unicode-character-code", fromValOp unicode_character_code_ VAL.unicode_character_code_) + , ("characters", fromNullaryValOp characters_ VAL.characters_) + , ("chars", fromNullaryValOp characters_ VAL.characters_) + ] + +ascii_characters_ = applyFuncon "ascii-characters" +ascii_character_ = applyFuncon "ascii-character" +unicode_ = applyFuncon "unicode" +unicode_character_code_ = applyFuncon "unicode-character-code" +characters_ = applyFuncon "characters" +chars_ = applyFuncon "characters" diff --git a/manual/Funcons/Core/Values/Primitive/FloatsBuiltin.hs b/manual/Funcons/Core/Values/Primitive/FloatsBuiltin.hs new file mode 100644 --- /dev/null +++ b/manual/Funcons/Core/Values/Primitive/FloatsBuiltin.hs @@ -0,0 +1,266 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Values.Primitive.FloatsBuiltin where + +import Funcons.EDSL +import Funcons.Operations (Values(..), ComputationTypes(..), Types(..), isIEEEFormat, doubleFromIEEEFormat, tobool) +import Funcons.Core.Values.Primitive.BoolBuiltin +import Funcons.Core.Values.Primitive.IntegersBuiltin + +import Data.Fixed (mod') + +library = libFromList [ + ("ieee-float-float-power", ValueOp stepIEEE_Float_Power) + , ("ieee-float-add", ValueOp stepIEEE_Float_Add) + , ("ieee-float-truncate", ValueOp stepIEEE_Float_Truncate) + , ("ieee-float-multiply", ValueOp stepIEEE_Float_Multiply) + , ("ieee-float-subtract", ValueOp stepIEEE_Float_Subtract) + , ("ieee-float-negate", ValueOp stepIEEE_Float_Negate) + , ("ieee-float-divide", ValueOp stepIEEE_Float_Divide) +-- , ("signed-bits-maximum", ValueOp stepSigned_Bits_Maximum) +-- , ("signed-bits-minimum", ValueOp stepSigned_Bits_Minimum) + , ("ieee-float-acos", ValueOp stepIEEE_Float_Acos) + , ("ieee-float-asin", ValueOp stepIEEE_Float_Asin) + , ("ieee-float-atan", ValueOp stepIEEE_Float_Atan) + , ("ieee-float-atan2", ValueOp stepIEEE_Float_Atan2) + , ("ieee-float-cos", ValueOp stepIEEE_Float_Cos) + , ("ieee-float-cosh", ValueOp stepIEEE_Float_Cosh) + , ("ieee-float-exp", ValueOp stepIEEE_Float_Exp) + , ("ieee-float-log", ValueOp stepIEEE_Float_Log) + , ("ieee-float-log10", ValueOp stepIEEE_Float_Log10) + , ("ieee-float-sin", ValueOp stepIEEE_Float_Sin) + , ("ieee-float-sinh", ValueOp stepIEEE_Float_Sinh) + , ("ieee-float-sqrt", ValueOp stepIEEE_Float_Sqrt) + , ("ieee-float-tan", ValueOp stepIEEE_Float_Tan) + , ("ieee-float-tanh", ValueOp stepIEEE_Float_Tanh) + , ("ieee-float-ceiling", ValueOp stepIEEE_Float_Ceiling) + , ("ieee-float-floor", ValueOp stepIEEE_Float_Floor) + , ("ieee-float-absolute-value", ValueOp stepIEEE_Float_Absolute_Value) + , ("ieee-float-remainder", ValueOp stepIEEE_Float_Remainder) + , ("ieee-float-is-less", ValueOp stepIEEE_Float_Is_Less) + , ("ieee-float-is-less-or-equal", ValueOp stepIEEE_Float_Is_Less_Or_Equal) + , ("ieee-float-is-greater-or-equal", ValueOp stepIEEE_Float_Is_Greater_Or_Equal) + , ("ieee-float-is-greater", ValueOp stepIEEE_Float_Is_Greater) + ] + +ieee_float_truncate = applyFuncon "ieee-float-truncate" +stepIEEE_Float_Truncate [IEEE_Float_64 f, ADTVal "binary64" _] = rewriteTo $ int_ (truncate f) +stepIEEE_Float_Truncate vn = sortErr (ieee_float_truncate (fvalues vn)) "ieee-float-truncate not applied to a float of the right format" +stepIEEE_Float_Add vs = ieee_float_add_op vs +stepIEEE_Float_Multiply vs = ieee_float_multiply_op vs +stepIEEE_Float_Subtract [f,f1,f2] = ieee_float_subtract_op f f1 f2 +stepIEEE_Float_Subtract vn = sortErr (ieee_float_subtract (fvalues vn)) "sort check" +stepIEEE_Float_Negate [f,f1] = ieee_float_negate_op f f1 +stepIEEE_Float_Negate vn = sortErr (ieee_float_negate (fvalues vn)) "sort check" +stepIEEE_Float_Divide [f,f1,f2] = ieee_float_divide_op f f1 f2 +stepIEEE_Float_Divide vn = sortErr (ieee_float_divide (fvalues vn)) "sort check" +stepIEEE_Float_Power [f,f1,f2] = ieee_float_power_op f f1 f2 +stepIEEE_Float_Power vn = sortErr (ieee_float_float_power (fvalues vn)) "sort check" + +signed_bits_maximum = applyFuncon "signed-bits-maximum" +stepSigned_Bits_Maximum [vn] | Nat n <- upcastNaturals vn + = rewriteTo $ integer_subtract_ [integer_power_ [int_ 2, integer_subtract_ [int_ $ fromInteger n, int_ 1]],int_ 1] +stepSigned_Bits_Maximum vs = sortErr (signed_bits_maximum (fvalues vs)) "sort check" + +signed_bits_minimum = applyFuncon "signed-bits-minimum" +stepSigned_Bits_Minimum [vn] | Nat n <- upcastNaturals vn + = rewriteTo $ applyFuncon "integer-negate" [signed_bits_maximum [FValue vn]] +stepSigned_Bits_Minimum vs = sortErr (signed_bits_maximum (fvalues vs)) "sort check" + + -- TODO binary64 assumption (perhaps use config files) +ieee_float_acos = applyFuncon "ieee-float-acos" +stepIEEE_Float_Acos [f,vx] = let f1 = doubleFromIEEEFormat f vx + in rewriteTo $ FValue $ IEEE_Float_64 (acos f1) +stepIEEE_Float_Acos vn = sortErr (ieee_float_acos (fvalues vn)) "sort check" + +ieee_float_asin = applyFuncon "ieee-float-asin" +stepIEEE_Float_Asin [f,vx] = let f1 = doubleFromIEEEFormat f vx + in rewriteTo $ FValue $ IEEE_Float_64 (asin f1) +stepIEEE_Float_Asin vn = sortErr (ieee_float_asin (fvalues vn)) "sort check" + +ieee_float_atan = applyFuncon "ieee-float-atan" +stepIEEE_Float_Atan [f,vx] = let f1 = doubleFromIEEEFormat f vx + in rewriteTo $ FValue $ IEEE_Float_64 (atan f1) +stepIEEE_Float_Atan vn = sortErr (ieee_float_atan (fvalues vn)) "sort check" + +ieee_float_atan2 = applyFuncon "ieee-float-atan2" +stepIEEE_Float_Atan2 [f,vx,vy] = let f1 = doubleFromIEEEFormat f vx + f2 = doubleFromIEEEFormat f vy + in rewriteTo $ FValue $ IEEE_Float_64 (atan2 f1 f2) +stepIEEE_Float_Atan2 vn = sortErr (ieee_float_atan2 (fvalues vn)) "sort check" + +ieee_float_cos = applyFuncon "ieee-float-cos" +stepIEEE_Float_Cos [f,vx] = let f1 = doubleFromIEEEFormat f vx + in rewriteTo $ FValue $ IEEE_Float_64 (cos f1) +stepIEEE_Float_Cos vn = sortErr (ieee_float_cos (fvalues vn)) "sort check" + +ieee_float_cosh = applyFuncon "ieee-float-cosh" +stepIEEE_Float_Cosh [f,vx] = let f1 = doubleFromIEEEFormat f vx + in rewriteTo $ FValue $ IEEE_Float_64 (cosh f1) +stepIEEE_Float_Cosh vn = sortErr (ieee_float_cosh (fvalues vn)) "sort check" + +ieee_float_exp = applyFuncon "ieee-float-exp" +stepIEEE_Float_Exp [f,vx] = let f1 = doubleFromIEEEFormat f vx + in rewriteTo $ FValue $ IEEE_Float_64 (exp f1) +stepIEEE_Float_Exp vn = sortErr (ieee_float_exp (fvalues vn)) "sort check" + +ieee_float_log = applyFuncon "ieee-float-log" +stepIEEE_Float_Log [f,vx] = let f1 = doubleFromIEEEFormat f vx + in rewriteTo $ FValue $ IEEE_Float_64 (log f1) +stepIEEE_Float_Log vn = sortErr (ieee_float_log (fvalues vn)) "sort check" + +ieee_float_log10 = applyFuncon "ieee-float-log10" +stepIEEE_Float_Log10 [f,vx] = let f1 = doubleFromIEEEFormat f vx + in rewriteTo $ FValue $ IEEE_Float_64 (logBase 10 f1) +stepIEEE_Float_Log10 vn = sortErr (ieee_float_log10 (fvalues vn)) "sort check" + +ieee_float_sin = applyFuncon "ieee-float-sin" +stepIEEE_Float_Sin [f,vx] = let f1 = doubleFromIEEEFormat f vx + in rewriteTo $ FValue $ IEEE_Float_64 (sin f1) +stepIEEE_Float_Sin vn = sortErr (ieee_float_sin (fvalues vn)) "sort check" + +ieee_float_sinh = applyFuncon "ieee-float-sinh" +stepIEEE_Float_Sinh [f,vx] = let f1 = doubleFromIEEEFormat f vx + in rewriteTo $ FValue $ IEEE_Float_64 (sinh f1) +stepIEEE_Float_Sinh vn = sortErr (ieee_float_sinh (fvalues vn)) "sort check" + +ieee_float_sqrt = applyFuncon "ieee-float-sqrt" +stepIEEE_Float_Sqrt [f,vx] = let f1 = doubleFromIEEEFormat f vx + in rewriteTo $ FValue $ IEEE_Float_64 (sqrt f1) +stepIEEE_Float_Sqrt vn = sortErr (ieee_float_sqrt (fvalues vn)) "sort check" + +ieee_float_tan = applyFuncon "ieee-float-tan" +stepIEEE_Float_Tan [f,vx] = let f1 = doubleFromIEEEFormat f vx + in rewriteTo $ FValue $ IEEE_Float_64 (tan f1) +stepIEEE_Float_Tan vn = sortErr (ieee_float_tan (fvalues vn)) "sort check" + +ieee_float_tanh = applyFuncon "ieee-float-tanh" +stepIEEE_Float_Tanh [f,vx] = let f1 = doubleFromIEEEFormat f vx + in rewriteTo $ FValue $ IEEE_Float_64 (tanh f1) +stepIEEE_Float_Tanh vn = sortErr (ieee_float_tanh (fvalues vn)) "sort check" + +ieee_float_ceiling = applyFuncon "ieee-float-ceiling" +stepIEEE_Float_Ceiling [f,vx] = let f1 = doubleFromIEEEFormat f vx + in rewriteTo $ int_ (ceiling f1) +stepIEEE_Float_Ceiling vn = sortErr (ieee_float_ceiling (fvalues vn)) "sort check" + +ieee_float_floor = applyFuncon "ieee-float-floor" +stepIEEE_Float_Floor [f,vx] = let f1 = doubleFromIEEEFormat f vx + in rewriteTo $ int_ (floor f1) +stepIEEE_Float_Floor vn = sortErr (ieee_float_floor (fvalues vn)) "sort check" + +ieee_float_absolute_value = applyFuncon "ieee-float-absolute-value" +stepIEEE_Float_Absolute_Value [f,vx] = let f1 = doubleFromIEEEFormat f vx + in rewriteTo $ FValue $ IEEE_Float_64 (Prelude.abs f1) +stepIEEE_Float_Absolute_Value vn = sortErr (ieee_float_absolute_value (fvalues vn)) "sort check" + +stepIEEE_Float_Remainder [f,f1,f2] = ieee_float_remainder_op f f1 f2 +stepIEEE_Float_Remainder vn = sortErr (ieee_float_remainder (fvalues vn)) "sort check" + +stepIEEE_Float_Is_Less [f,f1,f2] = ieee_float_is_less_op f f1 f2 +stepIEEE_Float_Is_Less vn = sortErr (ieee_float_is_less (fvalues vn)) "sort check" +stepIEEE_Float_Is_Greater [f,f1,f2] = ieee_float_is_greater_op f f1 f2 +stepIEEE_Float_Is_Greater vn = sortErr (ieee_float_is_greater (fvalues vn)) "sort check" +stepIEEE_Float_Is_Less_Or_Equal [f,f1,f2] = ieee_float_is_less_or_equal_op f f1 f2 +stepIEEE_Float_Is_Less_Or_Equal vn = sortErr (ieee_float_is_less_or_equal (fvalues vn)) "sort check" +stepIEEE_Float_Is_Greater_Or_Equal [f,f1,f2] = ieee_float_is_greater_or_equal_op f f1 f2 +stepIEEE_Float_Is_Greater_Or_Equal vn = sortErr (ieee_float_is_greater_or_equal (fvalues vn)) "sort check" + + +ieee_float_op :: String -> ([Funcons] -> Funcons) + -> (Double -> Double -> Double) + -> Double -> Funcons.EDSL.Values -> [Funcons.EDSL.Values] -> Rewrite Rewritten +ieee_float_op str cons f b format vs + | all (isIEEEFormat format) vs = rewriteTo $ FValue $ IEEE_Float_64 + $ foldr f b $ map (doubleFromIEEEFormat format) vs + | otherwise = sortErr (cons (map FValue vs)) err + where err = str ++ " not applied to ieee_floats" + +ieee_float_add = applyFuncon "ieee-float-add" +ieee_float_add_op (format:vs) = ieee_float_op "ieee_float-add" ieee_float_add (+) 0 format vs +ieee_float_add_op [] = sortErr (ieee_float_add [FValue (ADTVal "list" [])]) "ieee-float-add not applied to a format and a list of floats" + +ieee_float_multiply_ = ieee_float_multiply +ieee_float_multiply = applyFuncon "ieee-float-multiply" +ieee_float_multiply_op (format:vs) = ieee_float_op "ieee_float-multiply" ieee_float_multiply (*) 1 format vs +ieee_float_multiply_op [] = sortErr (ieee_float_multiply [FValue (ADTVal "list" [])]) "ieee-float-multiply not applied to a format and a list of floats" + +ieee_float_divide = applyFuncon "ieee-float-divide" +ieee_float_divide_op format vx vy + | isIEEEFormat format vx && isIEEEFormat format vy = + let f1 = doubleFromIEEEFormat format vx + f2 = doubleFromIEEEFormat format vy + in rewriteTo $ FValue $ IEEE_Float_64 $ (f1 / f2) +ieee_float_divide_op ft vx vy = sortErr (ieee_float_divide [FValue ft,FValue vx, FValue vy]) + "ieee-float-divide not applied to a format and ieee-floats" + +ieee_float_remainder = applyFuncon "ieee-float-remainder" +ieee_float_remainder_op format vx vy + | isIEEEFormat format vx = + let f1 = doubleFromIEEEFormat format vx + f2 = doubleFromIEEEFormat format vy + in rewriteTo $ FValue $ IEEE_Float_64 $ (f1 `mod'` f2) +ieee_float_remainder_op ft vx vy = sortErr (ieee_float_remainder [FValue ft,FValue vx, FValue vy]) + "ieee-float-remainder not applied to a format and ieee-floats" + +ieee_float_negate = applyFuncon "ieee-float-negate" +ieee_float_negate_op format vx + | isIEEEFormat format vx = let f1 = doubleFromIEEEFormat format vx + in rewriteTo $ FValue $ IEEE_Float_64 (-f1) + | otherwise = sortErr (ieee_float_negate [FValue format,FValue vx]) "ieee-float-negate not applied to ieee-float" + +ieee_float_subtract = applyFuncon "ieee-float-subtract" +ieee_float_subtract_op format vx vy + | isIEEEFormat format vx && isIEEEFormat format vy = + let f1 = doubleFromIEEEFormat format vx + f2 = doubleFromIEEEFormat format vy + in rewriteTo $ FValue $ IEEE_Float_64 $ (f1 - f2) +ieee_float_subtract_op ft vx vy = sortErr (ieee_float_subtract [FValue ft, FValue vx, FValue vy]) + "ieee-float-subtract not applied to a format and ieee-floats" + +ieee_float_float_power = applyFuncon "ieee-float-float-power" +ieee_float_power_op format vx vy + | isIEEEFormat format vx && isIEEEFormat format vy = + let f1 = doubleFromIEEEFormat format vx + f2 = doubleFromIEEEFormat format vy + in rewriteTo $ FValue $ IEEE_Float_64 $ (f1 ** f2) +ieee_float_power_op ft vx vy = sortErr (ieee_float_float_power [FValue ft, FValue vx, FValue vy]) + "ieee-float-power not applied to a format and ieee-floats" + +ieee_float_is_less = applyFuncon "ieee-float-is-less" +ieee_float_is_less_op format vx vy + | isIEEEFormat format vx && isIEEEFormat format vy = + let f1 = doubleFromIEEEFormat format vx + f2 = doubleFromIEEEFormat format vy + in rewriteTo $ FValue $ tobool (f1 < f2) +ieee_float_is_less_op ft vx vy = sortErr (ieee_float_is_less [FValue ft, FValue vx, FValue vy]) + "ieee-float-is-less not applied to a format and ieee-floats" + +ieee_float_is_greater = applyFuncon "ieee-float-is-greater" +ieee_float_is_greater_op format vx vy + | isIEEEFormat format vx && isIEEEFormat format vy = + let f1 = doubleFromIEEEFormat format vx + f2 = doubleFromIEEEFormat format vy + in rewriteTo $ FValue $ tobool (f1 > f2) +ieee_float_is_greater_op ft vx vy = sortErr (ieee_float_is_greater [FValue ft, FValue vx, FValue vy]) + "ieee-float-is-greater not applied to a format and ieee-floats" + +ieee_float_is_less_or_equal = applyFuncon "ieee-float-is-less-or-equal" +ieee_float_is_less_or_equal_op format vx vy + | isIEEEFormat format vx && isIEEEFormat format vy = + let f1 = doubleFromIEEEFormat format vx + f2 = doubleFromIEEEFormat format vy + in rewriteTo $ FValue $ tobool (f1 <= f2) +ieee_float_is_less_or_equal_op ft vx vy = sortErr (ieee_float_is_less_or_equal [FValue ft,FValue vx, FValue vy]) + "ieee-float-is-less-or-equal not applied to a format and ieee-floats" + +ieee_float_is_greater_or_equal = applyFuncon "ieee-float-is-greater-or-equal" +ieee_float_is_greater_or_equal_op format vx vy + | isIEEEFormat format vx && isIEEEFormat format vy = + let f1 = doubleFromIEEEFormat format vx + f2 = doubleFromIEEEFormat format vy + in rewriteTo $ FValue $ tobool (f1 >= f2) +ieee_float_is_greater_or_equal_op ft vx vy = sortErr (ieee_float_is_greater_or_equal [FValue ft,FValue vx, FValue vy]) + "ieee-float-is-greater-or-equal not applied to a format and ieee-floats" + + diff --git a/manual/Funcons/Core/Values/Primitive/IntegersBuiltin.hs b/manual/Funcons/Core/Values/Primitive/IntegersBuiltin.hs new file mode 100644 --- /dev/null +++ b/manual/Funcons/Core/Values/Primitive/IntegersBuiltin.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Values.Primitive.IntegersBuiltin where + +import Funcons.EDSL hiding (integers_) +import qualified Funcons.Operations as VAL + +import Funcons.Core.Values.Primitive.BoolBuiltin + +library = libFromList [ + ("integer-add", fromValOp integer_add_ VAL.integer_add_) + , ("int-add", fromValOp integer_add_ VAL.integer_add_) + , ("int-mul", fromValOp integer_multiply_ VAL.integer_multiply_) + , ("integer-multiply", fromValOp integer_multiply_ VAL.integer_multiply_) + , ("integer-divide", fromValOp integer_divide_ VAL.integer_divide_) + , ("int-div", fromValOp integer_divide_ VAL.integer_divide_) + , ("integer-subtract", fromValOp integer_subtract_ VAL.integer_subtract_) + , ("integer-sub", fromValOp integer_subtract_ VAL.integer_subtract_) + , ("integer-power", fromValOp integer_power_ VAL.integer_power_) + , ("int-pow", fromValOp integer_power_ VAL.integer_power_) + , ("integer-list", fromValOp integer_list_ VAL.integer_list_) + , ("integer-modulo", fromValOp integer_modulo_ VAL.integer_modulo_) + , ("integer-absolute-value", fromValOp integer_absolute_value_ VAL.integer_absolute_value_) + , ("integer-abs", fromValOp integer_absolute_value_ VAL.integer_absolute_value_) + , ("decimal-natural", fromValOp decimal_natural_ VAL.decimal_natural_) + , ("natural-predecessor", fromValOp natural_predecessor_ VAL.natural_predecessor_) + , ("nat-pred", fromValOp natural_predecessor_ VAL.natural_predecessor_) + , ("natural-successor", fromValOp natural_successor_ VAL.natural_successor_) + , ("nat-succ", fromValOp natural_successor_ VAL.natural_successor_) + , ("integer-is-less", fromValOp is_less_ VAL.is_less_) + , ("is-less", fromValOp is_less_ VAL.is_less_) + , ("integer-is-greater", fromValOp is_greater_ VAL.is_greater_) + , ("is-greater", fromValOp is_greater_ VAL.is_greater_) + , ("integer-is-greater-or-equal", fromValOp is_greater_or_equal_ VAL.is_greater_or_equal_) + , ("is-greater-or-equal", fromValOp is_greater_or_equal_ VAL.is_greater_or_equal_) + , ("integer-is-less-or-equal", fromValOp is_less_or_equal_ VAL.is_less_or_equal_) + , ("is-less-or-equal", fromValOp is_less_or_equal_ VAL.is_less_or_equal_) + , ("integers", fromNullaryValOp integers_ VAL.integers_) + , ("ints", fromNullaryValOp integers_ VAL.integers_) + ] + +ints_ = integers_ +integers_ = applyFuncon "integers" +natural_predecessor_, nat_pred_ :: [Funcons] -> Funcons +natural_predecessor_ = applyFuncon "natural-predecessor" +nat_pred_ = applyFuncon "nat-pred" +natural_successor_, nat_succ_ :: [Funcons] -> Funcons +natural_successor_ = applyFuncon "natural-successor" +nat_succ_ = applyFuncon "nat-succ" +int_add_ = FApp "integer-add" +integer_add_ = FApp "integer-add" +integer_multiply_ = FApp "integer-multiply" +integer_divide_ = FApp "integer-divide" +integer_subtract_ = applyFuncon "integer-subtract" +integer_power_ = applyFuncon "integer-power" +integer_power_op vx = sortErr (applyFuncon "integer-power" (fvalues vx)) + "integer-power not applied to two integers" +integer_list_ = applyFuncon "integer-list" +integer_modulo_ = applyFuncon "integer-modulo" +integer_mod_ = applyFuncon "integer-modulo" +integer_absolute_value_ = applyFuncon "integer-absolute-value" +decimal_natural_ = FApp "decimal-natural" +is_less_ = applyFuncon "is-less" +integer_is_less_ = applyFuncon "is-less" +is_less_or_equal_ = FApp "is-less-or-equal" +integer_is_less_or_equal_ = FApp "is-less-or-equal" +is_greater_ = FApp "is-greater" +integer_is_greater_ = FApp "is-greater" +is_greater_or_equal_ = FApp "is-greater-or-equal" +integer_is_greater_or_equal_ = FApp "is-greater-or-equal" diff --git a/manual/Funcons/Core/Values/Primitive/Numbers/IeeeFloatsBuiltin.hs b/manual/Funcons/Core/Values/Primitive/Numbers/IeeeFloatsBuiltin.hs deleted file mode 100644 --- a/manual/Funcons/Core/Values/Primitive/Numbers/IeeeFloatsBuiltin.hs +++ /dev/null @@ -1,275 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Values.Primitive.Numbers.IeeeFloatsBuiltin where - -import Funcons.EDSL -import Funcons.Types -import Funcons.Core.Values.Primitive.BoolBuiltin -import Funcons.Core.Values.Primitive.Numbers.Integers - -import Data.Fixed (mod') - -library = libFromList [ - ("ieee-float-float-power", ValueOp stepIEEE_Float_Power) - , ("ieee-float-add", ValueOp stepIEEE_Float_Add) - , ("ieee-float-truncate", ValueOp stepIEEE_Float_Truncate) - , ("ieee-float-multiply", ValueOp stepIEEE_Float_Multiply) - , ("ieee-float-subtract", ValueOp stepIEEE_Float_Subtract) - , ("ieee-float-negate", ValueOp stepIEEE_Float_Negate) - , ("ieee-float-divide", ValueOp stepIEEE_Float_Divide) --- , ("signed-bits-maximum", ValueOp stepSigned_Bits_Maximum) --- , ("signed-bits-minimum", ValueOp stepSigned_Bits_Minimum) - , ("ieee-float-acos", ValueOp stepIEEE_Float_Acos) - , ("ieee-float-asin", ValueOp stepIEEE_Float_Asin) - , ("ieee-float-atan", ValueOp stepIEEE_Float_Atan) - , ("ieee-float-atan2", ValueOp stepIEEE_Float_Atan2) - , ("ieee-float-cos", ValueOp stepIEEE_Float_Cos) - , ("ieee-float-cosh", ValueOp stepIEEE_Float_Cosh) - , ("ieee-float-exp", ValueOp stepIEEE_Float_Exp) - , ("ieee-float-log", ValueOp stepIEEE_Float_Log) - , ("ieee-float-log10", ValueOp stepIEEE_Float_Log10) - , ("ieee-float-sin", ValueOp stepIEEE_Float_Sin) - , ("ieee-float-sinh", ValueOp stepIEEE_Float_Sinh) - , ("ieee-float-sqrt", ValueOp stepIEEE_Float_Sqrt) - , ("ieee-float-tan", ValueOp stepIEEE_Float_Tan) - , ("ieee-float-tanh", ValueOp stepIEEE_Float_Tanh) - , ("ieee-float-ceiling", ValueOp stepIEEE_Float_Ceiling) - , ("ieee-float-floor", ValueOp stepIEEE_Float_Floor) - , ("ieee-float-absolute-value", ValueOp stepIEEE_Float_Absolute_Value) - , ("ieee-float-remainder", ValueOp stepIEEE_Float_Remainder) - , ("ieee-float-is-less", ValueOp stepIEEE_Float_Is_Less) - , ("ieee-float-is-less-or-equal", ValueOp stepIEEE_Float_Is_Less_Or_Equal) - , ("ieee-float-is-greater-or-equal", ValueOp stepIEEE_Float_Is_Greater_Or_Equal) - , ("ieee-float-is-greater", ValueOp stepIEEE_Float_Is_Greater) - ] - -ieee_float_truncate = applyFuncon "ieee-float-truncate" -stepIEEE_Float_Truncate [IEEE_Float_64 f, ADTVal "binary64" _] = rewriteTo $ int_ (truncate f) -stepIEEE_Float_Truncate vn = sortErr (ieee_float_truncate (fvalues vn)) "ieee-float-truncate not applied to a float of the right format" -stepIEEE_Float_Add vs = ieee_float_add_op vs -stepIEEE_Float_Multiply vs = ieee_float_multiply_op vs -stepIEEE_Float_Subtract [f,f1,f2] = ieee_float_subtract_op f f1 f2 -stepIEEE_Float_Subtract vn = sortErr (ieee_float_subtract (fvalues vn)) "sort check" -stepIEEE_Float_Negate [f,f1] = ieee_float_negate_op f f1 -stepIEEE_Float_Negate vn = sortErr (ieee_float_negate (fvalues vn)) "sort check" -stepIEEE_Float_Divide [f,f1,f2] = ieee_float_divide_op f f1 f2 -stepIEEE_Float_Divide vn = sortErr (ieee_float_divide (fvalues vn)) "sort check" -stepIEEE_Float_Power [f,f1,f2] = ieee_float_power_op f f1 f2 -stepIEEE_Float_Power vn = sortErr (ieee_float_float_power (fvalues vn)) "sort check" - -signed_bits_maximum = applyFuncon "signed-bits-maximum" -stepSigned_Bits_Maximum [vn] | Nat n <- upcastNaturals vn - = rewriteTo $ integer_subtract[integer_power[int_ 2, integer_subtract [int_ $ fromInteger n, int_ 1]],int_ 1] -stepSigned_Bits_Maximum vs = sortErr (signed_bits_maximum (fvalues vs)) "sort check" - -signed_bits_minimum = applyFuncon "signed-bits-minimum" -stepSigned_Bits_Minimum [vn] | Nat n <- upcastNaturals vn - = rewriteTo $ applyFuncon "integer-negate" [signed_bits_maximum [FValue vn]] -stepSigned_Bits_Minimum vs = sortErr (signed_bits_maximum (fvalues vs)) "sort check" - - -- TODO binary64 assumption (perhaps use config files) -ieee_float_acos = applyFuncon "ieee-float-acos" -stepIEEE_Float_Acos [f,vx] = let f1 = doubleFromIEEEFormat f vx - in rewriteTo $ FValue $ IEEE_Float_64 (acos f1) -stepIEEE_Float_Acos vn = sortErr (ieee_float_acos (fvalues vn)) "sort check" - -ieee_float_asin = applyFuncon "ieee-float-asin" -stepIEEE_Float_Asin [f,vx] = let f1 = doubleFromIEEEFormat f vx - in rewriteTo $ FValue $ IEEE_Float_64 (asin f1) -stepIEEE_Float_Asin vn = sortErr (ieee_float_asin (fvalues vn)) "sort check" - -ieee_float_atan = applyFuncon "ieee-float-atan" -stepIEEE_Float_Atan [f,vx] = let f1 = doubleFromIEEEFormat f vx - in rewriteTo $ FValue $ IEEE_Float_64 (atan f1) -stepIEEE_Float_Atan vn = sortErr (ieee_float_atan (fvalues vn)) "sort check" - -ieee_float_atan2 = applyFuncon "ieee-float-atan2" -stepIEEE_Float_Atan2 [f,vx,vy] = let f1 = doubleFromIEEEFormat f vx - f2 = doubleFromIEEEFormat f vy - in rewriteTo $ FValue $ IEEE_Float_64 (atan2 f1 f2) -stepIEEE_Float_Atan2 vn = sortErr (ieee_float_atan2 (fvalues vn)) "sort check" - -ieee_float_cos = applyFuncon "ieee-float-cos" -stepIEEE_Float_Cos [f,vx] = let f1 = doubleFromIEEEFormat f vx - in rewriteTo $ FValue $ IEEE_Float_64 (cos f1) -stepIEEE_Float_Cos vn = sortErr (ieee_float_cos (fvalues vn)) "sort check" - -ieee_float_cosh = applyFuncon "ieee-float-cosh" -stepIEEE_Float_Cosh [f,vx] = let f1 = doubleFromIEEEFormat f vx - in rewriteTo $ FValue $ IEEE_Float_64 (cosh f1) -stepIEEE_Float_Cosh vn = sortErr (ieee_float_cosh (fvalues vn)) "sort check" - -ieee_float_exp = applyFuncon "ieee-float-exp" -stepIEEE_Float_Exp [f,vx] = let f1 = doubleFromIEEEFormat f vx - in rewriteTo $ FValue $ IEEE_Float_64 (exp f1) -stepIEEE_Float_Exp vn = sortErr (ieee_float_exp (fvalues vn)) "sort check" - -ieee_float_log = applyFuncon "ieee-float-log" -stepIEEE_Float_Log [f,vx] = let f1 = doubleFromIEEEFormat f vx - in rewriteTo $ FValue $ IEEE_Float_64 (log f1) -stepIEEE_Float_Log vn = sortErr (ieee_float_log (fvalues vn)) "sort check" - -ieee_float_log10 = applyFuncon "ieee-float-log10" -stepIEEE_Float_Log10 [f,vx] = let f1 = doubleFromIEEEFormat f vx - in rewriteTo $ FValue $ IEEE_Float_64 (logBase 10 f1) -stepIEEE_Float_Log10 vn = sortErr (ieee_float_log10 (fvalues vn)) "sort check" - -ieee_float_sin = applyFuncon "ieee-float-sin" -stepIEEE_Float_Sin [f,vx] = let f1 = doubleFromIEEEFormat f vx - in rewriteTo $ FValue $ IEEE_Float_64 (sin f1) -stepIEEE_Float_Sin vn = sortErr (ieee_float_sin (fvalues vn)) "sort check" - -ieee_float_sinh = applyFuncon "ieee-float-sinh" -stepIEEE_Float_Sinh [f,vx] = let f1 = doubleFromIEEEFormat f vx - in rewriteTo $ FValue $ IEEE_Float_64 (sinh f1) -stepIEEE_Float_Sinh vn = sortErr (ieee_float_sinh (fvalues vn)) "sort check" - -ieee_float_sqrt = applyFuncon "ieee-float-sqrt" -stepIEEE_Float_Sqrt [f,vx] = let f1 = doubleFromIEEEFormat f vx - in rewriteTo $ FValue $ IEEE_Float_64 (sqrt f1) -stepIEEE_Float_Sqrt vn = sortErr (ieee_float_sqrt (fvalues vn)) "sort check" - -ieee_float_tan = applyFuncon "ieee-float-tan" -stepIEEE_Float_Tan [f,vx] = let f1 = doubleFromIEEEFormat f vx - in rewriteTo $ FValue $ IEEE_Float_64 (tan f1) -stepIEEE_Float_Tan vn = sortErr (ieee_float_tan (fvalues vn)) "sort check" - -ieee_float_tanh = applyFuncon "ieee-float-tanh" -stepIEEE_Float_Tanh [f,vx] = let f1 = doubleFromIEEEFormat f vx - in rewriteTo $ FValue $ IEEE_Float_64 (tanh f1) -stepIEEE_Float_Tanh vn = sortErr (ieee_float_tanh (fvalues vn)) "sort check" - -ieee_float_ceiling = applyFuncon "ieee-float-ceiling" -stepIEEE_Float_Ceiling [f,vx] = let f1 = doubleFromIEEEFormat f vx - in rewriteTo $ int_ (ceiling f1) -stepIEEE_Float_Ceiling vn = sortErr (ieee_float_ceiling (fvalues vn)) "sort check" - -ieee_float_floor = applyFuncon "ieee-float-floor" -stepIEEE_Float_Floor [f,vx] = let f1 = doubleFromIEEEFormat f vx - in rewriteTo $ int_ (floor f1) -stepIEEE_Float_Floor vn = sortErr (ieee_float_floor (fvalues vn)) "sort check" - -ieee_float_absolute_value = applyFuncon "ieee-float-absolute-value" -stepIEEE_Float_Absolute_Value [f,vx] = let f1 = doubleFromIEEEFormat f vx - in rewriteTo $ FValue $ IEEE_Float_64 (Prelude.abs f1) -stepIEEE_Float_Absolute_Value vn = sortErr (ieee_float_absolute_value (fvalues vn)) "sort check" - -stepIEEE_Float_Remainder [f,f1,f2] = ieee_float_remainder_op f f1 f2 -stepIEEE_Float_Remainder vn = sortErr (ieee_float_remainder (fvalues vn)) "sort check" - -stepIEEE_Float_Is_Less [f,f1,f2] = ieee_float_is_less_op f f1 f2 -stepIEEE_Float_Is_Less vn = sortErr (ieee_float_is_less (fvalues vn)) "sort check" -stepIEEE_Float_Is_Greater [f,f1,f2] = ieee_float_is_greater_op f f1 f2 -stepIEEE_Float_Is_Greater vn = sortErr (ieee_float_is_greater (fvalues vn)) "sort check" -stepIEEE_Float_Is_Less_Or_Equal [f,f1,f2] = ieee_float_is_less_or_equal_op f f1 f2 -stepIEEE_Float_Is_Less_Or_Equal vn = sortErr (ieee_float_is_less_or_equal (fvalues vn)) "sort check" -stepIEEE_Float_Is_Greater_Or_Equal [f,f1,f2] = ieee_float_is_greater_or_equal_op f f1 f2 -stepIEEE_Float_Is_Greater_Or_Equal vn = sortErr (ieee_float_is_greater_or_equal (fvalues vn)) "sort check" - - -ieee_float_op :: String -> ([Funcons] -> Funcons) - -> (Double -> Double -> Double) - -> Double -> Values -> [Values] -> Rewrite Rewritten -ieee_float_op str cons f b format vs - | all (isIEEEFormat format) vs = rewriteTo $ FValue $ IEEE_Float_64 - $ foldr f b $ map (doubleFromIEEEFormat format) vs - | otherwise = sortErr (cons (map FValue vs)) err - where err = str ++ " not applied to ieee_floats" - -ieee_float_add = applyFuncon "ieee-float-add" -ieee_float_add_op (format:vs) = ieee_float_op "ieee_float-add" ieee_float_add (+) 0 format vs -ieee_float_add_op [] = sortErr (ieee_float_add [listval []]) "ieee-float-add not applied to a format and a list of floats" - -ieee_float_multiply = applyFuncon "ieee-float-multiply" -ieee_float_multiply_op (format:vs) = ieee_float_op "ieee_float-multiply" ieee_float_multiply (*) 1 format vs -ieee_float_multiply_op [] = sortErr (ieee_float_multiply [listval []]) "ieee-float-multiply not applied to a format and a list of floats" - -ieee_float_divide = applyFuncon "ieee-float-divide" -ieee_float_divide_op format vx vy - | isIEEEFormat format vx && isIEEEFormat format vy = - let f1 = doubleFromIEEEFormat format vx - f2 = doubleFromIEEEFormat format vy - in rewriteTo $ FValue $ IEEE_Float_64 $ (f1 / f2) -ieee_float_divide_op ft vx vy = sortErr (ieee_float_divide [FValue ft,FValue vx, FValue vy]) - "ieee-float-divide not applied to a format and ieee-floats" - -ieee_float_remainder = applyFuncon "ieee-float-remainder" -ieee_float_remainder_op format vx vy - | isIEEEFormat format vx = - let f1 = doubleFromIEEEFormat format vx - f2 = doubleFromIEEEFormat format vy - in rewriteTo $ FValue $ IEEE_Float_64 $ (f1 `mod'` f2) -ieee_float_remainder_op ft vx vy = sortErr (ieee_float_remainder [FValue ft,FValue vx, FValue vy]) - "ieee-float-remainder not applied to a format and ieee-floats" - -ieee_float_negate = applyFuncon "ieee-float-negate" -ieee_float_negate_op format vx - | isIEEEFormat format vx = let f1 = doubleFromIEEEFormat format vx - in rewriteTo $ FValue $ IEEE_Float_64 (-f1) - | otherwise = sortErr (ieee_float_negate [FValue format,FValue vx]) "ieee-float-negate not applied to ieee-float" - -ieee_float_subtract = applyFuncon "ieee-float-subtract" -ieee_float_subtract_op format vx vy - | isIEEEFormat format vx && isIEEEFormat format vy = - let f1 = doubleFromIEEEFormat format vx - f2 = doubleFromIEEEFormat format vy - in rewriteTo $ FValue $ IEEE_Float_64 $ (f1 - f2) -ieee_float_subtract_op ft vx vy = sortErr (ieee_float_subtract [FValue ft, FValue vx, FValue vy]) - "ieee-float-subtract not applied to a format and ieee-floats" - -ieee_float_float_power = applyFuncon "ieee-float-float-power" -ieee_float_power_op format vx vy - | isIEEEFormat format vx && isIEEEFormat format vy = - let f1 = doubleFromIEEEFormat format vx - f2 = doubleFromIEEEFormat format vy - in rewriteTo $ FValue $ IEEE_Float_64 $ (f1 ** f2) -ieee_float_power_op ft vx vy = sortErr (ieee_float_float_power [FValue ft, FValue vx, FValue vy]) - "ieee-float-power not applied to a format and ieee-floats" - -ieee_float_is_less = applyFuncon "ieee-float-is-less" -ieee_float_is_less_op format vx vy - | isIEEEFormat format vx && isIEEEFormat format vy = - let f1 = doubleFromIEEEFormat format vx - f2 = doubleFromIEEEFormat format vy - in rewriteTo $ FValue $ tobool (f1 < f2) -ieee_float_is_less_op ft vx vy = sortErr (ieee_float_is_less [FValue ft, FValue vx, FValue vy]) - "ieee-float-is-less not applied to a format and ieee-floats" - -ieee_float_is_greater = applyFuncon "ieee-float-is-greater" -ieee_float_is_greater_op format vx vy - | isIEEEFormat format vx && isIEEEFormat format vy = - let f1 = doubleFromIEEEFormat format vx - f2 = doubleFromIEEEFormat format vy - in rewriteTo $ FValue $ tobool (f1 > f2) -ieee_float_is_greater_op ft vx vy = sortErr (ieee_float_is_greater [FValue ft, FValue vx, FValue vy]) - "ieee-float-is-greater not applied to a format and ieee-floats" - -ieee_float_is_less_or_equal = applyFuncon "ieee-float-is-less-or-equal" -ieee_float_is_less_or_equal_op format vx vy - | isIEEEFormat format vx && isIEEEFormat format vy = - let f1 = doubleFromIEEEFormat format vx - f2 = doubleFromIEEEFormat format vy - in rewriteTo $ FValue $ tobool (f1 <= f2) -ieee_float_is_less_or_equal_op ft vx vy = sortErr (ieee_float_is_less_or_equal [FValue ft,FValue vx, FValue vy]) - "ieee-float-is-less-or-equal not applied to a format and ieee-floats" - -ieee_float_is_greater_or_equal = applyFuncon "ieee-float-is-greater-or-equal" -ieee_float_is_greater_or_equal_op format vx vy - | isIEEEFormat format vx && isIEEEFormat format vy = - let f1 = doubleFromIEEEFormat format vx - f2 = doubleFromIEEEFormat format vy - in rewriteTo $ FValue $ tobool (f1 >= f2) -ieee_float_is_greater_or_equal_op ft vx vy = sortErr (ieee_float_is_greater_or_equal [FValue ft,FValue vx, FValue vy]) - "ieee-float-is-greater-or-equal not applied to a format and ieee-floats" - - -isIEEEFormat :: Values -> Values -> Bool -isIEEEFormat (ADTVal "binary32" _) (IEEE_Float_32 _) = True -isIEEEFormat (ADTVal "binary64" _) (IEEE_Float_64 _) = True -isIEEEFormat _ _ = False - -doubleFromIEEEFormat :: RealFloat a => Values -> Values -> Double -doubleFromIEEEFormat (ADTVal "binary64" _) (IEEE_Float_64 d) = d -doubleFromIEEEFormat _ _ = error "fromIEEEFormat" - - diff --git a/manual/Funcons/Core/Values/Primitive/Numbers/Integers.hs b/manual/Funcons/Core/Values/Primitive/Numbers/Integers.hs deleted file mode 100644 --- a/manual/Funcons/Core/Values/Primitive/Numbers/Integers.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Values.Primitive.Numbers.Integers where - -import Funcons.EDSL -import Funcons.Types - -library = libFromList [ - ("integer-add", ValueOp integer_add_op) - , ("integer-multiply", ValueOp integer_multiply_op) - , ("integer-divide", ValueOp integer_divide_op) - , ("integer-subtract", ValueOp integer_subtract_op) - , ("integer-power", ValueOp integer_power_op) --- , ("integer-negate", ValueOp stepInteger_Negate) - , ("integer-list", ValueOp stepInteger_List) - , ("integer-modulo", ValueOp stepInteger_Modulo) - , ("integer-absolute-value", ValueOp stepInteger_Absolute_Value) - ] - -integer_op :: String -> ([Funcons] -> Funcons) - -> (Integer -> Integer -> Integer) - -> Integer -> [Values] -> Rewrite Rewritten -integer_op str cons f b vs | all isInt vs = - rewriteTo $ int_ $ fromInteger $ foldr f b $ map toInt vs - | otherwise = sortErr (cons (map FValue vs)) err - where isInt v | Int _ <- upcastIntegers v = True - | otherwise = False - toInt v | Int i <- upcastIntegers v = i - | otherwise = error err - err = str ++ " not applied to integers" - -integer_add_ = FApp "integer-add" . FTuple - -integer_add_op vs = integer_op "integer-add" integer_add_ (+) 0 vs - -integer_multiply_ = FApp "integer-multiple" . FTuple -integer_multiply_op vs = integer_op "integer-multiply" integer_multiply_ (*) 1 vs - -integer_divide_ = FApp "integer-divide" . FTuple -integer_divide_op [vx,vy] - | (Int x,Int y) <- (upcastIntegers vx, upcastIntegers vy) = - rewriteTo $ int_ $ fromInteger (x `div` y) - | True = sortErr (integer_divide_ [FValue vx, FValue vy]) "integer-divide not applied to ints" -integer_divide_op vx = sortErr (integer_divide_ (fvalues vx)) "integer-divide not applied to two arguments" - -integer_subtract = applyFuncon "integer-subtract" -integer_subtract_op [vx,vy] - | (Int x, Int y) <- (upcastIntegers vx, upcastIntegers vy)= - rewriteTo $ int_ $ fromInteger (x - y) - | otherwise = sortErr (applyFuncon "integer-subtract" [FValue vx, FValue vy]) - "integer-subtract not applied to ints" -integer_subtract_op v = sortErr (applyFuncon "integer-subtract" (fvalues v)) "integer-subtract should receive two integers" - -integer_power = applyFuncon "integer-power" -integer_power_op [vx, vy] - | (Int x, Int y) <- (upcastIntegers vx, upcastIntegers vy) = - rewriteTo $ int_ $ fromInteger $(x ^ y) -integer_power_op vx = sortErr (applyFuncon "integer-power" (fvalues vx)) - "integer-power not applied to two integers" - -integer_negate = applyFuncon "integer-negate" -stepInteger_Negate [v] - | (Int i) <- upcastIntegers v = rewriteTo $ int_ (- (fromInteger i)) -stepInteger_Negate vs = sortErr (integer_negate (fvalues vs)) "integer-negate not applied to an integer" - -integer_list = applyFuncon "integer-list" -stepInteger_List [vi1,vi2] - | (Int i1, Int i2) <- (upcastIntegers vi1, upcastIntegers vi2) - = rewriteTo $ FValue $ List (map mk_integers [i1.. i2]) -stepInteger_List vs = sortErr (integer_list (fvalues vs)) "sort check: integer-list(I,J)" - -integer_modulo = applyFuncon "integer-modulo" -stepInteger_Modulo [i1,i2] = integer_modulo_op i1 i2 -stepInteger_Modulo vs = sortErr (integer_modulo (fvalues vs)) - "sort check: integer-modulo(I1,I2)" -integer_modulo_op vx vy - | (Int x,Int y) <- (upcastIntegers vx, upcastIntegers vy)= - rewriteTo $ int_ $ fromInteger (x `mod` y) -integer_modulo_op vx vy = sortErr (integer_modulo [FValue vx, FValue vy]) - "integer-modulo not applied to ints" - -integer_absolute_value = applyFuncon "integer-absolute-value" -stepInteger_Absolute_Value [v] - | Int i <- upcastIntegers v = rewriteTo $ FValue $ mk_integers (Prelude.abs i) -stepInteger_Absolute_Value vs = sortErr (integer_absolute_value $ fvalues vs) - "sort check: integer-absolute-value(I1)" - diff --git a/manual/Funcons/Core/Values/Primitive/Numbers/RationalsBuiltin.hs b/manual/Funcons/Core/Values/Primitive/Numbers/RationalsBuiltin.hs deleted file mode 100644 --- a/manual/Funcons/Core/Values/Primitive/Numbers/RationalsBuiltin.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Funcons.Core.Values.Primitive.Numbers.RationalsBuiltin where - -import Funcons.EDSL -import Funcons.Types -import Funcons.Core.Values.Primitive.BoolBuiltin - -library = libFromList [ - ("is-less", ValueOp is_less_op) - , ("is-less-or-equal", ValueOp is_less_or_equal_op) - , ("is-greater", ValueOp is_greater_op) - , ("is-greater-or-equal", ValueOp is_greater_or_equal_op) - , ("rational-to-ieee-float", ValueOp stepRational_To_IEEE_Float) - , ("add", ValueOp add_op) - ] - -is_less_ = applyFuncon "is-less" -is_less_op [vx, vy] - | (Rational x, Rational y) <- (upcastRationals vx, upcastRationals vy) - = rewriteTo $ FValue $ tobool (x < y) -is_less_op vs = sortErr (is_less_ (fvalues vs)) "is-less not applied to rationals" - -is_less_or_equal_ = FApp "is-less-or-equal" . FTuple -is_less_or_equal_op [vx, vy] - | (Rational x, Rational y) <- (upcastRationals vx, upcastRationals vy) - = rewriteTo $ FValue $ tobool (x <= y) -is_less_or_equal_op vs = sortErr (is_less_or_equal_ (fvalues vs)) - "is_less_or_equal not applied to two arguments" - -is_greater_ = FApp "is-greater" . FTuple -is_greater_op [vx, vy] - | (Rational x, Rational y) <- (upcastRationals vx, upcastRationals vy) - = rewriteTo $ FValue $ tobool (x > y) -is_greater_op vs = sortErr (is_greater_ (fvalues vs)) "is-greater not applied to two arguments" - -is_greater_or_equal_ = FApp "is-greater-or-equal" . FTuple -is_greater_or_equal_op [vx, vy] - | (Rational x, Rational y) <- (upcastRationals vx, upcastRationals vy) - = rewriteTo $ FValue $ tobool (x >= y) -is_greater_or_equal_op vs = sortErr (is_greater_or_equal_ (fvalues vs)) - "is-greater-or-equal not applied to rationals" - -stepRational_To_IEEE_Float [f, vn] - | Rational r <- upcastRationals vn = rewriteTo $ FValue $ IEEE_Float_64 (fromRational r) -stepRational_To_IEEE_Float vs = sortErr (applyFuncon "rational-to-ieee-float" (fvalues vs)) - "rational-to-ieee-float not applied to a rational" - -rational_op:: String -> ([Funcons] -> Funcons) - -> (Rational -> Rational -> Rational) - -> Rational -> [Values] -> Rewrite Rewritten -rational_op str cons f b vs | all isRat vs = rewriteTo $ rational_ $ foldr f b $ map toRat vs - | otherwise = sortErr (cons (fvalues vs)) err - where isRat v | Rational _ <- upcastRationals v = True - | otherwise = False - toRat v | Rational r <- upcastRationals v = r - | otherwise = error err - err = str ++ " not applied to rationals" - - -add = applyFuncon "add" -add_op = rational_op "add" add (+) 0 - - diff --git a/manual/Funcons/Core/Values/Primitive/StringsBuiltin.hs b/manual/Funcons/Core/Values/Primitive/StringsBuiltin.hs --- a/manual/Funcons/Core/Values/Primitive/StringsBuiltin.hs +++ b/manual/Funcons/Core/Values/Primitive/StringsBuiltin.hs @@ -3,70 +3,12 @@ module Funcons.Core.Values.Primitive.StringsBuiltin where import Funcons.EDSL -import Funcons.Types - -import Numeric +import Funcons.Types hiding (stepTo_String, to_string_) +import qualified Funcons.Operations as VAL library = libFromList [ - ("decimal-natural", ValueOp decimal_natural_op) - , ("string-append", ValueOp string_append_op) - , ("decimal-rational", ValueOp stepDecimal_Rational) - , ("string-to-list", ValueOp stepString_To_List) - , ("list-to-string", ValueOp stepList_To_String) - , ("to-string", ValueOp stepTo_String) - , ("string", ValueOp stepString) + ("to-string", fromValOp to_string_ VAL.to_string_) ] -stepString_To_List [String s] = rewriteTo $ listval $ map (Ascii . fromEnum) s -stepString_To_List vn = sortErr (applyFuncon "string-to-list" (fvalues vn)) "sort check" - - -stepString vs - | all isChar_ vs = rewriteTo $ string_ (map fromChar vs) - | otherwise = sortErr (applyFuncon "string" (fvalues vs)) - "string not applied unicode characters" - where isChar_ v | Char _ <- upcastUnicode v = True - | otherwise = False - fromChar v | Char c <- upcastUnicode v = c - | otherwise = error "upcast in 'string'" - -decimal_natural_ = FApp "decimal-natural" . FTuple -decimal_natural_op [String s] = rewriteTo $ nat_ (read s) -decimal_natural_op vs = sortErr (decimal_natural_ (fvalues vs)) - "decimal-natural not applied to strings" - - -stepDecimal_Rational [String s] = rewriteTo $ rational_ (readRational s) -stepDecimal_Rational v = sortErr (applyFuncon "decimal-rational" (fvalues v)) - "decimal-natural not applied to a string" - -stepList_To_String [List cs] = list_to_string_op cs -stepList_To_String vs = sortErr (applyFuncon "list-to-string" (fvalues vs)) - "list-to-string not applied to a list" - --- | --- Concatenate a sequence of strings. -string_append_ :: [Funcons] -> Funcons -string_append_ = applyFuncon "string-append" -string_append_op vs = maybe exc (rewriteTo . string_) $ foldr (.++.) (Just []) vs - where (.++.) (String s) = fmap (s ++) - (.++.) _ = const Nothing - exc = sortErr (applyFuncon "string-append" [listval vs]) - "string-append not applied to strings" - -list_to_string_op vs | all isAscii_ vs = rewriteTo $ string_ $ map ascii2char vs - | otherwise = sortErr (applyFuncon "list-to-string" (fvalues vs)) - "list-to-string not applied to a list of ascii-characters" - where ascii2char (Ascii i) = toEnum i - ascii2char _ = error "list-to-string not applied to a list of ascii-characters" - isAscii_ (Ascii i) = True - isAscii_ _ = False - -readRational :: String -> Rational -readRational = fst . head . readFloat - -stepTo_String [String str] = rewriteTo $ string_(str) -stepTo_String [Rational r] = rewriteTo $ string_(show (fromRational r)) -stepTo_String [Ascii o] = rewriteTo $ string_([toEnum o]) -stepTo_String vs = rewriteTo $ string_(showValues (safe_tuple_val vs)) +to_string_ = applyFuncon "to-string" diff --git a/manual/Funcons/Core/Values/TypesBuiltin.hs b/manual/Funcons/Core/Values/TypesBuiltin.hs new file mode 100644 --- /dev/null +++ b/manual/Funcons/Core/Values/TypesBuiltin.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE OverloadedStrings, LambdaCase #-} + +module Funcons.Core.Values.TypesBuiltin where + +import Funcons.EDSL +import qualified Funcons.Operations as VAL + +library = libFromList [ + ("datatype-values", fromNullaryValOp datatype_values_ VAL.datatype_values_) + , ("ground-values", fromNullaryValOp ground_values_ VAL.ground_values_) + , ("ground-vals", fromNullaryValOp ground_values_ VAL.ground_values_) + , ("none", fromNullaryValOp none_ VAL.none_) + , ("defined-values", fromNullaryValOp defined_values_ VAL.defined_values_) + , ("nothing", fromNullaryValOp nothing_ VAL.nothing_) + , ("types", fromNullaryValOp types_ VAL.types_) + , ("value-types", fromNullaryValOp value_types_ VAL.value_types_) + ] + +types_ = applyFuncon "types" +value_types_ = applyFuncon "value-types" +defined_values_ = applyFuncon "defined-values" +nothing_ = applyFuncon "nothing" +datatype_values_ = applyFuncon "datatype-values" +none_ = applyFuncon "none" +ground_values_ = applyFuncon "ground-values" diff --git a/manual/Funcons/MetaProgramming.hs b/manual/Funcons/MetaProgramming.hs new file mode 100644 --- /dev/null +++ b/manual/Funcons/MetaProgramming.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE OverloadedStrings, LambdaCase #-} + +-- | +-- This module implements HGMPification of funcons based on Berger et al. (2017) +-- (First-order.) +module Funcons.MetaProgramming where + +import Funcons.MSOS +import Funcons.EDSL +import Funcons.Types +import Funcons.Patterns +import Funcons.RunOptions +import Funcons.Simulation + +import Data.Text (pack, unpack) +import qualified Data.Map as M + +-- | This function implements the ==CT=> relation. +-- Compiling programs to executable funcons terms, +-- removing occurrences of `meta-up`, `meta-down` and `meta-let` and `meta-bound`. +ctRel :: Funcons -> MSOS Funcons +ctRel f = case f of + FName nm -> return f + FApp "meta-up" [m] -> ulRel m + FApp "meta-down" [m] -> staticEval m + FApp "meta-let" [FValue nm,m,n] | isString_ nm -> do + v <- evalRel =<< ctRel m + menv <- getInh "env" + let env' = case menv of + Map env -> Map (M.insert nm v env) + _ -> Map (M.singleton nm v) + withInh "env" env' (ctRel n) + FApp nm arg -> FApp nm <$> mapM ctRel arg +-- FList fs -> FList <$> mapM ctRel fs + FSet fs -> FSet <$> mapM ctRel fs + FMap fs -> FMap <$> mapM ctRel fs + FValue v -> return (FValue v) + _ -> liftRewrite (sortErr f ("ctRel not defined")) + where staticEval m = ctRel m >>= evalRel >>= liftRewrite . dlRel + +-- | This function implements the ==UL=> relation. +-- Translating a funcon into its meta-representation +ulRel :: Funcons -> MSOS Funcons +ulRel f = case f of + FName nm -> return $ ast_ [string_ (unpack nm)] + FApp "meta-down" [f] -> ctRel f + FApp "meta-up" [m] -> ulRel m >>= ulRel + FApp nm fs -> ast_ . (string_ (unpack nm):) <$> mapM ulRel fs +-- FList fs -> ast_ . (string_ "list":) <$> mapM ulRel fs + FSet fs -> ast_ . (string_ "set":) <$> mapM ulRel fs + FMap fs -> ast_ . (string_ "map":) <$> mapM ulRel fs + FValue v -> return $ ast_ [type_ (tyOf v), FValue v] + -- What TODO with type annotations? + _ -> liftRewrite (sortErr f ("ulRel not defined")) + +-- | This function implements the ==DL=> relation. +-- Translating a meta-representation of a program into the actual program +dlRel :: Values -> Rewrite Funcons +dlRel v = case v of + VMeta tag -> dlRel' tag + _ -> sortErr (meta_down_ (fvalues [v])) "meta-down not applied to a meta-representation" + where + dlRel' :: TaggedSyntax -> Rewrite Funcons + dlRel' t = case t of + TagType ty lit -> return (FValue lit) + TagName nm [] -> return $ FName nm + TagName "set" vs -> FSet <$> mapM dlRel vs + TagName "map" vs -> FMap <$> mapM dlRel vs + TagName nm vs -> FApp nm <$> mapM dlRel vs + +evalRel :: Funcons -> MSOS Values +evalRel f = evalFuncons f >>= \case + Right [v] -> return v + Right vs -> liftRewrite $ internal "meta evaluation yields a sequence of values" + Left f' -> evalRel f' + where setGlobal f ctxt = ctxt { ereader = (ereader ctxt) { global_fct = f } } + +compile :: FunconLibrary -> TypeRelation -> Funcons -> Funcons -> Funcons +compile lib tyenv fenv f = + case runSimIO (runMSOS process (cmp_MSOSReader lib tyenv f) cmp_MSOSState) M.empty of + ((Left ie , _,_), _) -> error ("failed to compile\n" ++ showIException ie) + ((Right f, _, _), _) -> f + where process = do + env <- evalRel fenv + putMut "atom-gen" (Atom "0") + putMut "store" (Map M.empty) + withInh "env" env (ctRel f) + +translationStep :: ([Funcons] -> Funcons) -> StrictFuncon +translationStep f vs = compstep $ do fs <- liftRewrite (mapM dlRel vs) + Left <$> ulRel (f fs) + +cmp_MSOSReader lib env f = MSOSReader cmp_RewriteReader M.empty M.empty (fread True) + where cmp_RewriteReader = RewriteReader lib env defaultRunOptions f f +--cmp_MSOSWriter = MSOSWriter mempty mempty mempty +cmp_MSOSState = MSOSState M.empty M.empty (RewriteState) + +library :: FunconLibrary +library = libFromList [ +-- ("meta-up", NonStrictFuncon step_meta_up) -- static funcon +-- , ("meta-down", StrictFuncon step_meta_down) -- static funcon + ("eval", StrictFuncon step_meta_eval) + , ("code", NonStrictFuncon step_code) + , ("ast", StrictFuncon step_ast) + , ("type-of", StrictFuncon step_ty_of) + ] + +meta_up_ = applyFuncon "meta-up" +meta_down_ = applyFuncon "meta-down" +meta_let_ = applyFuncon "meta-let" + +eval_ = applyFuncon "eval" +code_ = applyFuncon "code" +step_meta_eval :: [Values] -> Rewrite Rewritten +step_meta_eval [v] = dlRel v >>= rewriteTo +step_meta_eval fs = sortErr (eval_ (fvalues fs)) "eval not applied to one argument" + +step_code :: [Funcons] -> Rewrite Rewritten +step_code [f] = compstep (toStepRes <$> ulRel f) +step_code fs = sortErr (code_ fs) "code not applied to a single term" + +ast_ = applyFuncon "ast" +step_ast :: [Values] -> Rewrite Rewritten +step_ast vs@(s:args) | isString_ s = + Funcons.Patterns.isInTupleType args [(ASTs, Just StarOp)] >>= \case + True -> rewriteTo $ FValue $ VMeta (TagName (pack (unString s)) args) + False -> sortErr (ast_ (fvalues vs)) "'ast' is not applied to a string and a sequence of meta-representations" +step_ast vs@[ComputationType (Type ty), v] = Funcons.Patterns.isInType v ty >>= \case + True -> rewriteTo $ FValue $ VMeta (TagType ty v) + False -> sortErr (ast_ (fvalues vs)) "type-checking failed during evaluation of 'ast'" +step_ast vs = sortErr (ast_ (fvalues vs)) "'ast' is not applied to a string or not to a type and a member of that type" + +type_of_ = applyFuncon "type-of" +step_ty_of :: [Values] -> Rewrite Rewritten +step_ty_of [v] = rewriteTo $ type_ $ tyOf v +step_ty_of vs = sortErr (type_of_ (fvalues vs)) "type-of not applied to a single value" + +--TODO perhaps the parser should be extended to recognise "ast-" prefixes +-- which are translated into applications of VMeta diff --git a/src/Funcons/Core.hs b/src/Funcons/Core.hs --- a/src/Funcons/Core.hs +++ b/src/Funcons/Core.hs @@ -9,18 +9,18 @@ -- exports have been generated. -- --If a funcon is called 'handle-thrown', its smart constructor is called ---'handle_thrown_' (hypens replaced by underscores and an additional underscore +--'handle_thrown_' (hyphens replaced by underscores and an additional underscore --at the end). Each smart constructors has a single argument, a list --(of type (['Funcons']) representing the actual arguments of a funcon application. -- For example, the funcon 'integer-add' can be applied to an arbitrary number --of (integer) arguments, e.g. 'integer_add_' ['int_' 3, 'int_' 4, 'int_' 5]. module Funcons.Core ( - list_, tuple_, set_, int_, nat_, string_, + int_, nat_, module Funcons.Core.Library, module Funcons.Core.Manual) where -import Funcons.Types -- Haddock dependency +import Funcons.Types hiding (set_) -- Haddock dependency import Funcons.Core.Library hiding (entities, funcons, types) -import Funcons.Core.Manual hiding (entities, funcons, types) +import Funcons.Core.Manual hiding (entities, funcons, types, unicode_, ascii_character_) diff --git a/src/Funcons/EDSL.hs b/src/Funcons/EDSL.hs --- a/src/Funcons/EDSL.hs +++ b/src/Funcons/EDSL.hs @@ -6,20 +6,21 @@ -- Module "Funcons.Tools" provides functions for creating executables. module Funcons.EDSL ( -- * Funcon representation - Funcons(..), Values(..), Types(..), ComputationTypes(..),SeqSortOp(..), + Funcons(..), Values(..), Types(..), ComputationTypes(..),SeqSortOp(..),TaggedSyntax(..), applyFuncon, -- ** Smart construction of funcon terms + app0_, app1_, app2_, app3_, -- *** Funcon terms - list_, tuple_, set_, map_empty_, empty_tuple_, + tuple_, list_, set_, map_, vec_, env_fromlist_, none__, -- *** Values - int_, nat_, string_, + int_, nat_, float_, ieee_float_32_, ieee_float_64_, string_, string__, atom_, -- *** Types - values_, integers_, strings_, unicode_characters_, + values_, integers_, atoms_, unicode_characters_, vectors_, type_, -- ** Pretty-print funcon terms - showValues, showFuncons, showTypes, + showValues, showValuesSeq, showFuncons, showFunconsSeq, showTypes, showTerms, showOp, -- ** Is a funcon term a certain value? - isVal, isString, isInt, isNat, isList, isMap, isType, - isVec, isAscii, isChar, isTup, isId, isThunk, + isVal, isInt, isNat, isList, isMap, isType, + isVec, isAscii, isChar, isTup, isString, isString_, unString, -- ** Up and downcasting between funcon terms downcastValue, downcastType, downcastValueType, upcastNaturals, upcastIntegers, upcastRationals, upcastUnicode, @@ -28,38 +29,45 @@ NonStrictFuncon, ValueOp, NullaryFuncon, -- *** Funcon libraries - FunconLibrary, libEmpty, libUnion, libUnions, libFromList, library, + FunconLibrary, libEmpty, libUnion, libOverride, libUnions, libOverrides, libFromList, Funcons.EDSL.library, fromNullaryValOp, fromValOp, fromSeqValOp, -- ** Implicit & modular propagation of entities MSOS, Rewrite, Rewritten, -- *** Helpers to create rewrites & step rules - rewriteTo, stepTo, compstep, rewritten, premiseStep, premiseEval, + rewriteTo, rewriteSeqTo, stepTo, stepSeqTo, + compstep, rewritten, premiseStep, premiseEval, norule, sortErr, partialOp, -- *** Entities and entity access Inherited, getInh, withInh, Mutable, getMut, putMut, Output, writeOut, readOut, - Control, raiseSignal, receiveSignal, - Input, consumeInput, withExtraInput, withExactInput, + Control, raiseSignal, receiveSignals, + Input, withExtraInput, withExactInput, -- * CBS compilation -- $cbsintro -- ** Funcon representation with meta-variables - FTerm(..), Env, emptyEnv, + FTerm(..), Env, emptyEnv, fvalues, -- *** Defining rules rewriteTermTo,stepTermTo,premise, -- *** Entity access withInhTerm, getInhPatt, putMutTerm, getMutPatt, writeOutTerm, readOutPatt, - receiveSignalPatt, raiseTerm, assignInput, withExtraInputTerms, withExactInputTerms, + receiveSignalPatt, raiseTerm, matchInput, withExtraInputTerms, withExactInputTerms, + withControlTerm, getControlPatt, -- ** Backtracking - evalRules, SideCondition(..), sideCondition, lifted_sideCondition, - + evalRules, stepRules, rewriteRules, + SideCondition(..), sideCondition, lifted_sideCondition, -- ** Pattern Matching - VPattern(..), FPattern(..), - vsMatch, fsMatch, - lifted_vsMatch, lifted_fsMatch, - + VPattern(..), FPattern(..), TPattern(..), + vsMatch, fsMatch, f2vPattern, + lifted_vsMatch, lifted_fsMatch, pat2term, vpat2term, typat2term, + -- ** Meta-environment + envRewrite, envStore, lifted_envRewrite, lifted_envStore, + + -- * Type substitution + TypeEnv, TyAssoc(..), HasTypeVar(..), limitedSubsTypeVar, limitedSubsTypeVarWildcard, + -- * Tools for creating interpreters -- For more explanation see "Funcons.Tools" @@ -68,53 +76,65 @@ -- ** Default entity values EntityDefaults, EntityDefault(..), -- ** Type environments - TypeEnv, DataTypeMembers(..), DataTypeAlt(..), - typeLookup, typeEnvUnion, typeEnvUnions, typeEnvFromList, emptyTypeEnv, + TypeRelation, TypeParam(..), DataTypeMembers(..), DataTypeAltt(..), + typeLookup, typeEnvUnion, typeEnvUnions, typeEnvFromList, emptyTypeRelation, )where import Funcons.MSOS import Funcons.Types +import qualified Funcons.Operations as VAL import Funcons.Entities import Funcons.Patterns import Funcons.Substitution import Funcons.Printer +import Funcons.TypeSubstitution import Control.Arrow ((***)) congruence1_1 :: Name -> Funcons -> Rewrite Rewritten -congruence1_1 fnm = compstep . premiseStepApp app - where app f = applyFuncon fnm [f] +congruence1_1 fnm = compstep . premiseStepApp (flattenApp app) + where app = applyFuncon fnm congruence1_2 :: Name -> Funcons -> Funcons -> Rewrite Rewritten -congruence1_2 fnm arg1 arg2 = compstep $ premiseStepApp app arg1 - where app f = applyFuncon fnm [f, arg2] +congruence1_2 fnm arg1 arg2 = compstep $ premiseStepApp (flattenApp app) arg1 + where app fs = applyFuncon fnm (fs++[arg2]) congruence2_2 :: Name -> Funcons -> Funcons -> Rewrite Rewritten -congruence2_2 fnm arg1 arg2 = compstep $ premiseStepApp app arg2 - where app f = applyFuncon fnm [arg1, f] +congruence2_2 fnm arg1 arg2 = compstep $ premiseStepApp (flattenApp app) arg2 + where app fs = applyFuncon fnm (arg1:fs) congruence1_3 :: Name -> Funcons -> Funcons -> Funcons -> Rewrite Rewritten -congruence1_3 fnm arg1 arg2 arg3 = compstep $ premiseStepApp app arg1 - where app f = applyFuncon fnm [f, arg2, arg3] +congruence1_3 fnm arg1 arg2 arg3 = compstep $ premiseStepApp (flattenApp app) arg1 + where app fs = applyFuncon fnm (fs ++ [arg2, arg3]) congruence2_3 :: Name -> Funcons -> Funcons -> Funcons -> Rewrite Rewritten -congruence2_3 fnm arg1 arg2 arg3 = compstep $ premiseStepApp app arg2 - where app f = applyFuncon fnm [arg1, f, arg3] +congruence2_3 fnm arg1 arg2 arg3 = compstep $ premiseStepApp (flattenApp app) arg2 + where app fs = applyFuncon fnm (arg1 : fs ++ [arg3]) congruence3_3 :: Name -> Funcons -> Funcons -> Funcons -> Rewrite Rewritten -congruence3_3 fnm arg1 arg2 arg3 = compstep $ premiseStepApp app arg3 - where app f = applyFuncon fnm [arg1, arg2, f] +congruence3_3 fnm arg1 arg2 arg3 = compstep $ premiseStepApp (flattenApp app) arg3 + where app fs = applyFuncon fnm ([arg1, arg2] ++ fs) +flattenApp :: ([Funcons] -> Funcons) -> (StepRes -> StepRes) +flattenApp app res = case res of + Left f -> toStepRes (app [f]) + Right vs -> toStepRes (app (map FValue vs)) + +-- | Create an environment from a list of bindings (String to Values) +-- This function has been introduced for easy expression of the +-- semantics of builtin identifiers +env_fromlist_ :: [(String, Funcons)] -> Funcons +env_fromlist_ = FMap . concatMap (\(k,v) -> [string_ k, v]) + + -- | A funcon library with funcons for builtin types. library :: FunconLibrary -library = libUnions [unLib, nullLib, binLib, floatsLib, bitsLib - ,boundedLib] +library = libUnions [unLib, nullLib, binLib, floatsLib,boundedLib] where nullLib = libFromList (map (id *** mkNullary) nullaryTypes) unLib = libFromList (map (id *** mkUnary) unaryTypes) binLib = libFromList (map (id *** mkBinary) binaryTypes) floatsLib = libFromList (map (id *** mkFloats) floatTypes) - bitsLib = libFromList (map (id *** mkBits) bitsTypes) boundedLib = libFromList (map (id *** mkBounded) boundedIntegerTypes) mkNullary :: Types -> EvalFunction @@ -125,35 +145,42 @@ where sfuncon [ADTVal "binary32" _] = rewritten $ typeVal $ cons Binary32 sfuncon [ADTVal "binary64" _] = rewritten $ typeVal $ cons Binary64 sfuncon vs = sortErr (tuple_val_ vs) "ieee-float not applied to ieee-format" - - mkBits :: (Int -> Types) -> EvalFunction - mkBits cons = StrictFuncon sfuncon - where sfuncon [v] | Nat n <- upcastNaturals v = - rewritten $ typeVal $ cons (fromInteger n) - sfuncon vs = sortErr (tuple_val_ vs) "bits not applied to naturals" - - mkBounded :: (Integer -> Integer -> Types) -> EvalFunction + mkBounded :: (Integer -> Types) -> EvalFunction mkBounded cons = StrictFuncon sfuncon - where sfuncon [v1,v2] - | Int i1 <- upcastIntegers v1, Int i2 <- upcastIntegers v2 = - rewritten $ typeVal $ cons i1 i2 - sfuncon v = sortErr (tuple_val_ v) "bounded-integers not applied to two integers" + where sfuncon [v1] + | Int i1 <- upcastIntegers v1 = + rewritten $ typeVal $ cons i1 + sfuncon v = sortErr (tuple_val_ v) "type not applied to an integer value" mkUnary :: (Types -> Types) -> EvalFunction mkUnary cons = StrictFuncon sfuncon where sfuncon [ComputationType (Type x)] = rewritten $ typeVal $ cons x - sfuncon _ = rewritten $ typeVal $ cons Values + sfuncon _ = rewritten $ typeVal $ cons VAL.Values mkBinary :: (Types -> Types -> Types) -> EvalFunction mkBinary cons = StrictFuncon sfuncon where sfuncon [ComputationType (Type x), ComputationType (Type y)] = rewritten $ typeVal $ Maps x y - sfuncon _ = rewritten $ typeVal $ cons Values Values + sfuncon _ = rewritten $ typeVal $ cons VAL.Values VAL.Values +app0_ :: ([Funcons] -> Funcons) -> Funcons +app0_ cons = cons [] + +app1_ :: ([Funcons] -> Funcons) -> Funcons -> Funcons +app1_ cons x = cons [x] + +app2_ :: ([Funcons] -> Funcons) -> Funcons -> Funcons -> Funcons +app2_ cons x y = cons [x,y] + +app3_ :: ([Funcons] -> Funcons) -> Funcons -> Funcons -> Funcons -> Funcons +app3_ cons x y z = cons [x,y,z] + + -- $cbsintro -- This section describes functions that extend the interpreter with -- backtracking and pattern-matching facilities. These functions -- are developed for compiling CBS funcon specifications to -- Haskell. To read about CBS we refer to --- The functions can be +-- . +-- The functions can be -- used for manual development of funcons, although this is not recommended. diff --git a/src/Funcons/Entities.hs b/src/Funcons/Entities.hs --- a/src/Funcons/Entities.hs +++ b/src/Funcons/Entities.hs @@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} module Funcons.Entities ( -- * Accessing entities @@ -7,11 +8,12 @@ -- ** inherited getInh, withInh, getInhPatt, withInhTerm, -- ** control - raiseSignal, receiveSignal, raiseTerm, receiveSignalPatt, + raiseSignal, receiveSignals, raiseTerm, receiveSignalPatt, + withControlTerm, getControlPatt, -- ** output writeOut, readOut, writeOutTerm, readOutPatt, -- ** input - assignInput, consumeInput, withExtraInput,withExactInput, + matchInput, withExtraInput,withExactInput, withExtraInputTerms, withExactInputTerms, -- * Default entity values EntityDefaults, EntityDefault(..), setEntityDefaults @@ -23,6 +25,7 @@ import Funcons.Exceptions import Funcons.Patterns +import Control.Applicative import Control.Arrow import qualified Data.Map as M import Data.Text @@ -40,16 +43,20 @@ | DefControl Name | DefInput Name -setEntityDefaults :: EntityDefaults -> MSOS Funcons -> MSOS Funcons +setEntityDefaults :: EntityDefaults -> MSOS StepRes -> MSOS StepRes setEntityDefaults [] msos = msos setEntityDefaults ((DefMutable nm f):rest) msos = liftRewrite (rewriteFuncons f) >>= \case - ValTerm v -> putMut nm v >> setEntityDefaults rest msos + ValTerm [v] -> putMut nm v >> setEntityDefaults rest msos + ValTerm vs -> liftRewrite $ exception f "default value evaluates to a sequence" _ -> liftRewrite $ exception f "default value requires steps to evaluate" setEntityDefaults ((DefInherited nm f):rest) msos = liftRewrite (rewriteFuncons f) >>= \case - ValTerm v -> withInh nm v (setEntityDefaults rest msos) + ValTerm [v] -> withInh nm v (setEntityDefaults rest msos) + ValTerm vs -> liftRewrite $ exception f "default value evaluates to a sequence" _ -> liftRewrite $ exception f "default value requires steps to evaluate" +setEntityDefaults ((DefControl nm):rest) msos = + withControl nm Nothing (setEntityDefaults rest msos) setEntityDefaults (_:rest) msos = setEntityDefaults rest msos ---------------------------------------------------- @@ -67,7 +74,7 @@ getMut :: Name -> MSOS Values getMut key = do rw <- giveMUT case M.lookup key rw of - Nothing -> error ("unknown mutable entity: " ++ unpack key) + Nothing -> return none__ Just v -> return v -- | Variant of 'getMut' that performs pattern-matching. @@ -79,7 +86,7 @@ modifyMUT :: Name -> (Values -> Values) -> MSOS () modifyMUT key f = do rw <- giveMUT newMUT (M.alter up key rw) - where up Nothing = error ("unknown mutable entity: " ++ unpack key) + where up Nothing = Just (f none__) up (Just x) = Just (f x) -- | Set the value of some mutable entity. @@ -89,7 +96,7 @@ -- | Variant of 'putMut' that applies substitution. putMutTerm :: Name -> FTerm -> Env -> MSOS () -putMutTerm nm term env = liftRewrite (subsAndRewrite term env) >>= putMut nm +putMutTerm nm term env = liftRewrite (subsAndRewritesToValue term env) >>= putMut nm newMUT :: Mutable -> MSOS () newMUT rw = MSOS $ \ctxt mut-> return (Right(), mut {mut_entities = rw}, mempty) @@ -98,18 +105,21 @@ -- input -- | Consume a single value from the input stream. -- | Throws an 'unsufficient input' exception, if not enough input is available. -consumeInput :: Name -> MSOS Values +consumeInput :: Name -> MSOS Funcons consumeInput nm = MSOS $ \ctxt mut -> case M.lookup nm (inp_es mut) of - Just (vss, mreadM) -> case attemptConsume vss of - Just (v,vss') -> - return (Right v, mut {inp_es = M.insert nm (vss',mreadM) (inp_es mut)},mempty) - Nothing -> case mreadM of - Nothing -> return (Left (ctxt2exception (InsufficientInput nm) ctxt), mut, mempty) - Just readM -> do v <- readM - return (Right v, mut, mempty) - Nothing -> error ("unknown input entity " ++ unpack nm) + Just (vss, mreadM) -> wrapAttempt ctxt mut vss mreadM + Nothing -> wrapAttempt ctxt mut [] (Just (def_fread ctxt nm)) where + wrapAttempt ctxt mut vss mreadM = case attemptConsume vss of + Just (v,vss') -> return + (Right (FValue v), mut {inp_es = M.insert nm (vss',mreadM) (inp_es mut)},mempty) + Nothing -> case mreadM of + Nothing -> return + (Left (ctxt2exception (InsufficientInput nm) ctxt), mut, mempty) + Just readM -> do v <- readM + return (Right v, mut, mempty) + attemptConsume :: [[a]] -> Maybe (a,[[a]]) attemptConsume [] = Nothing attemptConsume ((v:vs):vss) = Just (v,vs:vss) @@ -128,48 +138,51 @@ withExactInput = withInput True withInput :: Bool -> Name -> [Values] -> MSOS a -> MSOS a -withInput isExactInput nm vs (MSOS f) = MSOS $ \ctxt mut -> - case M.lookup nm (inp_es mut) of - Just (vss, mreadM) | let newInp = (vs:vss, if isExactInput then Nothing else mreadM) -> do +withInput isExactInput nm vs (MSOS f) = MSOS $ \ctxt mut -> do + let provideInput newInp mreadM = do (a,mut',wr') <- f ctxt mut{ inp_es = M.insert nm newInp (inp_es mut)} let (res,vss'') = case (inp_es mut') M.! nm of ([]:vss',_) -> (a, vss') _ -> (Left(ctxt2exception(InsufficientInputConsumed nm) ctxt), vss'') return (res, mut' {inp_es = M.insert nm (vss'',mreadM) (inp_es mut')}, wr') - Nothing -> error ("unknown input entity " ++ unpack nm) + case M.lookup nm (inp_es mut) of + Just (vss, mreadM) -> + provideInput (vs:vss, if isExactInput then Nothing else mreadM) mreadM + Nothing -> provideInput ([vs], Nothing) Nothing --- | Variant of 'consumeInput' that binds the given 'MetaVar' to the consumed +-- | Variant of 'consumeInput' that matches the given `VPattern` to the consumed -- value in the given 'Env'. -assignInput :: Name -> MetaVar -> Env -> MSOS Env -assignInput nm var env = do - v <- consumeInput nm - return (envInsert var (ValueTerm v) env) +matchInput :: Name -> VPattern -> Env -> MSOS Env +matchInput nm pat env = do + fs <- consumeInput nm + vs <- liftRewrite (rewritesToValues fs) + liftRewrite (vsMatch vs [pat] env) --- | Variant of withExtraInput' that performs substitution. +-- | Variant of 'withExtraInput' that performs substitution. withExtraInputTerms = withInputTerms False --- | Variant of withExactInput' that performs substitution. +-- | Variant of 'withExactInput' that performs substitution. withExactInputTerms = withInputTerms True withInputTerms :: Bool -> Name -> [FTerm] -> Env -> MSOS a -> MSOS a withInputTerms b nm fs env msos = do - vs <- liftRewrite (mapM (flip subsAndRewrite env) fs) + vs <- liftRewrite (mapM (flip subsAndRewritesToValue env) fs) withInput b nm vs msos -- control -- | Receive the value of a control entity from a given 'MSOS' computation. -receiveSignal :: Name -> MSOS a -> MSOS (a, Maybe Values) -receiveSignal key (MSOS f) = MSOS (\ctxt mut -> do +receiveSignals :: [Name] -> MSOS a -> MSOS (a, [Maybe Values]) +receiveSignals keys (MSOS f) = MSOS (\ctxt mut -> do (e_a, mut1, wr1) <- f ctxt mut case e_a of Left err -> return (Left err, mut1, wr1) - Right a -> return (Right (a,maybe Nothing id $ M.lookup key (ctrl_entities wr1)) - , mut1, wr1 {ctrl_entities = M.delete key (ctrl_entities wr1)})) + Right a -> return $ + (Right (a, Prelude.map (find (ctrl_entities wr1)) keys) + , mut1, wr1 {ctrl_entities = Prelude.foldr M.delete (ctrl_entities wr1) keys})) + where find m key = maybe Nothing id $ M.lookup key m -- | Variant of 'receiveSignal' that performs pattern-matching. -receiveSignalPatt :: Name -> Maybe VPattern -> MSOS Env -> MSOS Env -receiveSignalPatt nm mpat msos = do - (env, val) <- receiveSignal nm msos - liftRewrite (vMaybeMatch val mpat env) +receiveSignalPatt :: Maybe Values -> Maybe VPattern -> Env -> MSOS Env +receiveSignalPatt mval mpat env = liftRewrite (vMaybeMatch mval mpat env) -- | Signal a value of some control entity. raiseSignal :: Name -> Values -> MSOS () @@ -178,15 +191,49 @@ -- | Variant of 'raiseSignal' that applies substitution. raiseTerm :: Name -> FTerm -> Env -> MSOS () -raiseTerm nm term env = liftRewrite (subsAndRewrite term env) >>= raiseSignal nm +raiseTerm nm term env = liftRewrite (subsAndRewritesToValue term env) >>= raiseSignal nm +-- downwards control +-- | Set the value of an downwards control entity. +-- The new value is /only/ set for 'MSOS' computation given as a third argument. +withControl :: Name -> Maybe Values -> MSOS a -> MSOS a +withControl key mfct (MSOS f) = MSOS (\ctxt mut -> + let ctxt' = ctxt { dctrl_entities = M.insert key mfct (dctrl_entities ctxt) } + in f ctxt' mut) + +withControlTerm :: Name -> Maybe FTerm -> Env -> MSOS a -> MSOS a +withControlTerm nm mterm env msos = do + mfct <- case mterm of + Nothing -> return Nothing + Just term -> Just <$> liftRewrite (substitute_signal term env) + withControl nm mfct msos + +-- | Get the value of an down control entity. +getControl :: Name -> MSOS (Maybe Values) +getControl key = do + ro <- giveCTRL + case M.lookup key ro of + Nothing -> return Nothing + Just mv -> return mv + +-- | Version of 'getControl' that applies pattern-matching. +getControlPatt :: Name -> Maybe VPattern -> Env -> MSOS Env +getControlPatt nm mpat env = do + mpat' <- liftRewrite $ maybe (return Nothing) (fmap Just . flip substitute_patt_signal env) mpat + mfct <- getControl nm + liftRewrite (eval_catch (vMaybeMatch mfct mpat' env) >>= \case + Left (_,_,PatternMismatch _) -> return env --TODO suboptimal + Left exc -> rewrite_rethrow exc + Right env' -> return env') + + -- inherited -- | Get the value of an inherited entity. getInh :: Name -> MSOS Values getInh key = do ro <- giveINH case M.lookup key ro of - Nothing -> error ("unknown inherited entity: " ++ unpack key) + Nothing -> return none__ Just v -> return v -- | Version of 'getInh' that applies pattern-matching. @@ -205,7 +252,7 @@ -- | Variant of 'withInh' that performs substitution. withInhTerm :: Name -> FTerm -> Env -> MSOS a -> MSOS a withInhTerm nm term env msos = do - v <- liftRewrite $ (subsAndRewrite term env) + v <- liftRewrite $ (subsAndRewritesToValue term env) withInh nm v msos -- output @@ -216,9 +263,8 @@ -- | Variant of 'writeOut' that applies substitution. writeOutTerm :: Name -> FTerm -> Env -> MSOS () -writeOutTerm nm term env = liftRewrite (subsAndRewrite term env) >>= \case - (List values) -> writeOut nm values - v -> liftRewrite $ exception (FValue v) "Attempting to output a single value" +writeOutTerm nm term env = + liftRewrite (subsAndRewritesToValues term env) >>= writeOut nm -- | Read the values of a certain output entity. The output is obtained -- from the 'MSOS' computation given as a second argument. @@ -230,4 +276,4 @@ readOutPatt :: Name -> VPattern -> MSOS Env -> MSOS Env readOutPatt key pat msos = do (env, vals) <- readOut key msos - liftRewrite (vMatch (List vals) pat env) + liftRewrite (vMatch (ADTVal "list" (Prelude.map FValue vals)) pat env) diff --git a/src/Funcons/Exceptions.hs b/src/Funcons/Exceptions.hs --- a/src/Funcons/Exceptions.hs +++ b/src/Funcons/Exceptions.hs @@ -13,14 +13,15 @@ | PartialOp String | Internal String | NoRule + | NoMoreBranches | SideCondFail String | InsufficientInput Name | InsufficientInputConsumed Name | PatternMismatch String - | StepOnValue + | StepOnValue [Values] showIException :: IException -> String -showIException (f0,f,ie) = "Internal Exception: " ++ show ie ++ " on " ++ showFuncons f +showIException (f0,f,ie) = "Internal Exception: " ++ show ie ++ " on \n" ++ showFuncons f0 instance Show IE where show (SortErr err) = "dynamic sort check (" ++ err ++ ")" @@ -32,7 +33,8 @@ show (InsufficientInput nm) = "insufficient supply for " ++ unpack nm show (InsufficientInputConsumed nm) = "insufficient input consumed for entity " ++ unpack nm show (PartialOp str) = "partial operation" - show StepOnValue = "attempting to step a value" + show (NoMoreBranches) = "no more branches to try" + show (StepOnValue v) = "attempting to step a value: " ++ showValuesSeq v -- which exceptions stop a rule from executing so that the next one can be attempted? failsRule :: IException -> Bool @@ -40,7 +42,9 @@ failsRule (_,_,PatternMismatch _) = True failsRule (_,_,SortErr _) = True failsRule (_,_,PartialOp _) = True -failsRule (_,_,StepOnValue) = True +failsRule (_,_,StepOnValue _) = True +failsRule (_,_,NoMoreBranches) = True +failsRule (_,_,NoRule) = True failsRule _ = False diff --git a/src/Funcons/GLLParser.hs b/src/Funcons/GLLParser.hs new file mode 100644 --- /dev/null +++ b/src/Funcons/GLLParser.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.GLLParser where + +import Funcons.Types +import GLL.Combinators hiding (many, some, Char, parse) + +import Data.Char (isAlphaNum, isLower) +import Text.Regex.Applicative hiding ((<**>), optional) +import Data.Text (pack) +import Numeric + +type Parser a = BNF Token a + +fct_parse :: String -> Funcons +fct_parse = parser_a pFuncons + +fvalue_parse :: String -> Funcons +fvalue_parse = FValue . fvalue_parse_ + +fvalue_parse_ :: String -> Values +fvalue_parse_ = parser_a pValues + +parse :: Parser a -> String -> a +parse p str = case allParses p str of [] -> error "no parse" + (a:_) -> a + +parser_a :: Parser a -> String -> a +parser_a p string = case allParses p string of + [] -> error "no parse" + (f:_) -> f + +allParses :: Parser a -> String -> [a] +allParses p string = GLL.Combinators.parseWithOptions [throwErrors] p + (Funcons.GLLParser.lexer string) + +fct_lexerSettings = emptyLanguage { + lineComment = "//" + , identifiers = lName + , keywords = fct_keywords + , keychars = fct_keychars + } + +lexer = GLL.Combinators.lexer fct_lexerSettings + +fct_keywords = ["void", "depends", "forall", "type_abs" + ,"typevar", "?", "*", "+", "|->", "=>"] +fct_keychars = "{}(),'\"[]|^&~" + +lName = (:) <$> psym isLower <*> many (psym (\c -> isAlphaNum c || c == '-')) + +data FSuffix = SuffixComputesFrom Funcons + | SuffixSeq SeqSortOp + | SuffixSortUnion Funcons + | SuffixSortInter Funcons + | SuffixPower Funcons + +pFuncons :: Parser Funcons +pFuncons = "FUNCONS" + <:= FSet <$$> braces (multipleSepBy pFuncons (keychar ',')) +-- <||> FTuple <$$> parens (multipleSepBy pFuncons (keychar ',')) + <||> FApp "list" <$$> brackets (multipleSepBy pFuncons (keychar ',')) + <||> FMap . concat <$$> braces (multipleSepBy1 pKeyPair (keychar ',')) + <||> FSortComputes <$$ keyword "=>" <**> pFuncons + <||> FSortComplement <$$ keychar '~' <**> pFuncons + <||> suffix_select <$$> pFuncons <**> pFSuffix + <||> suffix_select <$$> parens pFuncons <**> pFSuffix + <||> maybe_apply . pack <$$> id_lit <**> optional pFunconss + <||> FValue <$$> pValues + where + maybe_apply nm Nothing = FName nm + maybe_apply nm (Just (Right args)) = FApp nm args + maybe_apply nm (Just (Left arg)) = FApp nm [arg] + + suffix_select f1 s = case s of + SuffixComputesFrom f2 -> FSortComputesFrom f1 f2 + SuffixSeq op -> FSortSeq f1 op + SuffixSortUnion f2 -> FSortUnion f1 f2 + SuffixSortInter f2 -> FSortInter f1 f2 + SuffixPower f2 -> FSortPower f1 f2 + + pFSuffix :: Parser FSuffix + pFSuffix = "FSUFFIX" + <:=> SuffixComputesFrom <$$ keyword "=>" <**> pFuncons + <||> SuffixSeq <$$> pOp + <||> SuffixSortUnion <$$ keychar '|' <**> pFuncons + <||> SuffixSortInter <$$ keychar '&' <**> pFuncons + <||> SuffixPower <$$ keychar '^' <**> pFuncons + +pFunconss :: Parser (Either Funcons [Funcons]) +pFunconss = "FUNCONS-SEQUENCE" + <::= Left <$$> pFuncons + <||> Right . merge <$$> parens (multipleSepBy pFunconss (keychar ',')) + where merge = foldr op [] + where op (Left f) acc = f:acc + op (Right fs) acc = fs++acc + +pFunconsSeq :: Parser [Funcons] +pFunconsSeq = "FUNCONS-SEQ" + <:=> either (:[]) id <$$> pFunconss + +pKeyPair :: Parser [Funcons] +pKeyPair = "KEYPAIR" <:=> + (\x y -> [x,y]) <$$> pFuncons <** keyword "|->" <**> pFuncons + +pOp :: Parser SeqSortOp +pOp = "OP" <:=> + StarOp <$$ keyword "*" + <||> PlusOp <$$ keyword "+" + <||> QuestionMarkOp <$$ keyword "?" + +pValues :: Parser Values +pValues = "VALUES" + <:=> Char <$$> char_lit + <||> string__ <$$> string_lit + <||> mk_integers . toInteger <$$> int_lit + <||> IEEE_Float_64 . fst . head . readFloat <$$> pRatioAsString + where pRatioAsString = "RATIOasSTRING" -- NOT OK, would parse "-2.-3" + <:=> (\m l -> show m ++ "." ++ show l) <$$> int_lit <** keychar '.' + <**> int_lit + + diff --git a/src/Funcons/Lexer.hs b/src/Funcons/Lexer.hs deleted file mode 100644 --- a/src/Funcons/Lexer.hs +++ /dev/null @@ -1,32 +0,0 @@ -module Funcons.Lexer where - -import Text.ParserCombinators.Parsec -import Text.ParserCombinators.Parsec.Language (emptyDef) -import qualified Text.ParserCombinators.Parsec.Token as P - -lexer = P.makeTokenParser emptyDef { P.identStart = letter - , P.identLetter = alphaNum <|> (char '-') - , P.reservedNames = [ "id", "void", "newline", "depends", "forall", "type_abs", "typevar", "atom", "?", "*", "+"] - , P.reservedOpNames = ["|->", "=>"] - , P.commentLine = "//" - } - -types_keywords = ["chars", "strings", "integers","meta", "atoms", "bounded-integers", "computation-types", "empty-type", "unicode-characters", "maps", "types", "algebraic-datatypes", "bits", "ieee-floats", "lists", "sets", "multisets", "vectors", "naturals", "rationals", "thunks", "tuples", "ascii-characters", "values", "unknown"] - -parens = P.parens lexer -brackets = P.brackets lexer -braces = P.braces lexer -identifier = P.identifier lexer -natural = P.natural lexer -reserved = P.reserved lexer -reservedOp = P.reservedOp lexer -comma = P.comma lexer -stringLiteral = P.stringLiteral lexer -period = P.dot lexer -commaSep = P.commaSep lexer -commaSep1 = P.commaSep1 lexer -whiteSpace = P.whiteSpace lexer -bar = whiteSpace *> char '|' <* whiteSpace -doubleArrow = whiteSpace *> reservedOp "=>" <* whiteSpace -barredArrow = whiteSpace *> reservedOp "|->" <* whiteSpace -barSep2 p = (:) <$> p <* bar <*> sepBy1 p bar diff --git a/src/Funcons/MSOS.hs b/src/Funcons/MSOS.hs --- a/src/Funcons/MSOS.hs +++ b/src/Funcons/MSOS.hs @@ -6,28 +6,35 @@ MSOS(..), Rewrite(..), liftRewrite, rewrite_rethrow, rewrite_throw, eval_catch, msos_throw, EvalFunction(..), Strictness(..), StrictFuncon, PartiallyStrictFuncon, NonStrictFuncon, ValueOp, NullaryFuncon, RewriteState(..), + StepRes, toStepRes, -- ** Entity-types Output, readOuts, Mutable, Inherited, giveINH, - Control, singleCTRL, + Control, singleCTRL, giveCTRL, Input, -- ** IMSOS helpers - applyFuncon, rewritten, rewriteTo, stepTo - , compstep, - norule, exception, sortErr, partialOp, internal, buildStep, + applyFuncon, rewritten, rewriteTo, rewriteSeqTo, stepTo, stepSeqTo,rewrittens, + compstep, + norule, exception, sortErr, partialOp, internal, buildStep, sidecond, -- *** Congruence rules premiseStepApp, premiseStep, premiseEval, -- ** Pattern Matching SeqSortOp(..), rewriteRules, stepRules, evalRules, MSOSState(..), emptyMSOSState, emptyRewriteState, MSOSReader(..),RewriteReader(..),showIException, MSOSWriter(..), RewriteWriterr(..), -- * Evaluation funcons TODO internal usage only (by Funcons.Tools) - Rewritten(..), rewriteFuncons, evalFuncons, stepTrans, emptyINH, Interactive(..), SimIO(..), + Rewritten(..), rewriteFuncons, rewriteFunconsWcount, evalFuncons + , stepTrans, rewritesToValue, rewritesToValues + , emptyDCTRL, emptyINH, Interactive(..), SimIO(..) + , rewriteToValErr, count_delegation, optRefocus + , evalStrictSequence, rewriteStrictSequence, evalSequence, -- * Values - showValues, showFuncons, + showTypes, showSorts, showValues, showValuesSeq, showFuncons, showFunconsSeq,traceLib, -- * Funcon libraries - FunconLibrary, libUnions, libEmpty, libUnion, libFromList, - evalctxt2exception, ctxt2exception, + FunconLibrary, libUnions, libOverrides, libEmpty, libUnion, libOverride, libFromList, + evalctxt2exception, ctxt2exception, fromSeqValOp, fromNullaryValOp, fromValOp, + -- * Counters + displayCounters, counterKeys, ppCounters, )where @@ -36,19 +43,53 @@ import Funcons.Printer import Funcons.Exceptions import Funcons.Simulation +import qualified Funcons.Operations as VAL +import Control.Applicative import Control.Arrow ((***)) import Control.Monad.Writer -import Data.Maybe (isJust, isNothing) -import Data.List (foldl') +import Data.Maybe (isJust, isNothing, fromJust) +import Data.List (foldl', intercalate) import Data.Text (unpack) import qualified Data.Map as M +import System.IO.Unsafe +--trace p b = unsafePerformIO (putStrLn p >> return b) +trace p b = b +traceLib :: FunconLibrary -> FunconLibrary +traceLib lib = unsafePerformIO + (putStrLn (unlines (map unpack (M.keys lib))) >> return lib) + + --------------------------------------------------------------------- -- | A funcon library maps funcon names to their evaluation functions. type FunconLibrary = M.Map Name EvalFunction +fromValOp = fromAbsValOp False +fromSeqValOp = fromAbsValOp True +fromAbsValOp :: Bool -> ([Funcons] -> Funcons) -> ([OpExpr Funcons] -> OpExpr Funcons) -> EvalFunction +fromAbsValOp seqRes cons mkExpr = ValueOp op + where op vs = report f seqRes (VAL.eval (mkExpr (map ValExpr vs))) + where f = cons (map FValue vs) +fromNullaryValOp :: ([Funcons] -> Funcons) -> ([OpExpr Funcons] -> OpExpr Funcons) -> EvalFunction +fromNullaryValOp cons mkExpr = NullaryFuncon op + where op = report (cons []) False (VAL.eval (mkExpr [])) + +report f seqRes res = case res of + Error _ (VAL.SortErr str) -> sortErr f str + Error _ (DomErr str) -> rewritten none__ + Error _ (ArityErr str) -> sortErr f str + Error _ (ProjErr str) -> sortErr f str + Error _ (Normal (FValue v)) -> rewritten' v + Error _ (Normal t) -> rewriteFuncons t + Success (FValue v) -> rewritten' v + Success t -> rewriteFuncons t + where rewritten' v | seqRes, ADTVal "list" fs <- v, + let mvs = map project fs, all isJust mvs + = rewrittens (map fromJust mvs) + | otherwise = rewritten v + -- | -- Evaluation functions capture the operational behaviour of a funcon. -- Evaluation functions come in multiple flavours, each with a different @@ -61,7 +102,7 @@ -- | Strict funcons whose arguments are evaluated. | StrictFuncon StrictFuncon -- | Funcons for which /some/ arguments are evaluated. - | PartiallyStrictFuncon [Strictness] NonStrictFuncon + | PartiallyStrictFuncon [Strictness] Strictness NonStrictFuncon -- | Synonym for 'StrictFuncon', for value operations. | ValueOp ValueOp -- | Funcons without any arguments. @@ -86,12 +127,16 @@ -- computational steps. data Rewritten = -- | Fully rewritten to a value. - ValTerm Values + ValTerm [Values] -- | Fully rewritten to a term and the step required to continue evaluation. - | CompTerm Funcons (MSOS Funcons) + | CompTerm Funcons (MSOS StepRes) +-- | A single step on a funcon term produces either a funcon term +-- or a (possibly empty or unary) sequence of values +type StepRes = Either Funcons [Values] + instance Show Rewritten where - show (ValTerm v) = showValues v + show (ValTerm vs) = showValuesSeq vs show (CompTerm _ _) = "" -- | Creates an empty 'FunconLibrary'. @@ -103,11 +148,19 @@ libUnion = M.unionWithKey op where op k x _ = error ("duplicate funcon name: " ++ unpack k) +-- | Right-based union of 'FunconLibrary's +libOverride :: FunconLibrary -> FunconLibrary -> FunconLibrary +libOverride = flip M.union + -- | Unites a list of 'FunconLibrary's. libUnions :: [FunconLibrary] -> FunconLibrary libUnions = foldl' libUnion libEmpty where op _ _ = error ("duplicate funcon name") +-- | Right-based union of list of 'FunconLibrary's +libOverrides :: [FunconLibrary] -> FunconLibrary +libOverrides = M.unions . reverse + -- | Creates a 'FunconLibrary' from a list. libFromList :: [(Name, EvalFunction)] -> FunconLibrary libFromList = M.fromList @@ -124,7 +177,7 @@ --------------------------------------------------------------------------- data RewriteReader = RewriteReader { funconlib :: FunconLibrary - , ty_env :: TypeEnv, run_opts :: RunOptions + , ty_env :: TypeRelation, run_opts :: RunOptions , global_fct :: Funcons, local_fct :: Funcons } data RewriteState = RewriteState { } emptyRewriteState = RewriteState @@ -181,28 +234,33 @@ rewrite_rethrow ie = Rewrite $ \ctxt st -> (Left ie, st, mempty) rewrite_throw :: IE -> Rewrite a -rewrite_throw ie = Rewrite $ \ctxt st -> - (Left (global_fct ctxt, local_fct ctxt, ie), st, mempty) +rewrite_throw ie = Rewrite $ \ctxt st -> (Left (evalctxt2exception ie ctxt), st, mempty) evalctxt2exception :: IE -> RewriteReader -> IException evalctxt2exception ie ctxt = (global_fct ctxt, local_fct ctxt, ie) -ctxt2exception :: IE -> MSOSReader -> IException +ctxt2exception :: IE -> MSOSReader m -> IException ctxt2exception ie ctxt = (global_fct (ereader ctxt), local_fct (ereader ctxt), ie) -rewriteRules :: Funcons -> [Rewrite Rewritten] -> Rewrite Rewritten -rewriteRules f [] = norule f -rewriteRules f (t1:ts) = Rewrite $ \ctxt st -> +rewriteRules :: [Rewrite Rewritten] -> Rewrite Rewritten +rewriteRules [] = rewrite_throw NoMoreBranches +rewriteRules (t1:ts) = Rewrite $ \ctxt st -> let (rw_res, st', rw_cs) = runRewrite t1 ctxt st in case rw_res of Left ie| failsRule ie -> -- resets state - runRewrite (rewriteRules f ts) ctxt st + trace (showIException ie) $ runRewrite (do + count_backtrack_in + addToRCounter (counters rw_cs) + rewriteRules ts) ctxt st _ -> (rw_res, st', rw_cs) --------------------------------------------------------------------------- -data MSOSReader = MSOSReader { ereader :: RewriteReader, inh_entities :: Inherited} +data MSOSReader m = MSOSReader{ ereader :: RewriteReader + , inh_entities :: Inherited + , dctrl_entities :: DownControl + , def_fread :: Name -> m Funcons} data MSOSWriter = MSOSWriter { ctrl_entities :: Control, out_entities :: Output , ewriter :: RewriteWriterr } data MSOSState m = MSOSState { inp_es :: Input m, mut_entities :: Mutable @@ -212,7 +270,7 @@ -- | Monadic type for the propagation of semantic entities and meta-information -- on the evaluation of funcons. The meta-information includes a library --- of funcons (see 'FunconLibrary'), a typing environment (see 'TypeEnv'), +-- of funcons (see 'FunconLibrary'), a typing environment (see 'TypeRelation'), -- runtime options, etc. -- -- The semantic entities are divided into five classes: @@ -234,7 +292,7 @@ -- This enables modular access to the entities. newtype MSOS a = MSOS { runMSOS :: forall m. Interactive m => - (MSOSReader -> MSOSState m + (MSOSReader m -> MSOSState m -> m (Either IException a, MSOSState m, MSOSWriter)) } instance Applicative MSOS where @@ -264,13 +322,18 @@ -- | A map storing the values of /mutable/ entities. type Mutable = M.Map Name Values -stepRules :: [MSOS Funcons] -> MSOS Funcons -stepRules [] = msos_throw NoRule -stepRules (t1:ts) = MSOS $ \ctxt mut -> do +stepRules = stepARules NoMoreBranches count_backtrack_in + +stepARules :: IE -> Rewrite () -> [MSOS StepRes] -> MSOS StepRes +stepARules exc _ [] = msos_throw exc +stepARules exc counter (t1:ts) = MSOS $ \ctxt mut -> do (e_ie_a, mut', wr) <- runMSOS t1 ctxt mut case e_ie_a of Left ie | failsRule ie -> -- resets input & read/write entities - runMSOS (stepRules ts) ctxt mut + trace (showIException ie) $ runMSOS (do + liftRewrite counter + addToCounter (counters (ewriter wr)) + stepARules exc counter ts) ctxt mut _ -> return (e_ie_a, mut', wr) -- | Function 'evalRules' implements a backtracking procedure. @@ -290,14 +353,17 @@ -- -- When no rules are successfully executed to completetion a -- 'no rule exception' is thrown. -evalRules :: [Rewrite Rewritten] -> [MSOS Funcons] -> Rewrite Rewritten -evalRules [] msoss = buildStep (stepRules msoss) +evalRules :: [Rewrite Rewritten] -> [MSOS StepRes] -> Rewrite Rewritten +evalRules [] msoss = buildStep (stepARules NoRule count_backtrack_out msoss) evalRules ((Rewrite rw_rules):rest) msoss = Rewrite $ \ctxt st -> - let (rw_res, st', cs) = rw_rules ctxt st + let (rw_res, st', wo) = rw_rules ctxt st in case rw_res of Left ie | failsRule ie -> --resets counters and state - runRewrite (evalRules rest msoss) ctxt st - _ -> (rw_res, st', cs) + trace (showIException ie) $ runRewrite (do + count_backtrack_out + addToRCounter (counters wo) + evalRules rest msoss) ctxt st + _ -> (rw_res, st', wo) msos_throw :: IE -> MSOS b msos_throw = liftRewrite . rewrite_throw @@ -310,13 +376,13 @@ giveINH :: MSOS Inherited giveINH = MSOS $ \ctxt mut -> return (Right (inh_entities ctxt), mut, mempty) +giveCTRL :: MSOS DownControl +giveCTRL = MSOS $ \ctxt mut -> return (Right (dctrl_entities ctxt), mut, mempty) + doRefocus :: MSOS Bool doRefocus = MSOS $ \ctxt mut -> return (Right $ do_refocus (run_opts (ereader ctxt)), mut, mempty) -modifyCTXT :: (MSOSReader -> MSOSReader) -> MSOS a -> MSOS a -modifyCTXT mod (MSOS f) = MSOS (\ctxt mut -> f (mod ctxt) mut) - modifyRewriteCTXT :: (RewriteReader -> RewriteReader) -> Rewrite a -> Rewrite a modifyRewriteCTXT mod (Rewrite f) = Rewrite (f . mod) ----------------- @@ -330,7 +396,11 @@ ---------- -- | a map storing the values of /control/ entities. type Control = M.Map Name (Maybe Values) +type DownControl = M.Map Name (Maybe Values) +emptyDCTRL :: DownControl +emptyDCTRL = M.empty + emptyCTRL :: Control emptyCTRL = M.empty @@ -359,40 +429,57 @@ , mut1, wr1 { out_entities = mempty})) ----------- -- | A map storing the values of /input/ entities. -type Input m = M.Map Name ([[Values]], Maybe (m Values)) +type Input m = M.Map Name ([[Values]], Maybe (m Funcons)) ----------- --- steps, rewrites, restarts, refocus, delegations -data Counters = Counters !Int !Int !Int !Int !Int +-- steps, rewrites, restarts, refocus, delegations, backtracking (outer/inner) +data Counters = Counters !Int !Int !Int !Int !Int !Int !Int !Int instance Monoid Counters where - mempty = Counters 0 0 0 0 0 - (Counters x1 x2 x3 x4 x5) `mappend` (Counters y1 y2 y3 y4 y5) = - Counters (x1+y1) (x2+y2) (x3+y3) (x4+y4) (x5+y5) + mempty = Counters 0 0 0 0 0 0 0 0 + (Counters x1 x2 x3 x4 x5 x6 x7 x8) `mappend` (Counters y1 y2 y3 y4 y5 y6 y7 y8) = + Counters (x1+y1) (x2+y2) (x3+y3) (x4+y4) (x5+y5) (x6+y6) (x7+y7) (x8+y8) -emptyCounters :: Int -> Int -> Int -> Int -> Int -> MSOSWriter -emptyCounters x1 x2 x3 x4 x5 = - mempty { ewriter = mempty {counters = Counters x1 x2 x3 x4 x5 }} +emptyCounters x1 x2 x3 x4 x5 x6 x7 x8 = + mempty { ewriter = mempty {counters = Counters x1 x2 x3 x4 x5 x6 x7 x8}} +addToCounter :: Counters -> MSOS () +addToCounter cs = MSOS $ \_ mut -> return (Right(), mut, mempty { ewriter = mempty { counters = cs } }) + +addToRCounter :: Counters -> Rewrite () +addToRCounter cs = Rewrite $ \_ mut -> (Right(), mut, mempty { counters = cs }) + count_step :: MSOS () -count_step = MSOS $ \_ mut -> return (Right (), mut, emptyCounters 1 0 0 0 0) +count_step = MSOS $ \_ mut -> return (Right (), mut, emptyCounters 1 0 0 0 0 0 0 0) count_delegation :: MSOS () -count_delegation = MSOS $ \_ mut -> return (Right (), mut, emptyCounters 0 0 0 0 1) +count_delegation = MSOS $ \_ mut -> return (Right (), mut, emptyCounters 0 0 0 0 0 1 0 0) -count_refocus = MSOS $ \_ mut -> return (Right (), mut, emptyCounters 0 0 0 1 0) +count_refocus = MSOS $ \_ mut -> return (Right (), mut, emptyCounters 0 0 0 0 1 0 0 0) count_restart :: MSOS () -count_restart = MSOS $ \_ mut -> return (Right (), mut, emptyCounters 0 0 1 0 0) +count_restart = MSOS $ \_ mut -> return (Right (), mut, emptyCounters 0 0 0 1 0 0 0 0) count_rewrite :: Rewrite () -count_rewrite = Rewrite $ \_ st -> (Right (), st, mempty { counters = Counters 0 1 0 0 0 }) +count_rewrite = Rewrite $ \_ st -> (Right (), st, mempty { counters = Counters 0 1 0 0 0 0 0 0}) -instance Show Counters where - show (Counters steps rewrites restarts refocus delegations) = - "number of (restarts, rewrites, steps, refocus, premises): " ++ - show (restarts, rewrites, steps, refocus, delegations) +count_rewrite_attempt :: Rewrite () +count_rewrite_attempt = Rewrite $ \_ st -> (Right (), st, mempty { counters = Counters 0 0 1 0 0 0 0 0}) +count_backtrack_out :: Rewrite () +count_backtrack_out = Rewrite $ \_ st -> (Right (), st, mempty { counters = Counters 0 0 0 0 0 0 1 0 }) + +count_backtrack_in :: Rewrite () +count_backtrack_in = Rewrite $ \_ st -> (Right (), st, mempty { counters = Counters 0 0 0 0 0 0 0 1 }) + +ppCounters cs = + "number of (" ++ counterKeys ++ "): (" ++ displayCounters cs ++ ")" + +counterKeys = "restarts,rewrites,(attempts),steps,refocus,premises,backtracking(outer),backtracking(inner)" +displayCounters (Counters steps rewrites rattempts restarts refocus delegations bout bin) = + intercalate "," $ + map show [restarts, rewrites, rattempts, steps, refocus, delegations, bout, bin] + -- | Yields an error signaling that no rule is applicable. -- The funcon term argument may be used to provide a useful error message. norule :: Funcons -> Rewrite a @@ -419,48 +506,68 @@ internal :: String -> Rewrite a internal str = rewrite_throw (Internal str) +sidecond :: String -> Rewrite a +sidecond str = rewrite_throw (SideCondFail str) -buildStep :: MSOS Funcons -> Rewrite Rewritten +buildStep :: MSOS StepRes -> Rewrite Rewritten buildStep = buildStepCounter (return ()) -- does not count -buildStepCount :: MSOS Funcons -> Rewrite Rewritten +buildStepCount :: MSOS StepRes -> Rewrite Rewritten buildStepCount = buildStepCounter count_delegation -buildStepCounter :: MSOS () -> MSOS Funcons -> Rewrite Rewritten +buildStepCounter :: MSOS () -> MSOS StepRes -> Rewrite Rewritten buildStepCounter counter mf = compstep (counter >> mf) -optRefocus :: MSOS Funcons -> MSOS Funcons +optRefocus :: MSOS StepRes -> MSOS StepRes optRefocus stepper = doRefocus >>= \case True -> refocus stepper False -> stepper -refocus :: MSOS Funcons -> MSOS Funcons +refocus :: MSOS StepRes -> MSOS StepRes refocus stepper -- stop refocussing when a signal has been raised = count_refocus >> if_violates_refocus stepper return continue - where continue f | isVal f = return f - | otherwise = refocus (evalFuncons f) + where continue = \case + Right vs -> return (Right vs) + Left f -> + liftRewrite (rewriteFuncons f) >>= \case + ValTerm [v] -> return (Right [v]) + ValTerm vs -> return (Left f) -- undo rewrites and accept last step + res -> refocus $ stepRewritten res -stepRewritten :: Rewritten -> MSOS Funcons -stepRewritten (ValTerm v) = return (FValue v) +stepRewritten :: Rewritten -> MSOS StepRes +stepRewritten (ValTerm vs) = return (Right vs) stepRewritten (CompTerm _ step) = count_step >> step -- | Returns a value as a fully rewritten term. rewritten :: Values -> Rewrite Rewritten -rewritten = return . ValTerm +rewritten = return . ValTerm . (:[]) +rewrittens :: [Values] -> Rewrite Rewritten +rewrittens = return . ValTerm + -- | Yield a funcon term as the result of a syntactic rewrite. -- This function must be used instead of @return@. -- The given term is fully rewritten. rewriteTo :: Funcons -> Rewrite Rewritten -- only rewrites, no possible signal rewriteTo f = count_rewrite >> rewriteFuncons f +-- | Yield a sequence of funcon terms as the result of a rewrite. +-- This is only valid when all terms rewrite to a value +rewriteSeqTo :: [Funcons] -> Rewrite Rewritten +rewriteSeqTo fs = count_rewrite >> (ValTerm <$> rewriteStrictSequence fs) + -- | Yield a funcon term as the result of an 'MSOS' computation. -- This function must be used instead of @return@. -stepTo :: Funcons -> MSOS Funcons -stepTo f = return f +stepTo :: Funcons -> MSOS StepRes +stepTo = return . Left -if_abruptly_terminates :: Bool -> MSOS Funcons -> (Funcons -> MSOS Funcons) - -> (Funcons -> MSOS Funcons) -> MSOS Funcons +-- | Yield a sequence of funcon terms as the result of a computation. +-- This is only valid when all terms rewrite to a value +stepSeqTo :: [Funcons] -> MSOS StepRes +stepSeqTo fs = Right <$> liftRewrite (rewriteStrictSequence fs) + +if_abruptly_terminates :: Bool -> MSOS StepRes -> (StepRes -> MSOS StepRes) + -> (StepRes -> MSOS StepRes) -> MSOS StepRes if_abruptly_terminates care (MSOS fstep) abr no_abr = MSOS $ \ctxt mut -> fstep ctxt mut >>= \case (Right f', mut', wr') -> @@ -471,14 +578,17 @@ return (e_f'', mut'', wr' <> wr'') norule_res -> return norule_res -if_violates_refocus :: MSOS Funcons -> (Funcons -> MSOS Funcons) - -> (Funcons -> MSOS Funcons) -> MSOS Funcons +-- TODO is input test accurate? +-- TODO We should also find changes to mutable entities +if_violates_refocus :: MSOS StepRes -> (StepRes -> MSOS StepRes) + -> (StepRes -> MSOS StepRes) -> MSOS StepRes if_violates_refocus (MSOS fstep) viol no_viol = MSOS $ \ctxt mut -> fstep ctxt mut >>= \case (Right f', mut', wr') -> let violates = any isJust (ctrl_entities wr') || any (not . null) (out_entities wr') || any (isNothing . snd) (inp_es mut') +-- || any isJust (dctrl_entities ctxt) MSOS fstep | violates = viol f' | otherwise = no_viol f' in do (e_f'', mut'', wr'') <- fstep ctxt mut' @@ -486,84 +596,156 @@ norule_res -> return norule_res -- | Execute a premise as either a rewrite or a step. --- Depending on whether rewrites were performed or a step was performed +-- Depending on whether only rewrites are necessary to yield a value, +-- or whether a computational step is necessary, -- a different continuation is applied (first and second argument). -- Example usage: -- -- @ -- stepScope :: NonStrictFuncon --strict in first argument -- stepScope [FValue (Map e1), x] = premiseEval x rule1 step1 --- where rewrite1 v = rewritten v +-- where rule1 v = rewritten v -- step1 stepX = do -- Map e0 <- getInh "environment" -- x' <- withInh "environment" (Map (union e1 e0)) stepX -- stepTo (scope_ [FValue e1, x']) -- @ -premiseEval :: (Values -> Rewrite Rewritten) -> (MSOS Funcons -> MSOS Funcons) -> +premiseEval :: ([Values] -> Rewrite Rewritten) -> (MSOS StepRes -> MSOS StepRes) -> Funcons -> Rewrite Rewritten premiseEval vapp fapp f = rewriteFuncons f >>= \case - ValTerm v -> vapp v + ValTerm vs -> vapp vs CompTerm _ step -> buildStepCount (optRefocus (fapp step)) -premiseCont :: (Funcons -> Funcons) -> Funcons -> MSOS Funcons -premiseCont app f = liftRewrite (rewriteFuncons f) >>= \case - ValTerm v -> msos_throw StepOnValue - CompTerm _ step -> app <$> (count_delegation >> optRefocus step) - -premiseStepApp :: (Funcons -> Funcons) -> Funcons -> MSOS Funcons -premiseStepApp app f = premiseCont app f - -- | Execute a computational step as a /premise/. -- The result of the step is the returned funcon term. -premiseStep :: Funcons -> MSOS Funcons -premiseStep = premiseStepApp id +premiseStepApp :: (StepRes -> StepRes) -> Funcons -> MSOS StepRes +premiseStepApp app f = liftRewrite (rewriteFuncons f) >>= \case + ValTerm vs -> msos_throw (StepOnValue vs) + CompTerm _ step -> app <$> (count_delegation >> optRefocus step) +premiseStep :: Funcons -> MSOS StepRes +premiseStep = premiseStepApp id + ----- main `step` function -evalFuncons :: Funcons -> MSOS Funcons +evalFuncons :: Funcons -> MSOS StepRes evalFuncons f = liftRewrite (rewriteFuncons f) >>= stepRewritten +rewritesToValue :: Funcons -> Rewrite Values +rewritesToValue f = do + rewriteFunconsWcount f >>= \case + ValTerm [v] -> return v + _ -> rewriteToValErr + +rewritesToValues :: Funcons -> Rewrite [Values] +rewritesToValues f = do + rewriteFunconsWcount f >>= \case + ValTerm vs -> return vs + _ -> rewriteToValErr + +rewriteToValErr = rewrite_throw $ + SideCondFail "side-condition/entity-value/annotation evaluation requires step" + +rewriteFunconsWcount :: Funcons -> Rewrite Rewritten +rewriteFunconsWcount f = count_rewrite_attempt >> rewriteFuncons f + rewriteFuncons :: Funcons -> Rewrite Rewritten -rewriteFuncons f = modifyRewriteCTXT (\ctxt -> ctxt {local_fct = f}) (rewriteFuncons' f) +rewriteFuncons f = modifyRewriteCTXT (\ctxt -> ctxt{local_fct = f}) (rewriteFuncons' f) where - rewriteFuncons' (FValue v) = return (ValTerm v) - rewriteFuncons' (FTuple fs) = let fmops = tupleTypeTemplate fs - in if any (isJust . snd) fmops - then rewritten . typeVal =<< evalTupleType fmops - else evalStrictSequence fs safe_tuple_val FTuple - rewriteFuncons' (FList fs) = evalStrictSequence fs List FList - rewriteFuncons' (FSet fs) = evalStrictSequence fs setval_ FSet - rewriteFuncons' (FMap fs) = evalStrictSequence fs mapval_ FMap - rewriteFuncons' f@(FSortSeq s1 op) = - internal ("naked sequence-sort appearing outside of tuple-notation: " ++ showFuncons f) + rewriteFuncons' (FValue v) = return (ValTerm [v]) +{- rewriteFuncons' (FTuple fs) = + let fmops = tupleTypeTemplate fs + in if any (isJust . snd) fmops + -- sequence contains a sequence-operator, thus is a sequence of sorts + then rewritten . typeVal =<< evalTupleType fmops + -- regular sequence + else evalStrictSequence fs (rewritten . safe_tuple_val) FTuple +-} +-- rewriteFuncons' (FList fs) = evalStrictSequence fs (rewritten . List) FList + rewriteFuncons' (FSet fs) = evalStrictSequence fs (rewritten . setval_) FSet + rewriteFuncons' (FMap fs) = evalStrictSequence fs (rewritten . mapval_) FMap + rewriteFuncons' f@(FSortPower s1 fn) = case (s1,fn) of + (FValue mty@(ComputationType _), FValue v) + | Nat n <- upcastNaturals v -> + rewrittens (replicate (fromInteger n) (ComputationType (Type (downcastValueType mty)))) + (FValue mty, _) -> rewriteFuncons fn >>= \case + ValTerm [v] -> rewriteFuncons $ FSortPower s1 (FValue v) + ValTerm _ -> sortErr f "second operand of ^ cannot compute a sequence" + CompTerm _ mf -> flattenApplyWithExc ie (FSortPower s1) mf + where ie = SortErr "^_ multiadic argument" + _ -> rewriteFuncons s1 >>= \case + ValTerm [v] -> rewriteFuncons $ FSortPower (FValue v) fn + ValTerm _ -> sortErr f "first operand of ^ cannot compute a sequence" + CompTerm _ mf -> flattenApplyWithExc ie (flip FSortPower fn) mf + where ie = SortErr "_^ multiadic argument" + rewriteFuncons' f@(FSortSeq s1 op) = case s1 of + (FValue (ComputationType (Type ty))) -> rewritten $ ComputationType $ Type $ AnnotatedType ty op + (FValue _) -> sortErr (FSortSeq s1 op) "sort-sequence operator not on type" + _ -> rewriteFuncons s1 >>= \case + ValTerm [v1] -> rewriteFuncons $ FSortSeq (FValue v1) op + ValTerm vs -> sortErr (FSortSeq s1 op) "operand of sort-sequence operator cannot compute a sequence" + CompTerm _ mf -> flattenApplyWithExc ie (flip FSortSeq op) mf + where ie = SortErr "sort-sequence operator, multiadic argument" rewriteFuncons' (FSortComputes f1) = case f1 of (FValue (ComputationType (Type ty))) -> rewritten $ ComputationType $ ComputesType ty (FValue _) -> sortErr (FSortComputes f1) "=> not applied to a type" _ -> rewriteFuncons f1 >>= \case - ValTerm v1 -> rewriteFuncons $ FSortComputes (FValue v1) - CompTerm _ mf -> compstep (FSortComputes <$> mf) + ValTerm [v1] -> rewriteFuncons $ FSortComputes (FValue v1) + ValTerm vs -> sortErr (FSortComputes f1) "operand of => cannot compute a sequence" + CompTerm _ mf -> flattenApplyWithExc ie FSortComputes mf + where ie = SortErr "=>_ multiadic argument" rewriteFuncons' (FSortComputesFrom f1 f2) = case (f1,f2) of (FValue (ComputationType (Type ty1)),FValue (ComputationType (Type ty2))) -> rewritten $ ComputationType (ComputesFromType ty1 ty2) (FValue _, FValue _) -> sortErr (FSortComputesFrom f1 f2) "=> not applied to types" (FValue (ComputationType (Type ty1)),_) -> rewriteFuncons f2 >>= \case - ValTerm v2 -> rewriteFuncons $ FSortComputesFrom f1 (FValue v2) - CompTerm _ mf -> compstep (FSortComputesFrom f1 <$> mf) + ValTerm [v2] -> rewriteFuncons $ FSortComputesFrom f1 (FValue v2) + ValTerm _ -> sortErr (FSortComputesFrom f1 f2) "second operand of => cannot compute a sequence" + CompTerm _ mf -> flattenApplyWithExc ie (FSortComputesFrom f1) mf + where ie = SortErr "_=>_ multiadic operand (2)" (_,_) -> rewriteFuncons f1 >>= \case - ValTerm v1 -> rewriteFuncons $ FSortComputesFrom (FValue v1) f2 - CompTerm _ mf -> compstep (flip FSortComputesFrom f2 <$> mf) + ValTerm [v1] -> rewriteFuncons $ FSortComputesFrom (FValue v1) f2 + ValTerm _ -> sortErr (FSortComputesFrom f1 f2) "_=>_ multiadic operand (1)" + CompTerm _ mf -> flattenApplyWithExc ie (flip FSortComputesFrom f2) mf + where ie = SortErr "_=>_ multiadic operand (1)" rewriteFuncons' (FSortUnion s1 s2) = case (s1, s2) of (FValue (ComputationType (Type t1)) , FValue (ComputationType (Type t2))) -> rewritten $ typeVal $ Union t1 t2 (FValue _, FValue _) -> sortErr (FSortUnion s1 s2) "sort-union not applied to two sorts" - (FValue v1, _) -> do rewriteFuncons s2 >>= \case - ValTerm v2 -> rewriteFuncons $ FSortUnion s1 (FValue v2) - CompTerm _ mf -> compstep (FSortUnion s1 <$> mf) + (FValue v1, _) -> rewriteFuncons s2 >>= \case + ValTerm [v2] -> rewriteFuncons $ FSortUnion s1 (FValue v2) + ValTerm _ -> sortErr (FSortUnion s1 s2) "sort-union multiadic argument (2)" + CompTerm _ mf -> flattenApplyWithExc ie (FSortUnion s1) mf + where ie = SortErr "sort-union multiadic argument (2)" + _ -> rewriteFuncons s1 >>= \case + ValTerm [v] -> rewriteFuncons $ FSortUnion (FValue v) s2 + ValTerm _ -> sortErr (FSortUnion s1 s2) "sort-union multiadic argument (1)" + CompTerm _ mf -> flattenApplyWithExc ie (flip FSortUnion s2) mf + where ie = SortErr "sort-union multiadic argument (1)" + rewriteFuncons' (FSortInter s1 s2) = case (s1, s2) of + (FValue (ComputationType (Type t1)) + , FValue (ComputationType (Type t2))) -> rewritten $ typeVal $ Intersection t1 t2 + (FValue _, FValue _) -> sortErr (FSortInter s1 s2) "sort-intersection not applied to two sorts" + (FValue v1, _) -> rewriteFuncons s2 >>= \case + ValTerm [v2] -> rewriteFuncons $ FSortInter s1 (FValue v2) + ValTerm _ -> sortErr (FSortInter s1 s2) "sort-intersection multiadic argument (2)" + CompTerm _ mf -> flattenApplyWithExc ie (FSortInter s1) mf + where ie = SortErr "sort-intersection multiadic argument (2)" _ -> do rewriteFuncons s1 >>= \case - ValTerm v -> rewriteFuncons $ FSortUnion (FValue v) s2 - CompTerm _ mf -> compstep (flip FSortUnion s2 <$> mf) - rewriteFuncons' (FName nm) = + ValTerm [v1] -> rewriteFuncons $ FSortInter (FValue v1) s2 + ValTerm _ -> sortErr (FSortInter s1 s2) "sort-intersection multiadic argument (1)" + CompTerm _ mf -> flattenApplyWithExc ie (flip FSortInter s2) mf + where ie = SortErr "sort-intersection multiadic argument (1)" + rewriteFuncons' (FSortComplement s1) = case s1 of + FValue (ComputationType (Type t1)) -> rewritten $ typeVal $ Complement t1 + FValue _ -> sortErr (FSortComplement s1) "sort-complement not applied to a sort" + _ -> do rewriteFuncons s1 >>= \case + ValTerm [v] -> rewriteFuncons $ FSortComplement (FValue v) + ValTerm vs -> sortErr (FSortComplement s1) "sort-complement multiadic argument" + CompTerm _ mf -> flattenApplyWithExc ie FSortComplement mf + where ie = SortErr "sort-complement multiadic argument" + rewriteFuncons' (FName nm) = do mystepf <- lookupFuncon nm case mystepf of NullaryFuncon mystep -> mystep @@ -571,39 +753,42 @@ rewriteFuncons' (FApp nm arg) = do mystepf <- lookupFuncon nm case mystepf of - NullaryFuncon _ -> exception (FApp nm arg) ("nullary funcon " ++ unpack nm ++ " applied to arguments") - ValueOp mystep -> rewriteFuncons arg >>= - \case ValTerm v -> mystep (tuple_unval v) - CompTerm _ mf -> compstep (FApp nm <$> mf) - StrictFuncon mystep -> rewriteFuncons arg >>= - \case ValTerm v -> mystep (tuple_unval v) - CompTerm _ mf -> compstep (FApp nm <$> mf) - NonStrictFuncon mystep -> case arg of - FTuple fs -> mystep fs - _ -> exception (FApp nm arg) ("lazy funcon " ++ unpack nm ++ " not applied to a tuple of arguments") - PartiallyStrictFuncon strns mystep -> case arg of - FTuple fs -> evalSequence strns fs mystep (applyFuncon nm) - _ -> exception (FApp nm arg) ("partially lazy funcon " ++ unpack nm ++ " not applied to a tuple of arguments") + NullaryFuncon _ -> exception (FApp nm arg) ("nullary funcon " ++ unpack nm ++ " applied to arguments: " ++ (showFunconsSeq arg)) + ValueOp mystep -> evalStrictSequence arg mystep (applyFuncon nm) + StrictFuncon mystep -> evalStrictSequence arg mystep (applyFuncon nm) + NonStrictFuncon mystep -> mystep arg + PartiallyStrictFuncon strns strn mystep -> + evalSequence (strns ++ repeat strn) arg mystep (applyFuncon nm) ---OPT: replace by specialised veriant of evalSequence -evalStrictSequence :: [Funcons] -> ([Values] -> Values) -> ([Funcons] -> Funcons) -> Rewrite Rewritten +rewriteStrictSequence :: [Funcons] -> Rewrite [Values] +rewriteStrictSequence fs = case rest of + [] -> return (map downcastValue vs) + (x:xs) -> rewriteFuncons x >>= \case + ValTerm vs' -> rewriteStrictSequence (vs++map FValue vs'++xs) + CompTerm f0 mf -> internal ("step on sequence of computations: " ++ show fs) + where (vs, rest) = span (not . hasStep) fs + +--OPT: replace by specialised variant of evalSequence +evalStrictSequence :: [Funcons] -> ([Values] -> Rewrite Rewritten) -> ([Funcons] -> Funcons) -> Rewrite Rewritten evalStrictSequence args cont cons = evalSequence (replicate (length args) Strict) args - (return . ValTerm . cont . map downcastValue) cons + (cont . map downcastValue) cons evalSequence :: [Strictness] -> [Funcons] -> ([Funcons] -> Rewrite Rewritten) -> ([Funcons] -> Funcons) -> Rewrite Rewritten evalSequence strns args cont cons = uncurry evalSeqAux $ map snd *** id $ span isDone (zip strns args) - where evalSeqAux :: [Funcons] -> [(Strictness, Funcons)] -> Rewrite Rewritten + where unmatched = drop (length strns) args + evalSeqAux :: [Funcons] -> [(Strictness, Funcons)] -> Rewrite Rewritten evalSeqAux vs [] = cont vs evalSeqAux vs ((_,f):fs) = premiseEval valueCont funconCont f - where valueCont v = do + where valueCont vs' = do count_rewrite - evalSeqAux (vs++(FValue v:map snd othervs)) otherfs + evalSeqAux (vs++(map FValue vs' ++ map snd othervs)) otherfs where (othervs, otherfs) = span isDone fs - funconCont stepf = do f' <- stepf - stepTo (cons (vs++[f']++map snd fs)) + funconCont stepf = stepf >>= \case + Left f' -> stepTo (cons (vs++[f']++map snd fs)) + Right vs' -> stepTo (cons (vs++(map FValue vs')++map snd fs)) isDone (Strict, FValue _) = True isDone (NonStrict, _) = True isDone _ = False @@ -611,41 +796,25 @@ -- | Yield an 'MSOS' computation as a fully rewritten term. -- This function must be used in order to access entities in the definition -- of funcons. -compstep :: MSOS Funcons -> Rewrite Rewritten +compstep :: MSOS StepRes -> Rewrite Rewritten compstep mf = Rewrite $ \ctxt st -> let f0 = local_fct ctxt in (Right (CompTerm f0 mf), st, mempty) -tupleTypeTemplate :: [Funcons] -> [(Funcons, Maybe SeqSortOp)] -tupleTypeTemplate = map aux - where aux (FSortSeq f op) = (f, Just op) - aux f = (f, Nothing) - - -evalTupleType :: [(Funcons,Maybe SeqSortOp)] -> Rewrite Types -evalTupleType = fmap Tuples . evalTupleType' - where - evalTupleType' :: [(Funcons, Maybe SeqSortOp)] -> Rewrite [TTParam] - evalTupleType' [] = return [] - evalTupleType' ((f,mop):fs) = rewriteFuncons f >>= \case - ValTerm v -> case castType v of - Just t -> ((t,mop):) <$> evalTupleType' fs - Nothing-> sortErr(FValue v)"non-type value appeared in type tuple" - CompTerm _ _ -> - sortErr f"tuple type expressions may not contain compsteps" - --- transitive closure over steps -stepTrans :: RunOptions -> Int -> Funcons -> MSOS Funcons -stepTrans opts i f - | isVal f || maybe False ((<= i)) (max_restarts opts) = return f - | otherwise = if_abruptly_terminates (do_abrupt_terminate opts) - (stepAndOutput f) return continue - where continue f' = do count_restart - modifyCTXT setGlobal (stepTrans opts (i+1) f') - where setGlobal ctxt = ctxt { ereader = - (ereader ctxt) {global_fct = f' }} +stepTrans :: RunOptions -> Int -> StepRes -> MSOS StepRes +stepTrans opts i res = case res of + Right vs -> return res + Left f | maybe False ((<= i)) (max_restarts opts) -> return res + | otherwise -> if_abruptly_terminates (do_abrupt_terminate opts) + (stepAndOutput f) return continue + where continue res = count_restart >> stepTrans opts (i+1) res + stepAndOutput :: Funcons -> MSOS StepRes stepAndOutput f = MSOS $ \ctxt mut -> - let MSOS stepper = evalFuncons f + let MSOS stepper' = evalFuncons f + stepper ctxt mut = stepper' (setGlobal ctxt) mut + setGlobal ctxt = ctxt + { ereader = (ereader ctxt) {global_fct = f }} in do (eres,mut',wr') <- stepper ctxt mut mapM_ (uncurry fprint) [ (entity,val) @@ -654,4 +823,13 @@ return (eres, mut', wr') +toStepRes :: Funcons -> StepRes +toStepRes (FValue v) = Right [v] +toStepRes f = Left f + +flattenApplyWithExc :: IE -> (Funcons -> Funcons) -> MSOS StepRes -> Rewrite Rewritten +flattenApplyWithExc ie app m = compstep $ m >>= \case + Left f -> return $ Left $ app f + Right [v] -> return $ Left $ app (FValue v) + Right vs -> msos_throw ie diff --git a/src/Funcons/Parser.hs b/src/Funcons/Parser.hs --- a/src/Funcons/Parser.hs +++ b/src/Funcons/Parser.hs @@ -1,133 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -module Funcons.Parser (Funcons.Parser.parse, Funcons.Parser.parser, pFuncons, pValues) where - -import Text.ParserCombinators.Parsec - -import Control.Applicative hiding ((<|>)) -import Data.Char (isDigit) -import Data.Text (pack) -import Numeric - -import Funcons.Lexer -import Funcons.Types - -data Suffix = SuffixOp SeqSortOp - | SuffixSort Funcons - | SuffixBar Funcons - | NoSuffix - -pFuncons = applySuffix <$> pFuncons0 <*> mSuffix - where mSuffix :: Parser Suffix - mSuffix = SuffixOp <$> pOp - <|> SuffixSort <$ doubleArrow <*> pFuncons - <|> try (SuffixBar <$ bar <*> pFuncons) -- necessary for builtin maps - <|> return NoSuffix - applySuffix f NoSuffix = f - applySuffix f (SuffixOp op) = FSortSeq f op - applySuffix f (SuffixSort f2) = FSortComputesFrom f f2 - applySuffix f (SuffixBar f2) = FSortUnion f f2 - --- introduced to bottom-out left-recursion -pFuncons0 :: Parser Funcons -pFuncons0 = - FList <$> brackets (commaSep pFuncons) - <|> try (FMap <$> braces (commaSep1 pKeyValue)) - <|> FSet <$> braces (commaSep pFuncons) - <|> FTuple <$> parens (commaSep pFuncons) - <|> FSortComputes <$ doubleArrow <*> pFuncons - <|> maybe_apply . pack <$> identifier <*> optionMaybe pFuncons - <|> FValue <$> pValues - where pKeyValue :: Parser Funcons - pKeyValue = (\x y -> FTuple [x,y]) <$> pFuncons <* barredArrow <*> pFuncons - - maybe_apply :: Name -> Maybe Funcons -> Funcons - maybe_apply nm mf = case mf of - Nothing -> FName nm - Just arg -> FApp nm arg - - -pOp :: Parser SeqSortOp -pOp = StarOp <$ reserved "*" - <|> PlusOp <$ reserved "+" - <|> QuestionMarkOp <$ reserved "?" - -pValues :: Parser Values -pValues = - Char <$ char '\'' <*> anyChar <* char '\'' - <|> String <$> stringLiteral - <|> EmptyTuple <$ reserved "void" - <|> List [] <$ reserved "nil" - <|> String "\n" <$ reserved "newline" - <|> (\(FValue v) -> v) . int_ . (0-) . readInt <$ char '-' <*> (many1 digit) - <|> (\(FValue v) -> v) . nat_ . readInt <$> (many1 digit) - <|> Atom <$ reserved "atom" <*> parens stringLiteral - <|> mk_rationals . readRational - <$> ((\m l -> m ++ "." ++ l) <$> many1 (satisfy isDigit) <* period <*> - many1 (satisfy isDigit)) - where readInt :: String -> Int - readInt = read - -{- -ComputationTypes and Types should really be parsed as arbitrary terms, - then evaluated to ComputationType/Type. -However, computation types can currently not be parsed because of left-recursion (see above). - -pComputationType :: Parser ComputationTypes -pComputationType = Type <$> pTypes - <|> ComputesType <$ reserved "=>" <*> pTypes - <|> ComputesFromType <$> pTypes <* reserved "=>" <*> pTypes - -pTypes :: Parser Types -pTypes = - Atoms <$ reserved "atoms" - <|> AsciiCharacters <$ reserved "ascii-characters" - <|> reserved "bounded-integers" *> - parens (BoundedIntegers <$> natural <* comma <*> natural) - <|> ComputationTypes <$ reserved "computation-types" - <|> EmptyType <$ reserved "empty-type" - <|> UnicodeCharacters <$ reserved "unicode-characters" - <|> Integers <$ reserved "integers" - <|> Strings <$ reserved "strings" - <|> Values <$ reserved "values" - <|> reserved "maps" *> parens (Maps <$> pTypes <* comma <*> pTypes) - <|> Types <$ reserved "types" - <|> ADTs <$ reserved "algebraic-datatypes" --- <|> ADT - <|> reserved "bits" *> parens (Bits . fromInteger <$> natural) - <|> IEEEFloats <$ reserved "ieee-floats" <*> parens pIEEEFormat - <|> Lists <$ reserved "lists" <*> parens pTypes - <|> Multisets <$ reserved "multisets" <*> parens pTypes - <|> Naturals <$ reserved "naturals" - <|> Rationals <$ reserved "rationals" - <|> Thunks <$ reserved "thunks" <*> parens pComputationType - <|> Sets <$ reserved "sets" <*> parens pTypes - <|> Vectors <$ reserved "vectors" <*> parens pTypes --- <|> Tuples <$ reserved "tuples" <*> parens (commaSep pTypes) --- <|> parens (Union <$> pTypes <* reserved "|" <*> pTypes) --} - -pIEEEFormat :: Parser IEEEFormats -pIEEEFormat = Binary32 <$ reserved "binary32" - <|> Binary64 <$ reserved "binary64" - -readRational :: String -> Rational -readRational = fst . head . readFloat - --------- -parse :: FilePath -> String -> Funcons -parse = parser (whiteSpace *> pFuncons <* whiteSpace) - -parser :: Parser a -> FilePath -> String -> a -parser p fp str = case Text.ParserCombinators.Parsec.parse p fp str of - Left err -> error (show err) - Right a -> a - -reader :: Parser a -> FilePath -> String -> [(a, String)] -reader p fp str = [(parser p fp str, "")] +module Funcons.Parser (fct_parse, fvalue_parse) where -instance Read Funcons where - readsPrec d str = reader pFuncons "" str +import Funcons.GLLParser (fct_parse, fvalue_parse) -instance Read Values where - readsPrec d str = reader pValues "" str diff --git a/src/Funcons/Patterns.hs b/src/Funcons/Patterns.hs --- a/src/Funcons/Patterns.hs +++ b/src/Funcons/Patterns.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase, StandaloneDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} module Funcons.Patterns where @@ -7,12 +10,14 @@ import Funcons.Substitution import Funcons.Exceptions -import Control.Monad (foldM) +import Control.Applicative +import Control.Monad (foldM, forM) import Data.Function (on) -import Data.List (sortBy) +import Data.List (sortBy, intercalate) import Data.Monoid import Data.Text (unpack) -import qualified Data.BitVector as BV +import Data.Foldable (toList) +import qualified Data.Map as M -- pattern matching type Matcher a = [a] -> Int -> Env -> Rewrite [(Int, Env)] @@ -48,10 +53,10 @@ Left ie | failsRule ie -> return [] | otherwise -> rewrite_rethrow ie -matching :: [a] -> [Matcher a] -> Env -> Rewrite Env -matching str ps env = do +matching :: (a -> String) -> [a] -> [Matcher a] -> Env -> Rewrite Env +matching show str ps env = do matches <- (seqms ps) str 0 env - let rule_fail = PatternMismatch ("Pattern match failed: " ++ show (map fst matches)) + let rule_fail = PatternMismatch ("Pattern match failed: " ++ intercalate "," (map show str)) case matches of [] -> rewrite_throw rule_fail [(_,env')] -> return env' @@ -92,6 +97,7 @@ | PSeqVar MetaVar SeqSortOp | PAnnotated FPattern FTerm | PWildCard + deriving (Show, Eq, Ord, Read) f2vPattern :: FPattern -> VPattern f2vPattern (PValue v) = v @@ -103,21 +109,67 @@ -- | Patterns for matching values ('Values'). data VPattern = PADT Name [VPattern] | VPWildCard - | PEmptySet - | PTuple [VPattern] - | PList [VPattern] +-- | PList [VPattern] | VPMetaVar MetaVar | VPAnnotated VPattern FTerm | VPSeqVar MetaVar SeqSortOp | VPLit Values + | VPType TPattern + deriving (Show, Eq, Ord, Read) +v2tPattern :: VPattern -> Maybe TPattern +v2tPattern (VPType t) = Just t +v2tPattern (VPMetaVar var) = Just $ TPVar var +v2tPattern (VPSeqVar var op) = Just $ TPSeqVar var op +v2tPattern (PADT cons pats) = TPADT cons <$> mapM v2tPattern pats +v2tPattern (VPLit lit) = Just $ TPLit (TFuncon (FValue lit)) +v2tPattern VPWildCard = Just TPWildCard +--v2tPattern (PList _) = Nothing +v2tPattern (VPAnnotated fp t) = Nothing + +-- required for "matching" lazy arguments (fields) of adt constructors +v2fPattern :: VPattern -> FPattern +v2fPattern (VPMetaVar x) = PMetaVar x +v2fPattern (VPSeqVar x op) = PSeqVar x op +v2fPattern (VPAnnotated pat ann) = PAnnotated (v2fPattern pat) ann +v2fPattern VPWildCard = PWildCard +v2fPattern vp = PValue vp + +substitute_patt_signal :: VPattern -> Env -> Rewrite VPattern +substitute_patt_signal vpat env = case vpat of + PADT name vpats -> PADT name <$> subs_flatten vpats env + VPWildCard -> return VPWildCard +-- PList pats -> PList <$> subs_flatten pats env + VPMetaVar var -> case M.lookup var env of + Nothing -> return (VPMetaVar var) + Just v -> VPLit <$> vLevel v + VPAnnotated vpat ann -> VPAnnotated <$> substitute_patt_signal vpat env + <*> return ann + VPSeqVar var op -> case M.lookup var env of + Nothing -> return (VPSeqVar var op) + Just v -> VPLit <$> vLevel v + VPLit lit -> return $ VPLit lit + VPType tpat -> return $ VPType tpat -- assumes type patterns do not occur in signals + where subs_flatten :: [VPattern] -> Env -> Rewrite [VPattern] + subs_flatten terms env = (concat <$>) $ forM terms $ \case + vpat@(VPMetaVar k) -> envMaybeLookup env k vpat + vpat@(VPSeqVar k op) -> envMaybeLookup env k vpat + vpat -> (:[]) <$> substitute_patt_signal vpat env + + envMaybeLookup :: Env -> MetaVar -> VPattern -> Rewrite [VPattern] + envMaybeLookup env k vpat = case M.lookup k env of + Nothing -> return [vpat] + Just lf -> map VPLit <$> vsLevel lf + + -- | Variant of 'vsMatch' that is lifted into the 'MSOS' monad. lifted_vsMatch str pats env = liftRewrite $ vsMatch str pats env -- | Matching values with value patterns patterns. -- If the list of patterns is a singleton list, then 'vsMatch' attempts -- to match the values as a tuple against the pattern as well. vsMatch :: [Values] -> [VPattern] -> Env -> Rewrite Env -vsMatch str pats env = case pats of +vsMatch str pats env = strict_vsMatch str pats env +{-case pats of [pat] -> do e_ie_env <- eval_catch (strict_vsMatch str [pat] env) case e_ie_env of @@ -125,23 +177,28 @@ Left ie | failsRule ie -> vMatch (safe_tuple_val str) pat env | otherwise -> rewrite_rethrow ie _ -> strict_vsMatch str pats env +-} -- | Match stricly values with patterns. strict_vsMatch :: [Values] -> [VPattern] -> Env -> Rewrite Env -strict_vsMatch str pats env = matching str matchers env - where matchers = map (toMatcher vMatch vpSeqVarInfo) pats - toMatcher prop minfo pat = case minfo pat of +strict_vsMatch str pats env + | all isSort_ str + , Just tpats <- sequence (map v2tPattern pats) + = tsMatch (map (downcastSort . FValue) str) tpats env + | otherwise = matching showValues str matchers env + where matchers = map toMatcher pats + toMatcher pat = case vpSeqVarInfo pat of Just info -> seqMatcher isInMaybeTermType ValuesTerm info - Nothing -> singleMatcher prop pat + Nothing -> singleMatcher vMatch pat -- | Variant of 'premiseStep' that applies substitute and pattern-matching. premise :: FTerm -> FPattern -> Env -> MSOS Env -premise x pat env = do - f <- liftRewrite (substitute x env) - case isVal f of - True -> msos_throw (SideCondFail "attempting to step a value") - False -> do f' <- premiseStep f - liftRewrite $ (fMatch f' pat env) +premise x pat env = liftRewrite (subsAndRewritesInEnv x env) >>= \case + (ValTerm v, env') -> msos_throw (StepOnValue v) + (CompTerm f step,env') -> do + ef' <- count_delegation >> optRefocus step + case ef' of Left f' -> liftRewrite $ fMatch f' pat env' + Right vs' -> liftRewrite $ fsMatch (map FValue vs') [pat] env' -- | Variant of 'fsMatch' that is lifted into the 'MSOS' monad. -- If all given terms are values, then 'vsMatch' is used instead. @@ -152,32 +209,39 @@ fsMatchStrictness :: Bool -> [Funcons] -> [FPattern] -> Env -> Rewrite Env fsMatchStrictness strict str pats env -- if all the given funcons are values, then perform value matching instead. - | not strict && all isVal str = vsMatch (map downcastValue str) (map f2vPattern pats) env - | otherwise = matching str matchers env - where matchers = map (toMatcher fMatch fpSeqVarInfo) pats - toMatcher prop minfo pat = case minfo pat of - Just info -> seqMatcher (\_ _ _ -> return True) FunconsTerm info - Nothing -> singleMatcher prop pat + | not strict && all (not.hasStep) str = + let downValues vs = map downcastValue vs + in vsMatch (downValues str) (map f2vPattern pats) env + | otherwise = matching showFuncons str matchers env + where matchers = map toMatcher pats + toMatcher pat = case fpSeqVarInfo pat of + Just info -> seqMatcher rewritesToAnnotatedType FunconsTerm info + Nothing -> singleMatcher fMatch pat fMatch :: Funcons -> FPattern -> Env -> Rewrite Env fMatch _ PWildCard env = return env -fMatch f (PMetaVar var) env = return (envInsert var (FunconTerm f) env) +fMatch f (PMetaVar var) env = return (envInsert var (FunconTerm f Nothing) env) fMatch f (PAnnotated pat term) env = do - ty <- subsAndRewrite term env - let fail = rewrite_throw (PatternMismatch ("pattern annotation check failed: " ++ show ty)) - rewriteFuncons f >>= \case - ValTerm v -> do b <- isIn v ty - if b then vMatch v (f2vPattern pat) env - else fail + tys <- subsAndRewritesToValues term env + let fail = rewrite_throw (PatternMismatch ("pattern annotation check failed: " ++ showValuesSeq tys)) + rewriteFunconsWcount f >>= \case + ValTerm vs -> do b <- isInTuple vs tys + if b then vsMatch vs [f2vPattern pat] env + else fail otherwise -> fail -- * a sequence variable can match the singleton sequence fMatch f pat@(PSeqVar _ _) env = fsMatch [f] [pat] env -- if the pattern is a value attempt evaluation by rewrite -fMatch f (PValue pat) env = rewriteFuncons f >>= - \case ValTerm v -> vMatch v pat env +fMatch f (PValue pat) env = rewriteFunconsWcount f >>= + \case ValTerm vs -> vsMatch vs [pat] env CompTerm _ _ -> rewrite_throw --important, should remain last (PatternMismatch ("could not rewrite to value: " ++ showFuncons f)) +lifted_fMaybeMatch mf mp env = liftRewrite $ fMaybeMatch mf mp env +fMaybeMatch Nothing Nothing env = return env +fMaybeMatch (Just f) (Just p) env = fMatch f p env +fMaybeMatch _ _ env = rewrite_throw (PatternMismatch "fMaybeMatch") + lifted_vMaybeMatch mv mp env = liftRewrite $ vMaybeMatch mv mp env vMaybeMatch :: Maybe Values -> Maybe VPattern -> Env -> Rewrite Env vMaybeMatch Nothing Nothing env = return env @@ -186,40 +250,65 @@ lifted_vMatch v p env = liftRewrite $ vMatch v p env vMatch :: Values -> VPattern -> Env -> Rewrite Env +-- builtin special case for builtin value constructor `datatype-value` +vMatch (ADTVal str vs) (PADT "datatype-value" pats) env = + adtMatch "" "" (string_ (unpack str):vs) pats env vMatch _ (VPWildCard) env = return env +vMatch VAny _ env = return env vMatch v (VPMetaVar var) env = return (envInsert var (ValueTerm v) env) -vMatch (Set s) PEmptySet env | null s = return env -vMatch EmptyTuple (PTuple pats) env = vsMatch [] pats env -vMatch (NonEmptyTuple v1 v2 vs) (PTuple pats) env = vsMatch (v1:v2:vs) pats env vMatch (ADTVal str vs) (PADT con pats) env = adtMatch str con vs pats env -- strict because we do not want to match the sequence "inside" the list -vMatch (List vs) (PList ps) env = strict_vsMatch vs ps env +--vMatch (List vs) (PList ps) env = strict_vsMatch vs ps env vMatch v (VPAnnotated pat term) env = do - ty <- subsAndRewrite term env + ty <- subsAndRewritesToValue term env isIn v ty >>= \case True -> vMatch v pat env - False -> rewrite_throw (PatternMismatch ("pattern annotation check failed: " ++ show ty)) + False -> rewrite_throw (PatternMismatch ("pattern annotation check failed: " ++ showValues ty)) vMatch v (VPLit v2) env | v == v2 = return env -- special treatment for sequence variables: -- * a (single) sequence variable can match a tuple -vMatch EmptyTuple pat@(VPSeqVar _ _) env = vsMatch [] [pat] env -vMatch (NonEmptyTuple v1 v2 vs) pat@(VPSeqVar _ _) env = vsMatch (v1:v2:vs) [pat] env -- * a sequence variable can match the singleton sequence vMatch v pat@(VPSeqVar _ _) env = vsMatch [v] [pat] env -- * a single value can match a tuple of patterns if it contains sequences -vMatch v (PTuple pats) env = vsMatch [v] pats env +vMatch (ComputationType ty) (VPType pat) env = tMatch ty pat env vMatch v _ _ = rewrite_throw (PatternMismatch ("failed to match")) +tsMatch :: [ComputationTypes] -> [TPattern] -> Env -> Rewrite Env +tsMatch = strict_tsMatch -adtMatch :: Name -> Name -> [Values] -> [VPattern] -> Env -> Rewrite Env -adtMatch con pat_con vs pats env +strict_tsMatch :: [ComputationTypes] -> [TPattern] -> Env -> Rewrite Env +strict_tsMatch str pats env = matching showSorts str matchers env + where matchers = map toMatcher pats + toMatcher pat = case tpSeqVarInfo pat of + Nothing -> singleMatcher tMatch pat + Just info -> seqMatcher (\_ _ _ -> return True) TypesTerm info + +tMatch :: ComputationTypes -> TPattern -> Env -> Rewrite Env +tMatch t p env = case p of + TPWildCard -> return env + TPVar x -> return (envInsert x (TypeTerm t) env) + TPSeqVar _ _ -> tsMatch [t] [p] env + TPLit ft -> subsAndRewritesToValue ft env >>= \case + ComputationType ty -> + if t == ty then return env + else rewrite_throw (PatternMismatch ("failed to match")) + _ -> internal "type-pattern literal not a type" + TPComputes fp | ComputesType ft <- t -> tMatch (Type ft) fp env + TPComputesFrom fp tp | ComputesFromType ft tt <- t -> + tMatch (Type ft) fp env >>= tMatch (Type tt) tp + TPADT nm ps | Type (ADT nm' ts) <- t, nm == nm' -> + fsMatch ts (map (PValue . VPType) ps) env -- TODO change ps to value pattern (also in generator, see other TODO) + _ -> rewrite_throw (PatternMismatch ("failed to match")) + +adtMatch :: Name -> Name -> [Funcons] -> [VPattern] -> Env -> Rewrite Env +adtMatch con pat_con vs vpats env | con /= pat_con = rewrite_throw (PatternMismatch ("failed to match constructors: (" ++ show (con,pat_con) ++ ")")) - | otherwise = vsMatch vs pats env + | otherwise = fsMatch vs (map v2fPattern vpats) env fpSeqVarInfo :: FPattern -> Maybe SeqVarInfo fpSeqVarInfo (PSeqVar var op) = Just (var, op, Nothing) -fpSeqVarInfo (PAnnotated (PSeqVar var op) _) = Just (var, op, Nothing) +fpSeqVarInfo (PAnnotated (PSeqVar var op) term) = Just (var, op, Just term) fpSeqVarInfo _ = Nothing vpSeqVarInfo :: VPattern -> Maybe SeqVarInfo @@ -227,6 +316,9 @@ vpSeqVarInfo (VPAnnotated (VPSeqVar var op) term) = Just (var, op, Just term) vpSeqVarInfo _ = Nothing +tpSeqVarInfo :: TPattern -> Maybe SeqVarInfo +tpSeqVarInfo (TPSeqVar var op) = Just (var, op, Nothing) +tpSeqVarInfo _ = Nothing -- | CSB supports five kinds of side conditions. -- Each of the side conditions are explained below. @@ -254,91 +346,115 @@ sideCondition :: SideCondition -> Env -> Rewrite Env sideCondition cs env = case cs of SCEquality term1 term2 -> - prop "equality condition" (\a b -> return (a === b)) term1 term2 env + prop "equality condition" (lift allEqual) term1 term2 env SCInequality term1 term2 -> - prop "inequality condition" (\a b -> return (a =/= b))term1 term2 env - SCIsInSort term1 term2 -> prop "type-check condition" isIn term1 term2 env + prop "inequality condition" (lift allUnEqual) term1 term2 env + SCIsInSort term1 term2 -> prop "sort annotation" isInTuple term1 term2 env SCNotInSort term1 term2 -> - prop "type-check condition" (\a b -> isIn a b >>= return . not) term1 term2 env - SCPatternMatch term vpat -> do - -- special treatment of pattern-matching condition - f <- substitute term env - eval_catch (rewriteFuncons f) >>= \case - Right (ValTerm v) -> vMatch v vpat env - Right (CompTerm lf _) -> fMatch lf pat env - Left (_,_,PartialOp _) -> fMatch f pat env - Left ie -> rewrite_rethrow ie + prop "neg. sort annotation" (\a b -> isInTuple a b >>= return . not) term1 term2 env + SCPatternMatch term vpat -> + eval_catch (subsAndRewritesInEnv term env) >>= \case + -- env' binds term to step or value, if possible + -- courtesy of subsAndRewritesInEnv + Right (ValTerm vs, env') -> vsMatch vs [vpat] env' + Right (CompTerm lf step, env') -> case vpat of + VPMetaVar v -> return (envInsert v (FunconTerm lf (Just step)) env') + _ -> fMatch lf pat env' + Left (_,lf,PartialOp _) -> fMatch lf pat env + Left ie -> rewrite_rethrow ie where pat = case vpat of VPMetaVar var -> PMetaVar var value_pat -> PValue value_pat - where prop msg op term1 term2 env = do - v1 <- subsAndRewrite term1 env - v2 <- subsAndRewrite term2 env - b <- op v1 v2 - if b then return env - else rewrite_throw (SideCondFail (msg ++ " fails")) - + where prop :: String -> ([Values] -> [Values] -> Rewrite Bool) -> FTerm -> FTerm -> Env -> Rewrite Env + prop msg op term1 term2 env = do + (vs1,env1) <- subsAndRewritesToValuesInEnv term1 env + (vs2,env2) <- subsAndRewritesToValuesInEnv term2 env1 + b <- op vs1 vs2 + if b then return env2 + else rewrite_throw (SideCondFail (msg ++ " fails with " ++ showValuesSeq vs1 ++ " and " ++ showValuesSeq vs2)) + lift op xs ys = return (op xs ys) + -- piggy back on -matchTypeParams :: [Types] -> [TypeParam] -> Rewrite Env +matchTypeParams :: [ComputationTypes] -> [TypeParam] -> Rewrite Env matchTypeParams tys tparams = let param_pats = map mkPattern tparams - where mkPattern (Nothing, kind) = VPAnnotated VPWildCard kind - mkPattern (Just var, kind) = VPAnnotated (VPMetaVar var) kind - in vsMatch (map typeVal tys) param_pats emptyEnv + where mkPattern (Nothing, _, kind) = VPAnnotated VPWildCard kind + mkPattern (Just var, Nothing, kind) = VPAnnotated (VPMetaVar var) kind + mkPattern (Just var, Just op, kind) = VPAnnotated (VPSeqVar var op) kind + in vsMatch (map ComputationType tys) param_pats emptyEnv +alwaysAccept :: Funcons -> Maybe FTerm -> Env -> Rewrite Bool +alwaysAccept _ _ _ = return True + +rewritesToAnnotatedType :: Funcons -> Maybe FTerm -> Env -> Rewrite Bool +rewritesToAnnotatedType f Nothing _ = return True +rewritesToAnnotatedType f (Just term) env = rewriteFunconsWcount f >>= \case + ValTerm [v] -> isInMaybeTermType v (Just term) env + ValTerm vs -> isInMaybeTupleType vs term env + CompTerm _ _ -> return False + -- type checking isInMaybeTermType :: Values -> (Maybe FTerm) -> Env -> Rewrite Bool isInMaybeTermType v Nothing _ = return True isInMaybeTermType v (Just term) env = - subsAndRewrite term env >>= isIn v + subsAndRewritesToValue term env >>= isIn v +-- | To type check a sequence values simply checker whether all elements +-- of the sequence are of the given type +isInMaybeTupleType :: [Values] -> FTerm -> Env -> Rewrite Bool +isInMaybeTupleType vs term env = + subsAndRewritesToValue term env >>= isInTuple vs . (:[]) + +isInTuple :: [Values] -> [Values] -> Rewrite Bool +isInTuple vs mtys = case sequence (map castType mtys) of + Nothing -> sortErr (FValue $ ADTVal "" (map FValue mtys)) + "rhs of annotation is not a type" + Just tys -> Funcons.Patterns.isInTupleType vs (map mkParam tys) + where mkParam (AnnotatedType ty op) = (ty, Just op) + mkParam ty = (ty, Nothing) + isIn :: Values -> Values -> Rewrite Bool isIn v mty = case castType mty of Nothing -> sortErr (FValue mty) "rhs of annotation is not a type" - Just ty -> isInType v ty - + Just ty -> Funcons.Patterns.isInType v ty + isInType :: Values -> Types -> Rewrite Bool isInType v (ADT nm tys) = do - DataTypeMembers tparams alts <- typeEnvLookup nm - env <- matchTypeParams tys tparams - or <$> mapM (isInAlt env) alts - where isInAlt env (DataTypeInclusion ty_term) = do - subsAndRewrite ty_term env >>= isIn v - isInAlt env (DataTypeConstructor cons ty_term) = case v of - ADTVal cons' arg | cons' == cons -> - subsAndRewrite ty_term env >>= isIn (safe_tuple_val arg) - _ -> return False -isInType (ADTVal _ _) ADTs = return True -isInType (Atom _) Atoms = return True -isInType (Ascii _) AsciiCharacters = return True -isInType (Bit bv) (Bits n) = return (BV.size bv == n) -isInType v (BoundedIntegers m n) - | Int i <- upcastIntegers v = return (i >= m && i <= n) -isInType (ComputationType (ComputesFromType _ _)) ComputationTypes = return True -isInType (ComputationType (ComputesType _)) ComputationTypes = return True -isInType _ EmptyType = return False -isInType (IEEE_Float_32 _) (IEEEFloats Binary32) = return True -isInType (IEEE_Float_64 _) (IEEEFloats Binary64) = return True -isInType v Integers | Int _ <- upcastIntegers v = return True -isInType (List _) (Lists _) = return True -isInType (Map _) (Maps _ _) = return True -isInType (Multiset _) (Multisets _) = return True -isInType v Naturals | Nat _ <- upcastNaturals v = return True -isInType v Rationals | Rational _ <- upcastRationals v = return True -isInType (Set _) (Sets _) = return True -isInType (String _) Strings = return True -isInType (Thunk _) (Thunks _) = return True -isInType v (Tuples ttparams) = case v of - EmptyTuple -> isInTupleType [] ttparams - NonEmptyTuple v1 v2 vs -> isInTupleType (v1:v2:vs) ttparams - _ -> isInTupleType [v] ttparams -isInType (ComputationType (Type _)) Types = return True -isInType v UnicodeCharacters | Char _ <- upcastUnicode v = return True -isInType v (Union ty1 ty2) = (||) <$> isInType v ty1 <*> isInType v ty2 -isInType _ Values = return True -isInType (Vector _) (Vectors _) = return True -isInType _ _ = return False + DataTypeMemberss _ tpats alts <- typeEnvLookup nm + or <$> mapM (isInAlt tpats) alts + where isInAlt tpats (DataTypeInclusionn ty_term) = do + -- TODO change DataTypeMember so that tpats are value-patterns + -- requires change in the generator + env <- fsMatch tys (map (PValue . VPType) tpats) emptyEnv + subsAndRewritesToValue ty_term env >>= isIn v + isInAlt tpats (DataTypeMemberConstructor cons ty_terms mtpats) + | ADTVal cons' args <- v, cons' == cons = do + env <- case mtpats of + Just tpats -> fsMatch tys (map (PValue . VPType) tpats) emptyEnv + Nothing -> fsMatch tys (map (PValue . VPType) tpats) emptyEnv + case all (not.hasStep) args of + True -> mapM (flip subsAndRewritesToValues env) ty_terms >>= + isInTuple (map downcastValue args) . concat + _ -> return True -- imprecision + isInAlt _ _ = return False +isInType v (AnnotatedType ty op) = Funcons.Patterns.isInTupleType [v] [(ty, Just op)] +isInType (Map m) (Maps kt vt) = + and <$> sequence [and <$> mapM (flip Funcons.Patterns.isInType kt) (M.keys m) + ,and <$> mapM (flip Funcons.Patterns.isInType vt) (M.elems m)] +isInType (Multiset ls) (Multisets ty) = + and <$> mapM (flip Funcons.Patterns.isInType ty) (toList ls) +isInType (Set ls) (Sets ty) = + and <$> mapM (flip Funcons.Patterns.isInType ty) (toList ls) +isInType (Vector ls) (Vectors ty) = + and <$> mapM (flip Funcons.Patterns.isInType ty) (toList ls) +isInType v (Union ty1 ty2) = + (||) <$> Funcons.Patterns.isInType v ty1 <*> Funcons.Patterns.isInType v ty2 +isInType v (Intersection ty1 ty2) = + (&&) <$> Funcons.Patterns.isInType v ty1 <*> Funcons.Patterns.isInType v ty2 +isInType v (Complement t) = + not <$> Funcons.Patterns.isInType v t +isInType v t = maybe (return False) return (Funcons.Types.isInType v t) isInTupleType :: [Values] -> [TTParam] -> Rewrite Bool isInTupleType vs ttparams = @@ -346,11 +462,10 @@ Right env' -> return True Left (_,_,PatternMismatch _) -> return False Left ie -> rewrite_rethrow ie - where mkPattern (ty, mop) = VPAnnotated ty_pat (TFuncon ty_funcon) + where mkPattern (ty, mop) = VPAnnotated ty_pat (TFuncon (type_ ty)) where ty_pat = case mop of Nothing -> VPMetaVar "Dummy" Just op -> VPSeqVar "Dummy" op - ty_funcon = type_ ty typeEnvLookup :: Name -> Rewrite DataTypeMembers typeEnvLookup con = Rewrite $ \ctxt st -> @@ -362,9 +477,36 @@ -- | -- Parameterisable evaluation function function for types. rewriteType :: Name -> [Values] -> Rewrite Rewritten -rewriteType nm vs - | all isType_ vs = - rewritten (ComputationType(Type(ADT nm (map downcastValueType vs)))) - | otherwise = sortErr (applyFuncon nm (map FValue vs)) - ("argument of type " <> unpack nm <> " is not a type") +rewriteType nm vs = rewritten (ComputationType(Type(ADT nm (map inject vs)))) + +pat2term :: FPattern -> FTerm +pat2term pat = case pat of + PAnnotated pat _ -> pat2term pat + PWildCard -> TAny + PMetaVar var -> TVar var + PSeqVar var _ -> TVar var + PValue vpat -> vpat2term vpat + +vpat2term :: VPattern -> FTerm +vpat2term vpat = case vpat of + PADT cons pats -> case pats of [] -> TName cons + _ -> TApp cons (map vpat2term pats) + VPLit lit -> TFuncon $ (FValue lit) + VPWildCard -> TAny +-- PList pats -> TList (map vpat2term pats) + VPMetaVar var -> TVar var + VPSeqVar var _ -> TVar var + VPAnnotated pat _ -> vpat2term pat + VPType typat -> typat2term typat + +typat2term :: TPattern -> FTerm +typat2term typat = case typat of + TPADT cons pats -> case pats of [] -> TName cons + _ -> TApp cons (map typat2term pats) + TPLit lit -> lit + TPWildCard -> TAny + TPVar var -> TVar var + TPSeqVar var _ -> TVar var + TPComputes f -> TSortComputes (typat2term f) + TPComputesFrom f t -> TSortComputesFrom (typat2term f) (typat2term t) diff --git a/src/Funcons/Printer.hs b/src/Funcons/Printer.hs --- a/src/Funcons/Printer.hs +++ b/src/Funcons/Printer.hs @@ -1,145 +1,79 @@ {-# LANGUAGE OverloadedStrings #-} module Funcons.Printer ( - ppFuncons, ppValues, ppTypes, - showValues, showFuncons, showTypes, + ppFuncons, ppValues, ppTypes, ppTerms, + showValues, showFuncons, showTypes, showSorts, showTerms, showOp, + showValuesSeq, ppValuesSeq, showFunconsSeq, ppFunconsSeq, ) where import Funcons.Types import Funcons.RunOptions import Data.List (intercalate) -import qualified Data.Map as M -import qualified Data.Set as S -import qualified Data.MultiSet as MS -import qualified Data.Vector as V -import qualified Data.BitVector as BV import Data.Text (unpack) -- | Pretty-print a 'Values'. showValues :: Values -> String -showValues = ppValues defaultRunOptions +showValues = ppValues showFuncons +-- | Pretty-print a sequence of `Values`. +showValuesSeq :: [Values] -> String +showValuesSeq = ppValuesSeq defaultRunOptions + +showOp :: SeqSortOp -> String +showOp = ppOp + +ppValuesSeq :: RunOptions -> [Values] -> String +ppValuesSeq opts = showArgs opts False . map FValue + -- | Pretty-print a 'Funcons'. showFuncons :: Funcons -> String showFuncons = ppFuncons defaultRunOptions --- | Pretty-print a 'Types'. +-- | Pretty-print a sequence of `Funcons`. +showFunconsSeq :: [Funcons] -> String +showFunconsSeq = ppFunconsSeq defaultRunOptions + +ppFunconsSeq :: RunOptions -> [Funcons] -> String +ppFunconsSeq opts = showArgs opts False + +-- | Pretty-print a 'Types'. showTypes :: Types -> String -showTypes = ppTypes defaultRunOptions +showTypes = ppTypes showFuncons +-- | Pretty-print a sort or 'ComputationType' +showSorts :: ComputationTypes -> String +showSorts = ppComputationTypes showFuncons + +showTerms :: FTerm -> String +showTerms = ppTerms defaultRunOptions + ppFuncons :: RunOptions -> Funcons -> String -ppFuncons opts (FList fs) = "[" ++ showArgs opts False fs ++ "]" -ppFuncons opts (FTuple fs) = "(" ++ showArgs opts False fs ++ ")" +ppFuncons opts (FApp "list" fs) = "[" ++ showArgs opts False fs ++ "]" +--ppFuncons opts (FTuple fs) = "(" ++ showArgs opts False fs ++ ")" ppFuncons opts (FSet fs) = "{" ++ showArgs opts False fs ++ "}" -ppFuncons opts (FMap fs) = "{" ++ intercalate "," (map toKeyFValue fs) ++ "}" - where toKeyFValue (FTuple [k,v]) = ppFuncons opts k ++ " |-> " ++ ppFuncons opts v - toKeyFValue _ = error "pretty-print map" -ppFuncons opts (FValue v) = ppValues opts v +ppFuncons opts (FMap fs) = + "{" ++ intercalate "," (map toKeyFValue $ mkPairs fs) ++ "}" + where toKeyFValue (k,v) = ppFuncons opts k ++ " |-> " ++ ppFuncons opts v +ppFuncons opts (FValue v) = ppValues (ppFuncons opts) v ppFuncons opts (FName nm) = unpack nm -ppFuncons opts (FSortSeq f o) = ppFuncons opts f ++ ppOp o +ppFuncons opts (FSortSeq f o) = ppFuncons opts f ++ ppOp o +ppFuncons opts (FSortPower f1 f2) = ppFuncons opts f1 ++ "^" ++ ppFuncons opts f2 ppFuncons opts (FSortUnion f1 f2) = "(" ++ ppFuncons opts f1 ++ "|" ++ ppFuncons opts f2 ++ ")" +ppFuncons opts (FSortInter f1 f2) = "(" ++ ppFuncons opts f1 ++ "&" ++ ppFuncons opts f2 ++ ")" +ppFuncons opts (FSortComplement f1) = "~("++ ppFuncons opts f1 ++ ")" ppFuncons opts (FSortComputes f) = "=>" ++ ppFuncons opts f ppFuncons opts (FSortComputesFrom s t) = ppFuncons opts s ++ "=>" ++ ppFuncons opts t -- some hard-coded funcons -ppFuncons opts (FApp "closure" (FTuple [x, y])) = +ppFuncons opts (FApp "closure" [x, y]) = let env | pp_full_environments opts = y | otherwise = string_ "..." in showFn opts "closure" [x, env] -ppFuncons opts (FApp "scope" (FTuple [x, y])) = +ppFuncons opts (FApp "scope" [x, y]) = let env | Prelude.not (pp_full_environments opts) && isMap x = string_ "..." | otherwise = x in showFn opts "scope" [env, y] -ppFuncons opts (FApp nm f) = unpack nm ++ ppFuncons opts f - -ppValues :: RunOptions -> Values -> String -ppValues opts (ADTVal c []) = unpack c -ppValues opts (ADTVal c vs) = unpack c ++ showArgs opts True (map FValue vs) -ppValues _ (Atom c) = "atom("++ c ++")" -ppValues _ (Ascii c) = "`" ++ [toEnum c] ++ "`" -ppValues _ (Bit i) = "bits(" ++ show (BV.size i) - ++ ", " ++ show (BV.int i) ++ ")" -ppValues _ (Char c) = show c -ppValues _ (Float f) = show f --- rationals -ppValues _ (IEEE_Float_32 f) = show f -ppValues _ (IEEE_Float_64 d) = show d -ppValues _ (Rational r) = show r -ppValues _ (Int f) = show f -ppValues _ (Nat f) = show f -ppValues opts (List vs) = if Prelude.null vs - then "[]" - else "[" ++ showArgs opts False (map FValue vs) ++ "]" -ppValues opts (Map m) = if M.null m then "map-empty" - else "{" ++ key_values ++ "}" - where key_values = intercalate ", " (map (\(k,v) -> ppValues opts k++" |-> "++ - ppValues opts v)$ M.toList m) -ppValues opts (Multiset s) - | MS.size s == 0 = "{}" - | otherwise = "{" ++ showArgs opts False (map FValue (MS.toList s)) ++ "}" -ppValues opts (Set s) - | S.size s == 0 = "{}" - | otherwise = "{" ++ showArgs opts False (map FValue (S.toList s)) ++ "}" -ppValues _ (String s) = show s -ppValues opts (Thunk f) = "thunk(" ++ ppFuncons opts f ++ ")" -ppValues opts EmptyTuple = "()" -ppValues opts (NonEmptyTuple v1 v2 vs) = showArgs opts True (map FValue (v1:v2:vs)) -ppValues opts (Vector v) = showFn opts "vector" (map FValue (V.toList v)) -ppValues opts (ComputationType ct) = ppComputationTypes opts ct - -ppComputationTypes :: RunOptions -> ComputationTypes -> String -ppComputationTypes opts (Type t) = ppTypes opts t -ppComputationTypes opts (ComputesType ty) = "=>" ++ ppTypes opts ty -ppComputationTypes opts (ComputesFromType s t) = ppTypes opts s ++ "=>" ++ ppTypes opts t - -ppTypes :: RunOptions -> Types -> String -ppTypes _ Atoms = "atoms" -ppTypes _ AsciiCharacters = "ascii-characters" -ppTypes _ (BoundedIntegers m n) = "bounded-integers(" ++ show m ++ ","++ show n ++ ")" -ppTypes _ ComputationTypes = "computation-types" -ppTypes _ EmptyType = "empty-type" -ppTypes _ (UnicodeCharacters) = "unicode-characters" -ppTypes _ (Integers) = "integers" -ppTypes _ (Strings) = "strings" -ppTypes _ (Values) = "values" -ppTypes opts (Maps x y) = showFn opts "maps" [type_ x, type_ y] -ppTypes _ Types = "types" -ppTypes _ ADTs = "algebraic-datatypes" -ppTypes opts (ADT nm ts) = unpack nm ++ showArgs opts True (map (type_) ts) -ppTypes _ (Bits n) = "bits(" ++ show n ++ ")" -ppTypes _ (IEEEFloats format) = "ieee-floats(" ++ show format ++ ")" -ppTypes opts (Lists ty) = "lists(" ++ ppTypes opts ty ++ ")" -ppTypes opts (Multisets ty) = showFn opts "multisets" [type_ ty] -ppTypes opts Naturals = "naturals" -ppTypes opts Rationals = "rationals" -ppTypes opts (Thunks ct) = "thunks(" ++ ppComputationTypes opts ct ++ ")" -ppTypes opts (Sets ty) = "sets(" ++ ppTypes opts ty ++ ")" -ppTypes opts (Vectors ty) = "vectors(" ++ ppTypes opts ty ++ ")" -ppTypes opts (Tuples tys) = "tuples(" ++ intercalate "," (map op tys) ++ ")" - where op (ty, Nothing) = ppTypes opts ty - op (ty, Just op) = ppTypes opts ty ++ ppOp op -ppTypes opts (Union ty1 ty2) = "(" ++ ppTypes opts ty1 ++ "|" ++ ppTypes opts ty2 ++")" - -ppOp :: SeqSortOp -> String -ppOp StarOp = "*" -ppOp PlusOp = "+" -ppOp QuestionMarkOp = "?" - -{- -ppTerms :: FTerm -> String -ppTerms (TApp nm ts) = unpack nm ++ ppTerms ts -ppTerms (TName nm) = unpack nm -ppTerms (TVar var) = var -ppTerms (TTuple ts) = "(" ++ intercalate "," (map ppTerms ts) ++ ")" -ppTerms (TList ts) = "[" ++ intercalate "," (map ppTerms ts) ++ "]" -ppTerms (TSet ts) = "{" ++ intercalate "," (map ppTerms ts) ++ "}" -ppTerms (TMap ts) = "map" ++ (ppTerms (TTuple ts)) -ppTerms (TSortSeq term op) = ppTerms term ++ ppOp op -ppTerms (TSortUnion t1 t2) = ppTerms t1 ++ "|" ++ show t2 -ppTerms (TSortComputes to) = "=>" ++ ppTerms to -ppTerms (TSortComputesFrom from to) = ppTerms from ++ "=>" ++ ppTerms to -ppTerms (TFuncon f) = ppFuncons defaultRunOptions f --} +ppFuncons opts (FApp nm fs) = unpack nm ++ showArgs opts True fs -- helpers @@ -150,4 +84,23 @@ showArgs opts b args | b = "(" ++ seq ++ ")" | otherwise = seq where seq = intercalate "," (map (ppFuncons opts) args) + +ppTerms :: RunOptions -> FTerm -> String +ppTerms opts (TApp "list" ts) = "[" ++ intercalate "," (map (ppTerms opts) ts) ++ "]" +ppTerms opts (TApp nm ts) = unpack nm ++ "(" ++ intercalate "," (map (ppTerms opts) ts) ++ ")" +ppTerms opts (TName nm) = unpack nm +ppTerms opts (TVar var) = var +ppTerms opts (TSeq ts) = "(" ++ intercalate "," (map (ppTerms opts) ts) ++ ")" +ppTerms opts (TSet ts) = "{" ++ intercalate "," (map (ppTerms opts) ts) ++ "}" +ppTerms opts (TMap ts) = "map" ++ ("(" ++ intercalate "," (map (ppTerms opts) ts) ++ ")") +ppTerms opts (TSortSeq term op) = ppTerms opts term ++ ppOp op +ppTerms opts (TSortPower t1 t2) = ppTerms opts t1 ++ "^" ++ ppTerms opts t2 +ppTerms opts (TSortUnion t1 t2) = ppTerms opts t1 ++ "|" ++ show t2 +ppTerms opts (TSortInter t1 t2) = ppTerms opts t1 ++ "&" ++ show t2 +ppTerms opts (TSortComplement t1) = "~(" ++ ppTerms opts t1 ++ ")" +ppTerms opts (TSortComputes to) = "=>" ++ ppTerms opts to +ppTerms opts (TSortComputesFrom from to) = ppTerms opts from ++ "=>" ++ ppTerms opts to +ppTerms opts (TFuncon f) = ppFuncons opts f +ppTerms opts TAny = "_" + diff --git a/src/Funcons/RunOptions.hs b/src/Funcons/RunOptions.hs --- a/src/Funcons/RunOptions.hs +++ b/src/Funcons/RunOptions.hs @@ -1,17 +1,16 @@ -{-# LANGUAGE OverloadedStrings, TupleSections #-} +{-# LANGUAGE OverloadedStrings, TupleSections, FlexibleContexts #-} module Funcons.RunOptions where import Funcons.Types -import Funcons.Parser +import Funcons.GLLParser (Parser(..), pFunconsSeq, pFuncons, fct_lexerSettings) +import Funcons.Parser (fct_parse) -import Text.ParserCombinators.Parsec -import qualified Text.ParserCombinators.Parsec.Token as P -import qualified Text.ParserCombinators.Parsec.Language as L +import GLL.Combinators hiding (chooses) import qualified Data.Map as M import Control.Monad (when) -import Data.Char (isSpace) +import Control.Compose (OO(..)) import Data.Text (pack) import Data.List (isSuffixOf, isPrefixOf) import Data.List.Split (splitOn) @@ -20,13 +19,13 @@ type GeneralOptions = M.Map Name String type BuiltinFunconsOptions = M.Map Name Funcons -type TestOptions = M.Map Name Funcons +type TestOptions = M.Map Name [Funcons] type InputValues = M.Map Name [Values] data RunOptions = RunOptions { mfuncon_term :: Maybe Funcons - , general_opts :: GeneralOptions - , builtin_funcons :: BuiltinFunconsOptions + , general_opts :: GeneralOptions + , builtin_funcons :: BuiltinFunconsOptions , expected_outcomes :: TestOptions , given_inputs :: InputValues } @@ -42,18 +41,18 @@ (given_inputs opts `M.union` given_inputs opts') funcon_term :: RunOptions -> Funcons -funcon_term = maybe err id . mfuncon_term +funcon_term = maybe err id . mfuncon_term where err = error "Please give a .fct file as an argument or use the --funcon-term flag" bool_opt_default :: Bool -> Name -> M.Map Name String -> Bool bool_opt_default def nm m = case M.lookup nm m of - Nothing -> def + Nothing -> def Just "false" -> False _ -> True bool_opt :: Name -> M.Map Name String -> Bool -bool_opt nm m = bool_opt_default False nm m +bool_opt nm m = bool_opt_default False nm m do_refocus :: RunOptions -> Bool do_refocus opts = bool_opt "refocus" (general_opts opts) @@ -68,12 +67,12 @@ pp_full_environments = bool_opt "full-environments" . general_opts show_result :: RunOptions -> Bool -show_result opts = if bool_opt "hide-result" (general_opts opts) +show_result opts = if bool_opt "hide-result" (general_opts opts) then False else not (interactive_mode opts) show_counts :: RunOptions -> Bool -show_counts opts = if bool_opt "display-steps" (general_opts opts) +show_counts opts = if bool_opt "display-steps" (general_opts opts) then not (interactive_mode opts) else False @@ -87,12 +86,11 @@ hide_input = maybe [] (map pack . splitOn ",") . M.lookup "hide-input-entity" . general_opts hide_control :: RunOptions -> [Name] -hide_control = maybe [] (map pack . splitOn ",") . M.lookup "hide-control-entity" . general_opts +hide_control = maybe [] (map pack . splitOn ",") . M.lookup "hide-control-entity" . general_opts interactive_mode :: RunOptions -> Bool -interactive_mode opts = if bool_opt "interactive-mode" (general_opts opts) - then M.null (inputValues opts) - else False +interactive_mode opts = + M.null (inputValues opts) && bool_opt "interactive-mode" (general_opts opts) pp_string_outputs :: RunOptions -> Bool pp_string_outputs = bool_opt "format-string-outputs" . general_opts @@ -101,7 +99,7 @@ string_inputs = bool_opt "string-inputs" . general_opts show_tests :: RunOptions -> Bool -show_tests opts = if bool_opt "hide-tests" (general_opts opts) +show_tests opts = if bool_opt "hide-tests" (general_opts opts) then False else M.size (expected_outcomes opts) > 0 @@ -113,55 +111,65 @@ auto_config :: RunOptions -> Bool auto_config opts = bool_opt_default True "auto-config" (general_opts opts) -inputValues :: RunOptions -> InputValues +csv_output :: RunOptions -> Bool +csv_output opts = if bool_opt "csv" (general_opts opts) + then True + else csv_output_with_keys opts + +csv_output_with_keys :: RunOptions -> Bool +csv_output_with_keys opts = bool_opt "csv-keys" (general_opts opts) + +inputValues :: RunOptions -> InputValues inputValues = given_inputs -booleanOptions = ["refocus", "full-environments", "hide-result", "display-steps" - , "no-abrupt-termination", "interactive-mode", "string-inputs", "format-string-outputs" - , "hide-tests", "show-output-only", "auto-config"] +booleanOptions = + ["refocus", "full-environments", "hide-result", "display-steps" + ,"no-abrupt-termination", "interactive-mode", "string-inputs" + ,"format-string-outputs", "hide-tests", "show-output-only" + ,"auto-config", "csv", "csv-keys"] booleanOptions_ = map ("--" ++) booleanOptions stringOptions = ["display-mutable-entity", "hide-output-entity" , "hide-control-entity", "hide-input-entity", "max-restarts"] stringOptions_ = map ("--" ++) stringOptions -allOptions = "funcon-term" : booleanOptions ++ stringOptions +allOptions = "funcon-term" : booleanOptions ++ stringOptions allOptions_ = "--funcon-term" : booleanOptions_ ++ stringOptions_ - + run_options :: [String] -> IO (RunOptions, [String]) run_options = fold (defaultRunOptions, []) where fold (opts,errors) (arg:args) - | arg `elem` booleanOptions_ = - let (val, rest) - | not (null args) + | arg `elem` booleanOptions_ = + let (val, rest) + | not (null args) , not (isPrefixOf "--" (head args)) = (head args, tail args) | otherwise = ("true", args) opts' = opts {general_opts = M.insert (pack (tail (tail arg))) val (general_opts opts)} in fold (opts',errors) rest | arg `elem` stringOptions_ && length args > 0 = - let opts' = opts {general_opts = M.insert (pack (tail (tail arg))) + let opts' = opts {general_opts = M.insert (pack (tail (tail arg))) (head args) (general_opts opts)} in fold (opts', errors) (tail args) | arg == "--funcon-term" && length args > 0 = - let opts' = opts {mfuncon_term = Just (read (head args))} + let opts' = opts {mfuncon_term = Just (fct_parse (head args))} in fold (opts', errors) (tail args) | isSuffixOf ".fct" arg = do fct <- readFile arg let cfg_name = take (length arg - 4) arg ++ ".config" exists <- doesFileExist cfg_name - opts' <- if exists && auto_config opts - then readFile cfg_name >>= + opts' <- if exists && auto_config opts + then readFile cfg_name >>= return . flip (parseAndApplyConfig cfg_name) opts - else return opts - let opts'' = opts' {mfuncon_term = Just (read fct)} + else return opts + let opts'' = opts' {mfuncon_term = Just (fct_parse fct)} fold (opts'', errors) args | isSuffixOf ".config" arg = fold (opts, errors) ("--config":arg:args) | arg == "--config" && length args > 0 = do let cfg_name = head args exists <- doesFileExist cfg_name when (not exists) (error ("config file not found: " ++ cfg_name)) - str <- readFile cfg_name + str <- readFile cfg_name let opts' = parseAndApplyConfig cfg_name str opts fold (opts', errors) (tail args) | otherwise = do @@ -171,86 +179,87 @@ fold (opts, errors) [] = return (opts, errors) parseAndApplyConfig :: FilePath -> String -> RunOptions -> RunOptions -parseAndApplyConfig fp str = optionsOverride (parser pRunOptions fp str) +parseAndApplyConfig fp str = optionsOverride (config_parser str) +-- gll config parser +config_parser :: String -> RunOptions +config_parser string = case GLL.Combinators.parseWithOptions [maximumPivot,throwErrors] pRunOptions + (Funcons.RunOptions.lexer string) of + [] -> error "no parse (config)" + (c:_) -> c + +lexer :: String -> [Token] +lexer = GLL.Combinators.lexer cfg_lexerSettings + +cfg_lexerSettings = fct_lexerSettings { + keywords = (keywords fct_lexerSettings) ++ cfg_keywords + , keychars = (keychars fct_lexerSettings) ++ cfg_keychars + } + +cfg_keychars = ":;=" +cfg_keywords = allOptions ++ ["result-term", "general", "tests", "funcons", "inputs"] + pRunOptions :: Parser RunOptions -pRunOptions = foldr optionsOverride defaultRunOptions <$> - many (choice [ keyword "general" *> braces pGeneral - , keyword "funcons" *> braces pBuiltinFuncons - , keyword "tests" *> braces pTestOutcomes - , keyword "inputs" *> braces pInputValues ] ) - where runOptions :: Maybe RunOptions -> Maybe BuiltinFunconsOptions -> - Maybe TestOptions -> RunOptions - runOptions mopts mbin mtests = let opts = maybe defaultRunOptions id mopts - in opts { builtin_funcons = maybe M.empty id mbin - , expected_outcomes = maybe M.empty id mtests } +pRunOptions = "SPECS" + <:=> foldr optionsOverride defaultRunOptions <$$> multiple pSpec +pSpec :: Parser RunOptions +pSpec = "SPEC" + <:=> keyword "general" **> braces pGeneral + <||> keyword "tests" **> braces pTestOutcomes + <||> keyword "funcons" **> braces pBuiltinFuncons + <||> keyword "inputs" **> braces pInputValues + pGeneral :: Parser RunOptions -pGeneral = toOpts <$> - (optionMaybe (keyword "funcon-term" *> colon *> pFuncons <* semiColon)) - <*> (M.fromList <$> many pKeyValues) +pGeneral = "GENERAL" + <:=> toOpts <$$> --TODO uncomfortable usage of id + optional (id <$$ keyword "funcon-term" <** keychar ':' <**> pFuncons <** keychar ';') + <**> (M.fromList <$$> multiple pKeyValues) where toOpts mf gen = defaultRunOptions {mfuncon_term = mf, general_opts = gen} - pKeyValues = pBoolOpts <|> pStringOpts - where pBoolOpts = choice (map pKeyValue booleanOptions) - where pKeyValue key = (pack key,) . maybe "true" id - <$ keyword key <*> optionMaybe (colon *> pBool) <* semiColon - - pStringOpts = choice (map pKeyValue stringOptions) - where pKeyValue key = (pack key,) <$ keyword key <* colon <*> pStringValue <* semiColon + pKeyValues = "GENERAL-KEYVALUES" <:=> pBoolOpts <||> pStringOpts + where pBoolOpts = "GENERAL-BOOLS" `chooses` (map pKeyValue booleanOptions) + where pKeyValue key = (pack key,) . maybe "true" id + <$$ keyword key <**> optional (keychar ':' **> pBool) + <** keychar ';' + pStringOpts = "GENERAL-STRINGS" `chooses` (map pKeyValue stringOptions) + where pKeyValue key = (pack key,) <$$ keyword key <** keychar ':' + <**> pStringValue <** keychar ';' + +chooses p alts = (<::=>) p (OO alts) + pBool :: Parser String -pBool = string "true" <|> string "false" +pBool = "BOOL-VALUE" <:=> id_lit -- everything except `false` is considered `true` pStringValue :: Parser String -pStringValue = filter (not . isSpace) . concat <$> commaSep1 stringValue - where stringValue = many1 (choice [alphaNum, char '-']) - -pFunconName = many1 (choice [alphaNum, char '-']) - -pFunconTerm :: Parser Funcons -pFunconTerm = pFuncons +pStringValue = "STRING-VALUE" <:=> id_lit <||> string_lit -pBuiltinFuncons :: Parser RunOptions -pBuiltinFuncons = (\list -> defaultRunOptions {builtin_funcons = M.fromList list}) <$> - many ((,) . pack <$> pFunconName <* equals <*> pFunconTerm <* semiColon) +pFunconName :: Parser String +pFunconName = "FUNCON-NAME" <:=> id_lit pTestOutcomes :: Parser RunOptions -pTestOutcomes = toOptions <$> (M.union <$> pResult <*> pEntityValues) - where pResult = mStoreResult <$> optionMaybe (id <$ keyword "result-term" <* colon - <*> pFunconTerm <* semiColon) +pTestOutcomes = "TEST-OUTCOMES" + <:=> toOptions <$$> (M.union <$$> pResult <**> pEntityValues) + where pResult = mStoreResult <$$> + optional (id <$$ keyword "result-term" <** keychar ':' + <**> pFunconsSeq <** keychar ';') where mStoreResult Nothing = M.empty mStoreResult (Just f) = M.singleton "result-term" f - pEntityValues = M.fromList <$> - many (((,) . pack <$> pFunconName <* colon <*> pFunconTerm <* semiColon)) + pEntityValues = "TEST-ENTITIES" <:=> M.fromList <$$> multiple + ((,) . pack <$$> pFunconName <** keychar ':' <**> pFunconsSeq <** keychar ';') toOptions map = defaultRunOptions { expected_outcomes = map } -pInputValues :: Parser RunOptions -pInputValues = (\list -> defaultRunOptions { given_inputs = M.fromList list}) <$> - many (toPair <$> pFunconName <* colon <*> pFunconTerm <* semiColon) - where toPair nm f = case recursiveFunconValue f of - Just (List vs) -> (pack nm, vs) - _ -> error ("inputs for " ++ nm ++ " not a list") - --- simple lexer -languageDef = L.emptyDef { - P.identStart = lower - , P.identLetter = lower <|> oneOf "-" - , P.reservedNames = allOptions ++ ["result-term"] - , P.reservedOpNames = [":"] - , P.commentLine = "--" - } - -language = P.makeTokenParser languageDef - -equals = whitespace *> char '=' <* whitespace -colon = whitespace *> char ':' <* whitespace -semiColon = whitespace *> char ';' <* whitespace +pBuiltinFuncons :: Parser RunOptions +pBuiltinFuncons = "BUILTIN-FUNCONS" + <:=> insertFuncons <$$> multiple ((,) . pack <$$> pFunconName <** keychar '=' + <**> pFuncons <** keychar ';') + where insertFuncons list = defaultRunOptions {builtin_funcons = M.fromList list} -whitespace = P.whiteSpace language -comma = P.comma language -keyword = P.reserved language -braces = P.braces language -identifier = P.identifier language -stringLiteral = P.stringLiteral language -commaSep1 = P.commaSep1 language -semiSep = P.semiSep language +pInputValues :: Parser RunOptions +pInputValues = "INPUT-VALUES" + <:=> insertInputs <$$> multiple (toPair <$$> pFunconName <** keychar ':' + <**> pFunconsSeq <** keychar ';') + where insertInputs list = defaultRunOptions { given_inputs = M.fromList list } + toPair nm fs = case sequence (map recursiveFunconValue fs) of + Just vs -> (pack nm, vs) + _ -> error ("inputs for " ++ nm ++ " not a list") diff --git a/src/Funcons/Simulation.hs b/src/Funcons/Simulation.hs --- a/src/Funcons/Simulation.hs +++ b/src/Funcons/Simulation.hs @@ -1,19 +1,21 @@ -{-# LANGUAGE TupleSections, FlexibleInstances, OverloadedStrings #-} +{-# LANGUAGE TupleSections, FlexibleInstances, OverloadedStrings,TypeSynonymInstances #-} module Funcons.Simulation where import Funcons.Types import Funcons.Exceptions import Funcons.Printer +import Funcons.Parser (fvalue_parse) import Funcons.RunOptions +import Control.Applicative import Control.Monad.State import System.IO (hFlush,stdout) import qualified Data.Map as M import Data.Text (unpack) class Monad m => Interactive m where - fread :: Bool -> Name -> m Values --entity name + fread :: Bool -> Name {- entity name -} -> m Funcons fprint :: Name -> Values -> m () fexec :: m a -> InputValues -> IO (a, InputValues) @@ -23,24 +25,28 @@ fread str_inp nm = (case nm of "standard-in" -> putStr "\n> " >> hFlush stdout _ -> putStrLn ("Please provide input for " ++ unpack nm ++ ":")) - >> getLine >>= return . toValue - where toValue str | str_inp = String str - | otherwise = read str + >> getLine >>= return . toFuncon + where toFuncon str | str_inp = string_ str + | otherwise = fvalue_parse str - fprint _ (String s) = putStr s - fprint _ v = putStr (showValues v) + fprint _ v | isString_ v = putStr (unString v) + | otherwise = putStr (showValues v) type SimIO = State InputValues +runSimIO :: SimIO a -> InputValues -> (a, InputValues) +runSimIO = runState instance Interactive SimIO where fexec ma defs = return (runState ma defs) fread _ nm = do v <- gets mLookup - modify (M.adjust tail nm) + modify (M.adjust mTail nm) return v where mLookup m = case M.lookup nm m of - Just (v:_) -> v - _ -> error ("simulated IO: " ++ show (InsufficientInput nm)) + Just (v:_) -> FValue v + _ -> FValue none__ + mTail [] = [] + mTail (_:vs) = vs -- SimIO ignores prints as simulated Output is always done -- alternative is to use tell from Writer monad here and somehow remember diff --git a/src/Funcons/Substitution.hs b/src/Funcons/Substitution.hs --- a/src/Funcons/Substitution.hs +++ b/src/Funcons/Substitution.hs @@ -1,14 +1,17 @@ {-# LANGUAGE LambdaCase #-} module Funcons.Substitution ( - Env(..), subsAndRewrite, envInsert, emptyEnv, Levelled(..), substitute, - rewriteTermTo, stepTermTo, + Env(..), subsAndRewritesInEnv, subsAndRewritesToValueInEnv, subsAndRewritesToValue, subsAndRewritesToValuesInEnv, subsAndRewritesToValues, + envInsert, emptyEnv, + Levelled(..), substitute_signal, substitute,rewriteTermTo, stepTermTo, + envRewrite, envStore, lifted_envRewrite, lifted_envStore, + fLevel, fsLevel, vLevel, vsLevel, envLookup ) where import Funcons.Types import Funcons.MSOS -import Funcons.Exceptions +import Control.Applicative import Control.Monad import Data.Monoid import qualified Data.Map as M @@ -17,9 +20,11 @@ -- This environment is used by a substitution procedure to transform -- funcon terms from 'FTerm' representation to 'Funcons'. type Env = M.Map MetaVar Levelled -data Levelled = ValueTerm Values +data Levelled = TypeTerm ComputationTypes + | TypesTerm [ComputationTypes] + | ValueTerm Values | ValuesTerm [Values] - | FunconTerm Funcons + | FunconTerm Funcons (Maybe (MSOS StepRes)) {- cached step -} | FunconsTerm [Funcons] -- | The empty substitution environment. @@ -28,73 +33,207 @@ envLookup :: Env -> MetaVar -> Rewrite Levelled envLookup env k = case M.lookup k env of - Nothing -> internal ("undefined metavar: " <> k) + Nothing -> internal ("no substitution for variable: " <> k) Just lf -> return lf envInsert :: MetaVar -> Levelled -> Env -> Env -envInsert = M.insert +envInsert = M.insertWith op + where op new old = new --TODO somehow unify values + {- + isWildCard (ValueTerm VAny) = True + isWildCard (ValuesTerm [VAny]) = True + isWildCard (FunconTerm (FValue VAny) _) = True + isWildCard (FunconsTerm [FValue VAny]) = True + isWildCard _ = False + -} + +{- +tsLevel :: Levelled -> Rewrite [ComputationTypes] +tsLevel = \case TypesTerm ts -> return ts + TypeTerm t -> return [t] + ValuesTerm vs + | all isSort_ vs -> return $ map downcastSort (map FValue vs) + | otherwise -> internal "not bound to types" + ValueTerm v | isSort_ v-> return $ [downcastSort v] +-} + +vsLevel :: Levelled -> Rewrite [Values] +vsLevel = \case FunconsTerm fs + | all (not.hasStep) fs -> return (map downcastValue fs) + | otherwise -> internal "not bound to values" + FunconTerm (FValue v) _ -> return [v] + FunconTerm f _ -> internal ("not bound to values") + ValuesTerm vs -> return vs + ValueTerm v -> return [v] + TypeTerm t -> return [ComputationType t] + TypesTerm ts -> return (map ComputationType ts) + +vLevel :: Levelled -> Rewrite Values +vLevel = \case FunconsTerm [FValue v] -> return v + FunconsTerm fs -> internal "not bound to values" + FunconTerm (FValue v) _ -> return v + FunconTerm f _ -> internal ("not bound to value") + ValuesTerm [v] -> return v + ValuesTerm vs -> internal ("not bound to value") + ValueTerm v -> return v + TypeTerm t -> return (ComputationType t) + TypesTerm [t] -> return (ComputationType t) + TypesTerm _ -> internal "not bound to a value" + fsLevel :: Levelled -> Rewrite [Funcons] fsLevel = \case FunconsTerm f -> return f - FunconTerm f -> return [f] + FunconTerm f _ -> return [f] ValuesTerm vs -> return (map FValue vs) ValueTerm v -> return [FValue v] - -fLevel k = \case FunconsTerm [f] -> return f - FunconsTerm fs - | all isVal fs -> return (FValue $ safe_tuple_val (map downcastValue fs)) - | otherwise -> return (FTuple fs) - FunconTerm f -> return f - ValuesTerm vs -> return (FValue (safe_tuple_val vs)) - ValueTerm v -> return (FValue v) + TypesTerm ts -> return (map sort_ ts) + TypeTerm t -> return [sort_ t] +fLevel k = \case + FunconsTerm [f] -> return f + FunconsTerm fs -> internal "not bound to a funcon" + FunconTerm f _ -> return f + ValuesTerm [v] -> return (FValue v) + ValuesTerm vs -> internal "not bound to a funcon" + ValueTerm v -> return (FValue v) + TypeTerm t -> return (sort_ t) + TypesTerm [t] -> return (sort_ t) + TypesTerm ts -> internal "not bound to a funcon" -- substitution + +substitute_signal :: FTerm -> Env -> Rewrite Values +substitute_signal t env = case t of + TVar k -> vLevel $ envMaybeLookup env k + TName nm -> return (ADTVal nm []) + TApp nm terms -> ADTVal nm . map FValue <$> subs_flatten terms env + TSeq ts -> internal "top level sequence during substitution (signal)" +-- TList ts -> List <$> subs_flatten ts env + TSet ts -> setval_ <$> subs_flatten ts env + TMap ts -> mapval_ <$> subs_flatten ts env + TFuncon (FValue v) -> return v + TAny -> return VAny + _ -> internal "missing case in substitute_signal" + where subs_flatten :: [FTerm] -> Env -> Rewrite [Values] + subs_flatten terms env = (concat <$>) $ forM terms $ \case + TVar k -> vsLevel $ envMaybeLookup env k + TSeq ts -> mapM (flip substitute_signal env) ts + term -> (:[]) <$> substitute_signal term env + + envMaybeLookup :: Env -> MetaVar -> Levelled + envMaybeLookup env k = case M.lookup k env of + Nothing -> ValueTerm VAny + Just lf -> lf + + substitute :: FTerm -> Env -> Rewrite Funcons substitute (TVar k) env = envLookup env k >>= fLevel k substitute (TName nm) env = return $ FName nm -substitute (TApp nm term) env = do - -- if its anything but a sequence-var or a tuple, make it a singleton sequence - fs <- case term of TVar k -> envLookup env k >>= fsLevel - TTuple l -> substitute term env >>= \case - FTuple fs -> return fs - _ -> error "subsitute assert" - _ -> (:[]) <$> substitute term env - return $ FApp nm (FTuple fs) -substitute (TTuple terms) env = FTuple <$> subsFlatten terms env +substitute (TApp nm terms) env = FApp nm <$> subsFlatten terms env +substitute (TSeq terms) env = internal ("top level sequence during substitution: " ++ show terms) -- e.g. print(V+:values+) -- standard-out![V+] -> () -substitute (TList terms) env = FList <$> subsFlatten terms env -substitute (TSet terms) env = FSet <$> subsFlatten terms env -substitute (TMap terms) env = FMap <$> mapM (flip substitute env) terms +--substitute (TList terms) env = FList <$> subsFlatten terms env +substitute (TSet terms) env = FSet <$> subsFlatten terms env +substitute (TMap terms) env = FMap <$> subsFlatten terms env substitute (TFuncon f) env = return f substitute (TSortUnion t1 t2) env = FSortUnion <$> substitute t1 env <*> substitute t2 env +substitute (TSortInter t1 t2) env = FSortInter <$> substitute t1 env <*> substitute t2 env +substitute (TSortComplement t1) env = FSortComplement <$> substitute t1 env substitute (TSortSeq t1 op) env = flip FSortSeq op <$> substitute t1 env +substitute (TSortPower t1 t2) env = FSortPower <$> substitute t1 env <*> substitute t2 env substitute (TSortComputes t1) env = FSortComputes <$> substitute t1 env substitute (TSortComputesFrom t1 t2) env = FSortComputesFrom <$> substitute t1 env <*> substitute t2 env +substitute TAny env = internal "missing substitution (wildcard)" -- flatten out sequence-variables subsFlatten :: [FTerm] -> Env -> Rewrite [Funcons] subsFlatten terms env = concat <$> (forM terms $ \case TVar k -> envLookup env k >>= fsLevel + TSeq ts -> mapM (flip substitute env) ts term -> (:[]) <$> substitute term env) -subsAndRewrite :: FTerm -> Env -> Rewrite Values -subsAndRewrite term env = do - f <- substitute term env - rewriteFuncons f >>= \case - ValTerm v -> return v - CompTerm _ _ -> rewrite_throw (SideCondFail "premise evaluation requires step") +-- Version of subsAndRewritesToValue that 'caches' computational steps: +-- If after rewriting a computational step is produced the +-- step and associated funcon replace the term in the environment +-- (if the term consists of just a meta-variable) +-- This function immediately returns a computational step when +-- a given term has a cached step +-- If the term is not just a meta-variable, this function behaves normally +subsAndRewritesInEnv :: FTerm -> Env -> Rewrite (Rewritten, Env) +subsAndRewritesInEnv (TVar x) env + | Just (FunconTerm f (Just step)) <- M.lookup x env = + return $ (CompTerm f step, env) +subsAndRewritesInEnv term env = do + f <- substitute term env + res <- rewriteFunconsWcount f + case term of + TVar x -> case res of + ValTerm vs -> return (res, envInsert x (ValuesTerm vs) env) + CompTerm f step -> return (res, envInsert x (FunconTerm f (Just step)) env) + _ -> return (res, env) +subsAndRewritesToValue :: FTerm -> Env -> Rewrite Values +subsAndRewritesToValue f env = fst <$> subsAndRewritesToValueInEnv f env +-- Important optimisation: +-- If the given term is a var, +-- update the env to store the rewritten value. +subsAndRewritesToValueInEnv :: FTerm -> Env -> Rewrite (Values, Env) +subsAndRewritesToValueInEnv (TVar x) env + -- assumed to be already rewritten (because cached step is present) + | Just (FunconTerm f (Just step)) <- M.lookup x env = rewriteToValErr +subsAndRewritesToValueInEnv term env = do + f <- substitute term env + v <- rewritesToValue f + case term of TVar var -> return (v, envInsert var (ValueTerm v) env) + _ -> return (v, env) + +subsAndRewritesToValues :: FTerm -> Env -> Rewrite [Values] +subsAndRewritesToValues f env = fst <$> subsAndRewritesToValuesInEnv f env + +subsAndRewritesToValuesInEnv :: FTerm -> Env -> Rewrite ([Values], Env) +subsAndRewritesToValuesInEnv (TVar x) env + -- assumed to be already rewritten (because cached step is present) + | Just (FunconTerm f (Just step)) <- M.lookup x env = rewriteToValErr +subsAndRewritesToValuesInEnv term env = do + fs <- subsFlatten [term] env + vs <- concat <$> mapM rewritesToValues fs + case term of TVar var -> return (vs, envInsert var (ValuesTerm vs) env) + _ -> return (vs, env) + + -- | Variant of 'rewriteTo' that applies substitution. rewriteTermTo :: FTerm -> Env -> Rewrite Rewritten -rewriteTermTo fterm env = substitute fterm env >>= rewriteTo +rewriteTermTo fterm env = subsFlatten [fterm] env >>= \case + [f] -> rewriteTo f + fs -> rewriteSeqTo fs -- | Variant of 'stepTo' that applies substitution. -stepTermTo :: FTerm -> Env -> MSOS Funcons -stepTermTo fterm env = do - (liftRewrite $ substitute fterm env) >>= stepTo +stepTermTo :: FTerm -> Env -> MSOS StepRes +stepTermTo fterm env = liftRewrite (subsFlatten [fterm] env) >>= \case + [f] -> stepTo f + fs -> stepSeqTo fs +lifted_envStore :: MetaVar -> FTerm -> Env -> MSOS Env +lifted_envStore m t e = liftRewrite (envStore m t e) + +envStore :: MetaVar -> FTerm -> Env -> Rewrite Env +envStore var term env = substitute term env >>= \case + (FValue v) -> return $ envInsert var (ValueTerm v) env + fct -> return $ envInsert var (FunconTerm fct Nothing) env + +lifted_envRewrite :: MetaVar -> Env -> MSOS Env +lifted_envRewrite m e = liftRewrite (envRewrite m e) + +-- | Apply as many rewrites as possible to the term bound to the +-- given variable in the meta-environment +envRewrite :: MetaVar -> Env -> Rewrite Env +envRewrite var env = do + envLookup env var >>= \case + FunconTerm fct Nothing -> rewriteFunconsWcount fct >>= \case + ValTerm vs -> return $ envInsert var (ValuesTerm vs) env + CompTerm f fs -> return $ envInsert var (FunconTerm f (Just fs)) env + _ -> return env diff --git a/src/Funcons/Tools.hs b/src/Funcons/Tools.hs --- a/src/Funcons/Tools.hs +++ b/src/Funcons/Tools.hs @@ -6,14 +6,15 @@ -- $moduledoc mkMain, mkMainWithLibrary, mkMainWithLibraryEntities, mkMainWithLibraryTypes, mkMainWithLibraryEntitiesTypes, + mkFullyFreshInterpreter, mkFreshInterpreter, -- * Creating embedded interpreters. - run, runWithExtensions, + run, runWithExtensions, runWithExtensionsNoCore, runWithExtensionsNoNothing, -- * Utility functions for interpreter extensions. -- ** Funcon libraries. - FunconLibrary, libEmpty, libUnion, libUnions, libFromList, + FunconLibrary, libEmpty, libUnion, libOverride, libUnions, libOverrides, libFromList, -- ** Type environments. - TypeEnv, DataTypeMembers(..), DataTypeAlt(..), TypeParam, - emptyTypeEnv, typeEnvUnion, typeEnvUnions, typeEnvFromList, + TypeRelation, DataTypeMembers(..), DataTypeAltt(..), TypeParam, + emptyTypeRelation, typeEnvUnion, typeEnvUnions, typeEnvFromList, -- ** Entity declarations EntityDefaults, EntityDefault(..), noEntityDefaults, ) where @@ -32,7 +33,7 @@ import Data.Text (unpack) import Data.List ((\\), intercalate) import qualified Data.Map as M -import Control.Monad (forM_, when, unless) +import Control.Monad (forM_, when, unless,join) -- | The empty collection of entity defaults. noEntityDefaults :: [EntityDefault] @@ -55,41 +56,69 @@ -- argument. mkMainWithLibraryEntities :: FunconLibrary -> EntityDefaults -> IO () mkMainWithLibraryEntities lib ents = - mkMainWithLibraryEntitiesTypes lib ents emptyTypeEnv + mkMainWithLibraryEntitiesTypes lib ents emptyTypeRelation -- | Creates a /main/ function for the interpreter obtained by extending -- the main interpreter with the funcons in the 'FunconLibrary' argument --- and with a 'TypeEnv' mapping datatypes to their constructors and +-- and with a 'TypeRelation' mapping datatypes to their constructors and -- type arguments. -mkMainWithLibraryTypes :: FunconLibrary -> TypeEnv -> IO () +mkMainWithLibraryTypes :: FunconLibrary -> TypeRelation -> IO () mkMainWithLibraryTypes lib tys = mkMainWithLibraryEntitiesTypes lib [] tys -- | Creates a /main/ function for the interpreter obtained by extending --- the main interpreter with funcons, 'EntityDefaults' and a 'TypeEnv'. -mkMainWithLibraryEntitiesTypes :: FunconLibrary -> EntityDefaults -> TypeEnv -> IO () +-- the main interpreter with funcons, 'EntityDefaults' and a 'TypeRelation'. +mkMainWithLibraryEntitiesTypes :: FunconLibrary -> EntityDefaults -> TypeRelation -> IO () mkMainWithLibraryEntitiesTypes lib defaults tyenv = do args <- getArgs - case args of - [] -> go0 - _ -> go2 args - where go0 = putStrLn "Please provide me with an .fct file" - go2 args = runWithExtensions lib defaults tyenv args Nothing + runWithExtensions lib defaults tyenv args Nothing +-- | Creates a /main/ function for the interpreter aware of only +-- the given 'FunconLibrary', 'EntityDefaults' and 'TypeRelation'. +mkFullyFreshInterpreter :: FunconLibrary -> EntityDefaults -> TypeRelation -> IO () +mkFullyFreshInterpreter lib defaults tyenv = do + args <- getArgs + runWithExtensionsNoNothing lib defaults tyenv args Nothing + +-- | Creates a /main/ function for the interpreter aware of only +-- the given 'FunconLibrary', 'EntityDefaults' and 'TypeRelation', +-- and the built-in types and operations. +mkFreshInterpreter :: FunconLibrary -> EntityDefaults -> TypeRelation -> IO () +mkFreshInterpreter lib defaults tyenv = do + args <- getArgs + runWithExtensionsNoCore lib defaults tyenv args Nothing + -- | Same as 'run', except receiving additional interpreter extensions as arguments. -- Useful when a translation to 'Funcons' has been implemented in Haskell as -- well as 'Funcons', entities or datatypes specific to the object language. +-- Includes the 'Funcons.Core' funcons. runWithExtensions :: - FunconLibrary -> EntityDefaults -> TypeEnv -> [String] -> Maybe Funcons -> IO () + FunconLibrary -> EntityDefaults -> TypeRelation -> [String] -> Maybe Funcons -> IO () runWithExtensions lib defaults tyenv = - emulate full_lib full_defaults full_tyenv - where - full_lib = libUnions [lib + runWithExtensionsNoCore + (libUnions [Funcons.Core.Library.funcons, lib]) + (concat [defaults, Funcons.Core.Library.entities]) + (typeEnvUnions [tyenv, Funcons.Core.Library.types]) + +-- | Same as 'run', except receiving additional interpreter extensions as arguments. +-- Useful when a translation to 'Funcons' has been implemented in Haskell as +-- well as 'Funcons', entities or datatypes specific to the object language. +-- Does not include the 'Funcons.Core' funcons. +runWithExtensionsNoCore :: + FunconLibrary -> EntityDefaults -> TypeRelation -> [String] -> Maybe Funcons -> IO () +runWithExtensionsNoCore lib defaults tyenv = runWithExtensionsNoNothing full_lib defaults tyenv + where full_lib = libUnions [lib ,Funcons.EDSL.library - ,Funcons.Core.Manual.library - ,Funcons.Core.Library.funcons] - full_defaults = concat [defaults, Funcons.Core.Library.entities] - full_tyenv = typeEnvUnions [tyenv, Funcons.Core.Library.types] + ,Funcons.Core.Manual.library] +-- | Same as 'run', except receiving additional interpreter extensions as arguments. +-- Useful when a translation to 'Funcons' has been implemented in Haskell as +-- well as 'Funcons', entities or datatypes specific to the object language. +-- Does not include the 'Funcons.Core' funcons. +runWithExtensionsNoNothing :: + FunconLibrary -> EntityDefaults -> TypeRelation -> [String] -> Maybe Funcons -> IO () +runWithExtensionsNoNothing lib defaults tyenv = emulate lib defaults tyenv + + -- | -- Creates a main function by passing in a list of command line arguments -- and an optional initial 'Funcons' to execute. The 'Funcons' argument is optional @@ -97,7 +126,7 @@ -- file that specifies an initial 'Funcons' term. -- Useful when a translation to 'Funcons' has been implemented in Haskell. run :: [String] -> Maybe Funcons -> IO () -run = runWithExtensions libEmpty [] emptyTypeEnv +run = runWithExtensions libEmpty [] emptyTypeRelation ------------------------------------------------------------------------------ --- running programs @@ -106,54 +135,58 @@ forM_ unknown_opts $ \arg -> do putStrLn ("unknown option: " ++ arg) case interactive_mode opts of - True -> emulate' (fread (string_inputs opts) :: Name -> IO Values) lib defaults tyenv opts mf0 - False -> emulate' (fread (string_inputs opts) :: Name -> SimIO Values) lib defaults tyenv opts mf0 + True -> emulate' (fread (string_inputs opts) :: Name -> IO Funcons) lib defaults tyenv opts mf0 + False -> emulate' (fread (string_inputs opts) :: Name -> SimIO Funcons) lib defaults tyenv opts mf0 -emulate' :: Interactive m => (Name -> m Values) -> - FunconLibrary -> EntityDefaults -> TypeEnv -> RunOptions -> Maybe Funcons -> IO () -emulate' reader lib defaults tyenv opts mf0 = do +emulate' :: Interactive m => (Name -> m Funcons) -> + FunconLibrary -> EntityDefaults -> TypeRelation -> RunOptions -> Maybe Funcons -> IO () +emulate' reader lib defaults tyenv opts mf0 = do -- the initial funcon term must be either given from a .fct file (Maybe Funcons) -- or specified in a configuration file - let f0 = maybe (funcon_term opts) id mf0 - msos_ctxt = MSOSReader (RewriteReader lib tyenv opts f0 f0) emptyINH + let f0 = maybe (funcon_term opts) id mf0 + msos_ctxt = MSOSReader (RewriteReader lib tyenv opts f0 f0) emptyINH emptyDCTRL reader -- run the Interactive monad, returning in the evaluation results + entity values. -- if in --interactive-mode the Interactive monad will be IO -- and all the desired output will already have been printed to the screen ((e_exc_f, mut, wr), rem_ins) <- - fexec (runMSOS (setEntityDefaults defaults (stepTrans opts 0 f0)) + fexec (runMSOS (setEntityDefaults defaults (stepTrans opts 0 (toStepRes f0))) msos_ctxt (emptyMSOSState {inp_es = inputs})) (inputValues opts) -- if not in --interactive-mode then print additional information based on flags - unless (interactive_mode opts) + unless (interactive_mode opts) (withResults defaults msos_ctxt e_exc_f mut wr rem_ins) - where inputs = foldr op M.empty defaults - where op (DefInput nm) = M.insert nm ([], Just (reader nm)) - op _ = id + where inputs = M.foldrWithKey op M.empty (inputValues opts) + where op nm _ = M.insert nm ([], Just (reader nm)) withResults defaults msos_ctxt e_exc_f msos_state wr rem_ins - | show_tests opts = + | show_tests opts = case e_exc_f of Left ie -> putStrLn (showIException ie) - Right f -> printTestResults f defaults msos_ctxt msos_state wr rem_ins + Right efvs -> printTestResults (either (:[]) (map FValue) efvs) + defaults msos_ctxt msos_state wr rem_ins | otherwise = do unless (show_output_only opts) $ do printCounts - case e_exc_f of + case e_exc_f of Left ie -> putStrLn (showIException ie) - Right f -> printResult f + Right f -> printResult (either (:[]) (map FValue) f) printMutable printControl - printInputOutput rem_ins (hide_input opts) + printInput rem_ins (hide_input opts) printOutput where muts = mut_entities msos_state opts = run_opts (ereader msos_ctxt) printResult f = when (show_result opts) $ do putStrLn "Result:" - putStrLn (ppFuncons opts f) + putStrLn (ppFunconsSeq opts f) putStrLn "" - printCounts = when (show_counts opts) - (putStrLn $ show (counters (ewriter wr))) + printCounts = do + when (show_counts opts) $ do + when (csv_output_with_keys opts) (putStrLn counterKeys) + if (csv_output opts) + then putStrLn $ displayCounters (counters (ewriter wr)) + else putStrLn $ ppCounters (counters (ewriter wr)) printMutable = forM_ toShow display where toShow = show_mutable opts @@ -177,36 +210,36 @@ unless (show_output_only opts) (putStrLn ("Output Entity: " ++ unpack name)) case all isString_ vs && pp_string_outputs opts of - True -> mapM_ (\(String s) -> putStr s) vs - False -> putStrLn (displayValue (List vs)) + True -> mapM_ (putStr . unString) vs + False -> putStrLn (displayValues vs) unless (show_output_only opts) (putStrLn "") where vs = out M.! name toHide = hide_output opts - printInputOutput ios toHide = forM_ (M.keys ios \\ toHide) display + printInput ios toHide = forM_ (M.keys ios \\ toHide) display where display name = unless (null vs) $ do - putStrLn ("Output Entity: " ++ unpack name) - putStrLn (displayValue (List vs)) + putStrLn ("Input Entity: " ++ unpack name) + putStrLn (displayValues vs) putStrLn "" where vs = ios M.! name + displayValues vs = intercalate "," (map displayValue vs) displayValue (Map m) = intercalate "\n" [ displayValue key ++ " |-> " ++ displayValue val | (key, val) <- M.assocs m ] - displayValue (ADTVal "variable" [Atom a, ComputationType (Type t)]) = - "variable(" ++ displayValue (Atom a) ++ ", " ++ ppTypes opts t ++ ")" + displayValue (ADTVal "variable" [FValue (Atom a) + ,FValue (ComputationType (Type t))]) = + "variable(" ++ displayValue (Atom a) ++ ", " ++ ppTypes (ppFuncons opts) t ++ ")" displayValue (Atom a) = "@" ++ a - displayValue (List vs) | all isString_ vs = concatMap displayValue vs - displayValue (ADTVal con vs) = unpack con ++"("++ intercalate "," (map displayValue vs)++")" - displayValue val = ppValues opts val + displayValue val = ppValues (ppFuncons opts) val -printTestResults :: Funcons -> EntityDefaults -> MSOSReader -> +printTestResults :: [Funcons] -> EntityDefaults -> MSOSReader m -> MSOSState m -> MSOSWriter -> InputValues -> IO () -printTestResults f defaults msos_ctxt msos_state wr rem_ins = do +printTestResults fs defaults msos_ctxt msos_state wr rem_ins = do forM_ (M.keys opts) printNotExists when (M.member "result-term" opts) $ - unless (result_term == f) (reportError "result-term" result_term f) + unless (result_term == fs) (reportError "result-term" (showFunconsSeq result_term) (showFunconsSeq fs)) printMutable printControl printInputOutput out @@ -218,25 +251,27 @@ localEval name term = case runRewrite (rewriteFuncons term) eval_ctxt eval_state of (Left ie,_,_) -> error ("internal exception in " ++ unpack name ++ " evaluation:\n" ++ showIException ie) - (Right (ValTerm v),_,_) -> v + (Right (ValTerm [v]),_,_) -> v + (Right (ValTerm vs),_,_) -> error + ("evaluation of " ++ unpack name ++ " results in sequence") (Right _,_,_) -> error ("evaluation of " ++ unpack name ++ " requires step") mLocalEval term = case runRewrite(rewriteFuncons term) eval_ctxt eval_state of - (Right (ValTerm v),_,_) -> Just v + (Right (ValTerm [v]),_,_) -> Just v _ -> Nothing - result_term = case recursiveFunconValue rf of - Nothing -> case mLocalEval rf of + result_term = case sequence (fmap recursiveFunconValue rf) of + Nothing -> case sequence (fmap mLocalEval rf) of Nothing -> rf - Just v -> FValue v - Just v -> FValue v + Just vs -> map FValue vs + Just vs -> map FValue vs where rf = (opts M.! "result-term") opts = expected_outcomes (run_opts eval_ctxt) reportError name expected actual = do - putStrLn ("expected " ++ unpack name ++ ": " ++ show expected) - putStrLn ("actual " ++ unpack name ++ ": " ++ show actual) + putStrLn ("expected " ++ unpack name ++ ": " ++ expected) + putStrLn ("actual " ++ unpack name ++ ": " ++ actual) printNotExists "result-term" = return () printNotExists name = @@ -249,10 +284,12 @@ printMutable = forM_ (M.assocs muts) (uncurry display) where display name val = case M.lookup name opts of Nothing -> return () - Just expected -> unless (localEval name expected == val) - (reportError name expected val) + Just expected -> unless + (map (localEval name) expected == [val]) + (reportError name (show $ map showFuncons expected) (showValues val)) -- set default values of output and control entities + ctrl :: M.Map Name (Maybe Values) ctrl = foldr op (ctrl_entities wr) defaults where op (DefControl name) ctrl | not (M.member name ctrl) = M.insert name Nothing ctrl @@ -266,30 +303,32 @@ -- TODO this does not test the case that a control signal is expected -- according to the test, but not present. printControl = forM_ (M.assocs ctrl) (uncurry display) - where -- test whether control signal is expected when there is none + where display :: Name -> Maybe Values -> IO () + -- test whether control signal is expected when there is none -- shows expected signal display name Nothing = case M.lookup name opts of Nothing -> return () - Just val -> putStrLn ("expected "++unpack name++": " - ++ show (localEval name val)) + Just vals -> putStrLn ("expected "++unpack name++": " + ++ show (map (showValues . localEval name) vals)) -- test whether control signal is expected when there is one -- shows that the emitted signal was unexpected -- if a signal was expected, shows if actual and expected are unequal display name (Just val) = case M.lookup name opts of - Nothing -> putStrLn ("unexpected " ++ unpack name ++ ": " ++ show val) - Just expected -> unless (localEval name expected == val) - (reportError name expected val) + Nothing -> putStrLn ("unexpected " ++ unpack name ++ ": " ++ showValues val) + Just expected -> unless + (map (localEval name) expected == [val]) + (reportError name (show $ map showFuncons expected) (showValues val)) printInputOutput remaining = forM_ (M.assocs remaining) (uncurry display) where -- no test-error if the input/output is empty -- (and no input/output was specified) display name [] | Nothing <- M.lookup name opts = return () display name vals = case M.lookup name opts of - Nothing -> putStrLn ("unexpected " ++ unpack name ++ ": " ++ show vals) - Just expected -> case localEval name expected of - List exps -> unless (exps == vals) (reportError name expected vals) + Nothing -> putStrLn ("unexpected " ++ unpack name ++ ": " ++ show (map showValues vals)) + Just expected -> case map (localEval name) expected of + [ADTVal "list" exps] -> unless (exps == map FValue vals) (reportError name (show $ map showFuncons exps) (show $ map showValues vals)) val -> error ("non-list given as expected output entity ("++ - unpack name ++ "): " ++ show val) + unpack name ++ "): " ++ show (map showValues val)) -- $moduledoc @@ -448,7 +487,7 @@ -- a 'FunconLibrary' is a "funcon module". -- An interpreter is obtained by importing the chosen "funcon modules" and uniting -- their 'FunconLibrary's (with 'libUnions'), perhaps together with default --- values for entities ('EntityDefault') and information about custom datatypes ('TypeEnv'). +-- values for entities ('EntityDefault') and information about custom datatypes ('TypeRelation'). -- The resulting maps are given as arguments to 'mkMainWithLibraryEntitiesTypes' -- (or variant). -- By using 'mkMainWithLibraryEntitiesTypes', all interpreters inherit the diff --git a/src/Funcons/TypeSubstitution.hs b/src/Funcons/TypeSubstitution.hs new file mode 100644 --- /dev/null +++ b/src/Funcons/TypeSubstitution.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.TypeSubstitution where + +import Funcons.Types +import Funcons.Patterns + +import qualified Data.Map as M +import qualified Data.Set as S + +-- | Associates types (Terms) with meta-variables +type TypeEnv = M.Map MetaVar TyAssoc +data TyAssoc = ElemOf FTerm | SubTyOf FTerm + +-- | Version of `subsTypeVar` that does not replace the meta-variables +-- in the given set +limitedSubsTypeVar :: HasTypeVar a => S.Set MetaVar -> TypeEnv -> a -> a +limitedSubsTypeVar pvars env = subsTypeVar (foldr aux env pvars) + where aux pvar = M.delete pvar + +-- | Version of `subsTypeVarWildcard` that does not replace the meta-variables +-- in the given set +limitedSubsTypeVarWildcard :: HasTypeVar a => S.Set MetaVar -> Maybe FTerm -> TypeEnv -> a -> a +limitedSubsTypeVarWildcard pvars mt env = subsTypeVarWildcard mt (foldr aux env pvars) + where aux pvar = M.delete pvar + + +-- | Used for replacing meta-variables `T` in pattern annotations `P:T` with +-- the type to which `T` is bound in some type-environment (if any) +class HasTypeVar a where + subsTypeVar :: TypeEnv -> a -> a + subsTypeVar = subsTypeVarWildcard Nothing + + subsTypeVarWildcard :: (Maybe FTerm) -> TypeEnv -> a -> a + +instance HasTypeVar FTerm where + subsTypeVarWildcard mt env t = case t of + TVar var -> case M.lookup var env of + Just (SubTyOf ty) -> ty + Just (ElemOf (TSortSeq (TName "types") op)) -> TSortSeq (TName "values") op + Just (ElemOf (TSortSeq (TName "value-types") op)) -> TSortSeq (TName "values") op + Just (ElemOf (TName "types")) -> TName "values" + Just (ElemOf vt) -> TVar var + Nothing -> TVar var + TName nm -> TName nm + TApp nm ts-> TApp nm (map (subsTypeVarWildcard mt env) ts) + TSeq ts -> TSeq (map (subsTypeVarWildcard mt env) ts) +-- TList ts -> TList (map (subsTypeVarWildcard mt env) ts) + TSet ts -> TSet (map (subsTypeVarWildcard mt env) ts) + TMap ts -> TMap (map (subsTypeVarWildcard mt env) ts) + TFuncon f -> TFuncon f + TSortSeq t op -> TSortSeq (subsTypeVarWildcard mt env t) op + TSortPower t1 t2 -> TSortPower (subsTypeVarWildcard mt env t1) (subsTypeVarWildcard mt env t2) + TSortUnion t1 t2 -> TSortUnion (subsTypeVarWildcard mt env t1) (subsTypeVarWildcard mt env t2) + TSortInter t1 t2 -> TSortInter (subsTypeVarWildcard mt env t1) (subsTypeVarWildcard mt env t2) + TSortComplement t -> TSortComplement (subsTypeVarWildcard mt env t) + TSortComputes t -> TSortComputes (subsTypeVarWildcard mt env t) + TSortComputesFrom f t -> TSortComputesFrom (subsTypeVarWildcard mt env f) (subsTypeVarWildcard mt env t) + TAny -> case mt of Nothing -> TAny + Just t -> t + +instance HasTypeVar VPattern where + subsTypeVarWildcard mt env pat = case pat of + VPAnnotated p t -> VPAnnotated (subsTypeVarWildcard mt env p) (subsTypeVarWildcard mt env t) + PADT n pats -> PADT n (map (subsTypeVarWildcard mt env) pats) +-- PList pats -> PList (map (subsTypeVarWildcard mt env) pats) + VPMetaVar var -> VPMetaVar var + VPSeqVar var op -> VPSeqVar var op + VPLit v -> VPLit v + VPWildCard -> VPWildCard + VPType pat -> VPType pat + +instance HasTypeVar FPattern where + subsTypeVarWildcard mt env pat = case pat of + PAnnotated p t -> PAnnotated (subsTypeVarWildcard mt env p) (subsTypeVarWildcard mt env t) + PValue p -> PValue $ subsTypeVarWildcard mt env p + PMetaVar var -> PMetaVar var + PSeqVar var op -> PSeqVar var op + PWildCard -> PWildCard + + diff --git a/src/Funcons/Types.hs b/src/Funcons/Types.hs --- a/src/Funcons/Types.hs +++ b/src/Funcons/Types.hs @@ -1,37 +1,44 @@ -{-# LANGUAGE OverloadedStrings, TupleSections #-} +{-# LANGUAGE OverloadedStrings, TupleSections, FlexibleInstances #-} -module Funcons.Types where +module Funcons.Types ( + module Funcons.Types, + module VAL,) where +import qualified Funcons.Operations as VAL hiding (SortErr, ValueOp) +import Funcons.Operations hiding (Name, Values, ComputationTypes, TaggedSyntax, Types, isMap, isAscii, isNoValue, isSet, map_empty_, isEnv, isDefinedVal, isString_, isChar, isVec, isType, isList, isNat, isInt, atoms_, integers_, values_, set_, list_, tuple_, atom_, nothing_, defined_values_, types_, value_types_, toList, isList) + +import qualified Data.Char as C import qualified Data.Map as M import qualified Data.Set as S import qualified Data.MultiSet as MS import qualified Data.Vector as V -import qualified Data.BitVector as BV import Data.Text (Text) -import Data.Maybe (isJust) import Data.Ratio type MetaVar = String type Name = Text --- | +-- | -- Internal representation of funcon terms. -- The generic constructors 'FName' and 'FApp' use names to represent --- nullary funcons and applications of funcons to other terms. +-- nullary funcons and applications of funcons to other terms. -- Funcon terms are easily created using 'applyFuncon' or via -- the smart constructors exported by "Funcons.Core". data Funcons = FName Name - | FApp Name Funcons - | FTuple [Funcons] - | FList [Funcons] + | FApp Name [Funcons] +-- | FTuple [Funcons] +-- | FList [Funcons] | FSet [Funcons] | FMap [Funcons] | FValue Values - | FSortSeq Funcons SeqSortOp + | FSortSeq Funcons VAL.SeqSortOp + | FSortPower Funcons Funcons {- evals to natural number -} | FSortUnion Funcons Funcons + | FSortInter Funcons Funcons + | FSortComplement Funcons | FSortComputes Funcons - | FSortComputesFrom Funcons Funcons - deriving (Eq, Ord, Show) + | FSortComputesFrom Funcons Funcons + deriving (Eq, Ord, Show, Read) -- | -- Build funcon terms by applying a funcon name to `zero or more' funcon terms. @@ -45,108 +52,59 @@ -- > handle_thrown_ :: Funcons -> Funcons -> Funcons -- > handle_thrown_ x y = applyFuncon "handle-thrown" [x,y] applyFuncon :: Name -> [Funcons] -> Funcons -applyFuncon str args | null args = FName str - | otherwise = FApp str (FTuple args) +applyFuncon str args | null args = FName str + | otherwise = FApp str args +tuple_ :: [Funcons] -> Funcons +tuple_ = FValue . ADTVal "list" + -- | Creates a list of funcon terms. list_ :: [Funcons] -> Funcons -list_ = FList +list_ = applyFuncon "list" -- | Creates a set of funcon terms. set_ :: [Funcons] -> Funcons -set_ = FSet - +set_ = applyFuncon "set" --- | Funcon term representation identical to 'Funcons', --- but with meta-variables. +-- | Funcon term representation identical to 'Funcons', +-- but with meta-variables. data FTerm = TVar MetaVar | TName Name - | TApp Name FTerm - | TTuple [FTerm] - | TList [FTerm] + | TApp Name [FTerm] + | TSeq [FTerm] -- a sequence of terms, consumed during substitution +-- | TList [FTerm] | TSet [FTerm] | TMap [FTerm] | TFuncon Funcons - | TSortSeq FTerm SeqSortOp + | TSortSeq FTerm VAL.SeqSortOp + | TSortPower FTerm FTerm {- should eval to a natural number -} | TSortUnion FTerm FTerm + | TSortInter FTerm FTerm + | TSortComplement FTerm | TSortComputes FTerm | TSortComputesFrom FTerm FTerm - deriving (Eq, Ord, Show) + | TAny -- used whenever funcon terms may have holes in them + -- currently only the case in "downwards" flowing signals + deriving (Eq, Ord, Show, Read) --- | --- This datatype provides a number of builtin value types. --- Composite values are only built up out of other values. --- The only exception is 'Thunk' which stores a thunked computation --- (funcon term). -data Values = ADTVal Name [Values] - | Ascii Int - | Atom String - | Bit BV.BitVector - | Char Char - | ComputationType ComputationTypes - | Float Float - | IEEE_Float_32 Float - | IEEE_Float_64 Double - | Int Integer - | List [Values] - | Map Map - | Multiset (MS.MultiSet Values) - | Nat Integer - | Rational Rational - | Set Set - | String String - | Thunk Funcons - | EmptyTuple -- | Tuples are split in 'EmptyTuple' and 'NonEmptyTuple' to avoid singleton tuples. Tuples should be constructed by applications of 'tuple_'. - | NonEmptyTuple Values Values [Values] - | Vector Vectors - deriving (Eq,Ord,Show) +type Values = VAL.Values Funcons +type TaggedSyntax = VAL.TaggedSyntax Funcons + +instance HasValues Funcons where + inject = FValue + project f = case f of + FValue v -> Just v + _ -> Nothing + type Map = M.Map Values Values type Set = S.Set Values type Vectors = V.Vector Values --- | Postfix operators for specifying sequences. -data SeqSortOp = StarOp | PlusOp | QuestionMarkOp - deriving (Show, Eq, Ord) - --- | Computation type /S=>T/ reflects a type of term --- whose given value is of type /S/ and result is of type /T/. -data ComputationTypes = Type Types -- | /=>T/ - | ComputesType Types -- | /S=>T/ - | ComputesFromType Types Types - deriving (Ord,Eq,Show) - -- | Representation of builtin types. -data Types = ADTs - | ADT Name [Types] - | AsciiCharacters - | Atoms - | Bits Int - | BoundedIntegers Integer Integer - | ComputationTypes - | EmptyType - | IEEEFloats IEEEFormats - | Integers - | Lists Types - | Maps Types Types - | Multisets Types - | Naturals - | Rationals - | Sets Types - | Strings - | Thunks ComputationTypes -- | Types optionally attached to 'SeqSortOp'. - | Tuples [TTParam] - | Types - | UnicodeCharacters - | Union Types Types - | Values - | Vectors Types - deriving (Ord,Eq,Show) - -type TTParam = (Types,Maybe SeqSortOp) - -data IEEEFormats = Binary32 | Binary64 - deriving (Enum,Show,Eq,Ord) +type ComputationTypes = VAL.ComputationTypes Funcons +type Types = VAL.Types Funcons +type TTParam = (Types,Maybe VAL.SeqSortOp) binary32 :: Values binary32 = ADTVal "binary32" [] @@ -154,111 +112,48 @@ binary64 :: Values binary64 = ADTVal "binary64" [] -adtval :: Name -> Values -> Values -adtval nm = ADTVal nm . tuple_unval +adtval :: Name -> [Values] -> Values +adtval nm = ADTVal nm . map FValue +tuple_val__ :: [Values] -> Values +tuple_val__ = adtval "tuple" +tuple_val_ = FValue . tuple_val__ + nullaryTypes :: [(Name,Types)] nullaryTypes = [ ("algebraic-datatypes", ADTs) + , ("adts" , ADTs) + , ("non-grounded-values", Complement GroundValues) , ("atoms", Atoms) - , ("computation-types", ComputationTypes) , ("empty-type", EmptyType) - , ("integers", Integers) - , ("naturals", Naturals) +-- , ("naturals", Naturals) +-- , ("nats", Naturals) , ("rationals", Rationals) - , ("strings", Strings) - , ("types", Types) , ("unicode-characters", UnicodeCharacters) - , ("values", Values) + , ("values", VAL.Values) ] unaryTypes :: [(Name,Types->Types)] unaryTypes = - [ ("lists", Lists) - , ("multisets", Multisets) - , ("sets", Sets) - , ("vectors", Vectors) + [ ("multisets", Multisets) +-- , ("lists", Lists) +-- , ("vectors", Vectors) ] binaryTypes :: [(Name,Types->Types->Types)] binaryTypes = - [ ("maps", Maps) - ] + [] -boundedIntegerTypes :: [(Name, Integer -> Integer -> Types)] -boundedIntegerTypes = [("bounded-integers", BoundedIntegers)] +boundedIntegerTypes :: [(Name, Integer -> Types)] +boundedIntegerTypes = [("integers-from", IntegersFrom) + ,("from", IntegersFrom) + ,("integers-up-to", IntegersUpTo) + ,("up-to", IntegersUpTo) + ] floatTypes :: [(Name, IEEEFormats -> Types)] floatTypes = [("ieee-floats", IEEEFloats)] -bitsTypes :: [(Name, Int -> Types)] -bitsTypes = [("bits", Bits)] - --- type environment - --- | The typing environment maps datatype names to their definitions. -type TypeEnv = M.Map Name DataTypeMembers - --- | A type parameter is of the form X:T where the name of the parameter,/X/, is optional. --- When present, /X/ can be used to specify the type of constructors. -type TypeParam = (Maybe MetaVar,FTerm) --- | A datatype has `zero or more' type parameters and --- `zero or more' alternatives. -data DataTypeMembers = DataTypeMembers [TypeParam] [DataTypeAlt] - --- | An alternative is either a datatype constructor or the inclusion --- of some other type. The types are arbitrary funcon terms (with possible --- variables) that may require evaluation to be resolved to a 'Types'. -data DataTypeAlt = DataTypeInclusion FTerm - | DataTypeConstructor Name FTerm - --- | Lookup the definition of a datatype in the typing environment. -typeLookup :: Name -> TypeEnv -> Maybe DataTypeMembers -typeLookup = M.lookup - --- | The empty 'TypeEnv'. -emptyTypeEnv :: TypeEnv -emptyTypeEnv = M.empty - --- | Unites a list of 'TypeEnv's. -typeEnvUnions :: [TypeEnv] -> TypeEnv -typeEnvUnions = foldr typeEnvUnion emptyTypeEnv - --- | Unites two 'TypeEnv's. -typeEnvUnion :: TypeEnv -> TypeEnv -> TypeEnv -typeEnvUnion = M.unionWith (\_ _ -> error "duplicate type-name") - --- | Creates a `TypeEnv' from a list. -typeEnvFromList :: [(Name, DataTypeMembers)] -> TypeEnv -typeEnvFromList = M.fromList - -{- --- I think this is no longer needed. --- Ids -newtype ID = ID' Values - deriving (Eq) - -instance Ord ID where - (ID' v1) `compare` (ID' v2) = idCompare v1 v2 - -idCompare :: Values -> Values -> Ordering -(Int i1) `idCompare` (Int i2) = compare i1 i2 -(Int _) `idCompare` _ = LT -_ `idCompare` (Int _) = GT -(String s) `idCompare` (String s2) = compare s s2 -_ `idCompare` _ = error "comparing non-atomic ids" --} - --- Values should be atoms: Ints,Booleans,Strings,Tuples? etc - --- Ids are just `strings` now. -{- -id_ :: Funcons -> Funcons -id_ (FValue v@(Int _)) = FValue (ID (ID' v)) -id_ (FValue v@(String _)) = FValue (ID (ID' v)) -id_ v = error $ "id supplied with non-atomic value" --} - --- smart constructors for values -- | Creates an integer 'literal'. @@ -266,26 +161,28 @@ int_ = FValue . mk_integers . toInteger -- | Creates a natural 'literal'. -nat_ :: Int -> Funcons +nat_ :: Int -> Funcons nat_ i | i < 0 = int_ i | otherwise = FValue $ mk_naturals $ toInteger i --- | Creates an atom from a 'String'. +-- | Creates an atom from a 'String'. atom_ :: String -> Funcons atom_ = FValue . Atom --- | Creates a rational literal. -rational_ :: Rational -> Funcons -rational_ = FValue . mk_rationals - -- | Creates a string literal. string_ :: String -> Funcons -string_ = FValue . String +string_ = FValue . string__ +string__ :: String -> Values +string__ = ADTVal "list" . map (FValue . Ascii) --- | Creates an empty tuple as a 'Values'. -empty_tuple_ :: Funcons -empty_tuple_ = FValue EmptyTuple +float_ :: Double -> Funcons +float_ = FValue . Float +ieee_float_32_ :: Float -> Funcons +ieee_float_32_ = FValue . IEEE_Float_32 +ieee_float_64_ :: Double -> Funcons +ieee_float_64_ = FValue . IEEE_Float_64 + -- | The empty map as a 'Funcons'. empty_map_,map_empty_ :: Funcons empty_map_ = FValue (Map M.empty) @@ -296,60 +193,50 @@ empty_set_ = FValue (Set S.empty) -- | Creates a tuple of funcon terms. -tuple_ :: [Funcons] -> Funcons -tuple_ = FTuple - -tuple_val_ :: [Values] -> Funcons -tuple_val_ = FValue . safe_tuple_val +--tuple_ :: [Funcons] -> Funcons +--tuple_ = FTuple type_ :: Types -> Funcons type_ = FValue . typeVal +sort_ :: ComputationTypes -> Funcons +sort_ = FValue . ComputationType + +comp_type_ :: ComputationTypes -> Funcons +comp_type_ = FValue . ComputationType + vec :: V.Vector (Values) -> Funcons vec = FValue . Vector +vec_ :: [Values] -> Funcons +vec_ = FValue . Vector . V.fromList -- idval :: Values -> Values -- idval = ID . ID' typeVal :: Types -> Values typeVal = ComputationType . Type -safe_tuple_val :: [Values] -> Values -safe_tuple_val [] = EmptyTuple -safe_tuple_val [v] = v -safe_tuple_val (v1:v2:vs) = NonEmptyTuple v1 v2 vs - -tuple_unval :: Values -> [Values] -tuple_unval EmptyTuple = [] -tuple_unval (NonEmptyTuple v1 v2 vs) = v1:v2:vs -tuple_unval v = [v] - -types_unval :: Types -> [Types] -types_unval (Tuples ts) - | any (isJust . snd) ts = [Tuples ts] - | otherwise = map fst ts -types_unval t = [t] - - fvalues :: [Values] -> [Funcons] fvalues = map FValue listval :: [Values] -> Funcons -listval = FValue . List +listval = FValue . ADTVal "list" . map FValue setval :: [Values] -> Funcons setval = FValue . setval_ +setval_ :: [Values] -> Values setval_ = Set . S.fromList mapval :: [Values] -> Funcons mapval = FValue . mapval_ -mapval_ = Map . M.fromList . map toKeyValue - where toKeyValue (NonEmptyTuple k v []) = (k,v) - toKeyValue _ = error "mapval" +mapval_ :: [Values] -> Values +mapval_ = Map . M.fromList . mkPairs -- subtyping rationals + +{- mk_rationals :: Rational -> Values mk_rationals r | denominator r == 1 = mk_integers (numerator r) | otherwise = Rational r @@ -361,129 +248,152 @@ mk_naturals :: Integer -> Values mk_naturals = Nat --- | Returns the /rational/ representation of a value if it is a subtype. --- Otherwise it returns the original value. -upcastRationals :: Values -> Values -upcastRationals (Nat n) = Rational (toRational n) -upcastRationals (Int i) = Rational (toRational i) -upcastRationals v = v +mk_unicode_characters :: Char -> Values +mk_unicode_characters c | C.isAscii c = mk_ascii_characters c + | otherwise = Char c --- | Returns the /integer/ representation of a value if it is a subtype. --- Otherwise it returns the original value. -upcastIntegers :: Values -> Values -upcastIntegers (Nat n) = Int n -upcastIntegers v = v +-- TODO: haven't included `basic-characters` in the subtyping heirarchy yet. --- | Returns the /natural/ representation of a value if it is a subtype. --- Otherwise it returns the original value. -upcastNaturals :: Values -> Values -upcastNaturals v = v +mk_ascii_characters :: Char -> Values +mk_ascii_characters = Ascii +-} -- | Returns the /unicode/ representation of an assci value. -- Otherwise it returns the original value. -upcastUnicode :: Values -> Values -upcastUnicode (Ascii c) = Char (toEnum c) -upcastUnicode v = v - -castType :: Values -> Maybe Types -castType (ComputationType (Type ty)) = Just ty -castType EmptyTuple = Just (Tuples []) -castType (NonEmptyTuple t1 t2 ts) = Tuples <$> mapM (fmap (,Nothing) . castType) (t1:t2:ts) -castType _ = Nothing - --- Value specific -- | Attempt to downcast a funcon term to a value. +downcastType :: Funcons -> Types +downcastType (FValue v) = downcastValueType v +downcastType _ = error "downcasting to sort failed" + +downcastSort :: Funcons -> ComputationTypes +downcastSort (FValue (ComputationType s)) = s +downcastSort _ = error "downcasting to sort failed" + downcastValue :: Funcons -> Values downcastValue (FValue v) = v downcastValue _ = error "downcasting to value failed" --- | Attempt to downcast a funcon term to a type. -downcastType :: Funcons -> Types -downcastType (FValue (ComputationType (Type ty))) = ty -downcastType _ = error "downcasting to type failed" - --- | Attempt to downcast a value to a type. -downcastValueType :: Values -> Types -downcastValueType (ComputationType (Type t)) = t -downcastValueType _ = error "valueType: not a type" - recursiveFunconValue :: Funcons -> Maybe Values recursiveFunconValue (FValue v) = Just v -recursiveFunconValue (FList fs) = List <$> mapM recursiveFunconValue fs +--recursiveFunconValue (FList fs) = List <$> mapM recursiveFunconValue fs recursiveFunconValue (FSet fs) = Set . S.fromList <$> mapM recursiveFunconValue fs -recursiveFunconValue (FMap fs) = Map . M.fromList <$> mapM unFTuple fs - where unFTuple (FTuple [k,v]) = (,) <$> recursiveFunconValue k <*> recursiveFunconValue v - unFTuple _ = Nothing +recursiveFunconValue (FMap fs) = Map . M.fromList . mkPairs <$> mapM recursiveFunconValue fs recursiveFunconValue _ = Nothing -(===) :: Values -> Values -> Bool -v1 === v2 = isGround v1 && isGround v2 && (v1 == v2) +allEqual :: [Values] -> [Values] -> Bool +allEqual xs ys = length xs == length ys && and (zipWith (===) xs ys) -(=/=) :: Values -> Values -> Bool -v1 =/= v2 = isGround v1 && isGround v2 && (v1 /= v2) +allUnEqual :: [Values] -> [Values] -> Bool +allUnEqual xs ys = length xs /= length ys || or (zipWith (=/=) xs ys) -isGround :: Values -> Bool -isGround (ADTVal _ mv) = all isGround mv -isGround (Ascii _) = True -isGround (Atom _) = True -isGround (Bit _) = True -isGround (Char _) = True -isGround (ComputationType _) = True -isGround (EmptyTuple) = True -isGround (Float _) = True -isGround (IEEE_Float_32 _) = True -isGround (IEEE_Float_64 _) = True -isGround (Int _) = True -isGround (List vs) = all isGround vs -isGround (Map m) = all isGround (M.elems m) -isGround (Multiset ms) = all isGround ms -isGround (Nat _) = True -isGround (NonEmptyTuple v1 v2 vs) = all isGround (v1:v2:vs) -isGround (Rational _) = True -isGround (Set s) = all isGround (S.toList s) -isGround (String _) = True -isGround (Thunk _) = False -isGround (Vector v) = all isGround (V.toList v) +isNoValue :: Funcons -> Bool +isNoValue (FValue n) = n == none__ +isNoValue _ = False +hasStep (FValue _) = False +hasStep _ = True +isVal (FValue _) = True +isVal _ = False +isDefinedVal f = isVal f && not (isNoValue f) + -- functions that check simple properties of funcons --- TODO: these may not be needed any longer +-- TODO: Some of these are used, and all are exported by Funcons.EDSL +-- But are all of them still needed. E.g isId doesn't seem very useful now that ids are just strings. isAscii (FValue (Ascii _)) = True isAscii _ = False +isAscii_ (Ascii _) = True +isAscii_ _ = False +isString (FValue (ADTVal "list" s)) = all isAscii s +isString _ = False +isString_ (ADTVal "list" s) = all isAscii s +isString_ _ = False isChar (FValue (Char _)) = True isChar _ = False -isId = isString -- TODO: is this needed any more? isNat (FValue (Int _)) = True isNat _ = False isInt (FValue (Int _)) = True isInt _ = False -isList (FValue (List _)) = True +isList (FValue (ADTVal "list" _)) = True isList _ = False isEnv f = isMap f isMap (FValue (Map _)) = True -isMap _ = False +isMap _ = False isSet (FValue (Set _)) = True isSet _ = False -isString (FValue v) = isString_ v -isString _ = False -isString_ (String _) = True -isString_ _ = False -isThunk (FValue (Thunk _)) = True -isThunk _ = False -isTup (FValue EmptyTuple) = True -isTup (FValue (NonEmptyTuple _ _ _)) = True isTup _ = False +isSort (FValue (ComputationType _)) = True +isSort _ = False +isSort_ (ComputationType _) = True +isSort_ _ = False isType (FValue (ComputationType (Type _))) = True isType _ = False -isVal (FValue _) = True -isVal _ = False isVec (FValue (Vector _)) = True isVec _ = False -isType_ (ComputationType (Type _)) = True -isType_ _ = False +isCharacter_ (Char _) = True +isCharacter_ (Ascii _) = True +isCharacter_ _ = False -integers_,strings_,values_,unicode_characters_ :: Funcons +integers_,atoms_,values_,unicode_characters_ :: Funcons integers_ = type_ Integers unicode_characters_ = type_ UnicodeCharacters -strings_ = type_ Strings -values_ = type_ Values +values_ = type_ VAL.Values +defined_values_ = type_ DefinedValues +nothing_ = type_ Nothings +vectors_ :: Types -> Funcons +vectors_ = type_ . Vectors +atoms_ = type_ Atoms + +-- type environment + +-- | The typing environment maps datatype names to their definitions. +type TypeRelation = M.Map Name DataTypeMembers + +-- | A type parameter is of the form X:T where the name of the parameter,/X/, is optional. +-- When present, /X/ can be used to specify the type of constructors. +-- Variable /X/ be a sequence variable. +type TypeParam = (Maybe MetaVar, Maybe VAL.SeqSortOp, FTerm) +data TPattern = TPWildCard + | TPVar MetaVar + | TPSeqVar MetaVar VAL.SeqSortOp + | TPLit FTerm {- should rewrite to a type -} + | TPComputes TPattern + | TPComputesFrom TPattern TPattern + | TPADT Name [TPattern] + deriving (Show, Eq, Ord, Read) + +-- | A datatype has `zero or more' type parameters and +-- `zero or more' alternatives. +data DataTypeMembers = DataTypeMemberss Name [TPattern] [DataTypeAltt] + deriving (Show) + +-- | An alternative is either a datatype constructor or the inclusion +-- of some other type. The types are arbitrary funcon terms (with possible +-- variables) that may require evaluation to be resolved to a 'Types'. +data DataTypeAltt = DataTypeInclusionn FTerm + | DataTypeMemberConstructor Name [FTerm] (Maybe [TPattern]) + deriving (Show) + +-- | Lookup the definition of a datatype in the typing environment. +typeLookup :: Name -> TypeRelation -> Maybe DataTypeMembers +typeLookup = M.lookup + +-- | The empty 'TypeRelation'. +emptyTypeRelation :: TypeRelation +emptyTypeRelation = M.empty + +-- | Unites a list of 'TypeRelation's. +typeEnvUnions :: [TypeRelation] -> TypeRelation +typeEnvUnions = foldr typeEnvUnion emptyTypeRelation + +-- | Unites two 'TypeRelation's. +typeEnvUnion :: TypeRelation -> TypeRelation -> TypeRelation +typeEnvUnion = M.unionWith (\_ _ -> error "duplicate type-name") + +-- | Creates a `TypeRelation' from a list. +typeEnvFromList :: [(Name, DataTypeMembers)] -> TypeRelation +typeEnvFromList = M.fromList + + + diff --git a/src/Funcons/ValueOperations.hs b/src/Funcons/ValueOperations.hs new file mode 100644 --- /dev/null +++ b/src/Funcons/ValueOperations.hs @@ -0,0 +1,32 @@ + +module Funcons.ValueOperations ( + execRewrites, evalOperation, + IException(..), IE(..), isIn, + ) where + +import Funcons.EDSL (library) +import Funcons.Types +import Funcons.MSOS +import Funcons.Patterns (isIn) +import Funcons.Exceptions (IException(..), IE(..)) +import Funcons.RunOptions +import Funcons.Core.Manual + +evalOperation :: Funcons -> Either IE [Values] +evalOperation f = + case execRewrites (rewriteFuncons f) of + Left exc -> Left exc + Right (ValTerm vs) -> Right vs + Right _ -> error "rewriteToTerm: did you provide a value operation?" + +execRewrites :: Rewrite a -> (Either IE a) +execRewrites rew = case e_exc_rewritten of + Left (_, _, exc) -> Left exc + Right r -> Right r + where + (e_exc_rewritten, _, _) = runRewrite rew reader state + reader = RewriteReader (libUnions [Funcons.EDSL.library + ,Funcons.Core.Manual.library]) + emptyTypeRelation defaultRunOptions undefined undefined + state = RewriteState +