diff --git a/funcons-values.cabal b/funcons-values.cabal --- a/funcons-values.cabal +++ b/funcons-values.cabal @@ -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 () 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 (). + . 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 - diff --git a/src/Funcons/Operations.hs b/src/Funcons/Operations.hs --- a/src/Funcons/Operations.hs +++ b/src/Funcons/Operations.hs @@ -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 + diff --git a/src/Funcons/Operations/ADTs.hs b/src/Funcons/Operations/ADTs.hs --- a/src/Funcons/Operations/ADTs.hs +++ b/src/Funcons/Operations/ADTs.hs @@ -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 diff --git a/src/Funcons/Operations/Integers.hs b/src/Funcons/Operations/Integers.hs --- a/src/Funcons/Operations/Integers.hs +++ b/src/Funcons/Operations/Integers.hs @@ -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" diff --git a/src/Funcons/Operations/Maps.hs b/src/Funcons/Operations/Maps.hs --- a/src/Funcons/Operations/Maps.hs +++ b/src/Funcons/Operations/Maps.hs @@ -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" diff --git a/src/Funcons/Operations/Optionals.hs b/src/Funcons/Operations/Optionals.hs --- a/src/Funcons/Operations/Optionals.hs +++ b/src/Funcons/Operations/Optionals.hs @@ -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 diff --git a/src/Funcons/Operations/Sets.hs b/src/Funcons/Operations/Sets.hs --- a/src/Funcons/Operations/Sets.hs +++ b/src/Funcons/Operations/Sets.hs @@ -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" diff --git a/src/Funcons/Operations/Strings.hs b/src/Funcons/Operations/Strings.hs --- a/src/Funcons/Operations/Strings.hs +++ b/src/Funcons/Operations/Strings.hs @@ -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") diff --git a/src/Funcons/Operations/Tuples.hs b/src/Funcons/Operations/Tuples.hs --- a/src/Funcons/Operations/Tuples.hs +++ b/src/Funcons/Operations/Tuples.hs @@ -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" diff --git a/src/Funcons/Operations/Types.hs b/src/Funcons/Operations/Types.hs --- a/src/Funcons/Operations/Types.hs +++ b/src/Funcons/Operations/Types.hs @@ -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 diff --git a/src/Funcons/Operations/Values.hs b/src/Funcons/Operations/Values.hs --- a/src/Funcons/Operations/Values.hs +++ b/src/Funcons/Operations/Values.hs @@ -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