packages feed

funcons-tools (empty) → 0.1.0.0

raw patch · 155 files changed

+8886/−0 lines, 155 filesdep +basedep +bvdep +containerssetup-changed

Dependencies added: base, bv, containers, directory, funcons-tools, mtl, multiset, parsec, split, text, vector

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cbs/Funcons/Core/Abstractions/Closures/Close.hs view
@@ -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
+ cbs/Funcons/Core/Abstractions/Closures/Closure.hs view
@@ -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"
+ cbs/Funcons/Core/Abstractions/Functions/Apply.hs view
@@ -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
+ cbs/Funcons/Core/Abstractions/Functions/BindingLambda.hs view
@@ -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"
+ cbs/Funcons/Core/Abstractions/Functions/Compose.hs view
@@ -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
+ cbs/Funcons/Core/Abstractions/Functions/Curry.hs view
@@ -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
+ cbs/Funcons/Core/Abstractions/Functions/Lambda.hs view
@@ -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
+ cbs/Funcons/Core/Abstractions/Functions/PartialApply.hs view
@@ -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
+ cbs/Funcons/Core/Abstractions/Functions/Supply.hs view
@@ -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
+ cbs/Funcons/Core/Abstractions/Functions/Uncurry.hs view
@@ -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
+ cbs/Funcons/Core/Abstractions/IsGroundValue.hs view
@@ -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
+ cbs/Funcons/Core/Abstractions/Patterns/Case.hs view
@@ -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"
+ cbs/Funcons/Core/Abstractions/Patterns/Match.hs view
@@ -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
+ cbs/Funcons/Core/Abstractions/Patterns/MatchLoosely.hs view
@@ -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
+ cbs/Funcons/Core/Abstractions/Patterns/PatternAny.hs view
@@ -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"]))
+ cbs/Funcons/Core/Abstractions/Patterns/PatternBind.hs view
@@ -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
+ cbs/Funcons/Core/Abstractions/Patterns/PatternPrefer.hs view
@@ -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
+ cbs/Funcons/Core/Abstractions/Patterns/PatternUnite.hs view
@@ -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
+ cbs/Funcons/Core/Abstractions/Patterns/Patterns.hs view
@@ -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")
+ cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/Abort.hs view
@@ -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
+ cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/CallCc.hs view
@@ -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
+ cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/Control.hs view
@@ -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")
+ cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/ControlSignal.hs view
@@ -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+    []
+ cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/Hole.hs view
@@ -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
+ cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/Plug.hs view
@@ -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"
+ cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/Prompt.hs view
@@ -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
+ cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/Reset.hs view
@@ -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
+ cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/ResumeSignal.hs view
@@ -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+    []
+ cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Continuations/Shift.hs view
@@ -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
+ cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Failing/CheckTrue.hs view
@@ -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")
+ cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Failing/Dereference.hs view
@@ -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")
+ cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Failing/Else.hs view
@@ -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
+ cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Failing/Fail.hs view
@@ -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")
+ cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Failing/Failed.hs view
@@ -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+    []
+ cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Failing/Signals.hs view
@@ -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" []
+ cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Stuck.hs view
@@ -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")
+ cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Throwing/Finally.hs view
@@ -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
+ cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Throwing/HandleRecursively.hs view
@@ -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
+ cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Throwing/HandleThrown.hs view
@@ -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
+ cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Throwing/Throw.hs view
@@ -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")
+ cbs/Funcons/Core/Computations/ControlFlow/Abnormal/Throwing/Thrown.hs view
@@ -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+    []
+ cbs/Funcons/Core/Computations/ControlFlow/Normal/Choosing/IfThenElse.hs view
@@ -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"
+ cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/FilteringCollections/ListFilter.hs view
@@ -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"
+ cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/FilteringCollections/MapFilter.hs view
@@ -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"
+ cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/FilteringCollections/MultisetFilter.hs view
@@ -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"
+ cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/FilteringCollections/SetFilter.hs view
@@ -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"
+ cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/MappingCollections/ListMap.hs view
@@ -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"
+ cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/MappingCollections/ListsMap.hs view
@@ -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"
+ cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/MappingCollections/MapMap.hs view
@@ -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"
+ cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/MappingCollections/SetMap.hs view
@@ -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"
+ cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/MappingCollections/TupleMap.hs view
@@ -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"
+ cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/MappingCollections/VectorMap.hs view
@@ -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"
+ cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/ReducingCollections/ListFoldl.hs view
@@ -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"
+ cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Definite/ReducingCollections/ListFoldr.hs view
@@ -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"
+ cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Indefinite/DoWhile.hs view
@@ -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
+ cbs/Funcons/Core/Computations/ControlFlow/Normal/Iterating/Indefinite/While.hs view
@@ -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
+ cbs/Funcons/Core/Computations/ControlFlow/Normal/Sequencing/Atomic.hs view
@@ -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
+ cbs/Funcons/Core/Computations/ControlFlow/Normal/Sequencing/LeftToRight.hs view
@@ -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
+ cbs/Funcons/Core/Computations/ControlFlow/Normal/Sequencing/Sequential.hs view
@@ -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
+ cbs/Funcons/Core/Computations/DataFlow/Binding/Accumulate.hs view
@@ -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
+ cbs/Funcons/Core/Computations/DataFlow/Binding/Bind.hs view
@@ -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
+ cbs/Funcons/Core/Computations/DataFlow/Binding/Bound.hs view
@@ -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")
+ cbs/Funcons/Core/Computations/DataFlow/Binding/Environment.hs view
@@ -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+    []
+ cbs/Funcons/Core/Computations/DataFlow/Binding/Environments.hs view
@@ -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" []
+ cbs/Funcons/Core/Computations/DataFlow/Binding/Recursion/BindRecursively.hs view
@@ -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"
+ cbs/Funcons/Core/Computations/DataFlow/Binding/Recursion/BoundRecursively.hs view
@@ -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
+ cbs/Funcons/Core/Computations/DataFlow/Binding/Recursion/Recursive.hs view
@@ -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"
+ cbs/Funcons/Core/Computations/DataFlow/Binding/Scope.hs view
@@ -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"
+ cbs/Funcons/Core/Computations/DataFlow/Effect.hs view
@@ -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 [])
+ cbs/Funcons/Core/Computations/DataFlow/Generating/AtomGenerator.hs view
@@ -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+    []
+ cbs/Funcons/Core/Computations/DataFlow/Generating/FreshAtom.hs view
@@ -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
+ cbs/Funcons/Core/Computations/DataFlow/Generating/FreshBinder.hs view
@@ -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"]))
+ cbs/Funcons/Core/Computations/DataFlow/Giving/Give.hs view
@@ -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"
+ cbs/Funcons/Core/Computations/DataFlow/Giving/Given.hs view
@@ -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)]))
+ cbs/Funcons/Core/Computations/DataFlow/Giving/GivenValue.hs view
@@ -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+    []
+ cbs/Funcons/Core/Computations/DataFlow/Interacting/Print.hs view
@@ -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 [])
+ cbs/Funcons/Core/Computations/DataFlow/Interacting/PrintList.hs view
@@ -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 [])
+ cbs/Funcons/Core/Computations/DataFlow/Interacting/Read.hs view
@@ -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
+ cbs/Funcons/Core/Computations/DataFlow/Interacting/StandardIn.hs view
@@ -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+    []
+ cbs/Funcons/Core/Computations/DataFlow/Interacting/StandardOut.hs view
@@ -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+    []
+ cbs/Funcons/Core/Computations/DataFlow/Linking/AllocateInitialisedLink.hs view
@@ -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
+ cbs/Funcons/Core/Computations/DataFlow/Linking/AllocateLink.hs view
@@ -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
+ cbs/Funcons/Core/Computations/DataFlow/Linking/FollowIfLink.hs view
@@ -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
+ cbs/Funcons/Core/Computations/DataFlow/Linking/FollowLink.hs view
@@ -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")
+ cbs/Funcons/Core/Computations/DataFlow/Linking/LinkStore.hs view
@@ -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+    []
+ cbs/Funcons/Core/Computations/DataFlow/Linking/LinkStores.hs view
@@ -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"]))
+ cbs/Funcons/Core/Computations/DataFlow/Linking/Links.hs view
@@ -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
+ cbs/Funcons/Core/Computations/DataFlow/Linking/SetLink.hs view
@@ -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")
+ cbs/Funcons/Core/Computations/DataFlow/Storing/GeneralVariables/AllocateMap.hs view
@@ -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
+ cbs/Funcons/Core/Computations/DataFlow/Storing/GeneralVariables/AllocateVector.hs view
@@ -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
+ cbs/Funcons/Core/Computations/DataFlow/Storing/GeneralVariables/GeneralAssign.hs view
@@ -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
+ cbs/Funcons/Core/Computations/DataFlow/Storing/GeneralVariables/GeneralAssigned.hs view
@@ -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
+ cbs/Funcons/Core/Computations/DataFlow/Storing/SimpleVariables/AllocateInitialisedVariable.hs view
@@ -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
+ cbs/Funcons/Core/Computations/DataFlow/Storing/SimpleVariables/AllocateVariable.hs view
@@ -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
+ cbs/Funcons/Core/Computations/DataFlow/Storing/SimpleVariables/Assign.hs view
@@ -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")
+ cbs/Funcons/Core/Computations/DataFlow/Storing/SimpleVariables/Assigned.hs view
@@ -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")
+ cbs/Funcons/Core/Computations/DataFlow/Storing/SimpleVariables/CurrentValue.hs view
@@ -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
+ cbs/Funcons/Core/Computations/DataFlow/Storing/SimpleVariables/DeallocateVariable.hs view
@@ -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")
+ cbs/Funcons/Core/Computations/DataFlow/Storing/Store.hs view
@@ -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+    []
+ cbs/Funcons/Core/Computations/DataFlow/Storing/Stores.hs view
@@ -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" []
+ cbs/Funcons/Core/Computations/DataFlow/Storing/Variables.hs view
@@ -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
+ cbs/Funcons/Core/Computations/Sorts.hs view
@@ -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")
+ cbs/Funcons/Core/Library.hs view
@@ -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+    ]
+ cbs/Funcons/Core/Values/CompositeValues/AlgebraicDatatypeValues/Records.hs view
@@ -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
+ cbs/Funcons/Core/Values/CompositeValues/AlgebraicDatatypeValues/References.hs view
@@ -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
+ cbs/Funcons/Core/Values/CompositeValues/AlgebraicDatatypeValues/Variants.hs view
@@ -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
+ cbs/Funcons/Core/Values/CompositeValues/Collections/DirectedGraphs.hs view
@@ -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
+ cbs/Funcons/Core/Values/CompositeValues/Collections/Tuples.hs view
@@ -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
+ cbs/Funcons/Core/Values/PrimitiveValues/Bits.hs view
@@ -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
+ cbs/Funcons/Core/Values/PrimitiveValues/Booleans.hs view
@@ -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" []
+ cbs/Funcons/Core/Values/PrimitiveValues/Numbers/IeeeFloats.hs view
@@ -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" []
+ cbs/Funcons/Core/Values/PrimitiveValues/Numbers/Integers.hs view
@@ -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
+ cbs/Funcons/Core/Values/PrimitiveValues/Numbers/Rationals.hs view
@@ -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
+ cbs/Funcons/Core/Values/PrimitiveValues/Strings.hs view
@@ -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")])]))
+ cbs/Funcons/Core/Values/PrimitiveValues/UnicodeCharacters.hs view
@@ -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
+ cbs/Funcons/Core/Values/PrimitiveValues/UnitType.hs view
@@ -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" []
+ cbs/Funcons/Core/Values/Types.hs view
@@ -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")
+ funcons-tools.cabal view
@@ -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: <http://plancomps.org>.+    Read more about funcons and their specification in CBS here: <http://plancomps.dreamhosters.com/taosd2015/ TAOSD2015>.+    .+    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 <ltvanbinsbergen@acm.org>+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
+ manual/Funcons/Core/Abstractions/Force.hs view
@@ -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"+
+ manual/Funcons/Core/Abstractions/Thunk.hs view
@@ -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"
+ manual/Funcons/Core/Computations/DataFlow/Generating/AtomSeed.hs view
@@ -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")))) ]+
+ manual/Funcons/Core/Computations/DataFlow/Generating/NextAtom.hs view
@@ -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"
+ manual/Funcons/Core/Manual.hs view
@@ -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+    ]
+ manual/Funcons/Core/Values/Composite/AlgebraicDatatypeValues/AlgebraicDatatypes.hs view
@@ -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"++
+ manual/Funcons/Core/Values/Composite/Collections/Lists.hs view
@@ -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
+ manual/Funcons/Core/Values/Composite/Collections/Maps.hs view
@@ -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"
+ manual/Funcons/Core/Values/Composite/Collections/Multisets.hs view
@@ -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"
+ manual/Funcons/Core/Values/Composite/Collections/Sets.hs view
@@ -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"+
+ manual/Funcons/Core/Values/Composite/Collections/TuplesBuiltin.hs view
@@ -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"
+ manual/Funcons/Core/Values/Composite/Collections/Vectors.hs view
@@ -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"
+ manual/Funcons/Core/Values/Primitive/Atoms.hs view
@@ -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"
+ manual/Funcons/Core/Values/Primitive/BitsBuiltin.hs view
@@ -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)"
+ manual/Funcons/Core/Values/Primitive/BoolBuiltin.hs view
@@ -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" []+
+ manual/Funcons/Core/Values/Primitive/Characters.hs view
@@ -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)"+
+ manual/Funcons/Core/Values/Primitive/Numbers/IeeeFloatsBuiltin.hs view
@@ -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"++
+ manual/Funcons/Core/Values/Primitive/Numbers/Integers.hs view
@@ -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)"+
+ manual/Funcons/Core/Values/Primitive/Numbers/RationalsBuiltin.hs view
@@ -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++
+ manual/Funcons/Core/Values/Primitive/StringsBuiltin.hs view
@@ -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))+
+ src/Funcons/Core.hs view
@@ -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)++
+ src/Funcons/EDSL.hs view
@@ -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 +-- <http://plancomps.dreamhosters.com/taosd2015/ TAOSD2015>The functions can be +-- used for manual development of funcons, although this is not recommended.
+ src/Funcons/Entities.hs view
@@ -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)
+ src/Funcons/Exceptions.hs view
@@ -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++
+ src/Funcons/Lexer.hs view
@@ -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
+ src/Funcons/MSOS.hs view
@@ -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 _ _) = "<step>"++-- | 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')+++
+ src/Funcons/Parser.hs view
@@ -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
+ src/Funcons/Patterns.hs view
@@ -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") +
+ src/Funcons/Printer.hs view
@@ -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)+
+ src/Funcons/RunOptions.hs view
@@ -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
+ src/Funcons/Simulation.hs view
@@ -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 ()+-----------+
+ src/Funcons/Substitution.hs view
@@ -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+++
+ src/Funcons/Tools.hs view
@@ -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+--  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)@, @&#x7b;1,2,3&#x7d;@,+--          and @&#x7b;1 |-> true, 2 |-> false, 3 |-> true &#x7d;@ 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 \<string\>: by default mutable entities are not displayed+--            this option is used to display one or more mutable entities.+--+--      * --hide-output-entity \<string\>:+--            by default output entities are displayed when output is available.+--            this option is used to hide one or more output entities.+--+--      * --hide-control-entity \<string\>:+--            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 \<string\>:+--            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 \<natural\>:+--          perform a maximum of `n` transitive steps, useful for debugging.+--+-- (4) __Boolean options__ (/true/, /false/ or no argument (/true/ by default)):+--+--      * --refocus \<bool\>: use refocusing, only valid under certain conditions.+--    +--      * --full-environments \<bool\>: when printing funcons, display environments +--              using map-notation, by default an environment is printed as "...".+--    +--      * --hide-result \<bool\>: do not show the resulting funcon term.+--    +--      * --display-steps \<bool\>: show meta-information about the interpretation, +--              e.g. the number of steps, rewrites and restarts. +--    +--      * --no-abrupt-termination \<bool\>: disable abrupt termination (affects uncaught control signals).+--    +--      * --interactive-mode \<bool\>: 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 \<bool\>: by default input is parsed into a 'Values'.+--            This option tells the interpreter to yield the given string as input.+--    +--      * --format-string-outputs \<bool\>: 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 \<bool\>: do not execute tests (by default tests are executed if specified in a configuration file).+--    +--      * --show-output-only \<bool\>: print only output (omits all other information).+--    +--      * --auto-config \<bool\>: 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:+--+-- > <group> {+-- >    <keyvalue>*+-- > }+-- +--  A \<keyvalue\> 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.+++
+ src/Funcons/Types.hs view
@@ -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
+ src/Main.hs view
@@ -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++