Make CQL output structured and human-readable. #71 (WIP) (#149)

* Make CQL output structured and human-readable. #71

* More output structure indentation. #71

* Print 4 spaces instead of tabs in output. #71

* Simplify prettyprinting. #71

* Prettify top-level output. #71

cli/Main.hs

@@ -23,12 +23,25 @@ module Main where
 import           Language.CQL
 import           System.Environment
 
-
 main :: IO ()
-main = do args <- getArgs
-          w <- mapM readFile args
-          _ <- mapM (putStrLn . f' . runProg) w
-          return ()
- where f' (Left x)        = x
-       f' (Right (_,t,c)) = show t ++ "\n\n-------------------\n\n" ++ show c
+main = do
+  args <- getArgs
+  src  <- mapM readFile args
+  _    <- mapM (putStrLn . showResult . runProg) src
+  return ()
+  where
+    showResult r = case r of
+      Right (_, types, env) ->
+        "////////////////////////////////////////////////////////////////////////////////\n" ++
+        "// types                                                                      //\n" ++
+        "////////////////////////////////////////////////////////////////////////////////\n" ++
+        "\n" ++
+        "\n" ++
+        show types ++
+        "////////////////////////////////////////////////////////////////////////////////\n" ++
+        "// environment                                                                //\n" ++
+        "////////////////////////////////////////////////////////////////////////////////\n" ++
+        "\n" ++
+        show env
+      Left err -> err
 

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)])
@@ -64,9 +65,6 @@ fromListAccum ((k,v):kvs) = Map.insert k op (fromListAccum kvs)
     op = maybe (Set.singleton v) (Set.insert v) (Map.lookup k r)
     r  = fromListAccum kvs
 
-showCtx :: (Show a1, Show a2) => Map a1 a2 -> String
-showCtx m = unwords $ Prelude.map (\(k,v) -> show k ++ " : " ++ show v) $ Map.toList m
-
 fromList'' :: (Show k, Ord k) => [k] -> Err (Set k)
 fromList'' [] = return Set.empty
 fromList'' (k:l) = do
@@ -84,9 +82,6 @@ toMapSafely ((k,v):l) = do
   then Left $ "Duplicate binding: " ++ show k
   else pure $ Map.insert k v l'
 
-showCtx'' :: (Show a1, Show a2) => Map a1 a2 -> String
-showCtx'' m = intercalate "\n" $ (\(k,v) -> show k ++ " = " ++ show v ++ "\n") <$> Map.toList m
-
 lookup' :: (Show k, Show a, Ord k) => k -> Map k a -> a
 lookup' m v = fromMaybe (error $ "Can't find " ++ show v ++ " in " ++ show m) $ Map.lookup m v
 
@@ -109,9 +104,17 @@ data Kind = CONSTRAINTS | TYPESIDE | SCHEMA | INSTANCE | MAPPING | TRANSFORM | Q
 
 type ID = Integer
 
+sepTup :: (Show a1, Show a2) => String -> (a1, a2) -> String
+sepTup sep (k,v) = show k ++ sep ++ show v
+
+section :: String -> String -> String
+section heading body = heading ++ "\n" ++ indentLines body
+
+indentLines :: String -> String
+indentLines = foldMap (\l -> tab <> l <> "\n"). lines
 
-showCtx' :: (Show a1, Show a2) => Map a1 a2 -> String
-showCtx' m = intercalate "\n\t" $ (\(k,v) -> show k ++ " : " ++ show v) <$> Map.toList m
+tab :: String
+tab = "    "
 
 -- | A version of intercalate that works on Foldables instead of just List,
 -- | adapted from PureScript.

src/Language/Instance.hs

@@ -49,7 +49,7 @@ import           Data.Set              (Set)
 import qualified Data.Set              as Set
 import           Data.Typeable         hiding (typeOf)
 import           Data.Void
