diff --git a/funcons-values.cabal b/funcons-values.cabal --- a/funcons-values.cabal +++ b/funcons-values.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: funcons-values -version: 0.1.0.3 +version: 0.1.0.5 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. @@ -53,7 +53,6 @@ ,bv >=0.5 ,multiset >=0.3 && <0.4 ,text >=1.2 && <1.3 - ,random-strings 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 @@ -25,7 +25,7 @@ import Funcons.Operations.Expr import Funcons.Operations.Libraries -import Funcons.Operations.Values hiding (showArgs, isGround, set_) +import Funcons.Operations.Values hiding (showArgs, set_) import Funcons.Operations.Eval hiding (showArgs) import Funcons.Operations.Atoms hiding (library) import qualified Funcons.Operations.Atoms (library) diff --git a/src/Funcons/Operations/Characters.hs b/src/Funcons/Operations/Characters.hs --- a/src/Funcons/Operations/Characters.hs +++ b/src/Funcons/Operations/Characters.hs @@ -29,8 +29,8 @@ ascii_character_ = unaryOp ascii_character ascii_character :: HasValues t => OpExpr t -> OpExpr t ascii_character = vUnaryOp "ascii-character" op - where op v | isString_ v, s <- unString v, length s == 1 - = Normal $ inject $ Ascii $ head s + where op v | isString_ v, [c] <- unString v + = Normal $ inject $ Ascii c | otherwise = SortErr "ascii-character not applied to a string (of 1 ascii character long)" unicode_ :: 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 @@ -9,13 +9,20 @@ library :: HasValues t => Library t library = libFromList [ ("integers", NullaryExpr integers) + , ("integers-from", UnaryExpr integers_from) + , ("from", UnaryExpr integers_from) + , ("integers-up-to", UnaryExpr integers_up_to) + , ("up-to", UnaryExpr integers_up_to) , ("is-integer", UnaryExpr is_integer) , ("is-int", UnaryExpr is_integer) + , ("int-add", NaryExpr integer_add_) , ("integer-add", NaryExpr integer_add_) + , ("int-sub", BinaryExpr integer_subtract) , ("integer-subtract", BinaryExpr integer_subtract) , ("integer-sub", BinaryExpr integer_subtract) , ("integer-modulo", BinaryExpr stepMod) , ("integer-mod", BinaryExpr stepMod) + , ("int-mod", BinaryExpr stepMod) , ("integer-multiply", NaryExpr integer_multiply_) , ("int-mul", NaryExpr integer_multiply_) , ("integer-divide", BinaryExpr integer_divide) @@ -30,6 +37,7 @@ , ("decimal-natural", UnaryExpr decimal_natural) , ("natural-predecessor", UnaryExpr natural_predecessor) , ("nat-pred", UnaryExpr natural_predecessor) + , ("natural-successor", UnaryExpr natural_successor) , ("nat-successor", UnaryExpr natural_successor) , ("nat-succ", UnaryExpr natural_successor) , ("integer-is-less", BinaryExpr is_less) @@ -57,6 +65,20 @@ integers_ = nullaryOp integers integers :: HasValues t => OpExpr t integers = vNullaryOp "integers" (Normal $ injectT Integers) + +integers_from_ :: HasValues t => [OpExpr t] -> OpExpr t +integers_from_ = unaryOp integers_from +integers_from :: HasValues t => OpExpr t -> OpExpr t +integers_from = vUnaryOp "integers-from" op + where op v | Int i <- upcastIntegers v = Normal $ injectT $ IntegersFrom i + | otherwise = SortErr "integers-from not applied to an integer" + +integers_up_to_ :: HasValues t => [OpExpr t] -> OpExpr t +integers_up_to_ = unaryOp integers_up_to +integers_up_to :: HasValues t => OpExpr t -> OpExpr t +integers_up_to = vUnaryOp "integers-up-to" op + where op v | Int i <- upcastIntegers v = Normal $ injectT $ IntegersUpTo i + | otherwise = SortErr "integers-up-to not applied to an integer" is_integer_ :: HasValues t => [OpExpr t] -> OpExpr t is_integer_ = unaryOp is_integer 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 @@ -33,7 +33,7 @@ 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__ + | otherwise = Normal $ inject null_value__ where areBindings = all isBinding vs where isBinding (ADTVal "tuple" (k:vs)) | Just _ <- project k @@ -84,10 +84,7 @@ map_lookup :: (HasValues t, Ord t) => OpExpr t -> OpExpr t -> OpExpr t map_lookup = vBinaryOp "map-lookup" op where op xv k = case xv of - Map m -> case M.lookup k m of - Nothing -> Normal $ inject $ list [] - Just [ADTVal "no-value" []] -> Normal $ inject $ list [] - Just vs -> Normal $ inject $ list vs + Map m -> Normal $ inject $ multi_ $ maybe [] id $ M.lookup k m _ -> SortErr "map-lookup(M,V) not applied to a map and a value" map_delete_ :: (HasValues t, Ord t) => [OpExpr t] -> OpExpr t @@ -138,6 +135,6 @@ map_elements_ = unaryOp map_elements 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 op (Map m) = Normal $ inject $ multi $ map inject $ M.foldrWithKey combine [] m where combine k vs ls = ADTVal "tuple" (inject k : map inject vs):ls op _ = SortErr "map-elements not applied to a map" 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 @@ -7,7 +7,6 @@ import qualified Data.Set as S -import Test.RandomStrings (randomString', randomASCII) import System.IO.Unsafe (unsafePerformIO) library :: (HasValues t, Ord t) => Library t @@ -55,7 +54,7 @@ set_elements_ = unaryOp set_elements set_elements :: HasValues t => OpExpr t -> OpExpr t set_elements = vUnaryOp "set-elements" op - where op (Set s) = Normal $ inject $ ADTVal "list" (map inject $ S.toList s) + where op (Set s) = Normal $ inject $ multi $map inject $ S.toList s op _ = SortErr "set-elements not applied to a set" set_size_ :: (Ord t, HasValues t) => [OpExpr t] -> OpExpr t @@ -125,7 +124,6 @@ where op (ComputationType (Type ty)) (Set set) = case ty of Atoms -> Normal $ inject $ head atoms _ -> error "missing case for `element-not-in`" - where getRnd = randomString' randomASCII 1 1 5 - atoms = dropWhile (flip S.member set) $ + where 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 @@ -6,6 +6,8 @@ import Funcons.Operations.Internal import Funcons.Operations.Types +import Data.String + library :: HasValues t => Library t library = libFromList [ ("is-string", UnaryExpr is_string) @@ -15,16 +17,17 @@ is_string_ :: HasValues t => [OpExpr t] -> OpExpr t is_string_ = unaryOp is_string -is_string x = RewritesTo "is-string" (type_member x (ValExpr (ComputationType (Type Strings)))) [x] +is_string x = RewritesTo "is-string" (type_member x (ValExpr (ComputationType (Type (ADT "strings" []))))) [x] to_string_ :: HasValues t => [OpExpr t] -> OpExpr t to_string_ = unaryOp to_string to_string :: HasValues t => OpExpr t -> OpExpr t to_string = vUnaryOp "to-string" stepTo_String -stepTo_String s | isString_ s = Normal $ inject $ s +stepTo_String s | isString_ s = Normal $ inject $ s stepTo_String (Rational r) = mk_string (show (fromRational r)) stepTo_String (Ascii c) = mk_string ([c]) +stepTo_String (Char c) = mk_string ([c]) stepTo_String (Atom s) = mk_string s stepTo_String (Int i) = mk_string (show i) stepTo_String (Nat n) = mk_string (show n) @@ -34,8 +37,7 @@ stepTo_String (ADTVal "true" []) = mk_string "true" stepTo_String (ADTVal "false"[]) = mk_string "false" 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") mk_string :: HasValues t => String -> Result t -mk_string = Normal . inject . ADTVal "list" . map (inject . Ascii) +mk_string = Normal . inject . fromString 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 @@ -19,6 +19,7 @@ library = libFromList [ ("types", NullaryExpr types) , ("value-types", NullaryExpr value_types) + , ("empty-type", NullaryExpr empty_type) -- , ("null-type", NullaryExpr nulltype) -- , ("null", NullaryExpr null) , ("values", NullaryExpr values) @@ -38,7 +39,7 @@ ground_values_ :: HasValues t => [OpExpr t] -> OpExpr t ground_values_ = nullaryOp ground_values ground_values :: HasValues t => OpExpr t -ground_values = vNullaryOp "ground-values" (Normal $ injectT GroundValues) +ground_values = vNullaryOp "ground-values" (Normal $ injectT (ADT "ground-values" [])) types_ :: HasValues t => [OpExpr t] -> OpExpr t types_ = nullaryOp types @@ -46,10 +47,15 @@ types = NullaryOp "types" (Normal $ injectT Types) value_types_ :: HasValues t => [OpExpr t] -> OpExpr t -value_types_ = nullaryOp types +value_types_ = nullaryOp value_types value_types :: HasValues t => OpExpr t value_types = NullaryOp "value-types" (Normal $ injectT Types) +empty_type_ :: HasValues t => [OpExpr t] -> OpExpr t +empty_type_ = nullaryOp empty_type +empty_type :: HasValues t => OpExpr t +empty_type = NullaryOp "empty-types" (Normal $ injectT EmptyType) + nulltype_ :: HasValues t => [OpExpr t] -> OpExpr t nulltype_ = nullaryOp nulltype nulltype :: HasValues t => OpExpr t @@ -102,7 +108,7 @@ tyOf (Vector v) | V.null v = vectors Values | otherwise = vectors (tyOf (v V.! 0)) tyOf VAny = Values -tyOf (VMeta t) = ASTs +tyOf (ValSeq ts) = Values type_member_ :: HasValues t => [OpExpr t] -> OpExpr t type_member_ = binaryOp type_member @@ -123,25 +129,20 @@ isInType :: HasValues t => Values t -> Types t -> Maybe Bool isInType _ EmptyType = return False isInType v Values = return True --(not (isNull v)) ---isInType n NullType = return (isNull n) -isInType v GroundValues = return (isGround v) +isInType n NullType = return (isNull n) +isInType v (ADT "ground-values" []) = return (isGround v) isInType v (ADT "strings" []) = return (isString_ v) isInType (ADTVal "list" vs') (ADT "lists" [ty']) | Just ty <- projectT ty', Just vs <- sequence (map project vs') = and <$> mapM (flip isInType ty) vs -isInType (ADTVal "true" []) (ADT "booleans" []) = return True -isInType (ADTVal "false" []) (ADT "booleans" []) = return True -isInType v (ADT "tuples" ttparams') - | Just ttparams <- sequence (map projectT ttparams') = case v of - ADTVal "tuple" vs' | Just vs <- sequence (map project vs') - -> isInTupleType vs ttparams - _ -> isInTupleType [v] ttparams + isInType v (ADT nm tys) = Nothing isInType (ADTVal _ _) ADTs = return True isInType (Atom _) Atoms = return True isInType (Ascii _) Characters = return True isInType (Char _) Characters = return True isInType (Ascii _) AsciiCharacters = return True +isInType (Char _) AsciiCharacters = return True isInType (Bit bv) (Bits n) = return (BV.size bv == n) isInType v (IntegersFrom n) | Int i <- upcastIntegers v = return (i >= n) @@ -160,7 +161,6 @@ 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 (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 @@ -41,9 +41,9 @@ | Rational Rational | Set (ValueSets (Values t)) | Vector (ValueVectors (Values t)) - | VMeta (TaggedSyntax t) | VAny -- used whenever funcon terms may have holes in them -- currently only the case in "downwards" flowing signals + | ValSeq [t] -- represents a multitude of values deriving (Eq,Ord,Show,Read) tuple :: HasValues t => [Values t] -> Values t @@ -52,13 +52,18 @@ list :: HasValues t => [Values t] -> Values t list = ADTVal "list" . map inject -instance HasValues t => IsString (Values t) where - fromString = ADTVal "list" . map (inject . Ascii) +vector :: HasValues t => [Values t] -> Values t +vector = ADTVal "vector" . map inject -data TaggedSyntax t = TagName Name [Values t] - | TagType (Types t) (Values t) - deriving (Eq, Ord, Show, Read) +multi :: HasValues t => [t] -> Values t +multi = ValSeq +multi_ :: HasValues t => [Values t] -> Values t +multi_ = multi . map inject + +instance HasValues t => IsString (Values t) where + fromString = ADTVal "list" . map (inject . Char) + type ValueMaps t = M.Map t [t] type ValueSets t = S.Set t type ValueVectors t = V.Vector t @@ -88,20 +93,16 @@ | Complement (Types t) | ComputationTypes | EmptyType - | GroundValues | IEEEFloats IEEEFormats | Integers | Intersection (Types t) (Types t) | Naturals | NullType | Rationals - | Strings | Types | UnicodeCharacters | Union (Types t) (Types t) | Values - -- extension for meta-programming (see Funcons.MetaProgramming) - | ASTs deriving (Ord,Eq,Show,Read) sets :: HasValues t => Types t -> Types t @@ -159,14 +160,10 @@ Nat n -> Nat n Rational r -> Rational r Vector v -> Vector $ V.map (vmap f) v - VMeta ts -> VMeta $ vmapTS f ts - VAny -> VAny + VAny -> VAny + ValSeq ts -> ValSeq (map f ts) -vmapTS :: (Ord b) => (a -> b) -> TaggedSyntax a -> TaggedSyntax b -vmapTS f ts = case ts of - TagName nm vs -> TagName nm (map (vmap f) vs) - TagType t v -> TagType (fmap f t) (vmap f v) - + traverseV :: (Ord b, Monad m, HasValues a, HasValues b) => (a -> m b) -> Values a -> m (Values b) traverseV f = traverseVM f (mapM f) @@ -194,8 +191,8 @@ Nat n -> return $ Nat n Rational r -> return $ Rational r Vector v -> return . Vector . V.fromList . map (fromJust . project) =<< fs (map inject $ V.toList v) - VMeta ts -> VMeta <$> traverseTSM f fs ts VAny -> return VAny + ValSeq ts -> ValSeq <$> fs ts traverseT :: (Ord b, Monad m, HasValues a, HasValues b) => (a -> m b) -> Types a -> m (Types b) @@ -208,12 +205,10 @@ AsciiCharacters -> return AsciiCharacters Atoms -> return Atoms AnnotatedType ty op -> AnnotatedType <$> traverseTM f fs ty <*> return op - ASTs -> return ASTs Bits i -> return (Bits i) Characters -> return Characters ComputationTypes -> return ComputationTypes Complement t -> Complement <$> traverseTM f fs t - 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 @@ -223,16 +218,11 @@ Integers -> return Integers Naturals -> return Naturals Rationals -> return Rationals - Strings -> return Strings Types -> return Types UnicodeCharacters -> return UnicodeCharacters Union t1 t2 -> Union <$> traverseTM f fs t1 <*> traverseTM f fs t2 Values -> return Values -traverseTSM f fs t = case t of - TagName nm vs -> TagName nm <$> traverse (traverseVM f fs) vs - TagType ty v -> TagType <$> traverseTM f fs ty <*> traverseVM f fs v - traverseCTM f fs t = case t of Type t -> Type <$> traverseTM f fs t ComputesType t -> ComputesType <$> traverseTM f fs t @@ -316,20 +306,11 @@ (VAny, VAny) -> Just (Just mempty) (_, VAny) -> Nothing (VAny, _) -> Nothing - (VMeta ts, VMeta ts') -> structTSMcompare comp comps ts ts' - (VMeta _, _) -> Nothing - (_, VMeta _) -> Nothing + (ValSeq ts, ValSeq ts') -> Just (comps ts ts') + (ValSeq _, _) -> Nothing + (_, ValSeq _) -> 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' -> - Just $ comps (map inject vs) (map inject vs') - (TagName _ _, _) -> Nothing - (_, TagName _ _) -> Nothing - (TagType ty v, TagType ty' v') -> - liftM2 (liftM2 mappend) (structTMcompare comp comps ty ty') - (structVMcompare comp comps v v') - structTMcompare :: (Monoid m, HasValues a, HasValues b) => (a -> b -> Maybe m) -> ([a] -> [b] -> Maybe m) -> Types a -> Types b -> Maybe (Maybe m) @@ -346,9 +327,6 @@ (AsciiCharacters, AsciiCharacters) -> Just (Just mempty) (AsciiCharacters, _) -> Nothing (_, AsciiCharacters) -> Nothing - (ASTs, ASTs) -> Just (Just mempty) - (_, ASTs) -> Nothing - (ASTs, _) -> Nothing (AnnotatedType t1 op1, AnnotatedType t2 op2) | op1 == op2 -> structTMcompare comp comps t1 t2 (AnnotatedType _ _, _) -> Nothing (_, AnnotatedType _ _) -> Nothing @@ -364,9 +342,6 @@ (ComputationTypes, ComputationTypes)-> Just (Just mempty) (_, ComputationTypes) -> Nothing (ComputationTypes, _) -> Nothing - (GroundValues, GroundValues) -> Just (Just mempty) - (GroundValues, _) -> Nothing - (_, GroundValues) -> Nothing (IntegersFrom mx, IntegersFrom mx') | mx == mx' -> Just (Just mempty) (IntegersFrom _, _) -> Nothing (_, IntegersFrom _) -> Nothing @@ -394,9 +369,6 @@ (Rationals, Rationals) -> Just (Just mempty) (Rationals, _) -> Nothing (_, Rationals) -> Nothing - (Strings, Strings) -> Just (Just mempty) - (_, Strings) -> Nothing - (Strings, _) -> Nothing (Types, Types) -> Just (Just mempty) (_, Types) -> Nothing (Types, _) -> Nothing @@ -415,11 +387,9 @@ AsciiCharacters -> AsciiCharacters Atoms -> Atoms AnnotatedType ty op -> AnnotatedType (fmap f ty) op - ASTs -> ASTs Bits n -> Bits n Complement t1 -> Complement (fmap f t1) ComputationTypes -> ComputationTypes - GroundValues -> GroundValues IntegersFrom p -> IntegersFrom p IntegersUpTo p -> IntegersUpTo p Characters -> Characters @@ -430,7 +400,6 @@ Naturals -> Naturals NullType -> NullType Rationals -> Rationals - Strings -> Strings Types -> Types UnicodeCharacters -> UnicodeCharacters Union t1 t2 -> Union (fmap f t1) (fmap f t2) @@ -448,13 +417,11 @@ ADTs -> mempty AsciiCharacters -> mempty Atoms -> mempty - ASTs -> mempty AnnotatedType ty op -> foldMap f ty Bits _ -> mempty Characters -> mempty Complement t1 -> foldMap f t1 ComputationTypes -> mempty - GroundValues -> mempty IntegersUpTo q -> mempty IntegersFrom q -> mempty Intersection t1 t2 -> foldMap f t1 `mappend` foldMap f t2 @@ -464,7 +431,6 @@ Naturals -> mempty NullType -> mempty Rationals -> mempty - Strings -> mempty Types -> mempty UnicodeCharacters -> mempty Union t1 t2 -> foldMap f t1 `mappend` foldMap f t2 @@ -477,12 +443,10 @@ AsciiCharacters -> pure AsciiCharacters AnnotatedType ty op -> AnnotatedType <$> traverse f ty <*> pure op Atoms -> pure Atoms - ASTs -> pure ASTs Bits n -> pure $ Bits n Characters -> pure Characters Complement t -> Complement <$> traverse f t ComputationTypes -> pure ComputationTypes - GroundValues -> pure GroundValues IntegersFrom n -> pure $ IntegersFrom n IntegersUpTo n -> pure $ IntegersUpTo n EmptyType -> pure EmptyType @@ -492,7 +456,6 @@ Naturals -> pure Naturals NullType -> pure NullType Rationals -> pure Rationals - Strings -> pure Strings Types -> pure Types UnicodeCharacters -> pure UnicodeCharacters Union t1 t2 -> Union <$> traverse f t1 <*> traverse f t2 @@ -577,8 +540,8 @@ isGround (Rational _) = True isGround (Set s) = all isGround (S.toList s) isGround (Vector v) = all isGround (V.toList v) -isGround (VMeta _) = True isGround VAny = False +isGround (ValSeq ts) = all (maybe False isGround . project) ts -- functions that check simple properties of funcons -- TODO: Some of these are used, and all are exported by Funcons.EDSL @@ -597,7 +560,7 @@ isSet ((Set _)) = True isSet _ = False isString_ :: HasValues t => Values t -> Bool -isString_ (ADTVal "list" vs) = not (null vs) && all (maybe False isAscii) (map project vs) +isString_ (ADTVal "list" vs) = not (null vs) && all (maybe False (isChar . upcastUnicode)) (map project vs) isString_ _ = False isType (ComputationType _) = True isType _ = False @@ -606,7 +569,8 @@ unString :: HasValues t => Values t -> String unString (ADTVal "list" vs) - | Just vs' <- sequence (map project vs), all isAscii vs' = map (\(Ascii c) -> c) vs' + | Just vs' <- sequence (map (fmap upcastUnicode . project) vs) + , all isChar vs' = map (\(Char c) -> c) vs' unString _ = error "unString" null__ :: Values t @@ -617,6 +581,7 @@ isNull :: Values t -> Bool isNull (ADTVal "null" _) = True +isNull (ADTVal "null-value" _) = True isNull _ = False isDefinedVal :: Values t -> Bool @@ -645,19 +610,16 @@ 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++" |-> "++ - showArgs (map (ppValues showT) v)) $ M.toList m) + where key_values = intercalate ", " (map showKP $ M.assocs m) + where showKP (k,vs) = ppValues showT k ++ " |-> " ++ + case vs of [v] -> ppValues showT v + _ -> showArgs (map (ppValues showT) vs) 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)) ppValues showT (ComputationType ty) = ppComputationTypes showT ty ppValues showT VAny = "_" -ppValues showT (VMeta ts) = ppTaggedSyntax showT ts - -ppTaggedSyntax :: HasValues t => (t -> String) -> TaggedSyntax t -> String -ppTaggedSyntax showT (TagName nm vs) = "astv" ++ showArgs (unpack nm : map (ppValues showT) vs) -ppTaggedSyntax showT (TagType ty val) = "astv" ++ showArgs [ppTypes showT ty, ppValues showT val] +ppValues showT (ValSeq ts) = showArgs_ (map showT ts) ppComputationTypes :: HasValues t => (t -> String) -> ComputationTypes t -> String ppComputationTypes showT (Type t) = ppTypes showT t @@ -668,9 +630,7 @@ ppTypes showT (AnnotatedType ty op) = ppTypes showT ty ++ ppOp op ppTypes showT (Complement ty) = "~(" ++ ppTypes showT ty ++ ")" ppTypes showT ComputationTypes = "computation-types" -ppTypes showT GroundValues = "ground-values" ppTypes showT NullType = "null-type" -ppTypes showT ASTs = "asts" ppTypes showT Atoms = "atoms" ppTypes showT AsciiCharacters = "ascii-characters" ppTypes showT Characters = "characters" @@ -680,7 +640,6 @@ ppTypes showT EmptyType = "empty-type" ppTypes showT (UnicodeCharacters) = "unicode-characters" ppTypes showT (Integers) = "integers" -ppTypes showT (Strings) = "strings" ppTypes showT (Values) = "values" ppTypes showT Types = "types" ppTypes showT ADTs = "algebraic-datatypes"