diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2015 L. Thomas van Binsbergen and Neil Sculthorpe + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cbs/Funcons/Core/Abstractions/Closures/Close.hs b/cbs/Funcons/Core/Abstractions/Closures/Close.hs new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Abstractions/Closures/Close.hs @@ -0,0 +1,26 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Abstractions/Closures/Closure.hs @@ -0,0 +1,31 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Abstractions/Functions/Apply.hs @@ -0,0 +1,24 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Abstractions/Functions/BindingLambda.hs @@ -0,0 +1,26 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Abstractions/Functions/Compose.hs @@ -0,0 +1,25 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Abstractions/Functions/Curry.hs @@ -0,0 +1,26 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Abstractions/Functions/Lambda.hs @@ -0,0 +1,25 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Abstractions/Functions/PartialApply.hs @@ -0,0 +1,26 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Abstractions/Functions/Supply.hs @@ -0,0 +1,26 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Abstractions/Functions/Uncurry.hs @@ -0,0 +1,25 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Abstractions/IsGroundValue.hs @@ -0,0 +1,69 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Abstractions/Patterns/Case.hs @@ -0,0 +1,27 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Abstractions/Patterns/Match.hs @@ -0,0 +1,70 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Abstractions/Patterns/MatchLoosely.hs @@ -0,0 +1,81 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Abstractions/Patterns/PatternAny.hs @@ -0,0 +1,23 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Abstractions/Patterns/PatternBind.hs @@ -0,0 +1,25 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Abstractions/Patterns/PatternPrefer.hs @@ -0,0 +1,26 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Abstractions/Patterns/PatternUnite.hs @@ -0,0 +1,25 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Abstractions/Patterns/Patterns.hs @@ -0,0 +1,20 @@ +-- 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/ControlFlow/Abnormal/Continuations/Abort.hs b/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/Abort.hs new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/Abort.hs @@ -0,0 +1,26 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/CallCc.hs @@ -0,0 +1,28 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/Control.hs @@ -0,0 +1,27 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/ControlSignal.hs @@ -0,0 +1,14 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/Hole.hs @@ -0,0 +1,23 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/Plug.hs @@ -0,0 +1,27 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/Prompt.hs @@ -0,0 +1,35 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/Reset.hs @@ -0,0 +1,27 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/ResumeSignal.hs @@ -0,0 +1,14 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/Shift.hs @@ -0,0 +1,28 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Failing/CheckTrue.hs @@ -0,0 +1,28 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Failing/Dereference.hs @@ -0,0 +1,29 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Failing/Else.hs @@ -0,0 +1,40 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Failing/Fail.hs @@ -0,0 +1,23 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Failing/Failed.hs @@ -0,0 +1,14 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Failing/Signals.hs @@ -0,0 +1,18 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Stuck.hs @@ -0,0 +1,19 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Throwing/Finally.hs @@ -0,0 +1,37 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Throwing/HandleRecursively.hs @@ -0,0 +1,26 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Throwing/HandleThrown.hs @@ -0,0 +1,38 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Throwing/Throw.hs @@ -0,0 +1,25 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Throwing/Thrown.hs @@ -0,0 +1,14 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/ControlFlow/Normal/Choosing/IfThenElse.hs @@ -0,0 +1,31 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/FilteringCollections/ListFilter.hs @@ -0,0 +1,30 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/FilteringCollections/MapFilter.hs @@ -0,0 +1,26 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/FilteringCollections/MultisetFilter.hs @@ -0,0 +1,26 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/FilteringCollections/SetFilter.hs @@ -0,0 +1,26 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/MappingCollections/ListMap.hs @@ -0,0 +1,30 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/MappingCollections/ListsMap.hs @@ -0,0 +1,32 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/MappingCollections/MapMap.hs @@ -0,0 +1,26 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/MappingCollections/SetMap.hs @@ -0,0 +1,26 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/MappingCollections/TupleMap.hs @@ -0,0 +1,26 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/MappingCollections/VectorMap.hs @@ -0,0 +1,26 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/ReducingCollections/ListFoldl.hs @@ -0,0 +1,33 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/ReducingCollections/ListFoldr.hs @@ -0,0 +1,33 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Indefinite/DoWhile.hs @@ -0,0 +1,26 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Indefinite/While.hs @@ -0,0 +1,26 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/ControlFlow/Normal/Sequencing/Atomic.hs @@ -0,0 +1,31 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/ControlFlow/Normal/Sequencing/LeftToRight.hs @@ -0,0 +1,30 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/ControlFlow/Normal/Sequencing/Sequential.hs @@ -0,0 +1,27 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/DataFlow/Binding/Accumulate.hs @@ -0,0 +1,40 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/DataFlow/Binding/Bind.hs @@ -0,0 +1,24 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/DataFlow/Binding/Bound.hs @@ -0,0 +1,32 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/DataFlow/Binding/Environment.hs @@ -0,0 +1,14 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/DataFlow/Binding/Environments.hs @@ -0,0 +1,31 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/DataFlow/Binding/Recursion/BindRecursively.hs @@ -0,0 +1,26 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/DataFlow/Binding/Recursion/BoundRecursively.hs @@ -0,0 +1,27 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/DataFlow/Binding/Recursion/Recursive.hs @@ -0,0 +1,51 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/DataFlow/Binding/Scope.hs @@ -0,0 +1,32 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/DataFlow/Effect.hs @@ -0,0 +1,24 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/DataFlow/Generating/AtomGenerator.hs @@ -0,0 +1,14 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/DataFlow/Generating/FreshAtom.hs @@ -0,0 +1,24 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/DataFlow/Generating/FreshBinder.hs @@ -0,0 +1,23 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/DataFlow/Giving/Give.hs @@ -0,0 +1,31 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/DataFlow/Giving/Given.hs @@ -0,0 +1,45 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/DataFlow/Giving/GivenValue.hs @@ -0,0 +1,14 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/DataFlow/Interacting/Print.hs @@ -0,0 +1,26 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/DataFlow/Interacting/PrintList.hs @@ -0,0 +1,25 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/DataFlow/Interacting/Read.hs @@ -0,0 +1,23 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/DataFlow/Interacting/StandardIn.hs @@ -0,0 +1,14 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/DataFlow/Interacting/StandardOut.hs @@ -0,0 +1,14 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/DataFlow/Linking/AllocateInitialisedLink.hs @@ -0,0 +1,26 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/DataFlow/Linking/AllocateLink.hs @@ -0,0 +1,30 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/DataFlow/Linking/FollowIfLink.hs @@ -0,0 +1,31 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/DataFlow/Linking/FollowLink.hs @@ -0,0 +1,43 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/DataFlow/Linking/LinkStore.hs @@ -0,0 +1,14 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/DataFlow/Linking/LinkStores.hs @@ -0,0 +1,20 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/DataFlow/Linking/Links.hs @@ -0,0 +1,61 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/DataFlow/Linking/SetLink.hs @@ -0,0 +1,50 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/DataFlow/Storing/GeneralVariables/AllocateMap.hs @@ -0,0 +1,25 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/DataFlow/Storing/GeneralVariables/AllocateVector.hs @@ -0,0 +1,25 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/DataFlow/Storing/GeneralVariables/GeneralAssign.hs @@ -0,0 +1,67 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/DataFlow/Storing/GeneralVariables/GeneralAssigned.hs @@ -0,0 +1,56 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/DataFlow/Storing/SimpleVariables/AllocateInitialisedVariable.hs @@ -0,0 +1,26 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/DataFlow/Storing/SimpleVariables/AllocateVariable.hs @@ -0,0 +1,31 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/DataFlow/Storing/SimpleVariables/Assign.hs @@ -0,0 +1,43 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/DataFlow/Storing/SimpleVariables/Assigned.hs @@ -0,0 +1,43 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/DataFlow/Storing/SimpleVariables/CurrentValue.hs @@ -0,0 +1,31 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/DataFlow/Storing/SimpleVariables/DeallocateVariable.hs @@ -0,0 +1,34 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/DataFlow/Storing/Store.hs @@ -0,0 +1,14 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/DataFlow/Storing/Stores.hs @@ -0,0 +1,24 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/DataFlow/Storing/Variables.hs @@ -0,0 +1,61 @@ +-- 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/Sorts.hs b/cbs/Funcons/Core/Computations/Sorts.hs new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Computations/Sorts.hs @@ -0,0 +1,17 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Library.hs @@ -0,0 +1,709 @@ +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 +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 +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 + ] +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 + ] +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 + ] diff --git a/cbs/Funcons/Core/Values/CompositeValues/AlgebraicDatatypeValues/Records.hs b/cbs/Funcons/Core/Values/CompositeValues/AlgebraicDatatypeValues/Records.hs new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Values/CompositeValues/AlgebraicDatatypeValues/Records.hs @@ -0,0 +1,34 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Values/CompositeValues/AlgebraicDatatypeValues/References.hs @@ -0,0 +1,26 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Values/CompositeValues/AlgebraicDatatypeValues/Variants.hs @@ -0,0 +1,37 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Values/CompositeValues/Collections/DirectedGraphs.hs @@ -0,0 +1,22 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Values/CompositeValues/Collections/Tuples.hs @@ -0,0 +1,22 @@ +-- 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/PrimitiveValues/Bits.hs b/cbs/Funcons/Core/Values/PrimitiveValues/Bits.hs new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Values/PrimitiveValues/Bits.hs @@ -0,0 +1,60 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Values/PrimitiveValues/Booleans.hs @@ -0,0 +1,126 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Values/PrimitiveValues/Numbers/IeeeFloats.hs @@ -0,0 +1,49 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Values/PrimitiveValues/Numbers/Integers.hs @@ -0,0 +1,22 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Values/PrimitiveValues/Numbers/Rationals.hs @@ -0,0 +1,30 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Values/PrimitiveValues/Strings.hs @@ -0,0 +1,28 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Values/PrimitiveValues/UnicodeCharacters.hs @@ -0,0 +1,38 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Values/PrimitiveValues/UnitType.hs @@ -0,0 +1,33 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/cbs/Funcons/Core/Values/Types.hs @@ -0,0 +1,30 @@ +-- 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/funcons-tools.cabal b/funcons-tools.cabal new file mode 100644 --- /dev/null +++ b/funcons-tools.cabal @@ -0,0 +1,194 @@ +-- Initial funcons.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: funcons-tools +version: 0.1.0.0 +synopsis: A modular interpreter for executing funcons +description: + The PLanCompS project has developed a component-based approach to formal semantics. + The semantics of a language is defined by translating its constructs to combinations + of `fundamental constructs' called /funcons/. + . + Read more about the project 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. + . + The executable provided by this package is an interpreter for running terms + constructed from the collection of funcons provided by "Funcons.Core". + How this executable is used is explained in "Funcons.Tools". + . + Additional funcons can be defined with the helper functions provided by + "Funcons.EDSL". The module "Funcons.Tools" provides functions for creating + executables by extending the main interpreter with additional funcons. + . + Please contact any of the maintainers when unexpected behaviour is encountered + or exports appear to be missing. + +homepage: http://plancomps.org +license: MIT +license-file: LICENSE +author: L. Thomas van Binsbergen and Neil Sculthorpe +maintainer: L. Thomas van Binsbergen +copyright: Copyright (C) 2015 L. Thomas van Binsbergen and Neil Sculthorpe +category: Compilers/Interpreters +build-type: Simple +stability: experimental +-- 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 + 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 + + + +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 diff --git a/manual/Funcons/Core/Abstractions/Force.hs b/manual/Funcons/Core/Abstractions/Force.hs new file mode 100644 --- /dev/null +++ b/manual/Funcons/Core/Abstractions/Force.hs @@ -0,0 +1,15 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/manual/Funcons/Core/Abstractions/Thunk.hs @@ -0,0 +1,20 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/manual/Funcons/Core/Computations/DataFlow/Generating/AtomSeed.hs @@ -0,0 +1,8 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/manual/Funcons/Core/Computations/DataFlow/Generating/NextAtom.hs @@ -0,0 +1,14 @@ +{-# 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/Manual.hs b/manual/Funcons/Core/Manual.hs new file mode 100644 --- /dev/null +++ b/manual/Funcons/Core/Manual.hs @@ -0,0 +1,82 @@ +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.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.Atoms + , module Funcons.Core.Values.Primitive.Characters + , module Funcons.Core.Abstractions.Thunk + , module Funcons.Core.Abstractions.Force + , module Funcons.Core.Values.Composite.Collections.TuplesBuiltin + )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.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.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 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.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.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 + +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.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.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 + ] diff --git a/manual/Funcons/Core/Values/Composite/AlgebraicDatatypeValues/AlgebraicDatatypes.hs b/manual/Funcons/Core/Values/Composite/AlgebraicDatatypeValues/AlgebraicDatatypes.hs new file mode 100644 --- /dev/null +++ b/manual/Funcons/Core/Values/Composite/AlgebraicDatatypeValues/AlgebraicDatatypes.hs @@ -0,0 +1,28 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/manual/Funcons/Core/Values/Composite/Collections/Lists.hs @@ -0,0 +1,96 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/manual/Funcons/Core/Values/Composite/Collections/Maps.hs @@ -0,0 +1,103 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/manual/Funcons/Core/Values/Composite/Collections/Multisets.hs @@ -0,0 +1,56 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/manual/Funcons/Core/Values/Composite/Collections/Sets.hs @@ -0,0 +1,85 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/manual/Funcons/Core/Values/Composite/Collections/TuplesBuiltin.hs @@ -0,0 +1,28 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/manual/Funcons/Core/Values/Composite/Collections/Vectors.hs @@ -0,0 +1,63 @@ +{-# 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/Primitive/Atoms.hs b/manual/Funcons/Core/Values/Primitive/Atoms.hs new file mode 100644 --- /dev/null +++ b/manual/Funcons/Core/Values/Primitive/Atoms.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Values.Primitive.Atoms where + +import Funcons.EDSL +import Funcons.Types + +library = libFromList [ + ("atom", ValueOp stepAtom) + ] + +stepAtom [String s] = rewriteTo $ FValue $ Atom s +stepAtom vs = sortErr (applyFuncon "atom" (fvalues vs)) "atom not applied to a string" diff --git a/manual/Funcons/Core/Values/Primitive/BitsBuiltin.hs b/manual/Funcons/Core/Values/Primitive/BitsBuiltin.hs new file mode 100644 --- /dev/null +++ b/manual/Funcons/Core/Values/Primitive/BitsBuiltin.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Values.Primitive.BitsBuiltin where + +import Funcons.EDSL +import Funcons.Types + +import qualified Data.BitVector as BV + +library = libFromList [ + ("bits-to-integer", ValueOp stepBits_To_Integer) + , ("integer-to-bits", ValueOp stepInteger_To_Bits) + , ("bits-not", ValueOp stepBits_Not) + , ("bits-or", ValueOp stepBits_Or) + , ("bits-and", ValueOp stepBits_And) + , ("bits-xor", ValueOp stepBits_Xor) + , ("bits-shift-left", ValueOp stepBits_Shift_Left) + , ("bits-logical-shift-right", ValueOp stepBits_Logical_Shift_Right) + , ("bits-arithmetic-shift-right", ValueOp stepBits_Arithmetic_Shift_Right) + , ("bits-to-integer", ValueOp stepBits_To_Integer) + , ("bits-to-natural", ValueOp stepBits_To_Natural) + , ("integer-to-bits", ValueOp stepInteger_To_Bits) + ] + +stepBits_Not [Bit bv] = rewriteTo $ FValue $ Bit $ BV.not bv +stepBits_Not vs = sortErr (applyFuncon "bits-not" (fvalues vs)) "bits-not not applied to bits" +stepBits_And [Bit bv1, Bit bv2] = rewriteTo $ FValue $ Bit (bv1 BV..&. bv2) +stepBits_And vs = sortErr (applyFuncon "bits-and" (fvalues vs)) "bits-and not applied to bits" + +bits_or = applyFuncon "bits-or" +stepBits_Or [Bit bv1, Bit bv2] = rewriteTo $ FValue $ Bit (bv1 BV..|. bv2) +stepBits_Or vs = sortErr (bits_or (fvalues vs)) "bits-or not applied to bits" + +bits_xor = applyFuncon "bits-xor" +stepBits_Xor [Bit bv1, Bit bv2] = rewriteTo $ FValue $ Bit (bv1 `BV.xor` bv2) +stepBits_Xor vs = sortErr (bits_xor (fvalues vs)) "bits-xor not applied to bits" + +bits_shift_left = applyFuncon "bits-shift-left" +stepBits_Shift_Left [Bit bv1, vn] + | Nat n <- upcastNaturals vn = rewriteTo $ FValue $ Bit (bv1 `BV.shl` (fromInteger n)) +stepBits_Shift_Left vs = sortErr (bits_shift_left (fvalues vs)) "bits-shift not applied to bits" + +bits_arithmetic_shift_right = applyFuncon "bits-arithmetic-shift_right" +stepBits_Arithmetic_Shift_Right [Bit bv1, vn] + | Nat n <- upcastNaturals vn = rewriteTo $ FValue $ Bit (bv1 `BV.ashr` (fromInteger n)) +stepBits_Arithmetic_Shift_Right vs = + sortErr (bits_arithmetic_shift_right (fvalues vs)) + "bits-arithmetic-shift-right not applied to bits" + +bits_logical_shift_right = applyFuncon "bits-logical-shift-right" +stepBits_Logical_Shift_Right [Bit bv1, vn] + | Nat n <- upcastNaturals vn = rewriteTo $ FValue $ Bit (bv1 `BV.shr` (fromInteger n)) +stepBits_Logical_Shift_Right vs = + sortErr (bits_logical_shift_right (fvalues vs)) "bits-logical-shift-right" + +bits_to_integer = applyFuncon "bits-to-integer" +stepBits_To_Integer [Bit bv] = rewriteTo $ int_ $ fromInteger $ (BV.int bv) +stepBits_To_Integer vs = sortErr (bits_to_integer (fvalues vs)) + "bits-to-integer not applied to bits" + +bits_to_natural = applyFuncon "bits-to-natural" +stepBits_To_Natural [Bit bv] = rewriteTo $ FValue $ mk_naturals (BV.nat bv) +stepBits_To_Natural vs = sortErr (bits_to_natural (fvalues vs)) "bits-to-natural not applied to bits" +integer_to_bits = applyFuncon "integer-to-bits" +stepInteger_To_Bits [vn,vi] + | (Nat n, Int i) <- (upcastNaturals vn, upcastIntegers vi) + = rewriteTo $ FValue $ Bit (BV.bitVec (fromInteger n) (i `mod` (2 ^ n))) +stepInteger_To_Bits vs = sortErr (applyFuncon "integer-to-bits" (fvalues vs)) + "sort check: integer-to-bits(_:naturals,_:integers)" diff --git a/manual/Funcons/Core/Values/Primitive/BoolBuiltin.hs b/manual/Funcons/Core/Values/Primitive/BoolBuiltin.hs new file mode 100644 --- /dev/null +++ b/manual/Funcons/Core/Values/Primitive/BoolBuiltin.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Values.Primitive.BoolBuiltin where + +import Funcons.EDSL + +tobool :: Bool -> Values +tobool True = ADTVal "true" [] +tobool False = ADTVal "false" [] + diff --git a/manual/Funcons/Core/Values/Primitive/Characters.hs b/manual/Funcons/Core/Values/Primitive/Characters.hs new file mode 100644 --- /dev/null +++ b/manual/Funcons/Core/Values/Primitive/Characters.hs @@ -0,0 +1,17 @@ +{-# 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/Numbers/IeeeFloatsBuiltin.hs b/manual/Funcons/Core/Values/Primitive/Numbers/IeeeFloatsBuiltin.hs new file mode 100644 --- /dev/null +++ b/manual/Funcons/Core/Values/Primitive/Numbers/IeeeFloatsBuiltin.hs @@ -0,0 +1,275 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/manual/Funcons/Core/Values/Primitive/Numbers/Integers.hs @@ -0,0 +1,87 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/manual/Funcons/Core/Values/Primitive/Numbers/RationalsBuiltin.hs @@ -0,0 +1,64 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/manual/Funcons/Core/Values/Primitive/StringsBuiltin.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Core.Values.Primitive.StringsBuiltin where + +import Funcons.EDSL +import Funcons.Types + +import Numeric + +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) + ] + +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)) + diff --git a/src/Funcons/Core.hs b/src/Funcons/Core.hs new file mode 100644 --- /dev/null +++ b/src/Funcons/Core.hs @@ -0,0 +1,26 @@ + +-- | +-- This module exports smart constructors for building funcon terms from a large +-- collections of funcons. +-- Module "Funcons.EDSL" can be used to construct funcons. +-- Module "Funcons.Tools" provides functions for creating executables. +-- +-- Apologies for the disorganisation of this file, most of its exports +-- 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 +--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_, + module Funcons.Core.Library, + module Funcons.Core.Manual) where + +import Funcons.Types -- Haddock dependency +import Funcons.Core.Library hiding (entities, funcons, types) +import Funcons.Core.Manual hiding (entities, funcons, types) + + diff --git a/src/Funcons/EDSL.hs b/src/Funcons/EDSL.hs new file mode 100644 --- /dev/null +++ b/src/Funcons/EDSL.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- This module provides the types and the functions necessary for defining funcons. +-- The package provides a large collection of predefined funcons in "Funcons.Core". +-- Module "Funcons.Tools" provides functions for creating executables. +module Funcons.EDSL ( + -- * Funcon representation + Funcons(..), Values(..), Types(..), ComputationTypes(..),SeqSortOp(..), + applyFuncon, + -- ** Smart construction of funcon terms + -- *** Funcon terms + list_, tuple_, set_, map_empty_, empty_tuple_, + -- *** Values + int_, nat_, string_, + -- *** Types + values_, integers_, strings_, unicode_characters_, + -- ** Pretty-print funcon terms + showValues, showFuncons, showTypes, + -- ** Is a funcon term a certain value? + isVal, isString, isInt, isNat, isList, isMap, isType, + isVec, isAscii, isChar, isTup, isId, isThunk, + -- ** Up and downcasting between funcon terms + downcastValue, downcastType, downcastValueType, + upcastNaturals, upcastIntegers, upcastRationals, upcastUnicode, + -- ** Evaluation functions + EvalFunction(..), Strictness(..), StrictFuncon, PartiallyStrictFuncon, + NonStrictFuncon, ValueOp, NullaryFuncon, + + -- *** Funcon libraries + FunconLibrary, libEmpty, libUnion, libUnions, libFromList, library, + -- ** Implicit & modular propagation of entities + MSOS, Rewrite, Rewritten, + -- *** Helpers to create rewrites & step rules + rewriteTo, stepTo, 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, + + -- * CBS compilation + + -- $cbsintro + + -- ** Funcon representation with meta-variables + FTerm(..), Env, emptyEnv, + -- *** Defining rules + rewriteTermTo,stepTermTo,premise, + -- *** Entity access + withInhTerm, getInhPatt, putMutTerm, getMutPatt, writeOutTerm, readOutPatt, + receiveSignalPatt, raiseTerm, assignInput, withExtraInputTerms, withExactInputTerms, + -- ** Backtracking + evalRules, SideCondition(..), sideCondition, lifted_sideCondition, + + -- ** Pattern Matching + VPattern(..), FPattern(..), + vsMatch, fsMatch, + lifted_vsMatch, lifted_fsMatch, + + -- * Tools for creating interpreters + + -- For more explanation see "Funcons.Tools" + -- ** Helpers for defining evaluation functions. + rewriteType, + -- ** Default entity values + EntityDefaults, EntityDefault(..), + -- ** Type environments + TypeEnv, DataTypeMembers(..), DataTypeAlt(..), + typeLookup, typeEnvUnion, typeEnvUnions, typeEnvFromList, emptyTypeEnv, + )where + +import Funcons.MSOS +import Funcons.Types +import Funcons.Entities +import Funcons.Patterns +import Funcons.Substitution +import Funcons.Printer + +import Control.Arrow ((***)) + +congruence1_1 :: Name -> Funcons -> Rewrite Rewritten +congruence1_1 fnm = compstep . premiseStepApp app + where app f = applyFuncon fnm [f] + +congruence1_2 :: Name -> Funcons -> Funcons -> Rewrite Rewritten +congruence1_2 fnm arg1 arg2 = compstep $ premiseStepApp app arg1 + where app f = applyFuncon fnm [f, arg2] + +congruence2_2 :: Name -> Funcons -> Funcons -> Rewrite Rewritten +congruence2_2 fnm arg1 arg2 = compstep $ premiseStepApp app arg2 + where app f = applyFuncon fnm [arg1, f] + +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] + +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] + +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] + +-- | A funcon library with funcons for builtin types. +library :: FunconLibrary +library = libUnions [unLib, nullLib, binLib, floatsLib, bitsLib + ,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 + mkNullary = NullaryFuncon . rewritten . typeVal + + mkFloats :: (IEEEFormats -> Types) -> EvalFunction + mkFloats cons = StrictFuncon sfuncon + 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 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" + + mkUnary :: (Types -> Types) -> EvalFunction + mkUnary cons = StrictFuncon sfuncon + where sfuncon [ComputationType (Type x)] = rewritten $ typeVal $ cons x + sfuncon _ = rewritten $ typeVal $ cons 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 + +-- $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 +-- used for manual development of funcons, although this is not recommended. diff --git a/src/Funcons/Entities.hs b/src/Funcons/Entities.hs new file mode 100644 --- /dev/null +++ b/src/Funcons/Entities.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE LambdaCase #-} + +module Funcons.Entities ( + -- * Accessing entities + -- ** mutables + getMut, putMut, getMutPatt, putMutTerm, + -- ** inherited + getInh, withInh, getInhPatt, withInhTerm, + -- ** control + raiseSignal, receiveSignal, raiseTerm, receiveSignalPatt, + -- ** output + writeOut, readOut, writeOutTerm, readOutPatt, + -- ** input + assignInput, consumeInput, withExtraInput,withExactInput, + withExtraInputTerms, withExactInputTerms, + -- * Default entity values + EntityDefaults, EntityDefault(..), setEntityDefaults + )where + +import Funcons.Types +import Funcons.MSOS +import Funcons.Substitution +import Funcons.Exceptions +import Funcons.Patterns + +import Control.Arrow +import qualified Data.Map as M +import Data.Text + +-- defaults +-- | A list of 'EntityDefault's is used to declare (and possibly initialise) +-- entities. +type EntityDefaults = [EntityDefault] +-- | Default values of entities can be specified for /inherited/ +-- and /mutable/ entities. +data EntityDefault = DefMutable Name Funcons + | DefInherited Name Funcons + -- | For the purpose of unit-testing it is advised to notify an interpreter of the existence of control, output and input entities as well. + | DefOutput Name + | DefControl Name + | DefInput Name + +setEntityDefaults :: EntityDefaults -> MSOS Funcons -> MSOS Funcons +setEntityDefaults [] msos = msos +setEntityDefaults ((DefMutable nm f):rest) msos = + liftRewrite (rewriteFuncons f) >>= \case + ValTerm v -> putMut nm v >> setEntityDefaults rest msos + _ -> 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) + _ -> liftRewrite $ exception f "default value requires steps to evaluate" +setEntityDefaults (_:rest) msos = setEntityDefaults rest msos + +---------------------------------------------------- +--- accessing entities + +-- mutables + +emptyMUT :: Mutable +emptyMUT = M.empty + +giveMUT :: MSOS Mutable +giveMUT = MSOS $ \ctxt mut -> return (Right (mut_entities mut), mut, mempty) + +-- | Get the value of some mutable entity. +getMut :: Name -> MSOS Values +getMut key = do rw <- giveMUT + case M.lookup key rw of + Nothing -> error ("unknown mutable entity: " ++ unpack key) + Just v -> return v + +-- | Variant of 'getMut' that performs pattern-matching. +getMutPatt :: Name -> VPattern -> Env -> MSOS Env +getMutPatt nm pat env = do + val <- getMut nm + liftRewrite (vMatch val pat env) + +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) + up (Just x) = Just (f x) + +-- | Set the value of some mutable entity. +putMut :: Name -> Values -> MSOS () +putMut key v = do rw <- giveMUT + newMUT (M.insert key v rw) + +-- | Variant of 'putMut' that applies substitution. +putMutTerm :: Name -> FTerm -> Env -> MSOS () +putMutTerm nm term env = liftRewrite (subsAndRewrite term env) >>= putMut nm + +newMUT :: Mutable -> MSOS () +newMUT rw = MSOS $ \ctxt mut-> return (Right(), mut {mut_entities = rw}, mempty) + + +-- 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 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) + where + attemptConsume :: [[a]] -> Maybe (a,[[a]]) + attemptConsume [] = Nothing + attemptConsume ((v:vs):vss) = Just (v,vs:vss) + attemptConsume ([]:vss) = second ([]:) <$> attemptConsume vss + +-- | Provides /extra/ values to a certain input entity, available +-- to be consumed by the given 'MSOS' computation argument. +withExtraInput :: Name -> [Values] -> MSOS a -> MSOS a +withExtraInput = withInput False + +-- | Provides an /exact/ amount of input for some input entity, +-- that is to be /completely/ consumed by the given 'MSOS' computation. +-- If less output is consumed a 'insufficient input consumed' exception +-- is thrown. +withExactInput :: Name -> [Values] -> MSOS a -> MSOS a +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 + (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) + +-- | Variant of 'consumeInput' that binds the given 'MetaVar' 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) + +-- | Variant of withExtraInput' that performs substitution. +withExtraInputTerms = withInputTerms False +-- | 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) + 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 + (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)})) + +-- | 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) + +-- | Signal a value of some control entity. +raiseSignal :: Name -> Values -> MSOS () +raiseSignal nm v = MSOS (\ctxt mut -> return + (Right (), mut, mempty { ctrl_entities = singleCTRL nm v})) + +-- | Variant of 'raiseSignal' that applies substitution. +raiseTerm :: Name -> FTerm -> Env -> MSOS () +raiseTerm nm term env = liftRewrite (subsAndRewrite term env) >>= raiseSignal nm + +-- 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) + Just v -> return v + +-- | Version of 'getInh' that applies pattern-matching. +getInhPatt :: Name -> VPattern -> Env -> MSOS Env +getInhPatt nm pat env = do + val <- getInh nm + liftRewrite (vMatch val pat env) + +-- | Set the value of an inherited entity. +-- The new value is /only/ set for 'MSOS' computation given as a third argument. +withInh :: Name -> Values -> MSOS a -> MSOS a +withInh key v (MSOS f) = MSOS (\ctxt mut -> + let ctxt' = ctxt { inh_entities = M.insert key v (inh_entities ctxt) } + in f ctxt' mut) + +-- | 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) + withInh nm v msos + +-- output +-- | Add new values to a certain output entity. +writeOut :: Name -> [Values] -> MSOS () +writeOut key vs = MSOS $ \ctxt mut -> return (Right (), mut + ,mempty { out_entities = M.singleton key vs }) + +-- | 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" + +-- | Read the values of a certain output entity. The output is obtained +-- from the 'MSOS' computation given as a second argument. +readOut :: Name -> MSOS a -> MSOS (a,[Values]) +readOut key msos = readOuts msos >>= + return . fmap (maybe [] id . M.lookup key) + +-- | Variant of 'readOut' that performs pattern-matching. +readOutPatt :: Name -> VPattern -> MSOS Env -> MSOS Env +readOutPatt key pat msos = do + (env, vals) <- readOut key msos + liftRewrite (vMatch (List vals) pat env) diff --git a/src/Funcons/Exceptions.hs b/src/Funcons/Exceptions.hs new file mode 100644 --- /dev/null +++ b/src/Funcons/Exceptions.hs @@ -0,0 +1,46 @@ + +module Funcons.Exceptions where + +import Funcons.Types +import Funcons.Printer + +import Data.Text + +-- handling exception from the interpreter +type IException = (Funcons, Funcons, IE) --global, local, exception +data IE = SortErr String + | Err String --TODO when used? + | PartialOp String + | Internal String + | NoRule + | SideCondFail String + | InsufficientInput Name + | InsufficientInputConsumed Name + | PatternMismatch String + | StepOnValue + +showIException :: IException -> String +showIException (f0,f,ie) = "Internal Exception: " ++ show ie ++ " on " ++ showFuncons f + +instance Show IE where + show (SortErr err) = "dynamic sort check (" ++ err ++ ")" + show NoRule = "no rule to execute" + show (Err err) = "exception (" ++ err ++ ")" + show (Internal err) = "exception (" ++ err ++ ")" + show (SideCondFail str) = str + show (PatternMismatch str) = str + 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" + +-- which exceptions stop a rule from executing so that the next one can be attempted? +failsRule :: IException -> Bool +failsRule (_,_,SideCondFail _) = True +failsRule (_,_,PatternMismatch _) = True +failsRule (_,_,SortErr _) = True +failsRule (_,_,PartialOp _) = True +failsRule (_,_,StepOnValue) = True +failsRule _ = False + + diff --git a/src/Funcons/Lexer.hs b/src/Funcons/Lexer.hs new file mode 100644 --- /dev/null +++ b/src/Funcons/Lexer.hs @@ -0,0 +1,32 @@ +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 new file mode 100644 --- /dev/null +++ b/src/Funcons/MSOS.hs @@ -0,0 +1,657 @@ +{-# LANGUAGE LambdaCase, OverloadedStrings, Rank2Types, TupleSections + , FlexibleInstances #-} + +module Funcons.MSOS ( + -- * Making steps + MSOS(..), Rewrite(..), liftRewrite, rewrite_rethrow, rewrite_throw, eval_catch, msos_throw, + EvalFunction(..), Strictness(..), StrictFuncon, PartiallyStrictFuncon, + NonStrictFuncon, ValueOp, NullaryFuncon, RewriteState(..), + -- ** Entity-types + Output, readOuts, + Mutable, + Inherited, giveINH, + Control, singleCTRL, + Input, + -- ** IMSOS helpers + applyFuncon, rewritten, rewriteTo, stepTo + , compstep, + norule, exception, sortErr, partialOp, internal, buildStep, + -- *** 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(..), + -- * Values + showValues, showFuncons, + -- * Funcon libraries + FunconLibrary, libUnions, libEmpty, libUnion, libFromList, + evalctxt2exception, ctxt2exception, + )where + + +import Funcons.Types +import Funcons.RunOptions +import Funcons.Printer +import Funcons.Exceptions +import Funcons.Simulation + +import Control.Arrow ((***)) +import Control.Monad.Writer +import Data.Maybe (isJust, isNothing) +import Data.List (foldl') +import Data.Text (unpack) + +import qualified Data.Map as M + +--------------------------------------------------------------------- +-- | A funcon library maps funcon names to their evaluation functions. +type FunconLibrary = M.Map Name EvalFunction + +-- | +-- Evaluation functions capture the operational behaviour of a funcon. +-- Evaluation functions come in multiple flavours, each with a different +-- treatment of the arguments of the funcon. +-- Before the application of an evaluation funcon, any argument may be +-- evaluated, depending on the 'Strictness' of the argument. +data EvalFunction = + -- | Funcons for which arguments are /not/ evaluated. + NonStrictFuncon NonStrictFuncon + -- | Strict funcons whose arguments are evaluated. + | StrictFuncon StrictFuncon + -- | Funcons for which /some/ arguments are evaluated. + | PartiallyStrictFuncon [Strictness] NonStrictFuncon + -- | Synonym for 'StrictFuncon', for value operations. + | ValueOp ValueOp + -- | Funcons without any arguments. + | NullaryFuncon NullaryFuncon +-- | Type synonym for the evaluation function of strict funcons. +-- The evaluation function of a 'StrictFuncon' receives fully evaluated arguments. +type StrictFuncon = [Values] -> Rewrite Rewritten +-- | Type synonym for the evaluation function of fully non-strict funcons. +type NonStrictFuncon = [Funcons] -> Rewrite Rewritten +-- | Type synonym for the evaluation function of non-strict funcons. +type PartiallyStrictFuncon = NonStrictFuncon +-- | Type synonym for value operations. +type ValueOp = StrictFuncon +-- | Type synonym for the evaluation functions of nullary funcons. +type NullaryFuncon = Rewrite Rewritten +-- | Denotes whether an argument of a funcon should be evaluated or not. +data Strictness = Strict | NonStrict + +-- | After a term is fully rewritten it is either a value or a +-- term that requires a computational step to proceed. +-- This types forms the interface between syntactic rewrites and +-- computational steps. +data Rewritten = + -- | Fully rewritten to a value. + ValTerm Values + -- | Fully rewritten to a term and the step required to continue evaluation. + | CompTerm Funcons (MSOS Funcons) + +instance Show Rewritten where + show (ValTerm v) = showValues v + show (CompTerm _ _) = "" + +-- | Creates an empty 'FunconLibrary'. +libEmpty :: FunconLibrary +libEmpty = M.empty + +-- | Unites two 'FunconLibrary's. +libUnion :: FunconLibrary -> FunconLibrary -> FunconLibrary +libUnion = M.unionWithKey op + where op k x _ = error ("duplicate funcon name: " ++ unpack k) + +-- | Unites a list of 'FunconLibrary's. +libUnions :: [FunconLibrary] -> FunconLibrary +libUnions = foldl' libUnion libEmpty + where op _ _ = error ("duplicate funcon name") + +-- | Creates a 'FunconLibrary' from a list. +libFromList :: [(Name, EvalFunction)] -> FunconLibrary +libFromList = M.fromList + +lookupFuncon :: Name -> Rewrite EvalFunction +lookupFuncon key = Rewrite $ \ctxt st -> + (case M.lookup key (funconlib ctxt) of + Just f -> Right f + _ -> case M.lookup key (builtin_funcons (run_opts ctxt)) of + Just f -> Right (NullaryFuncon (rewriteTo f)) + _ -> error ("unknown funcon: "++ unpack key) + , st, mempty) + +--------------------------------------------------------------------------- +data RewriteReader = RewriteReader + { funconlib :: FunconLibrary + , ty_env :: TypeEnv, run_opts :: RunOptions + , global_fct :: Funcons, local_fct :: Funcons } +data RewriteState = RewriteState { } +emptyRewriteState = RewriteState +data RewriteWriterr = RewriteWriterr { counters :: Counters } + +-- | Monadic type for the implicit propagation of meta-information on +-- the evaluation of funcon terms (no semantic entities). +-- It is separated from 'MSOS' to ensure +-- that side-effects (access or modification of semantic entities) can not +-- occur during syntactic rewrites. +newtype Rewrite a= Rewrite {runRewrite :: (RewriteReader -> RewriteState -> + (Either IException a, RewriteState, RewriteWriterr))} + +instance Applicative Rewrite where + pure = return + (<*>) = ap + +instance Functor Rewrite where + fmap = liftM + +instance Monad Rewrite where + return a = Rewrite (\_ st -> (Right a, st, mempty)) + + (Rewrite f) >>= k = Rewrite (\ctxt st -> + let res1@(e_a1,st1,cs1) = f ctxt st + in case e_a1 of + Left err -> (Left err, st1, cs1) + Right a1 -> let (Rewrite h) = k a1 + (a2,st2,cs2) = h ctxt st1 + in (a2,st2,cs1 <> cs2)) + +instance Monoid RewriteWriterr where + mempty = RewriteWriterr mempty + (RewriteWriterr cs1) `mappend` (RewriteWriterr cs2) = RewriteWriterr (cs1 `mappend` cs2) + +liftRewrite :: Rewrite a -> MSOS a +liftRewrite ev = MSOS $ \ctxt mut -> + let (e_a, est, ewr) = runRewrite ev (ereader ctxt) (estate mut) + in return (e_a, mut {estate = est}, mempty { ewriter = ewr }) + +eval_catch :: Rewrite a -> Rewrite (Either IException a) +eval_catch eval = Rewrite $ \ctxt st -> + let (eval_res, st', eval_cs) = runRewrite eval ctxt st + in (Right eval_res, st', eval_cs) + +eval_else :: (IE -> Bool) -> [Rewrite a] -> Rewrite a -> Rewrite a +eval_else prop [] def = def +eval_else prop (ev:evs) def = eval_catch ev >>= \case + Right a -> return a + Left (gf,lf,ie) | prop ie -> eval_else prop evs def + | otherwise -> rewrite_rethrow (gf,lf,ie) + +rewrite_rethrow :: IException -> Rewrite a +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) + +evalctxt2exception :: IE -> RewriteReader -> IException +evalctxt2exception ie ctxt = (global_fct ctxt, local_fct ctxt, ie) + +ctxt2exception :: IE -> MSOSReader -> 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 -> + 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 + _ -> (rw_res, st', rw_cs) + +--------------------------------------------------------------------------- +data MSOSReader = MSOSReader { ereader :: RewriteReader, inh_entities :: Inherited} +data MSOSWriter = MSOSWriter { ctrl_entities :: Control, out_entities :: Output + , ewriter :: RewriteWriterr } +data MSOSState m = MSOSState { inp_es :: Input m, mut_entities :: Mutable + , estate :: RewriteState } +emptyMSOSState :: MSOSState m +emptyMSOSState = MSOSState M.empty M.empty emptyRewriteState + +-- | 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'), +-- runtime options, etc. +-- +-- The semantic entities are divided into five classes: +-- +-- * inherited entities, propagated similar to values of a reader monad. +-- +-- * mutable entities, propagated similar to values of a state monad. +-- +-- * output entities, propagation similar to values of a write monad. +-- +-- * control entities, similar to output entities except only a single control /signal/ +-- can be emitted at once (signals do not form a monoid). +-- +-- * input entities, propagated like values of a state monad, but access like +-- value of a reader monad. This package provides simulated input/outout +-- and real interaction via the 'IO' monad. See "Funcons.Tools". +-- +-- For each entity class a map is propagated, mapping entity names to values. +-- This enables modular access to the entities. +newtype MSOS a = MSOS { runMSOS :: + forall m. Interactive m => + (MSOSReader -> MSOSState m + -> m (Either IException a, MSOSState m, MSOSWriter)) } + +instance Applicative MSOS where + pure = return + (<*>) = ap + +instance Functor MSOS where + fmap = liftM + +instance Monad MSOS where + return a = MSOS (\_ mut -> return (Right a,mut,mempty)) + + (MSOS f) >>= k = MSOS (\ctxt mut -> do + res1@(e_a1,mut1,wr1) <- f ctxt mut + case e_a1 of + Left err -> return (Left err, mut1, wr1) + Right a1 -> do + let (MSOS h) = k a1 + (a2,mut2,wr2) <- h ctxt mut1 + return (a2,mut2,wr1 <> wr2)) + +instance Monoid MSOSWriter where + mempty = MSOSWriter mempty mempty mempty + (MSOSWriter x1 x2 x3) `mappend` (MSOSWriter y1 y2 y3) = + MSOSWriter (x1 `unionCTRL` y1) (x2 `unionOUT` y2) (x3 `mappend` y3) + +-- | 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 + (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 + _ -> return (e_ie_a, mut', wr) + +-- | Function 'evalRules' implements a backtracking procedure. +-- It receives two lists of alternatives as arguments, the first +-- containing all rewrite rules of a funcon and the second all step rules. +-- The first successful rule is the only rule fully executed. +-- A rule is /unsuccessful/ if it throws an exception. Some of these +-- exceptions (partial operation, sort error or pattern-match failure) +-- cause the next alternative to be tried. Other exceptions +-- (different forms of internal errors) will be propagated further. +-- All side-effects of attempting a rule are discarded when a rule turns +-- out not to be applicable. +-- +-- First all rewrite rules are attempted, therefore avoiding performing +-- a step until it is absolutely necessary. This is a valid strategy +-- as valid (I)MSOS rules can be considered in any order. +-- +-- 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 rw_rules):rest) msoss = Rewrite $ \ctxt st -> + let (rw_res, st', cs) = 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) + +msos_throw :: IE -> MSOS b +msos_throw = liftRewrite . rewrite_throw + +--- +giveOpts :: MSOS RunOptions +giveOpts = MSOS $ \ctxt mut -> + return (Right (run_opts (ereader ctxt)), mut, mempty) + +giveINH :: MSOS Inherited +giveINH = MSOS $ \ctxt mut -> return (Right (inh_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) +----------------- +-- | a map storing the values of /inherited/ entities. +type Inherited = M.Map Name Values + +emptyINH :: Inherited +emptyINH = M.empty + + +---------- +-- | a map storing the values of /control/ entities. +type Control = M.Map Name (Maybe Values) + +emptyCTRL :: Control +emptyCTRL = M.empty + +singleCTRL :: Name -> Values -> Control +singleCTRL k = M.singleton k . Just + +unionCTRL = M.unionWithKey (error . err) + where err key = "Two " ++ unpack key ++ " signals converging!" + +----------- +-- | a map storing the values of /output/ entities. +type Output = M.Map Name [Values] + +unionOUT :: Output -> Output -> Output +unionOUT = M.unionWith (++) + +emptyOUT :: Output +emptyOUT = M.empty + +readOuts :: MSOS a -> MSOS (a, Output) +readOuts (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,(out_entities wr1)) + , mut1, wr1 { out_entities = mempty})) +----------- +-- | A map storing the values of /input/ entities. +type Input m = M.Map Name ([[Values]], Maybe (m Values)) + +----------- +-- steps, rewrites, restarts, refocus, delegations +data Counters = Counters !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) + +emptyCounters :: Int -> Int -> Int -> Int -> Int -> MSOSWriter +emptyCounters x1 x2 x3 x4 x5 = + mempty { ewriter = mempty {counters = Counters x1 x2 x3 x4 x5 }} + +count_step :: MSOS () +count_step = MSOS $ \_ mut -> return (Right (), mut, emptyCounters 1 0 0 0 0) + +count_delegation :: MSOS () +count_delegation = MSOS $ \_ mut -> return (Right (), mut, emptyCounters 0 0 0 0 1) + +count_refocus = MSOS $ \_ mut -> return (Right (), mut, emptyCounters 0 0 0 1 0) + +count_restart :: MSOS () +count_restart = MSOS $ \_ mut -> return (Right (), mut, emptyCounters 0 0 1 0 0) + +count_rewrite :: Rewrite () +count_rewrite = Rewrite $ \_ st -> (Right (), st, mempty { counters = Counters 0 1 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) + +-- | 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 +norule f = rewrite_throw NoRule + +-- | Yields an error signaling that a sort error was encountered. +-- These errors render a rule /inapplicable/ and a next rule is attempted +-- when a backtracking procedure like 'evalRules' is applied. +-- The funcon term argument may be used to provide a useful error message. +sortErr :: Funcons -> String -> Rewrite a +sortErr f str = rewrite_throw (SortErr str) + +-- | Yields an error signaling that a partial operation was applied +-- to a value outside of its domain (e.g. division by zero). +-- These errors render a rule /inapplicable/ and a next rule is attempted +-- when a backtracking procedure like 'evalRules' is applied. +-- The funcon term argument may be used to provide a useful error message. +partialOp :: Funcons -> String -> Rewrite a +partialOp f str = rewrite_throw (PartialOp str) + +exception :: Funcons -> String -> Rewrite a +exception f str = rewrite_throw (Err str) + +internal :: String -> Rewrite a +internal str = rewrite_throw (Internal str) + + +buildStep :: MSOS Funcons -> Rewrite Rewritten +buildStep = buildStepCounter (return ()) -- does not count + +buildStepCount :: MSOS Funcons -> Rewrite Rewritten +buildStepCount = buildStepCounter count_delegation + +buildStepCounter :: MSOS () -> MSOS Funcons -> Rewrite Rewritten +buildStepCounter counter mf = compstep (counter >> mf) + +optRefocus :: MSOS Funcons -> MSOS Funcons +optRefocus stepper = doRefocus >>= \case + True -> refocus stepper + False -> stepper + +refocus :: MSOS Funcons -> MSOS Funcons +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) + +stepRewritten :: Rewritten -> MSOS Funcons +stepRewritten (ValTerm v) = return (FValue v) +stepRewritten (CompTerm _ step) = count_step >> step + +-- | Returns a value as a fully rewritten term. +rewritten :: Values -> Rewrite Rewritten +rewritten = 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 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 + +if_abruptly_terminates :: Bool -> MSOS Funcons -> (Funcons -> MSOS Funcons) + -> (Funcons -> MSOS Funcons) -> MSOS Funcons +if_abruptly_terminates care (MSOS fstep) abr no_abr = MSOS $ \ctxt mut -> + fstep ctxt mut >>= \case + (Right f', mut', wr') -> + let failed = any isJust (ctrl_entities wr') + MSOS fstep | failed && care = abr f' + | otherwise = no_abr f' + in do (e_f'', mut'', wr'') <- fstep ctxt mut' + return (e_f'', mut'', wr' <> wr'') + norule_res -> return norule_res + +if_violates_refocus :: MSOS Funcons -> (Funcons -> MSOS Funcons) + -> (Funcons -> MSOS Funcons) -> MSOS Funcons +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') + MSOS fstep | violates = viol f' + | otherwise = no_viol f' + in do (e_f'', mut'', wr'') <- fstep ctxt mut' + return (e_f'', mut'', wr' <> wr'') + 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 +-- 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 +-- 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) -> + Funcons -> Rewrite Rewritten +premiseEval vapp fapp f = rewriteFuncons f >>= \case + ValTerm v -> vapp v + 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 + +----- main `step` function +evalFuncons :: Funcons -> MSOS Funcons +evalFuncons f = liftRewrite (rewriteFuncons f) >>= stepRewritten + +rewriteFuncons :: Funcons -> Rewrite Rewritten +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' (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) + 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) + (_,_) + -> rewriteFuncons f1 >>= \case + ValTerm v1 -> rewriteFuncons $ FSortComputesFrom (FValue v1) f2 + CompTerm _ mf -> compstep (flip FSortComputesFrom f2 <$> mf) + 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) + _ -> do rewriteFuncons s1 >>= \case + ValTerm v -> rewriteFuncons $ FSortUnion (FValue v) s2 + CompTerm _ mf -> compstep (flip FSortUnion s2 <$> mf) + rewriteFuncons' (FName nm) = + do mystepf <- lookupFuncon nm + case mystepf of + NullaryFuncon mystep -> mystep + _ -> error ("funcon " ++ unpack nm ++ " not applied to any arguments") + 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") + +--OPT: replace by specialised veriant of evalSequence +evalStrictSequence :: [Funcons] -> ([Values] -> Values) -> ([Funcons] -> Funcons) -> Rewrite Rewritten +evalStrictSequence args cont cons = + evalSequence (replicate (length args) Strict) args + (return . ValTerm . 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 + evalSeqAux vs [] = cont vs + evalSeqAux vs ((_,f):fs) = premiseEval valueCont funconCont f + where valueCont v = do + count_rewrite + evalSeqAux (vs++(FValue v:map snd othervs)) otherfs + where (othervs, otherfs) = span isDone fs + funconCont stepf = do f' <- stepf + stepTo (cons (vs++[f']++map snd fs)) + isDone (Strict, FValue _) = True + isDone (NonStrict, _) = True + isDone _ = False + +-- | 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 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' }} + stepAndOutput f = MSOS $ \ctxt mut -> + let MSOS stepper = evalFuncons f + in do (eres,mut',wr') <- stepper ctxt mut + mapM_ (uncurry fprint) + [ (entity,val) + | (entity, vals) <- M.assocs (out_entities wr') + , val <- vals ] + return (eres, mut', wr') + + + diff --git a/src/Funcons/Parser.hs b/src/Funcons/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Funcons/Parser.hs @@ -0,0 +1,133 @@ +{-# 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, "")] + +instance Read Funcons where + readsPrec d str = reader pFuncons "" str + +instance Read Values where + readsPrec d str = reader pValues "" str diff --git a/src/Funcons/Patterns.hs b/src/Funcons/Patterns.hs new file mode 100644 --- /dev/null +++ b/src/Funcons/Patterns.hs @@ -0,0 +1,370 @@ +{-# LANGUAGE LambdaCase #-} + +module Funcons.Patterns where + +import Funcons.MSOS +import Funcons.Types +import Funcons.Substitution +import Funcons.Exceptions + +import Control.Monad (foldM) +import Data.Function (on) +import Data.List (sortBy) +import Data.Monoid +import Data.Text (unpack) +import qualified Data.BitVector as BV + +-- pattern matching +type Matcher a = [a] -> Int -> Env -> Rewrite [(Int, Env)] +type SeqVarInfo = (MetaVar, SeqSortOp, Maybe FTerm) + +singleMatcher :: (a -> b -> Env -> Rewrite Env) -> b -> Matcher a +singleMatcher p pat str k env = case drop k str of + [] -> return [] + f:_ -> eval_catch (p f pat env) >>= \case + Left ie | failsRule ie -> return [] + | otherwise -> rewrite_rethrow ie + Right env' -> return [(k+1,env')] + +seqMatcher :: (a -> Maybe FTerm -> Env -> Rewrite Bool) -> ([a] -> Levelled) + -> SeqVarInfo -> Matcher a +seqMatcher p level (var, op, mty) str k env = case op of + QuestionMarkOp -> makeResults ((<=1) . length) + PlusOp -> case str of + [] -> return [] + _ -> makeResults ((>=1) . length) + StarOp -> makeResults (const True) + where makeResults filter_op = do + furthest <- takeWhileM (\a -> p a mty env) (drop k str) + return (map ins (filter filter_op $ ordered_subsequences furthest)) + where + ins fs = (k+length fs, envInsert var (level fs) env) + + takeWhileM :: (a -> Rewrite Bool) -> [a] -> Rewrite [a] + takeWhileM _ [] = return [] + takeWhileM p (x:xs) = eval_catch (p x) >>= \case + Right True -> (x:) <$> takeWhileM p xs + Right False -> return [] + Left ie | failsRule ie -> return [] + | otherwise -> rewrite_rethrow ie + +matching :: [a] -> [Matcher a] -> Env -> Rewrite Env +matching str ps env = do + matches <- (seqms ps) str 0 env + let rule_fail = PatternMismatch ("Pattern match failed: " ++ show (map fst matches)) + case matches of + [] -> rewrite_throw rule_fail + [(_,env')] -> return env' + _ -> internal ("ambiguity not resolved") + where m = length str + + seqms :: [Matcher a] -> Matcher a + seqms = foldr seqlongest lastMatcher + + -- sequencing of matchers specifically to disambiguate safely + lastMatcher :: Matcher a + lastMatcher _ k env | k == m = return [(k,env)] + | otherwise = return [] + + seqlongest :: Matcher a -> Matcher a -> Matcher a + seqlongest p q str k env = do + matches <- p str k env + -- implement `longest match' such that it always returns at least one + -- pattern match (if at least one exists). + -- (in combination with (`seqm` lastMatcher) it will always + -- produce exactly one match) + -- Strategy: try all `pivots' from largest to smallest and `use' + -- the first that does not yield an empty result list + foldM tryLargest [] (sortBy (((flip compare) `on` fst)) matches) + where tryLargest acc (r, env) + | null acc = q str r env + | otherwise = return acc + +ordered_subsequences :: [a] -> [[a]] +ordered_subsequences xs = ordered_subsequences' xs [] + where ordered_subsequences' [] acc = [acc] + ordered_subsequences' (x:xs) acc = acc : ordered_subsequences' xs (acc++[x]) + + +-- | Patterns for matching funcon terms ('FTerm'). +data FPattern = PValue VPattern + | PMetaVar MetaVar + | PSeqVar MetaVar SeqSortOp + | PAnnotated FPattern FTerm + | PWildCard + +f2vPattern :: FPattern -> VPattern +f2vPattern (PValue v) = v +f2vPattern (PMetaVar var) = VPMetaVar var +f2vPattern (PSeqVar var op) = VPSeqVar var op +f2vPattern (PAnnotated fp t) = VPAnnotated (f2vPattern fp) t +f2vPattern PWildCard = VPWildCard + +-- | Patterns for matching values ('Values'). +data VPattern = PADT Name [VPattern] + | VPWildCard + | PEmptySet + | PTuple [VPattern] + | PList [VPattern] + | VPMetaVar MetaVar + | VPAnnotated VPattern FTerm + | VPSeqVar MetaVar SeqSortOp + | VPLit Values + +-- | 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 + [pat] -> do + e_ie_env <- eval_catch (strict_vsMatch str [pat] env) + case e_ie_env of + Right env' -> return env' + 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 + Just info -> seqMatcher isInMaybeTermType ValuesTerm info + Nothing -> singleMatcher prop 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) + +-- | Variant of 'fsMatch' that is lifted into the 'MSOS' monad. +-- If all given terms are values, then 'vsMatch' is used instead. +lifted_fsMatch str pats env = liftRewrite $ fsMatch str pats env +-- | Match a sequence of terms to a sequence of patterns. +fsMatch = fsMatchStrictness False +strict_fsMatch = fsMatchStrictness True +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 + +fMatch :: Funcons -> FPattern -> Env -> Rewrite Env +fMatch _ PWildCard env = return env +fMatch f (PMetaVar var) env = return (envInsert var (FunconTerm f) 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 + 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 + CompTerm _ _ -> rewrite_throw --important, should remain last + (PatternMismatch ("could not rewrite to value: " ++ showFuncons f)) + +lifted_vMaybeMatch mv mp env = liftRewrite $ vMaybeMatch mv mp env +vMaybeMatch :: Maybe Values -> Maybe VPattern -> Env -> Rewrite Env +vMaybeMatch Nothing Nothing env = return env +vMaybeMatch (Just v) (Just p) env = vMatch v p env +vMaybeMatch _ _ env = rewrite_throw (PatternMismatch ("vMaybeMatch")) + +lifted_vMatch v p env = liftRewrite $ vMatch v p env +vMatch :: Values -> VPattern -> Env -> Rewrite Env +vMatch _ (VPWildCard) 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 v (VPAnnotated pat term) env = do + ty <- subsAndRewrite term env + isIn v ty >>= \case + True -> vMatch v pat env + False -> rewrite_throw (PatternMismatch ("pattern annotation check failed: " ++ show 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 v _ _ = rewrite_throw (PatternMismatch ("failed to match")) + + +adtMatch :: Name -> Name -> [Values] -> [VPattern] -> Env -> Rewrite Env +adtMatch con pat_con vs pats env + | con /= pat_con = rewrite_throw (PatternMismatch ("failed to match constructors: (" ++ show (con,pat_con) ++ ")")) + | otherwise = vsMatch vs pats env + + +fpSeqVarInfo :: FPattern -> Maybe SeqVarInfo +fpSeqVarInfo (PSeqVar var op) = Just (var, op, Nothing) +fpSeqVarInfo (PAnnotated (PSeqVar var op) _) = Just (var, op, Nothing) +fpSeqVarInfo _ = Nothing + +vpSeqVarInfo :: VPattern -> Maybe SeqVarInfo +vpSeqVarInfo (VPSeqVar var op) = Just (var, op, Nothing) +vpSeqVarInfo (VPAnnotated (VPSeqVar var op) term) = Just (var, op, Just term) +vpSeqVarInfo _ = Nothing + + +-- | CSB supports five kinds of side conditions. +-- Each of the side conditions are explained below. +-- When a side condition is not accepted an exception is thrown that +-- is caught by the backtrackign procedure 'evalRules'. +-- A value is a /ground value/ if it is not a thunk (and not composed out of +-- thunks). +data SideCondition + -- | /T1 == T2/. Accepted only when /T1/ and /T2/ rewrite to /equal/ ground values. + = SCEquality FTerm FTerm + -- | /T1 =\/= T2/. Accepted only when /T1/ and /T2/ rewrite to /unequal/ ground values. + | SCInequality FTerm FTerm + -- | /T1 : T2/. Accepted only when /T2/ rewrites to a type and /T1/ rewrites to a value of that type. + | SCIsInSort FTerm FTerm + -- | /~(T1 : T2)/. Accepted only when /T2/ rewrites to a type and /T1/ rewrites to a value /not/ of that type. + | SCNotInSort FTerm FTerm + -- | /T = P/. Accepted only when /T/ rewrites to a value that matches the pattern /P/. (May produce new bindings in 'Env'). + | SCPatternMatch FTerm VPattern + +-- | Variant of 'sideCondition' that is lifted into the 'MSOS' monad. +lifted_sideCondition sc env = liftRewrite $ sideCondition sc env + +-- | Executes a side condition, given an 'Env' environment, throwing possible exceptions, and +-- possibly extending the environment. +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 + 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 + 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 + 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")) + +-- piggy back on +matchTypeParams :: [Types] -> [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 + + +-- type checking +isInMaybeTermType :: Values -> (Maybe FTerm) -> Env -> Rewrite Bool +isInMaybeTermType v Nothing _ = return True +isInMaybeTermType v (Just term) env = + subsAndRewrite term env >>= isIn v + +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 + +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 + +isInTupleType :: [Values] -> [TTParam] -> Rewrite Bool +isInTupleType vs ttparams = + eval_catch (vsMatch vs (map mkPattern ttparams) emptyEnv) >>= \case + Right env' -> return True + Left (_,_,PatternMismatch _) -> return False + Left ie -> rewrite_rethrow ie + where mkPattern (ty, mop) = VPAnnotated ty_pat (TFuncon ty_funcon) + 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 -> + case typeLookup con (ty_env ctxt) of + Nothing -> (Left (evalctxt2exception(Internal "type lookup failed") ctxt) + , st, mempty) + Just members -> (Right members, st, mempty) + +-- | +-- 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") + diff --git a/src/Funcons/Printer.hs b/src/Funcons/Printer.hs new file mode 100644 --- /dev/null +++ b/src/Funcons/Printer.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Printer ( + ppFuncons, ppValues, ppTypes, + showValues, showFuncons, showTypes, + ) 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 + +-- | Pretty-print a 'Funcons'. +showFuncons :: Funcons -> String +showFuncons = ppFuncons defaultRunOptions + +-- | Pretty-print a 'Types'. +showTypes :: Types -> String +showTypes = ppTypes defaultRunOptions + +ppFuncons :: RunOptions -> Funcons -> String +ppFuncons opts (FList 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 (FName nm) = unpack nm +ppFuncons opts (FSortSeq f o) = ppFuncons opts f ++ ppOp o +ppFuncons opts (FSortUnion f1 f2) = "(" ++ ppFuncons opts f1 ++ "|" ++ ppFuncons opts f2 ++ ")" +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])) = + let env | pp_full_environments opts = y + | otherwise = string_ "..." + in showFn opts "closure" [x, env] +ppFuncons opts (FApp "scope" (FTuple [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 +-} + +-- helpers + +showFn :: RunOptions -> String -> [Funcons] -> String +showFn opts n xs = n ++ showArgs opts True xs + +showArgs :: RunOptions -> Bool -> [Funcons] -> String +showArgs opts b args | b = "(" ++ seq ++ ")" + | otherwise = seq + where seq = intercalate "," (map (ppFuncons opts) args) + diff --git a/src/Funcons/RunOptions.hs b/src/Funcons/RunOptions.hs new file mode 100644 --- /dev/null +++ b/src/Funcons/RunOptions.hs @@ -0,0 +1,256 @@ +{-# LANGUAGE OverloadedStrings, TupleSections #-} + +module Funcons.RunOptions where + +import Funcons.Types +import Funcons.Parser + +import Text.ParserCombinators.Parsec +import qualified Text.ParserCombinators.Parsec.Token as P +import qualified Text.ParserCombinators.Parsec.Language as L + +import qualified Data.Map as M +import Control.Monad (when) +import Data.Char (isSpace) +import Data.Text (pack) +import Data.List (isSuffixOf, isPrefixOf) +import Data.List.Split (splitOn) + +import System.Directory (doesFileExist) + +type GeneralOptions = M.Map Name String +type BuiltinFunconsOptions = 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 + , expected_outcomes :: TestOptions + , given_inputs :: InputValues + } + +defaultRunOptions :: RunOptions +defaultRunOptions = RunOptions Nothing M.empty M.empty M.empty M.empty + +optionsOverride opts opts' = RunOptions + (maybe (mfuncon_term opts) Just (mfuncon_term opts')) + (general_opts opts `M.union` general_opts opts') + (builtin_funcons opts `M.union` builtin_funcons opts') + (expected_outcomes opts `M.union` expected_outcomes opts') + (given_inputs opts `M.union` given_inputs opts') + +funcon_term :: RunOptions -> Funcons +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 + Just "false" -> False + _ -> True + + +bool_opt :: Name -> M.Map Name String -> Bool +bool_opt nm m = bool_opt_default False nm m + +do_refocus :: RunOptions -> Bool +do_refocus opts = bool_opt "refocus" (general_opts opts) + +max_restarts :: RunOptions -> Maybe Int +max_restarts = fmap read . M.lookup "max-restarts" . general_opts + +do_abrupt_terminate :: RunOptions -> Bool +do_abrupt_terminate = not . bool_opt "no-abrupt-termination" . general_opts + +pp_full_environments :: RunOptions -> Bool +pp_full_environments = bool_opt "full-environments" . general_opts + +show_result :: RunOptions -> Bool +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) + then not (interactive_mode opts) + else False + +show_mutable :: RunOptions -> [Name] +show_mutable = maybe [] (map pack . splitOn ",") . M.lookup "display-mutable-entity" . general_opts + +hide_output :: RunOptions -> [Name] +hide_output = maybe [] (map pack . splitOn ",") . M.lookup "hide-output-entity" . general_opts + +hide_input :: RunOptions -> [Name] +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 + +interactive_mode :: RunOptions -> Bool +interactive_mode opts = if bool_opt "interactive-mode" (general_opts opts) + then M.null (inputValues opts) + else False + +pp_string_outputs :: RunOptions -> Bool +pp_string_outputs = bool_opt "format-string-outputs" . general_opts + +string_inputs :: RunOptions -> Bool +string_inputs = bool_opt "string-inputs" . general_opts + +show_tests :: RunOptions -> Bool +show_tests opts = if bool_opt "hide-tests" (general_opts opts) + then False + else M.size (expected_outcomes opts) > 0 + +show_output_only :: RunOptions -> Bool +show_output_only opts = if bool_opt "show-output-only" (general_opts opts) + then True + else interactive_mode opts + +auto_config :: RunOptions -> Bool +auto_config opts = bool_opt_default True "auto-config" (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_ = 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_ + +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) + , 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))) + (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))} + 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 >>= + return . flip (parseAndApplyConfig cfg_name) opts + else return opts + let opts'' = opts' {mfuncon_term = Just (read 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 + let opts' = parseAndApplyConfig cfg_name str opts + fold (opts', errors) (tail args) + | otherwise = do + exists <- doesFileExist (arg++".fct") + if exists then fold (opts, errors) ((arg++".fct"):args) + else fold (opts, arg:errors) args + fold (opts, errors) [] = return (opts, errors) + +parseAndApplyConfig :: FilePath -> String -> RunOptions -> RunOptions +parseAndApplyConfig fp str = optionsOverride (parser pRunOptions fp str) + +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 } + +pGeneral :: Parser RunOptions +pGeneral = toOpts <$> + (optionMaybe (keyword "funcon-term" *> colon *> pFuncons <* semiColon)) + <*> (M.fromList <$> many 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 + +pBool :: Parser String +pBool = string "true" <|> string "false" + +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 + +pBuiltinFuncons :: Parser RunOptions +pBuiltinFuncons = (\list -> defaultRunOptions {builtin_funcons = M.fromList list}) <$> + many ((,) . pack <$> pFunconName <* equals <*> pFunconTerm <* semiColon) + +pTestOutcomes :: Parser RunOptions +pTestOutcomes = toOptions <$> (M.union <$> pResult <*> pEntityValues) + where pResult = mStoreResult <$> optionMaybe (id <$ keyword "result-term" <* colon + <*> pFunconTerm <* semiColon) + where mStoreResult Nothing = M.empty + mStoreResult (Just f) = M.singleton "result-term" f + pEntityValues = M.fromList <$> + many (((,) . pack <$> pFunconName <* colon <*> pFunconTerm <* semiColon)) + 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 + +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 diff --git a/src/Funcons/Simulation.hs b/src/Funcons/Simulation.hs new file mode 100644 --- /dev/null +++ b/src/Funcons/Simulation.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE TupleSections, FlexibleInstances, OverloadedStrings #-} + +module Funcons.Simulation where + +import Funcons.Types +import Funcons.Exceptions +import Funcons.Printer +import Funcons.RunOptions + +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 + fprint :: Name -> Values -> m () + fexec :: m a -> InputValues -> IO (a, InputValues) + +instance Interactive IO where + fexec ma _ = (,M.empty) <$> ma + + 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 + + fprint _ (String s) = putStr s + fprint _ v = putStr (showValues v) + +type SimIO = State InputValues + +instance Interactive SimIO where + fexec ma defs = return (runState ma defs) + + fread _ nm = do v <- gets mLookup + modify (M.adjust tail nm) + return v + where mLookup m = case M.lookup nm m of + Just (v:_) -> v + _ -> error ("simulated IO: " ++ show (InsufficientInput nm)) + + -- SimIO ignores prints as simulated Output is always done + -- alternative is to use tell from Writer monad here and somehow remember + -- whatever has been printed in Interactive instance for IO + -- (necessary for observing printed output by funcon defs, using 'readOUT') + fprint nm v = return () +----------- + diff --git a/src/Funcons/Substitution.hs b/src/Funcons/Substitution.hs new file mode 100644 --- /dev/null +++ b/src/Funcons/Substitution.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE LambdaCase #-} + +module Funcons.Substitution ( + Env(..), subsAndRewrite, envInsert, emptyEnv, Levelled(..), substitute, + rewriteTermTo, stepTermTo, + ) where + +import Funcons.Types +import Funcons.MSOS +import Funcons.Exceptions + +import Control.Monad +import Data.Monoid +import qualified Data.Map as M + +-- | An environment mapping meta-variables to funcon terms. +-- 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 + | ValuesTerm [Values] + | FunconTerm Funcons + | FunconsTerm [Funcons] + +-- | The empty substitution environment. +-- Bindings are inserted by pattern-matching. +emptyEnv = M.empty + +envLookup :: Env -> MetaVar -> Rewrite Levelled +envLookup env k = case M.lookup k env of + Nothing -> internal ("undefined metavar: " <> k) + Just lf -> return lf + +envInsert :: MetaVar -> Levelled -> Env -> Env +envInsert = M.insert + +fsLevel :: Levelled -> Rewrite [Funcons] +fsLevel = \case FunconsTerm 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) + + +-- substitution +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 +-- 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 (TFuncon f) env = return f +substitute (TSortUnion t1 t2) env = FSortUnion <$> substitute t1 env <*> substitute t2 env +substitute (TSortSeq t1 op) env = flip FSortSeq op <$> substitute t1 env +substitute (TSortComputes t1) env = FSortComputes <$> substitute t1 env +substitute (TSortComputesFrom t1 t2) env = + FSortComputesFrom <$> substitute t1 env <*> substitute t2 env + +-- flatten out sequence-variables +subsFlatten :: [FTerm] -> Env -> Rewrite [Funcons] +subsFlatten terms env = concat <$> (forM terms $ \case + TVar k -> envLookup env k >>= fsLevel + 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") + + +-- | Variant of 'rewriteTo' that applies substitution. +rewriteTermTo :: FTerm -> Env -> Rewrite Rewritten +rewriteTermTo fterm env = substitute fterm env >>= rewriteTo + +-- | Variant of 'stepTo' that applies substitution. +stepTermTo :: FTerm -> Env -> MSOS Funcons +stepTermTo fterm env = do + (liftRewrite $ substitute fterm env) >>= stepTo + + + diff --git a/src/Funcons/Tools.hs b/src/Funcons/Tools.hs new file mode 100644 --- /dev/null +++ b/src/Funcons/Tools.hs @@ -0,0 +1,458 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Funcons.Tools ( + -- * Creating standalone interpreters. + + -- $moduledoc + mkMain, mkMainWithLibrary, mkMainWithLibraryEntities, + mkMainWithLibraryTypes, mkMainWithLibraryEntitiesTypes, + -- * Creating embedded interpreters. + run, runWithExtensions, + -- * Utility functions for interpreter extensions. + -- ** Funcon libraries. + FunconLibrary, libEmpty, libUnion, libUnions, libFromList, + -- ** Type environments. + TypeEnv, DataTypeMembers(..), DataTypeAlt(..), TypeParam, + emptyTypeEnv, typeEnvUnion, typeEnvUnions, typeEnvFromList, + -- ** Entity declarations + EntityDefaults, EntityDefault(..), noEntityDefaults, + ) where + +import Funcons.EDSL (library) +import Funcons.RunOptions +import Funcons.Types +import Funcons.Entities +import Funcons.MSOS +import Funcons.Core.Library +import Funcons.Core.Manual +import Funcons.Printer + +import System.Environment (getArgs) + +import Data.Text (unpack) +import Data.List ((\\), intercalate) +import qualified Data.Map as M +import Control.Monad (forM_, when, unless) + +-- | The empty collection of entity defaults. +noEntityDefaults :: [EntityDefault] +noEntityDefaults = [] + +-- | Creates a /main/ function for the default interpreter (no extension). +-- The executable made from this /main/ function receives command line +-- argumenst as explained above ("Funcons.Tools"). +mkMain :: IO () +mkMain = mkMainWithLibrary libEmpty + +-- | Creates a /main/ function for the interpreter obtained by extending +-- the default library with the funcons in the 'FunconLibrary' argument. +mkMainWithLibrary :: FunconLibrary -> IO() +mkMainWithLibrary lib = mkMainWithLibraryEntities lib [] + +-- | Creates a /main/ function for the interpreter obtained by extending +-- the main interpreter with the funcons in the 'FunconLibrary' argument +-- and with default values for entities defined in the 'EntityDefaults' +-- argument. +mkMainWithLibraryEntities :: FunconLibrary -> EntityDefaults -> IO () +mkMainWithLibraryEntities lib ents = + mkMainWithLibraryEntitiesTypes lib ents emptyTypeEnv + +-- | 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 +-- type arguments. +mkMainWithLibraryTypes :: FunconLibrary -> TypeEnv -> 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 () +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 + +-- | 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. +runWithExtensions :: + FunconLibrary -> EntityDefaults -> TypeEnv -> [String] -> Maybe Funcons -> IO () +runWithExtensions lib defaults tyenv = + emulate full_lib full_defaults full_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] + +-- | +-- 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 +-- as one of the command line arguments may refer to an .fct file or .config +-- 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 + +------------------------------------------------------------------------------ +--- running programs +emulate lib defaults tyenv args mf0 = do + (opts, unknown_opts) <- run_options args + 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 + +emulate' :: Interactive m => (Name -> m Values) -> + FunconLibrary -> EntityDefaults -> TypeEnv -> 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 + -- 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)) + msos_ctxt (emptyMSOSState {inp_es = inputs})) (inputValues opts) + -- if not in --interactive-mode then print additional information based on flags + 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 + +withResults defaults msos_ctxt e_exc_f msos_state wr rem_ins + | 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 + | otherwise = do + unless (show_output_only opts) $ do + printCounts + case e_exc_f of + Left ie -> putStrLn (showIException ie) + Right f -> printResult f + printMutable + printControl + printInputOutput 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 "" + + printCounts = when (show_counts opts) + (putStrLn $ show (counters (ewriter wr))) + + printMutable = forM_ toShow display + where toShow = show_mutable opts + display name = case M.lookup name muts of + Nothing -> return () + Just v -> putStrLn ("Mutable Entity: " ++ unpack name) >> + putStrLn (displayValue v) >> putStrLn "" + + printControl = forM_ (M.keys ctrl \\ toHide) display + where ctrl = ctrl_entities wr + toHide = hide_control opts + display name = case M.lookup name ctrl of + Just (Just v) -> do + putStrLn ("Control Entity: " ++ unpack name) + putStrLn (displayValue v) >> putStrLn "" + _ -> return () + + printOutput = forM_ (M.keys out \\ toHide) display + where out = out_entities wr + display name = do + 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)) + unless (show_output_only opts) (putStrLn "") + where vs = out M.! name + toHide = hide_output opts + + + printInputOutput 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 "" + where vs = ios M.! name + + 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 (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 + +printTestResults :: Funcons -> EntityDefaults -> MSOSReader -> + MSOSState m -> MSOSWriter -> InputValues -> IO () +printTestResults f 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) + printMutable + printControl + printInputOutput out + printInputOutput rem_ins + + where eval_ctxt = ereader msos_ctxt + muts = mut_entities msos_state + eval_state = estate msos_state + 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 _,_,_) -> + error ("evaluation of " ++ unpack name ++ " requires step") + + mLocalEval term = case runRewrite(rewriteFuncons term) eval_ctxt eval_state of + (Right (ValTerm v),_,_) -> Just v + _ -> Nothing + + result_term = case recursiveFunconValue rf of + Nothing -> case mLocalEval rf of + Nothing -> rf + Just v -> FValue v + Just v -> FValue v + 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) + + printNotExists "result-term" = return () + printNotExists name = + case (M.lookup name muts, M.lookup name out + ,M.lookup name ctrl, M.lookup name rem_ins) of + (Nothing, Nothing, Nothing, Nothing) -> + putStrLn ("unknown entity: " ++ unpack name) + _ -> return () + + 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) + + -- set default values of output and control entities + ctrl = foldr op (ctrl_entities wr) defaults + where op (DefControl name) ctrl + | not (M.member name ctrl) = M.insert name Nothing ctrl + op _ ctrl = ctrl + + out = foldr op (out_entities wr) defaults + where op (DefOutput name) out + | not (M.member name out) = M.insert name [] out + op _ out = out + + -- 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 + -- shows expected signal + display name Nothing = case M.lookup name opts of + Nothing -> return () + Just val -> putStrLn ("expected "++unpack name++": " + ++ show (localEval name val)) + -- 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) + + 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) + val -> error ("non-list given as expected output entity ("++ + unpack name ++ "): " ++ show val) + + +-- $moduledoc +-- This module exports functions for creating executables for funcon interpeters. +-- The executables accepts a number of command line and configuration options that +-- are explained here. The /funcons-tools/ package exports an interpreter for +-- the core library of reusable funcons. This executable is called /runfct/ and is used +-- as an example here. +-- +-- @ dist\/build\/runfct\/runfct \@ +-- +-- === Options +-- Options are used to change the behaviour of the interpreter and to change the +-- output the interpreter provides after execution. +-- An option is either a boolean-option, a string-option, a .config file or a .fct file. +-- All command line flags are considered from left to right, +-- each changing the current configuration. +-- +-- (1) __Funcon term file__: A file containing a funcon term. (must have .fct extension). +-- These files contain funcon terms written +-- in prefix form with parentheses surrounding comma-separated arguments, +-- e.g. integer-multiply(6,7). The parser also accepts notation for lists, +-- tuples, sets and map. For example, @[1,2,3]@, @(1,2,3)@, @{1,2,3}@, +-- and @{1 |-> true, 2 |-> false, 3 |-> true }@ respectively. +-- +-- (2) __Configurations file__: A file containing configuration options (see below). +-- (must have .config extension) +-- +-- (3) __String options__ (comma-separate strings for multiple inputs): +-- +-- * --display-mutable-entity \: by default mutable entities are not displayed +-- this option is used to display one or more mutable entities. +-- +-- * --hide-output-entity \: +-- by default output entities are displayed when output is available. +-- this option is used to hide one or more output entities. +-- +-- * --hide-control-entity \: +-- by default control entities are displayed when a signal is raised. +-- this option is used to hide one or more control entities . +-- +-- * --hide-input-entity \: +-- by default input entities are displayed when input has not been consumed. +-- this option is used to hide one or more input entities. +-- * --max-restarts \: +-- perform a maximum of `n` transitive steps, useful for debugging. +-- +-- (4) __Boolean options__ (/true/, /false/ or no argument (/true/ by default)): +-- +-- * --refocus \: use refocusing, only valid under certain conditions. +-- +-- * --full-environments \: when printing funcons, display environments +-- using map-notation, by default an environment is printed as "...". +-- +-- * --hide-result \: do not show the resulting funcon term. +-- +-- * --display-steps \: show meta-information about the interpretation, +-- e.g. the number of steps, rewrites and restarts. +-- +-- * --no-abrupt-termination \: disable abrupt termination (affects uncaught control signals). +-- +-- * --interactive-mode \: use real I/O for input and output. +-- By default I/O is simulated and all input is expected to be +-- provided in a configuration file (see below) and output is collected +-- and displayed after execution is finished. +-- In interactive mode, the user has to provide input via the standard input, +-- and output is printed to the standard output as soon as it is available. +-- +-- * --string-inputs \: by default input is parsed into a 'Values'. +-- This option tells the interpreter to yield the given string as input. +-- +-- * --format-string-outputs \: if all output values are strings (and with this option on), +-- any escape characters are interpreted (e.g. "\\n" becomes an actual newline), and +-- the strings are concatenated and not enclosed in double quotes. +-- +-- * --hide-tests \: do not execute tests (by default tests are executed if specified in a configuration file). +-- +-- * --show-output-only \: print only output (omits all other information). +-- +-- * --auto-config \: if a .fct file is given, search for a .config file +-- with the same name and apply it (on by default). +-- +-- === Configuration files +-- A configuration file is a sequence of 'fragments', where each fragment is of the form: +-- +-- > { +-- > * +-- > } +-- +-- A \ is a colon separated key-value pair, closed off by a semicolon, e.g. +-- +-- > hide-control-entity: failed,thrown; +-- +-- There are 4 valid groups: /general/, /funcons/, /tests/ and /inputs/. +-- +-- (1) __general__: +-- The general /group/ is used as an alternative to command line flags, +-- All Boolean and string options are available. +-- Additionally, the option "funcon-term" is available for giving an initial +-- funcon term: +-- +-- > general { +-- > funcon-term: integer-add(3,2); +-- > } +-- +-- (2) __funcons__: +-- This group is used to define simple (nullary) funcons. +-- They key is the name of the funcon, +-- the value is a funcon term to which the funcon will rewrite once evaluated. +-- Keys and values are separated by '=' in this group. This group is useful +-- to choose an interpretation for unspecified components of a language specification. +-- For example (from a Caml Light specification): +-- +-- > funcons { +-- > implemented-vectors = vectors(values); +-- > implemented-floats-format = binary64; +-- > implemented-integers-width = 31; +-- > implemented-characters = unicode-characters; +-- > implemented-strings = strings; +-- > } +-- +-- (3) __tests__: +-- With this group unit-tests can be defined. +-- Each key-value pairs specifies the expected value of a semantic entities, +-- where the key is the name of a semantic entity +-- and the value is the expected value. +-- Additionally, the key "result-term" can be used to specify the expected result term. +-- The tests group is useful to specify a complete unit-test in a single file, e.g. +-- +-- > general { +-- > funcon-term: else(integer-add(integer-add(2,3),fail),print(3)); +-- > } +-- > tests { +-- > result-term: (); +-- > standard-out: [3]; +-- > } +-- +-- (4) __inputs__: +-- The inputs group is used to specify default values for input entities, e.g. +-- +-- > inputs { +-- > standard-in: [1,2,3]; +-- > } +-- +-- When input entities are given default values, simulation mode is turned on +-- (even if --interactive-mode is used). +-- +-- === Languages specific interpreters +-- This package does not provide just one interpreter, it provides +-- the ability to play `mix and match' with 'FunconLibrary's to form interpreters. +-- This enables the creation of interpreters for object languages from funcons +-- (entities, or datatypes) specific to that object language. +-- +-- For this purpose, this module exports 'mkMainWithLibraryEntitiesTypes' (and variants). +-- Say that a module exporting +-- 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'). +-- The resulting maps are given as arguments to 'mkMainWithLibraryEntitiesTypes' +-- (or variant). +-- By using 'mkMainWithLibraryEntitiesTypes', all interpreters inherit the +-- core reusable funcon library. + + + diff --git a/src/Funcons/Types.hs b/src/Funcons/Types.hs new file mode 100644 --- /dev/null +++ b/src/Funcons/Types.hs @@ -0,0 +1,489 @@ +{-# LANGUAGE OverloadedStrings, TupleSections #-} + +module Funcons.Types where + +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. +-- 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] + | FSet [Funcons] + | FMap [Funcons] + | FValue Values + | FSortSeq Funcons SeqSortOp + | FSortUnion Funcons Funcons + | FSortComputes Funcons + | FSortComputesFrom Funcons Funcons + deriving (Eq, Ord, Show) + +-- | +-- Build funcon terms by applying a funcon name to `zero or more' funcon terms. +-- This function is useful for defining smart constructors, e,g, +-- +-- > handle_thrown_ :: [Funcons] -> Funcons +-- > handle_thrown_ = applyFuncon "handle-thrown" +-- +-- or alternatively, +-- +-- > 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) + +-- | Creates a list of funcon terms. +list_ :: [Funcons] -> Funcons +list_ = FList + +-- | Creates a set of funcon terms. +set_ :: [Funcons] -> Funcons +set_ = FSet + + +-- | Funcon term representation identical to 'Funcons', +-- but with meta-variables. +data FTerm = TVar MetaVar + | TName Name + | TApp Name FTerm + | TTuple [FTerm] + | TList [FTerm] + | TSet [FTerm] + | TMap [FTerm] + | TFuncon Funcons + | TSortSeq FTerm SeqSortOp + | TSortUnion FTerm FTerm + | TSortComputes FTerm + | TSortComputesFrom FTerm FTerm + deriving (Eq, Ord, Show) + +-- | +-- 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 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) + +binary32 :: Values +binary32 = ADTVal "binary32" [] + +binary64 :: Values +binary64 = ADTVal "binary64" [] + +adtval :: Name -> Values -> Values +adtval nm = ADTVal nm . tuple_unval + +nullaryTypes :: [(Name,Types)] +nullaryTypes = + [ ("algebraic-datatypes", ADTs) + , ("atoms", Atoms) + , ("computation-types", ComputationTypes) + , ("empty-type", EmptyType) + , ("integers", Integers) + , ("naturals", Naturals) + , ("rationals", Rationals) + , ("strings", Strings) + , ("types", Types) + , ("unicode-characters", UnicodeCharacters) + , ("values", Values) + ] + +unaryTypes :: [(Name,Types->Types)] +unaryTypes = + [ ("lists", Lists) + , ("multisets", Multisets) + , ("sets", Sets) + , ("vectors", Vectors) + ] + +binaryTypes :: [(Name,Types->Types->Types)] +binaryTypes = + [ ("maps", Maps) + ] + +boundedIntegerTypes :: [(Name, Integer -> Integer -> Types)] +boundedIntegerTypes = [("bounded-integers", BoundedIntegers)] + +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'. +int_ :: Int -> Funcons +int_ = FValue . mk_integers . toInteger + +-- | Creates a natural 'literal'. +nat_ :: Int -> Funcons +nat_ i | i < 0 = int_ i + | otherwise = FValue $ mk_naturals $ toInteger i + +-- | 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 + +-- | Creates an empty tuple as a 'Values'. +empty_tuple_ :: Funcons +empty_tuple_ = FValue EmptyTuple + +-- | The empty map as a 'Funcons'. +empty_map_,map_empty_ :: Funcons +empty_map_ = FValue (Map M.empty) +map_empty_ = empty_map_ + +-- | The empty set as a 'Funcons'. +empty_set_ :: Funcons +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 + +type_ :: Types -> Funcons +type_ = FValue . typeVal + +vec :: V.Vector (Values) -> Funcons +vec = FValue . Vector + +-- 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 + +setval :: [Values] -> Funcons +setval = FValue . setval_ + +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" + +-- subtyping rationals +mk_rationals :: Rational -> Values +mk_rationals r | denominator r == 1 = mk_integers (numerator r) + | otherwise = Rational r + +mk_integers :: Integer -> Values +mk_integers i | i >= 0 = mk_naturals i + | otherwise = Int i + +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 + +-- | 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 + +-- | Returns the /natural/ representation of a value if it is a subtype. +-- Otherwise it returns the original value. +upcastNaturals :: Values -> Values +upcastNaturals v = v + +-- | 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. +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 (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 _ = Nothing + +(===) :: Values -> Values -> Bool +v1 === v2 = isGround v1 && isGround v2 && (v1 == v2) + +(=/=) :: Values -> Values -> Bool +v1 =/= v2 = isGround v1 && isGround v2 && (v1 /= v2) + +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) + +-- functions that check simple properties of funcons +-- TODO: these may not be needed any longer +isAscii (FValue (Ascii _)) = True +isAscii _ = 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 _ = False +isEnv f = isMap f +isMap (FValue (Map _)) = True +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 +isType (FValue (ComputationType (Type _))) = True +isType _ = False +isVal (FValue _) = True +isVal _ = False +isVec (FValue (Vector _)) = True +isVec _ = False +isType_ (ComputationType (Type _)) = True +isType_ _ = False + +integers_,strings_,values_,unicode_characters_ :: Funcons +integers_ = type_ Integers +unicode_characters_ = type_ UnicodeCharacters +strings_ = type_ Strings +values_ = type_ Values diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,13 @@ + +module Main where + +import Funcons.EDSL +import Funcons.Tools +import Funcons.Core.Manual as Manual + +import qualified Data.Map as M + +main :: IO () +main = mkMain + +