From c8cc7686f6e2833c117ba0c6ba663d0d1be4a459 Mon Sep 17 00:00:00 2001 From: Erik Post Date: Sat, 10 Aug 2019 16:42:33 +0200 Subject: [PATCH] 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 | 27 +++++++++++++++++------ src/Language/Common.hs | 19 ++++++++++------- src/Language/Instance.hs | 46 ++++++++++++++++++++++------------------ src/Language/Program.hs | 23 ++++++++++++-------- src/Language/Schema.hs | 24 ++++++++++++--------- src/Language/Term.hs | 31 ++++++++++++++++----------- src/Language/Typeside.hs | 22 +++++++++++++------ 7 files changed, 118 insertions(+), 74 deletions(-) diff --git a/cli/Main.hs b/cli/Main.hs index 622bb27..c18fbdc 100644 --- a/cli/Main.hs +++ b/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 diff --git a/src/Language/Common.hs b/src/Language/Common.hs index 68d8727..516468e 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)]) @@ -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. diff --git a/src/Language/Instance.hs b/src/Language/Instance.hs index 08125bb..6bd8903 100644 --- a/src/Language/Instance.hs +++ b/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 \ No newline at end of file diff --git a/src/Language/Program.hs b/src/Language/Program.hs index ea60a5e..e58a59e 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, 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) \ No newline at end of file diff --git a/src/Language/Schema.hs b/src/Language/Schema.hs index e297313..096160d 100644 --- a/src/Language/Schema.hs +++ b/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 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..4d1054f 100644 --- a/src/Language/Typeside.hs +++ b/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