-import           Language.Common
+import           Language.Common       (elem', intercalate, fromListAccum, mapl, section, sepTup, toMapSafely, Deps(..), Err, Kind(INSTANCE), MultiTyMap, TyMap, type (+))
 import           Language.Mapping      as Mapping
 import           Language.Options
 import           Language.Prover
@@ -792,29 +792,39 @@ 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
+    section "instance" $ unlines
+      [ section "presentation" $ show p
+      , section "algebra"      $ show alg
+      ]
+
+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') =
+    unlines
+      [ section "generators" $ intercalate "\n" $ sepTup " : " <$> Map.toList ens'
+      , section "equations"  $ intercalate "\n" $ Set.map show eqs'
+      ]
 
 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" ++
-    "type-algebra" ++ "\n" ++
-    "nulls" ++ "\n" ++
-    w ++
-    prettyTypeEqns
+    unlines $
+      [ section "entities"     $ unlines prettyEntities
+      , section "type-algebra" $ intercalate "\n" prettyTypeEqns
+      , section "nulls"        $ intercalate "\n" w
+      ]
     where
-      w = "  " ++ (intercalate "\n  " . mapl w2 . Typeside.tys . Schema.typeside $ sch)
+      w = 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')
+      prettyTypeEqns = Set.map show teqs'
 
 prettyEntity
   :: (TyMap Show '[ty, sym, en, fk, att, x, y], Eq en)
@@ -823,7 +833,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
@@ -868,10 +878,4 @@ prettyEntityTable alg@(Algebra sch en' _ _ _ _ _ _ _) es =
     -- prettyAtt :: x -> (att, w) -> String
     prettyAtt x (att,_) = prettyTerm $ aAtt alg att x
 
-    prettyTerm = show
-
-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') ++ "}"
+    prettyTerm = show

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, TyMap, Kind(..))
 import           Language.Instance  as I
 import           Language.Mapping   as M
 import           Language.Query     as Q
@@ -108,13 +108,18 @@ 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 "program" $ unlines
+      [ 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
+      ]
+    where
+      showCtx :: (Show a1, Show a2) => Map a1 a2 -> String
+      showCtx m = unlines $ (\(k,v) -> show k ++ " = " ++ show v ++ "\n") <$> Map.toList m
 
 allVars :: KindCtx ts s i m q t o -> [(String, Kind)]
 allVars x =
@@ -123,4 +128,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

@@ -78,16 +78,18 @@ instance TyMap Eq '[var, ty, sym, en, fk, att]
 
 instance TyMap Show '[var, ty, sym, en, fk, att]
   => Show (Schema var ty sym en fk att) where
-  show (Schema _ ens' fks' atts' path_eqs' obs_eqs' _) = "schema {\n" ++
-    "entities\n\t"  ++ intercalate "\n\t" (Prelude.map show $ Set.toList ens') ++
-    "\nforeign_keys\n\t" ++ intercalate "\n\t" fks'' ++
-    "\natts\n\t" ++ intercalate "\n\t" atts'' ++
-    "\npath_equations\n\t" ++ intercalate "\n\t" (eqs'' path_eqs') ++
-    "\nobservation_equations\n\t " ++ intercalate "\n\t" (eqs'' obs_eqs') ++ " }"
+  show (Schema _ ens' fks' atts' path_eqs' obs_eqs' _) =
+    section "schema" $ unlines
+      [ section "entities"               $ unlines $ show <$> Set.toList ens'
+      , section "foreign_keys"           $ unlines $ fks''
+      , section "atts"                   $ unlines $ atts''
+      , section "path_equations"         $ unlines $ eqs'' path_eqs'
+      , section "observation_equations " $ unlines $ eqs'' obs_eqs'
+      ]
     where
-      fks''   = Prelude.map (\(k,(s,t)) -> show k ++ " : " ++ show s ++ " -> " ++ show t) $ Map.toList fks'
-      atts''  = Prelude.map (\(k,(s,t)) -> show k ++ " : " ++ show s ++ " -> " ++ show t) $ Map.toList atts'
-      eqs'' x = Prelude.map (\(en,EQ (l,r)) -> "forall x : " ++ show en ++ " . " ++ show (mapVar "x" l) ++ " = " ++ show (mapVar "x" r)) $ Set.toList x
+      fks''   = (\(k,(s,t))     -> show k ++ " : " ++ show s ++ " -> " ++ show t)                                            <$> Map.toList fks'
+      atts''  = (\(k,(s,t))     -> show k ++ " : " ++ show s ++ " -> " ++ show t)                                            <$> Map.toList atts'
+      eqs'' x = (\(en,EQ (l,r)) -> "forall x : " ++ show en ++ " . " ++ show (mapVar "x" l) ++ " = " ++ show (mapVar "x" r)) <$> Set.toList x
 
 -- | Checks that the underlying theory is well-sorted.
 -- I.e. rule out "1" = one kind of errors.
@@ -171,7 +173,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

@@ -67,12 +67,18 @@ instance (Eq var, Eq ty, Eq sym) => Eq (Typeside var ty sym) where
     = (tys' == tys'') && (syms' == syms'') && (eqs' == eqs'')
 
 instance (Show var, Show ty, Show sym) => Show (Typeside var ty sym) where
-  show (Typeside tys' syms' eqs' _) = "typeside {\n" ++
-    "types\n\t"    ++ intercalate "\n\t" (Prelude.map show $ Set.toList tys') ++
-    "\nfunctions\n\t" ++ intercalate "\n\t" syms'' ++
-    "\nequations\n\t"  ++ intercalate "\n\t" eqs'' ++ " }"
-   where syms'' = Prelude.map (\(k,(s,t)) -> show k ++ " : " ++ show s ++ " -> " ++ show t) $ Map.toList syms'
-         eqs''  = Prelude.map (\(k,s) -> "forall " ++ showCtx k ++ " . " ++ show s) $ Set.toList eqs'
+  show (Typeside tys' syms' eqs' _) =
+    section "typeside" $ unlines
+      [ section "types"     $ unlines . fmap show $ Set.toList tys'
+      , section "functions" $ unlines syms''
+      , section "equations" $ unlines eqs''
+      ]
+   where
+    syms''  = (\(k,(s,t)) -> show k ++ " : " ++ show s ++ " -> " ++ show t) <$> Map.toList syms'
+    eqs''   = (\(k,s)     -> "forall " ++ showCtx k ++ " . " ++ show s)     <$> Set.toList eqs'
+
+    showCtx :: (Show a1, Show a2) => Map a1 a2 -> String
+    showCtx m = unwords $ fmap (sepTup " : ") $ Map.toList m
 
 instance (NFData var, NFData ty, NFData sym) => NFData (Typeside var ty sym) where
   rnf (Typeside tys0 syms0 eqs0 eq0) = deepseq tys0 $ deepseq syms0 $ deepseq eqs0 $ deepseq eq0 ()
@@ -94,7 +100,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