Make CQL output structured and human-readable. #71

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

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"

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)

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

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

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