funcons-values 0.1.0.2 → 0.1.0.3
raw patch · 11 files changed
+168/−166 lines, 11 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- Funcons.Operations: DefinedValues :: Types t
- Funcons.Operations: Maps :: (Types t) -> (Types t) -> Types t
- Funcons.Operations: Multisets :: (Types t) -> Types t
- Funcons.Operations: Nothings :: Types t
- Funcons.Operations: Sets :: (Types t) -> Types t
- Funcons.Operations: Vectors :: (Types t) -> Types t
- Funcons.Operations: defined_values :: HasValues t => OpExpr t
- Funcons.Operations: defined_values_ :: HasValues t => [OpExpr t] -> OpExpr t
- Funcons.Operations: isGround :: HasValues t => Values t -> Bool
- Funcons.Operations: isNoValue :: Values t -> Bool
- Funcons.Operations: map_override :: (HasValues t, Ord t) => OpExpr t -> OpExpr t -> OpExpr t
- Funcons.Operations: map_points :: (Ord t, HasValues t) => OpExpr t -> OpExpr t
- Funcons.Operations: map_points_ :: (Ord t, HasValues t) => [OpExpr t] -> OpExpr t
- Funcons.Operations: mkPairs :: [a] -> [(a, a)]
- Funcons.Operations: nothing :: HasValues t => OpExpr t
- Funcons.Operations: nothing_ :: HasValues t => [OpExpr t] -> OpExpr t
- Funcons.Operations: showArgs :: (HasValues t, Show t) => [OpExpr t] -> String
- Funcons.Operations: unInt :: () => Values t -> Integer
+ Funcons.Operations: NullType :: Types t
+ Funcons.Operations: isNull :: Values t -> Bool
+ Funcons.Operations: libAppWith :: (HasValues t, Ord t) => Library t -> OP -> [OpExpr t] -> Maybe (OpExpr t)
+ Funcons.Operations: libFromList :: [(OP, ValueOp t)] -> Library t
+ Funcons.Operations: libUnite :: [Library t] -> Library t
+ Funcons.Operations: multisets :: HasValues t => Types t -> Types t
+ Funcons.Operations: null :: HasValues t => OpExpr t
+ Funcons.Operations: null_ :: HasValues t => [OpExpr t] -> OpExpr t
+ Funcons.Operations: null__ :: Values t
+ Funcons.Operations: null_value__ :: Values t
+ Funcons.Operations: nulltype :: HasValues t => OpExpr t
+ Funcons.Operations: nulltype_ :: HasValues t => [OpExpr t] -> OpExpr t
+ Funcons.Operations: toMap :: () => Values t -> ValueMaps Values t
+ Funcons.Operations: tupleHeadOp :: HasValues t => OpExpr t -> OpExpr t
+ Funcons.Operations: tupleTailOp :: HasValues t => OpExpr t -> OpExpr t
+ Funcons.Operations: tuple_head_ :: HasValues t => [OpExpr t] -> OpExpr t
+ Funcons.Operations: tuple_is_empty :: HasValues t => OpExpr t -> OpExpr t
+ Funcons.Operations: tuple_is_empty_ :: HasValues t => [OpExpr t] -> OpExpr t
+ Funcons.Operations: tuple_tail_ :: HasValues t => [OpExpr t] -> OpExpr t
+ Funcons.Operations: vectors :: HasValues t => Types t -> Types t
- Funcons.Operations: isInt :: Values t -> Bool
+ Funcons.Operations: isInt :: () => Values t -> Bool
- Funcons.Operations: maps :: HasValues t => OpExpr t -> OpExpr t -> OpExpr t
+ Funcons.Operations: maps :: HasValues t => t -> t -> Types t
- Funcons.Operations: none__ :: Values t
+ Funcons.Operations: none__ :: () => Values t
- Funcons.Operations: sets :: HasValues t => OpExpr t -> OpExpr t
+ Funcons.Operations: sets :: HasValues t => Types t -> Types t
- Funcons.Operations: structTSMcompare :: (Monoid m, HasValues b2, HasValues b1) => (b1 -> b2 -> Maybe m) -> ([b1] -> [b2] -> Maybe m) -> TaggedSyntax b1 -> TaggedSyntax b2 -> Maybe Maybe m
+ Funcons.Operations: structTSMcompare :: (HasValues b1, HasValues b2, Monoid m) => b1 -> b2 -> Maybe m -> [b1] -> [b2] -> Maybe m -> TaggedSyntax b1 -> TaggedSyntax b2 -> Maybe Maybe m
- Funcons.Operations: traverseCTM :: (HasValues b, HasValues a, Monad m, Ord b) => (a -> m b) -> ([a] -> m [b]) -> ComputationTypes a -> m ComputationTypes b
+ Funcons.Operations: traverseCTM :: (Ord b, Monad m, HasValues a, HasValues b) => a -> m b -> [a] -> m [b] -> ComputationTypes a -> m ComputationTypes b
- Funcons.Operations: traverseTSM :: (HasValues b, HasValues a, Monad m, Ord b) => (a -> m b) -> ([a] -> m [b]) -> TaggedSyntax a -> m TaggedSyntax b
+ Funcons.Operations: traverseTSM :: (Ord b, Monad m, HasValues a, HasValues b) => a -> m b -> [a] -> m [b] -> TaggedSyntax a -> m TaggedSyntax b
- Funcons.Operations: type ValueMaps t = Map t t
+ Funcons.Operations: type ValueMaps t = Map t [t]
Files
- funcons-values.cabal +12/−7
- src/Funcons/Operations.hs +9/−5
- src/Funcons/Operations/ADTs.hs +2/−5
- src/Funcons/Operations/Integers.hs +6/−3
- src/Funcons/Operations/Maps.hs +36/−35
- src/Funcons/Operations/Optionals.hs +2/−0
- src/Funcons/Operations/Sets.hs +10/−8
- src/Funcons/Operations/Strings.hs +1/−1
- src/Funcons/Operations/Tuples.hs +24/−0
- src/Funcons/Operations/Types.hs +22/−26
- src/Funcons/Operations/Values.hs +44/−76
funcons-values.cabal view
@@ -2,9 +2,15 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: funcons-values-version: 0.1.0.2-synopsis: Library providing values and operations on values.--- description:+version: 0.1.0.3+synopsis: Library providing values and operations on values in a fixed universe.+description: + The PLanCompS project (<http://plancomps.org>) 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/.+ .+ This package provides a fixed universe types, values and operations which are lifted to funcons as part of the /funcons-tools/ package (<http://hackage.haskell.org/package/funcons-tools>).+ . homepage: http://plancomps.org license: MIT license-file: LICENSE@@ -34,9 +40,9 @@ ,Funcons.Operations.Lists ,Funcons.Operations.Tuples ,Funcons.Operations.NonGroundValues- ,Funcons.Operations.Multisets - ,Funcons.Operations.Sets - ,Funcons.Operations.Bits + ,Funcons.Operations.Multisets+ ,Funcons.Operations.Sets+ ,Funcons.Operations.Bits ,Funcons.Operations.Characters ,Funcons.Operations.Maps ,Funcons.Operations.Internal@@ -51,4 +57,3 @@ hs-source-dirs: src default-language: Haskell2010 ghc-options: -fwarn-incomplete-patterns -fwarn-monomorphism-restriction -fwarn-unused-imports-
src/Funcons/Operations.hs view
@@ -20,7 +20,7 @@ module Funcons.Operations.Bits, module Funcons.Operations.Characters, module Funcons.Operations.Maps,- libApp, Funcons.Operations.library, Library+ libApp, libAppWith, libFromList, libUnite, Funcons.Operations.library, Library ) where import Funcons.Operations.Expr @@ -49,13 +49,13 @@ import qualified Funcons.Operations.Strings (library) --import Funcons.Operations.Rationals hiding (library) --import qualified Funcons.Operations.Rationals (library)-import Funcons.Operations.Sets hiding (library)+import Funcons.Operations.Sets hiding (library, sets) import qualified Funcons.Operations.Sets (library) import qualified Funcons.Operations.Multisets (library) import qualified Funcons.Operations.Bits (library) import Funcons.Operations.Characters hiding (library) import qualified Funcons.Operations.Characters (library)-import Funcons.Operations.Maps hiding (library)+import Funcons.Operations.Maps hiding (library, maps) import qualified Funcons.Operations.Maps (library) import Funcons.Operations.ADTs hiding (library) import qualified Funcons.Operations.ADTs@@ -82,8 +82,11 @@ ] libApp :: (HasValues t, Ord t) => OP -> [OpExpr t] -> Maybe (OpExpr t)-libApp op args = do - valop <- libLookup op Funcons.Operations.library+libApp = libAppWith library++libAppWith :: (HasValues t, Ord t) => Library t -> OP -> [OpExpr t] -> Maybe (OpExpr t)+libAppWith lib op args = do + valop <- libLookup op lib case (args, valop) of ([], NullaryExpr op) -> Just op ([x], UnaryExpr op) -> Just (op x)@@ -91,3 +94,4 @@ ([x,y,z], TernaryExpr op) -> Just (op x y z) (_, NaryExpr op) -> Just (op args) _ -> Nothing+
src/Funcons/Operations/ADTs.hs view
@@ -37,11 +37,8 @@ adt_type_construct_ :: HasValues t => [OpExpr t] -> OpExpr t adt_type_construct_ = vNaryOp "adt-type-construct" op where op (s : vs) - | isString_ s = - if all isType vs - then Normal $ injectT $ ADT (pack (unString s))- (map (injectT . fromJust . castType) vs) - else SortErr "adt-type-construct: last arguments not types" + | isString_ s = Normal $ injectT $ ADT (pack (unString s))+ (map inject vs) op _ = SortErr "adt-construct: first argument not a string" adt_constructor_ :: HasValues t => [OpExpr t] -> OpExpr t
src/Funcons/Operations/Integers.hs view
@@ -49,7 +49,8 @@ stepMod :: HasValues t => OpExpr t -> OpExpr t -> OpExpr t stepMod = vBinaryOp "mod" op where op vx vy | (Int x, Int y)<- (upcastIntegers vx, upcastIntegers vy)- = Normal $ inject $ mk_integers $ x `mod` y+ = if y == 0 then Normal $ inject null__ + else Normal $ inject $ mk_integers $ x `mod` y op _ _ = SortErr "mod not applied to integers" integers_ :: HasValues t => [OpExpr t] -> OpExpr t@@ -94,7 +95,9 @@ integer_divide = vBinaryOp "integer-divide" op where op vx vy | (Int x,Int y) <- (upcastIntegers vx, upcastIntegers vy) = - Normal $ inject $ mk_integers $ fromInteger (x `div` y)+ if y == 0 + then Normal $ inject null__+ else Normal $ inject $ mk_integers $ fromInteger (x `div` y) | otherwise = SortErr "integer-divide not applied to ints" integer_power_ :: HasValues t => [OpExpr t] -> OpExpr t@@ -112,7 +115,7 @@ natural_predecessor :: HasValues t => OpExpr t -> OpExpr t natural_predecessor = vUnaryOp "natural-predecessor" op where op x | Nat n <- upcastNaturals x =- if n == 0 then DomErr "no predecessor of 0"+ if n == 0 then Normal $ inject null__ else Normal $ inject $ Nat (n - 1) | otherwise = SortErr "natural-pred not applied to a natural number"
src/Funcons/Operations/Maps.hs view
@@ -7,6 +7,7 @@ import Funcons.Operations.Sets import qualified Data.Map as M import qualified Data.Set as S +import Data.Maybe (fromJust) library :: (HasValues t, Ord t) => Library t library = libFromList [@@ -18,30 +19,40 @@ , ("lookup", BinaryExpr map_lookup) , ("map-domain", UnaryExpr domain) , ("domain", UnaryExpr domain)+ , ("dom", UnaryExpr domain) , ("map-delete", BinaryExpr map_delete) , ("is-in-domain", BinaryExpr is_in_domain) , ("map-unite", NaryExpr map_unite)- , ("map-override", BinaryExpr map_override)- , ("maps", BinaryExpr maps)+ , ("map-override", NaryExpr map_override_)+ , ("maps", BinaryExpr Funcons.Operations.Maps.maps) , ("map", NaryExpr map_) , ("map-elements", UnaryExpr map_elements)- , ("map-points", UnaryExpr map_points) ] map_ :: (Ord t, HasValues t) => [OpExpr t] -> OpExpr t-map_ = vNaryOp "map" (Normal . inject . Map . M.fromList . mkPairs)--mkPairs :: [a] -> [(a,a)]-mkPairs [] = []-mkPairs [x] = []-mkPairs (x:y:ys) = (x,y) : mkPairs ys-+map_ = vNaryOp "map" op+ where op vs | areBindings, allDistinct = Normal $ inject $ Map $ M.fromListWith const assocs+ | not (areBindings) = SortErr "map not applied to pairs"+ | otherwise = Normal $ inject null__ + where areBindings = all isBinding vs+ where isBinding (ADTVal "tuple" (k:vs))+ | Just _ <- project k+ , Just _ <- mapM project vs = True+ isBinding _ = False+ assocs = map mkBinding vs+ where mkBinding (ADTVal "tuple" (k:vs)) = + (fromJust (project k), map (fromJust . project) vs)+ mkBinding _ = error "assert: map$mkBinding"+ allDistinct = recDistinct (map fst assocs)+ where recDistinct [] = True+ recDistinct (k:ks) = not (k `S.member` (S.fromList ks))+ && recDistinct ks + maps_ :: HasValues t => [OpExpr t] -> OpExpr t-maps_ = binaryOp maps+maps_ = binaryOp Funcons.Operations.Maps.maps maps :: HasValues t => OpExpr t -> OpExpr t -> OpExpr t maps = vBinaryOp "maps" op- where op (ComputationType (Type t1)) (ComputationType (Type t2)) = Normal $ injectT (Maps t1 t2)- op _ _ = SortErr "maps not applied to two types"+ where op t1 t2 = Normal $ injectT (Funcons.Operations.Internal.maps (inject t1) (inject t2)) map_empty_ :: HasValues t => [OpExpr t] -> OpExpr t map_empty_ = nullaryOp map_empty@@ -65,7 +76,7 @@ map_insert :: (HasValues t, Ord t) => OpExpr t -> OpExpr t -> OpExpr t -> OpExpr t map_insert = vTernaryOp "map-insert" op where op xv k v = case xv of - Map m -> Normal $ inject $ Map (M.insert k v m)+ Map m -> Normal $ inject $ Map (M.insert k [v] m) _ -> SortErr "map-insert(M,K,V) not applied to a map (first argument)" map_lookup_ :: (HasValues t, Ord t) => [OpExpr t] -> OpExpr t@@ -74,8 +85,9 @@ map_lookup = vBinaryOp "map-lookup" op where op xv k = case xv of Map m -> case M.lookup k m of - Nothing -> DomErr "key not in domain"- Just v -> Normal $ inject v+ Nothing -> Normal $ inject $ list [] + Just [ADTVal "no-value" []] -> Normal $ inject $ list []+ Just vs -> Normal $ inject $ list vs _ -> SortErr "map-lookup(M,V) not applied to a map and a value" map_delete_ :: (HasValues t, Ord t) => [OpExpr t] -> OpExpr t@@ -98,11 +110,9 @@ op _ = SortErr "domain(M) not applied to a map" map_override_ :: (HasValues t, Ord t) => [OpExpr t] -> OpExpr t-map_override_ = binaryOp map_override-map_override :: (HasValues t, Ord t) => OpExpr t -> OpExpr t -> OpExpr t-map_override = vBinaryOp "map-override" op- where op (Map m1) (Map m2) = Normal $ inject $ Map (M.union m1 m2)- op _ _ = SortErr "map-override(M,M) not applied tOpExpr two maps"+map_override_ = vNaryOp "map-override" op+ where op vs | all isMap vs = Normal $ inject $ Map (M.unions (map toMap vs))+ op _ = SortErr "map-override not applied to maps" map_unite_ :: (HasValues t, Ord t) => [OpExpr t] -> OpExpr t map_unite_ = map_unite @@ -114,13 +124,12 @@ domains = map (M.keysSet) maps in if all (null . uncurry S.intersection) (allDomainPairs domains) then Normal $ inject $ Map $ M.unions maps- else DomErr "union with domain intersection"+ else Normal $ inject null__ | otherwise = SortErr "map-unite(M1,...,Mn) not applied to maps"- where isMap (Map _) = True- isMap _ = False- toMap (Map m) = m- toMap _ = error "map_unite" +toMap (Map m) = m+toMap _ = error "map_unite"+ allDomainPairs :: [a] -> [(a,a)] allDomainPairs (x:xs) = [ (x,y) | y <- xs ] ++ allDomainPairs xs allDomainPairs [] = []@@ -130,13 +139,5 @@ map_elements :: (Ord t, HasValues t) => OpExpr t -> OpExpr t map_elements = vUnaryOp "map-elements" op where op (Map m) = Normal $ inject $ ADTVal "list" (map inject $ M.foldrWithKey combine [] m)- where combine k v ls = k:v:ls+ where combine k vs ls = ADTVal "tuple" (inject k : map inject vs):ls op _ = SortErr "map-elements not applied to a map"--map_points_ :: (Ord t, HasValues t) => [OpExpr t] -> OpExpr t-map_points_ = unaryOp map_points-map_points :: (Ord t, HasValues t) => OpExpr t -> OpExpr t-map_points = vUnaryOp "map-points" op- where op (Map m) = Normal $ inject $ ADTVal "list" (map inject $ M.foldrWithKey combine [] m)- where combine k v ls = ADTVal "tuple" [inject k, inject v]:ls- op _ = SortErr "map-points not applied to a map"
src/Funcons/Operations/Optionals.hs view
@@ -15,6 +15,8 @@ toOpt (Just t) = ADTVal "some" [t] toOpt Nothing = none__ +none__ = ADTVal "none" []+ optionals_ :: HasValues t => [OpExpr t] -> OpExpr t optionals_ = unaryOp optionals optionals :: HasValues t => OpExpr t -> OpExpr t
src/Funcons/Operations/Sets.hs view
@@ -13,7 +13,7 @@ library :: (HasValues t, Ord t) => Library t library = libFromList [ ("set-empty", NullaryExpr set_empty)- , ("sets", UnaryExpr sets) + , ("sets", UnaryExpr Funcons.Operations.Sets.sets) , ("is-in-set", BinaryExpr is_in_set) , ("set", NaryExpr set_) , ("set-elements", UnaryExpr set_elements)@@ -29,10 +29,11 @@ ] sets_ :: HasValues t => [OpExpr t] -> OpExpr t-sets_ = unaryOp sets+sets_ = unaryOp Funcons.Operations.Sets.sets sets :: HasValues t => OpExpr t -> OpExpr t sets = vUnaryOp "sets" op- where op (ComputationType (Type t)) = Normal $ injectT $ Sets t+ where op (ComputationType (Type t)) = + Normal $ injectT $ Funcons.Operations.Internal.sets t op _ = SortErr "sets not applied to a type" set_empty_ :: HasValues t => [OpExpr t] -> OpExpr t@@ -87,7 +88,8 @@ some_element :: (HasValues t, Ord t) => OpExpr t -> OpExpr t some_element = vUnaryOp "some-element" op where op (Set s) | not (S.null s) = Normal $ inject $ S.findMax s- op _ = SortErr "some-element not applied to a non-empty set"+ | otherwise = Normal $ inject null__+ op _ = SortErr "some-element not applied to a set" is_subset_ :: (Ord t, HasValues t) => [OpExpr t] -> OpExpr t is_subset_ = binaryOp is_subset@@ -121,9 +123,9 @@ element_not_in :: (Ord t, HasValues t) => OpExpr t -> OpExpr t -> OpExpr t element_not_in = vBinaryOp "element-not-in" op where op (ComputationType (Type ty)) (Set set) = case ty of - Atoms -> Normal $ inject $ Atom (unsafePerformIO (getRnd >>= nextAtom))+ Atoms -> Normal $ inject $ head atoms _ -> error "missing case for `element-not-in`"- where nextAtom s | Atom s `S.member` set = getRnd >>= nextAtom- | otherwise = return s - getRnd = randomString' randomASCII 1 1 5+ where getRnd = randomString' randomASCII 1 1 5+ atoms = dropWhile (flip S.member set) $ + map (Atom . ("@" ++) . show) [1..] op _ _ = SortErr "element-not-in not applied to a type and a set"
src/Funcons/Operations/Strings.hs view
@@ -33,7 +33,7 @@ stepTo_String (IEEE_Float_64 d) = mk_string (show d) stepTo_String (ADTVal "true" []) = mk_string "true" stepTo_String (ADTVal "false"[]) = mk_string "false"-stepTo_String (ADTVal "none"[]) = mk_string "none"+stepTo_String (ADTVal "null"[]) = mk_string "null" stepTo_String v | isString_ v = mk_string (unString v) stepTo_String v = DomErr ("to-string undefined on this type")
src/Funcons/Operations/Tuples.hs view
@@ -3,6 +3,7 @@ module Funcons.Operations.Tuples where import Funcons.Operations.Internal+import Funcons.Operations.Booleans library :: HasValues t => Library t library = libFromList [@@ -11,11 +12,21 @@ , ("tuple-index", BinaryExpr tuple_index) , ("empty-tuple", NullaryExpr empty_tuple) , ("tuple-prepend", BinaryExpr tuple_prepend)+ , ("is-empty", UnaryExpr tuple_is_empty)+ , ("tuple-head", UnaryExpr tupleHeadOp)+ , ("tuple-tail", UnaryExpr tupleTailOp) ] tuples_ :: HasValues t => [OpExpr t] -> OpExpr t tuples_ = NaryOp "tuples" (Normal . injectT . ADT "tuples") +tuple_is_empty_ :: HasValues t => [OpExpr t] -> OpExpr t+tuple_is_empty_ = unaryOp tuple_is_empty+tuple_is_empty :: HasValues t => OpExpr t -> OpExpr t +tuple_is_empty = vUnaryOp "is-empty" op+ where op (ADTVal "tuple" vs) = Normal $ inject $ tobool (null vs)+ op _ = SortErr "is-empty not applied to a tuple" + empty_tuple_, tuple_prepend_ :: HasValues t => [OpExpr t] -> OpExpr t empty_tuple_ = nullaryOp empty_tuple tuple_prepend_ = binaryOp tuple_prepend@@ -43,3 +54,16 @@ _ -> SortErr "tuple-index not in range" | otherwise = SortErr ("tuple-index not applied to a natural number: " ++ ppValues (const "_") v) op _ _ = SortErr "tuple-index not applied to a tuple"++tuple_head_, tuple_tail_ :: HasValues t => [OpExpr t] -> OpExpr t+tuple_head_ = unaryOp tupleHeadOp+tuple_tail_ = unaryOp tupleTailOp+tupleHeadOp,tupleTailOp :: HasValues t => OpExpr t -> OpExpr t+tupleHeadOp = vUnaryOp "head" op+ where op (ADTVal "tuple" []) = DomErr "tuple-head of empty tuple"+ op (ADTVal "tuple" (x:xs)) = Normal x+ op _ = SortErr "tuple-head not applied to a tuple"+tupleTailOp = vUnaryOp "tail" op+ where op (ADTVal "tuple" []) = DomErr "tupletail of empty tuple"+ op (ADTVal "tuple" (x:xs)) = Normal $ inject (ADTVal "tuple" xs)+ op _ = SortErr "tuple-tail not applied to a tuple"
src/Funcons/Operations/Types.hs view
@@ -3,6 +3,8 @@ module Funcons.Operations.Types where +import Prelude hiding (null)+ import Funcons.Operations.Booleans import Funcons.Operations.Internal import Data.Foldable (toList) @@ -17,8 +19,8 @@ library = libFromList [ ("types", NullaryExpr types) , ("value-types", NullaryExpr value_types)- , ("defined-values", NullaryExpr defined_values)- , ("nothing", NullaryExpr nothing)+-- , ("null-type", NullaryExpr nulltype)+-- , ("null", NullaryExpr null) , ("values", NullaryExpr values) , ("type-member", BinaryExpr type_member) -- , ("is-value", UnaryExpr is_value)@@ -48,15 +50,15 @@ value_types :: HasValues t => OpExpr t value_types = NullaryOp "value-types" (Normal $ injectT Types) -defined_values_ :: HasValues t => [OpExpr t] -> OpExpr t-defined_values_ = nullaryOp defined_values-defined_values :: HasValues t => OpExpr t-defined_values = NullaryOp "defined-values" (Normal $ injectT DefinedValues)+nulltype_ :: HasValues t => [OpExpr t] -> OpExpr t+nulltype_ = nullaryOp nulltype +nulltype :: HasValues t => OpExpr t+nulltype = NullaryOp "null-type" (Normal $ injectT NullType) -nothing_ :: HasValues t => [OpExpr t] -> OpExpr t-nothing_ = nullaryOp nothing -nothing :: HasValues t => OpExpr t-nothing = NullaryOp "nothing" (Normal $ injectT Nothings)+null_ :: HasValues t => [OpExpr t] -> OpExpr t+null_ = nullaryOp null+null :: HasValues t => OpExpr t+null = NullaryOp "null" (Normal $ inject null__) values_ :: HasValues t => [OpExpr t] -> OpExpr t values_ = nullaryOp values@@ -92,13 +94,13 @@ tyOf (IEEE_Float_32 _) = IEEEFloats Binary32 tyOf (IEEE_Float_64 _) = IEEEFloats Binary64 tyOf (Rational _) = Rationals-tyOf (Map m) = Maps Values Values -- TODO find "strongest common type"-tyOf (Set s) | null s = Sets Values- | otherwise = Sets (tyOf (S.findMax s))-tyOf (Multiset s) | null s = Multisets Values- | otherwise = Multisets (tyOf (MS.findMax s)) -tyOf (Vector v) | V.null v = Vectors Values- | otherwise = Vectors (tyOf (v V.! 0))+tyOf (Map m) = maps (injectT Values) (injectT Values) -- TODO find "strongest common type"+tyOf (Set s) | S.null s = sets Values+ | otherwise = sets (tyOf (S.findMax s))+tyOf (Multiset s) | MS.null s = multisets Values+ | otherwise = multisets (tyOf (MS.findMax s)) +tyOf (Vector v) | V.null v = vectors Values+ | otherwise = vectors (tyOf (v V.! 0)) tyOf VAny = Values tyOf (VMeta t) = ASTs @@ -120,9 +122,8 @@ isInType :: HasValues t => Values t -> Types t -> Maybe Bool isInType _ EmptyType = return False-isInType v Values = return True -isInType n Nothings = return (isNoValue n) -isInType v DefinedValues = return (isDefinedVal v)+isInType v Values = return True --(not (isNull v)) +--isInType n NullType = return (isNull n) isInType v GroundValues = return (isGround v) isInType v (ADT "strings" []) = return (isString_ v) isInType (ADTVal "list" vs') (ADT "lists" [ty']) @@ -153,18 +154,13 @@ 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 (Map m) (Maps kt vt) = and <$> sequence [and <$> mapM (flip isInType kt) (M.keys m)- ,and <$> mapM (flip isInType vt) (M.elems m)]-isInType (Multiset ls) (Multisets ty) = and <$> mapM (flip isInType ty) (toList ls) isInType v Naturals | Nat _ <- upcastNaturals v = return True isInType v Rationals | Rational _ <- upcastRationals v = return True -isInType (Set ls) (Sets ty) = and <$> mapM (flip isInType ty) (toList ls) isInType v UnicodeCharacters | Char _ <- upcastUnicode v = return True isInType v (Union ty1 ty2) = (||) <$> isInType v ty1 <*> isInType v ty2 isInType v (Complement ty) = not <$> isInType v ty isInType v (Intersection ty1 ty2) = (&&) <$> isInType v ty1 <*> isInType v ty2-isInType (Vector ls) (Vectors ty) = and <$> mapM (flip isInType ty) (toList ls)---isInType (VMeta _) ASTs = return True -- for meta-programming (see Funcons.MetaProgramming)+isInType (VMeta _) ASTs = return True -- for meta-programming (see Funcons.MetaProgramming) isInType _ _ = return False isInTupleType :: HasValues t => [Values t] -> [Types t] -> Maybe Bool
src/Funcons/Operations/Values.hs view
@@ -25,8 +25,6 @@ -- The type `t` is expected to be a super-type of `Values t`, -- such that there is a projection and injection between `t` and `Values t`, -- (see 'HasValues')--- Values forms a functor over the type `t` and provides a generic way of--- comparing values (see `zipWithT`) for example to realise pattern matching data Values t = ADTVal Name [t] | Ascii Char | Atom String@@ -61,7 +59,7 @@ | TagType (Types t) (Values t) deriving (Eq, Ord, Show, Read) -type ValueMaps t = M.Map t t +type ValueMaps t = M.Map t [t] type ValueSets t = S.Set t type ValueVectors t = V.Vector t @@ -94,24 +92,30 @@ | IEEEFloats IEEEFormats | Integers | Intersection (Types t) (Types t)- | Maps (Types t) (Types t)- | Multisets (Types t) | Naturals- | Nothings+ | NullType | Rationals- | Sets (Types t) | Strings | Types | UnicodeCharacters | Union (Types t) (Types t)- | DefinedValues | Values- | Vectors (Types t) -- extension for meta-programming (see Funcons.MetaProgramming) | ASTs deriving (Ord,Eq,Show,Read) +sets :: HasValues t => Types t -> Types t+sets t = ADT "sets" [injectT t] +multisets :: HasValues t => Types t -> Types t+multisets t = ADT "multisets" [injectT t]++maps :: HasValues t => t -> t -> Types t+maps k v = ADT "maps" [k, v]++vectors :: HasValues t => Types t -> Types t+vectors t = ADT "vectors" [injectT t]+ class HasValues t where project :: t -> Maybe (Values t) inject :: Values t -> t@@ -149,7 +153,7 @@ IEEE_Float_32 f -> IEEE_Float_32 f IEEE_Float_64 f -> IEEE_Float_64 f Int i -> Int i- Map m -> Map $ M.fromList $ map (vmap f *** vmap f) $ M.assocs m+ Map m -> Map $ M.fromList $ map (vmap f *** fmap (vmap f)) $ M.assocs m Set s -> Set $ S.map (vmap f) s Multiset ms -> Multiset $ MS.map (vmap f) ms Nat n -> Nat n@@ -181,9 +185,9 @@ IEEE_Float_64 f -> return $ IEEE_Float_64 f Int i -> return $ Int i Map m -> do - let (keys, vals) = unzip (M.assocs m)+ let (keys, valss) = unzip (M.assocs m) keys' <- map (fromJust . project) <$> fs (map inject keys)- vals' <- map (fromJust . project) <$> fs (map inject vals)+ vals' <- map (map (fromJust . project)) <$> mapM (fs . map inject) valss return (Map $ M.fromList $ zip keys' vals') Set s -> return . Set . S.fromList . map (fromJust . project) =<< fs (map inject $ S.toList s) Multiset ms -> return . Multiset . MS.fromList . map (fromJust . project) =<< fs (map inject $ MS.toList ms)@@ -209,26 +213,21 @@ Characters -> return Characters ComputationTypes -> return ComputationTypes Complement t -> Complement <$> traverseTM f fs t - DefinedValues -> return DefinedValues GroundValues -> return GroundValues IntegersFrom f -> return (IntegersFrom f) IntegersUpTo f -> return (IntegersUpTo f) Intersection t1 t2 -> Intersection <$> traverseTM f fs t1 <*> traverseTM f fs t2- Nothings -> return Nothings+ NullType -> return NullType EmptyType -> return EmptyType IEEEFloats i -> return (IEEEFloats i) Integers -> return Integers- Maps t1 t2 -> Maps <$> traverseTM f fs t1 <*> traverseTM f fs t2- Multisets t -> Multisets <$> traverseTM f fs t Naturals -> return Naturals Rationals -> return Rationals- Sets t -> Sets <$> traverseTM f fs t Strings -> return Strings Types -> return Types UnicodeCharacters -> return UnicodeCharacters Union t1 t2 -> Union <$> traverseTM f fs t1 <*> traverseTM f fs t2 Values -> return Values- Vectors t -> Vectors <$> traverseTM f fs t traverseTSM f fs t = case t of TagName nm vs -> TagName nm <$> traverse (traverseVM f fs) vs@@ -295,13 +294,12 @@ (Int x, Int y) | x == y -> Just (Just mempty) (Int _, _) -> Nothing (_, Int _) -> Nothing- (Map m1, Map m2) -> Just $ liftM2 mappend (comps (map inject (M.keys m1)) - (map inject (M.keys m2)))- (comps (map inject (M.elems m1)) - (map inject (M.elems m2)))+ (Map m1, Map m2) -> Just $ liftM2 mappend (comps' (M.keys m1) (M.keys m2))+ (comps' (map list $ M.elems m1)+ (map list $ M.elems m2)) (Map _, _) -> Nothing (_, Map _) -> Nothing- (Set x, Set y) -> Just $ comps (map inject $ S.toList x) (map inject $ S.toList y) + (Set x, Set y) -> Just $ comps' (S.toList x) (S.toList y) (Set _, _) -> Nothing (_, Set _) -> Nothing (Multiset x, Multiset y) -> Just $ comps (map inject $ MS.toList x) @@ -321,6 +319,7 @@ (VMeta ts, VMeta ts') -> structTSMcompare comp comps ts ts' (VMeta _, _) -> Nothing (_, VMeta _) -> Nothing+ where comps' xs ys = comps (map inject xs) (map inject ys) structTSMcompare comp comps ts ts' = case (ts,ts') of (TagName nm vs, TagName nm' vs') | nm == nm' -> @@ -365,9 +364,6 @@ (ComputationTypes, ComputationTypes)-> Just (Just mempty) (_, ComputationTypes) -> Nothing (ComputationTypes, _) -> Nothing- (DefinedValues, DefinedValues) -> Just (Just mempty)- (_, DefinedValues) -> Nothing- (DefinedValues, _) -> Nothing (GroundValues, GroundValues) -> Just (Just mempty) (GroundValues, _) -> Nothing (_, GroundValues) -> Nothing@@ -383,33 +379,24 @@ (IEEEFloats x, IEEEFloats y) | x ==y-> Just (Just mempty) (IEEEFloats _, _) -> Nothing (_, IEEEFloats _) -> Nothing- (Maps k v, Maps k' v') -> liftM2 mappend (structTMcompare comp comps k k') (structTMcompare comp comps v v')- (Maps _ _, _) -> Nothing- (_, Maps _ _) -> Nothing (Integers, Integers) -> Just (Just mempty) (Integers, _) -> Nothing (_, Integers) -> Nothing (Intersection x y, Intersection x' y') -> liftM2 mappend (structTMcompare comp comps x x') (structTMcompare comp comps y y') (Intersection _ _, _) -> Nothing (_, Intersection _ _) -> Nothing- (Multisets x, Multisets y) -> structTMcompare comp comps x y- (Multisets _, _) -> Nothing- (_, Multisets _) -> Nothing (Naturals, Naturals) -> Just (Just mempty) (_, Naturals) -> Nothing (Naturals, _) -> Nothing- (Nothings, Nothings) -> Just (Just mempty)- (_, Nothings) -> Nothing- (Nothings,_) -> Nothing+ (NullType, NullType) -> Just (Just mempty)+ (_, NullType) -> Nothing+ (NullType,_) -> Nothing (Rationals, Rationals) -> Just (Just mempty) (Rationals, _) -> Nothing (_, Rationals) -> Nothing (Strings, Strings) -> Just (Just mempty) (_, Strings) -> Nothing (Strings, _) -> Nothing- (Sets x, Sets y) -> structTMcompare comp comps x y- (Sets _, _) -> Nothing- (_, Sets _) -> Nothing (Types, Types) -> Just (Just mempty) (_, Types) -> Nothing (Types, _) -> Nothing@@ -420,9 +407,6 @@ (Union _ _, _) -> Nothing (_, Union _ _) -> Nothing (Values, Values) -> Just (Just mempty)- (_, Values) -> Nothing- (Values, _) -> Nothing- (Vectors x, Vectors y) -> structTMcompare comp comps x y instance Functor Types where fmap f t = case t of @@ -435,7 +419,6 @@ Bits n -> Bits n Complement t1 -> Complement (fmap f t1) ComputationTypes -> ComputationTypes- DefinedValues -> DefinedValues GroundValues -> GroundValues IntegersFrom p -> IntegersFrom p IntegersUpTo p -> IntegersUpTo p@@ -444,18 +427,14 @@ IEEEFloats b -> IEEEFloats b Integers -> Integers Intersection t1 t2 -> Intersection (fmap f t1) (fmap f t2)- Maps k v -> Maps (fmap f k) (fmap f v) - Multisets t -> Multisets (fmap f t) Naturals -> Naturals- Nothings -> Nothings+ NullType -> NullType Rationals -> Rationals- Sets t -> Sets (fmap f t) Strings -> Strings Types -> Types UnicodeCharacters -> UnicodeCharacters Union t1 t2 -> Union (fmap f t1) (fmap f t2) Values -> Values - Vectors t -> Vectors (fmap f t) instance Functor ComputationTypes where fmap f t = case t of@@ -475,7 +454,6 @@ Characters -> mempty Complement t1 -> foldMap f t1 ComputationTypes -> mempty- DefinedValues -> mempty GroundValues -> mempty IntegersUpTo q -> mempty IntegersFrom q -> mempty@@ -483,18 +461,14 @@ EmptyType -> mempty IEEEFloats b -> mempty Integers -> mempty- Maps k v -> foldMap f k `mappend` foldMap f v- Multisets t -> foldMap f t Naturals -> mempty - Nothings -> mempty+ NullType -> mempty Rationals -> mempty- Sets t -> foldMap f t Strings -> mempty Types -> mempty UnicodeCharacters -> mempty Union t1 t2 -> foldMap f t1 `mappend` foldMap f t2 Values -> mempty - Vectors t -> foldMap f t instance Traversable Types where traverse f ta = case ta of @@ -508,7 +482,6 @@ Characters -> pure Characters Complement t -> Complement <$> traverse f t ComputationTypes -> pure ComputationTypes- DefinedValues -> pure DefinedValues GroundValues -> pure GroundValues IntegersFrom n -> pure $ IntegersFrom n IntegersUpTo n -> pure $ IntegersUpTo n@@ -516,18 +489,14 @@ IEEEFloats b -> pure $ IEEEFloats b Integers -> pure Integers Intersection t1 t2 -> Intersection <$> traverse f t1 <*> traverse f t2- Maps k v -> Maps <$> traverse f k <*> traverse f v- Multisets t -> Multisets <$> traverse f t Naturals -> pure Naturals- Nothings -> pure Nothings+ NullType -> pure NullType Rationals -> pure Rationals- Sets t -> Sets <$> traverse f t Strings -> pure Strings Types -> pure Types UnicodeCharacters -> pure UnicodeCharacters Union t1 t2 -> Union <$> traverse f t1 <*> traverse f t2 Values -> pure Values - Vectors t -> Vectors <$> traverse f t downcastValueType :: Values t -> Types t downcastValueType (ComputationType (Type t)) = t@@ -601,7 +570,7 @@ isGround (IEEE_Float_32 _) = True isGround (IEEE_Float_64 _) = True isGround (Int _) = True-isGround (Map m) = all isGround (M.elems m)+isGround (Map m) = all (all isGround) (M.elems m) isGround (Multiset ms) = all isGround (MS.elems ms) isGround (Nat _) = True isGround (ComputationType _) = True@@ -640,23 +609,26 @@ | Just vs' <- sequence (map project vs), all isAscii vs' = map (\(Ascii c) -> c) vs' unString _ = error "unString" -none__ :: Values t-none__ = ADTVal "none" []+null__ :: Values t+null__ = ADTVal "null" [] -isNoValue :: Values t -> Bool-isNoValue (ADTVal "none" _) = True-isNoValue _ = False+null_value__ :: Values t+null_value__ = ADTVal "null-value" [] +isNull :: Values t -> Bool+isNull (ADTVal "null" _) = True+isNull _ = False+ isDefinedVal :: Values t -> Bool-isDefinedVal f = not (isNoValue f)+isDefinedVal f = not (isNull f) set_ :: Ord t => [Values t] -> Values t set_ = Set . S.fromList ppValues :: HasValues t => (t -> String) -> Values t -> String ppValues showT v@(ADTVal "list" vs)- | isString_ v = show (unString v)- | otherwise = "[" ++ showArgs_ (map showT vs) ++ "]"+ | isString_ v, not (null vs) = show (unString v)+ | otherwise = "[" ++ showArgs_ (map showT vs) ++ "]" ppValues showT (ADTVal c []) = unpack c ppValues showT (ADTVal c vs) = unpack c ++ showArgs (map showT vs) ppValues showT (Atom c) = "atom("++ c ++")"@@ -673,8 +645,9 @@ ppValues showT (Nat f) = show f ppValues showT (Map m) = if M.null m then "map-empty" else "{" ++ key_values ++ "}"- where key_values = intercalate ", " (map (\(k,v) -> ppValues showT k++" |-> "++ - ppValues showT v)$ M.toList m)+ where key_values = intercalate ", " (map (\(k,v) -> + ppValues showT k++" |-> "++ + showArgs (map (ppValues showT) v)) $ M.toList m) ppValues showT (Multiset s) = "{" ++ showArgs (map (ppValues showT) (MS.toList s)) ++ "}" ppValues showT (Set s) = "{" ++ showArgs (map (ppValues showT) (S.toList s)) ++ "}" ppValues showT (Vector v) = "vector" ++ showArgs (map (ppValues showT) (V.toList v))@@ -696,8 +669,7 @@ ppTypes showT (Complement ty) = "~(" ++ ppTypes showT ty ++ ")" ppTypes showT ComputationTypes = "computation-types" ppTypes showT GroundValues = "ground-values"-ppTypes showT Nothings = "nothing"-ppTypes showT DefinedValues = "defined-values"+ppTypes showT NullType = "null-type" ppTypes showT ASTs = "asts" ppTypes showT Atoms = "atoms" ppTypes showT AsciiCharacters = "ascii-characters"@@ -710,17 +682,13 @@ ppTypes showT (Integers) = "integers" ppTypes showT (Strings) = "strings" ppTypes showT (Values) = "values"-ppTypes showT (Maps x y) = "maps" ++ showArgs [ppTypes showT x, ppTypes showT y] ppTypes showT Types = "types" ppTypes showT ADTs = "algebraic-datatypes" ppTypes showT (ADT nm ts) = unpack nm ++ showArgs (map showT ts) ppTypes showT (Bits n) = "bits(" ++ show n ++ ")" ppTypes showT (IEEEFloats format) = "ieee-floats(" ++ show format ++ ")"-ppTypes showT (Multisets ty) = "multisets" ++ showArgs [ppTypes showT ty] ppTypes showT Naturals = "naturals" ppTypes showT Rationals = "rationals"-ppTypes showT (Sets ty) = "sets(" ++ ppTypes showT ty ++ ")"-ppTypes showT (Vectors ty) = "vectors(" ++ ppTypes showT ty ++ ")" ppTypes showT (Union ty1 ty2) = "(" ++ ppTypes showT ty1 ++ "|" ++ ppTypes showT ty2 ++")" ppOp :: SeqSortOp -> String