diff --git a/src/Language/Common.hs b/src/Language/Common.hs index 68d8727..0616c57 100644 --- a/src/Language/Common.hs +++ b/src/Language/Common.hs @@ -47,6 +47,7 @@ import Data.Kind import Data.Map.Strict as Map hiding (foldl) import Data.Maybe import Data.Set as Set (Set, empty, insert, member, singleton) +import Data.String (lines) import Data.Typeable split' :: [(a, Either b1 b2)] -> ([(a, b1)], [(a, b2)]) @@ -113,6 +114,12 @@ type ID = Integer showCtx' :: (Show a1, Show a2) => Map a1 a2 -> String showCtx' m = intercalate "\n\t" $ (\(k,v) -> show k ++ " : " ++ show v) <$> Map.toList m +section :: String -> String -> String +section heading body = heading ++ "\n" ++ indentLines body ++ "\n" + +indentLines :: String -> String +indentLines = foldMap (\l -> "\t" <> l <> "\n"). lines + -- | A version of intercalate that works on Foldables instead of just List, -- | adapted from PureScript. intercalate :: (Foldable f, Monoid m) => m -> f m -> m diff --git a/src/Language/Instance.hs b/src/Language/Instance.hs index 08125bb..11f4559 100644 --- a/src/Language/Instance.hs +++ b/src/Language/Instance.hs @@ -792,26 +792,28 @@ evalDeltaInst m i _ = pure $ Instance (src m) (algebraToPresentation alg) eq' al ------------------------------------------------------------------------------------------------------------------- -- Printing -deriving instance Show InstanceEx +-- InstanceEx is an implementation detail, so hide its presence +instance (Show InstanceEx) where + show (InstanceEx i) = show i instance (TyMap Show '[var, ty, sym, en, fk, att, gen, sk, x, y], Eq en, Eq fk, Eq att) => Show (Instance var ty sym en fk att gen sk x y) where show (Instance _ p _ alg) = "instance\n" ++ - show p ++ "\n" ++ - show alg + (indentLines $ "presentation" ++ "\n" ++ show p) ++ "\n" ++ + (indentLines $ "algebra" ++ "\n" ++ show alg) ++ "\n" instance (TyMap Show '[var, ty, sym, en, fk, att, gen, sk, x, y], Eq en, Eq fk, Eq att) => Show (Algebra var ty sym en fk att gen sk x y) where show alg@(Algebra sch _ _ _ _ ty' _ _ teqs') = - "algebra" ++ "\n" ++ - intercalate "\n\n" prettyEntities ++ "\n" ++ + "entities" ++ "\n" ++ + (indentLines $ intercalate "\n" prettyEntities) ++ "\n" ++ "type-algebra" ++ "\n" ++ + indentLines prettyTypeEqns ++ "\n" ++ "nulls" ++ "\n" ++ - w ++ - prettyTypeEqns + indentLines w where - w = " " ++ (intercalate "\n " . mapl w2 . Typeside.tys . Schema.typeside $ sch) + w = intercalate "\n" . mapl w2 . Typeside.tys . Schema.typeside $ sch w2 ty'' = show ty'' ++ " (" ++ (show . Set.size $ ty' ty'') ++ ") = " ++ show (Foldable.toList $ ty' ty'') ++ " " prettyEntities = prettyEntityTable alg `mapl` Schema.ens sch prettyTypeEqns = intercalate "\n" (Set.map show teqs') @@ -823,7 +825,7 @@ prettyEntity -> String prettyEntity alg@(Algebra sch en' _ _ _ _ _ _ _) es = show es ++ " (" ++ (show . Set.size $ en' es) ++ ")\n" ++ - "-------------\n" ++ + "--------------------------------------------------------------------------------\n" ++ intercalate "\n" (prettyEntityRow es `mapl` en' es) where -- prettyEntityRow :: en -> x -> String @@ -872,6 +874,7 @@ prettyEntityTable alg@(Algebra sch en' _ _ _ _ _ _ _) es = instance TyMap Show '[var, ty, sym, en, fk, att, gen, sk] => Show (Presentation var ty sym en fk att gen sk) where - show (Presentation ens' _ eqs') = "presentation {\n" ++ - "generators\n\t" ++ showCtx' ens' ++ "\n" ++ - "equations\n\t" ++ intercalate "\n\t" (Set.map show eqs') ++ "}" + show (Presentation ens' _ eqs') = + indentLines $ + "generators\n\t" ++ showCtx' ens' ++ "\n" ++ + "equations\n\t" ++ intercalate "\n\t" (Set.map show eqs') ++ "\n" diff --git a/src/Language/Program.hs b/src/Language/Program.hs index ea60a5e..6dd09c8 100644 --- a/src/Language/Program.hs +++ b/src/Language/Program.hs @@ -40,7 +40,7 @@ module Language.Program where import Control.DeepSeq import Data.Map.Strict as Map -import Language.Common as C +import Language.Common (section, showCtx'', TyMap, Kind(..)) import Language.Instance as I import Language.Mapping as M import Language.Query as Q @@ -108,13 +108,13 @@ newEnv = KindCtx m m m m m m instance TyMap Show '[ts, s, i, m, q, t, o] => Show (KindCtx ts s i m q t o) where show (KindCtx ts s i m q t o) = - "typesides\n" ++ showCtx'' ts ++ "\n" ++ - "schemas\n" ++ showCtx'' s ++ "\n" ++ - "instances\n" ++ showCtx'' i ++ "\n" ++ - "mappings\n" ++ showCtx'' m ++ "\n" ++ - "queries\n" ++ showCtx'' q ++ "\n" ++ - "transforms\n" ++ showCtx'' t ++ "\n" ++ - "other\n" ++ show o ++ "\n" + section "typesides" (showCtx'' ts) ++ + section "schemas" (showCtx'' s) ++ + section "instances" (showCtx'' i) ++ + section "mappings" (showCtx'' m) ++ + section "queries" (showCtx'' q) ++ + section "transforms" (showCtx'' t) ++ + section "other" (show o) allVars :: KindCtx ts s i m q t o -> [(String, Kind)] allVars x = @@ -123,4 +123,4 @@ allVars x = fmap (, INSTANCE ) (keys $ instances x) ++ fmap (, MAPPING ) (keys $ mappings x) ++ fmap (, QUERY ) (keys $ queries x) ++ - fmap (, TRANSFORM) (keys $ transforms x) + fmap (, TRANSFORM) (keys $ transforms x) \ No newline at end of file diff --git a/src/Language/Schema.hs b/src/Language/Schema.hs index e297313..b30dde7 100644 --- a/src/Language/Schema.hs +++ b/src/Language/Schema.hs @@ -171,7 +171,9 @@ data SchemaEx :: * where => Schema var ty sym en fk att -> SchemaEx -deriving instance Show SchemaEx +-- SchemaEx is an implementation detail, so hide its presence +instance (Show SchemaEx) where + show (SchemaEx i) = show i instance NFData SchemaEx where rnf (SchemaEx x) = rnf x diff --git a/src/Language/Term.hs b/src/Language/Term.hs index f3f679f..28164f7 100644 --- a/src/Language/Term.hs +++ b/src/Language/Term.hs @@ -94,13 +94,20 @@ instance TyMap Show '[var, ty, sym, en, fk, att, gen, sk] => Show (Term var ty sym en fk att gen sk) where show x = case x of - Var v -> show v - Gen g -> show g - Sk s -> show s - Fk fk a -> show a ++ "." ++ show fk - Att att a -> show a ++ "." ++ show att - Sym sym [] -> show sym - Sym sym az -> show sym ++ "(" ++ (intercalate "," . fmap show $ az) ++ ")" + Var v -> dropQuotes $ show v + Gen g -> show' g + Sk s -> show' s + Fk fk a -> show' a ++ "." ++ show' fk + Att att a -> show' a ++ "." ++ show' att + Sym sym [] -> show' sym + Sym sym az -> show' sym ++ "(" ++ (intercalate "," . fmap show' $ az) ++ ")" + +show' :: Show a => a -> String +show' = dropQuotes . show + +dropQuotes :: String -> String +dropQuotes s = if '\"' `elem` s then Prelude.filter (not . ('\"' ==)) s + else s deriving instance TyMap Ord '[var, ty, sym, en, fk, att, gen, sk] => Ord (Term var ty sym en fk att gen sk) @@ -116,11 +123,11 @@ data Head ty sym en fk att gen sk = instance (Show ty, Show sym, Show en, Show fk, Show att, Show gen, Show sk) => Show (Head ty sym en fk att gen sk) where show x = case x of - HSym sym -> show sym - HFk fk -> show fk - HAtt att -> show att - HGen gen -> show gen - HSk sk -> show sk + HSym sym -> show' sym + HFk fk -> show' fk + HAtt att -> show' att + HGen gen -> show' gen + HSk sk -> show' sk -- | Maps functions through a term. mapTerm diff --git a/src/Language/Typeside.hs b/src/Language/Typeside.hs index 63e341e..d965c14 100644 --- a/src/Language/Typeside.hs +++ b/src/Language/Typeside.hs @@ -94,7 +94,9 @@ data TypesideEx :: * where instance NFData TypesideEx where rnf (TypesideEx x) = rnf x -deriving instance Show TypesideEx +-- TypesideEx is an implementation detail, so hide its presence +instance (Show TypesideEx) where + show (TypesideEx i) = show i ------------------------------------------------------------------------------------------------------------ -- Literal typesides