From ce9abfd10ad0f539381dd757023a2fd907554ba0 Mon Sep 17 00:00:00 2001
From: Erik Post <erik@shinsetsu.nl>
Date: Tue, 16 Oct 2018 00:18:18 +0200
Subject: [PATCH] Tease apart and rename bits of (Show algebra) instance. #71

---
 src/Language/Instance.hs | 53 ++++++++++++++++++++++++++++++++--------
 1 file changed, 43 insertions(+), 10 deletions(-)

diff --git a/src/Language/Instance.hs b/src/Language/Instance.hs
index 3f657ca..686cce9 100644
--- a/src/Language/Instance.hs
+++ b/src/Language/Instance.hs
@@ -6,6 +6,7 @@ import Prelude hiding (EQ)
 import Data.Set as Set
 import Data.Map.Strict as Map
 import Data.List hiding (intercalate)
+import qualified Data.Foldable as Foldable
 import Language.Common
 import Language.Term as Term
 import Language.Typeside as Typeside
@@ -97,21 +98,53 @@ sepBy (x:y ) sep = x ++ sep ++ (sepBy y sep)
 sepBy' :: [Char] -> [[Char]] -> [Char]
 sepBy' x y = sepBy y x
 
+-- instance (Show var, Show ty, Show sym, Show en, Show fk, Show att, Show gen, Show sk, Show x, Show y, Eq en, Eq fk, Eq att)
+--   => Show (Algebra var ty sym en fk att gen sk x y) where
+--   show (Algebra sch en' nf''' repr'' ty' nf'''' repr''' teqs') =
+--     "algebra\n" ++ l ++ "\ntype-algeba\n" ++ w ++ sepBy' "\n" (Prelude.map show $ Set.toList $ teqs')
+--       where w = "nulls\n" ++ sepBy' "\n" (Prelude.map (\ty'' -> show ty'' ++ " (" ++ show (Set.size (ty' ty'')) ++ ") = " ++ show (Set.toList $ ty' ty'') ++ " ") (Set.toList $ Typeside.tys $ Schema.typeside sch))
+--             h = Prelude.map (\en'' -> show en'' ++ " (" ++ show (Set.size (en' en'')) ++ ")\n-------------\n" ++ (sepBy' "\n" $ Prelude.map (\x -> show x ++ ": "
+--                  ++ (sepBy (Prelude.map (f x) $ fksFrom'  sch en'') ",") ++ ", "
+--                  ++ (sepBy (Prelude.map (g x) $ attsFrom' sch en'') ",")) $ Set.toList $ en' en'')) (Set.toList $ Schema.ens sch)
+--             l = sepBy' "\n" h
+--             f x (fk,_) = show   fk  ++ " = " ++ (show $ aFk alg  fk x )
+--             g x (att,_) = show   att ++ " = " ++ (show $ aAtt alg att x )
+--             alg = Algebra sch en' nf''' repr'' ty' nf'''' repr''' teqs'
+
 instance (Show var, Show ty, Show sym, Show en, Show fk, Show att, Show gen, Show sk, Show x, Show y, Eq en, Eq fk, Eq att)
   => Show (Algebra var ty sym en fk att gen sk x y) where
-  show (Algebra sch en' nf''' repr'' ty' nf'''' repr''' teqs') =
-    "algebra\n" ++ l ++ "\ntype-algeba\n" ++ w ++ sepBy' "\n" (Prelude.map show $ Set.toList $ teqs')
-      where w = "nulls\n" ++ sepBy' "\n" (Prelude.map (\ty'' -> show ty'' ++ " (" ++ show (Set.size (ty' ty'')) ++ ") = " ++ show (Set.toList $ ty' ty'') ++ " ") (Set.toList $ Typeside.tys $ Schema.typeside sch))
-            h = Prelude.map (\en'' -> show en'' ++ " (" ++ show (Set.size (en' en'')) ++ ")\n-------------\n" ++ (sepBy' "\n" $ Prelude.map (\x -> show x ++ ": "
-                 ++ (sepBy (Prelude.map (f x) $ fksFrom'  sch en'') ",") ++ ", "
-                 ++ (sepBy (Prelude.map (g x) $ attsFrom' sch en'') ",")) $ Set.toList $ en' en'')) (Set.toList $ Schema.ens sch)
-            l = sepBy' "\n" h
-            f x (fk,_) = show   fk  ++ " = " ++ (show $ aFk alg  fk x )
-            g x (att,_) = show   att ++ " = " ++ (show $ aAtt alg att x )
-            alg = Algebra sch en' nf''' repr'' ty' nf'''' repr''' teqs'
+  show alg@(Algebra sch en' _ _ ty' _ _ teqs') =
+    "algebra" ++ "\n" ++
+    intercalate "\n\n" prettyEntities ++ "\n" ++
+    "type-algebra" ++ "\n" ++
+    "nulls" ++ "\n" ++
+    w ++
+    prettyTypeEqns
+    where 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 = prettyEntity `mapl` Schema.ens sch
+
+          prettyEntity e =
+            show e ++ " (" ++ show (Set.size $ en' e) ++ ")\n" ++
+            "-------------\n" ++
+            (intercalate "\n" $ prettyEntityRow e `mapl` en' e)
+
+          prettyEntityRow en'' e =
+            show e ++ ": " ++
+            intercalate "," (prettyFk  e <$> fksFrom'  sch en'') ++ ", " ++
+            intercalate "," (prettyAtt e <$> attsFrom' sch en'')
+
+          prettyAtt :: x -> (att, w) -> String
+          prettyAtt x (att,_) = show att ++ " = " ++ (prettyTerm $ aAtt alg att x)
+
+          prettyFk  x (fk, _) = show fk  ++ " = " ++ (show $ aFk  alg fk  x)
 
+          prettyTerm = show
 
+          prettyTypeEqns = intercalate "\n" (Set.map show teqs')
 
+          mapl fn = fmap fn . Foldable.toList
 
 fksFrom :: Eq en => Collage var ty sym en fk att gen sk -> en -> [(fk,en)]
 fksFrom sch en' = f $ Map.assocs $ cfks sch