cleanup

src/Core/Examples.hs

@@ -117,6 +117,18 @@ simple1 = [coreProg|
     main = s k k 3;
 |]
 
+caseBool1 = [coreProg|
+    _if c x y = case c of
+        { 1 -> x
+        ; 0 -> y
+        };
+
+    false = Pack{0 0};
+    true = Pack{1 0};
+
+    main = _if false ((+#) 2 3) ((*#) 4 5);
+|]
+
 corePrelude :: Module
 corePrelude = Module (Just ("Prelude", [])) $
     -- non-primitive defs

src/Core/Lex.x

@@ -68,7 +68,6 @@ rlp :-
     "{"                     { constTok TokenLBrace }
     "}"                     { constTok TokenRBrace }
     ";"                     { constTok TokenSemicolon }
-    ","                     { constTok TokenComma }
     "{-#"                   { constTok TokenLPragma `andBegin` pragma }
 
     "let"                   { constTok TokenLet }
@@ -121,7 +120,6 @@ data CoreToken = TokenLet
                | TokenIn
                | TokenModule
                | TokenWhere
-               | TokenComma
                | TokenPack -- temp
                | TokenCase
                | TokenOf

src/Core/Parse.y

@@ -36,7 +36,6 @@ import Data.Default.Class   (def)
       where           { Located _ _ _ TokenWhere }
       case            { Located _ _ _ TokenCase }
       of              { Located _ _ _ TokenOf }
-      ','             { Located _ _ _ TokenComma }
       pack            { Located _ _ _ TokenPack } -- temp
       in              { Located _ _ _ TokenIn }
       litint          { Located _ _ _ (TokenLitInt $$) }
@@ -136,7 +135,7 @@ Words           : word Words                    { $1 : $2 }
                 | word                          { [$1] }
 
 PackCon         :: { Expr }
-PackCon         : pack '{' litint ',' litint '}' { Con $3 $5 }
+PackCon         : pack '{' litint litint '}'    { Con $3 $4 }
 
 Bindings        :: { [Binding] }
 Bindings        : Binding ';' Bindings          { $1 : $3 }

src/GM.hs

@@ -658,7 +658,7 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
         argOffset n = each . _2 %~ (+n)
 
 idPack :: Tag -> Int -> String
-idPack t n = printf "Pack{%d,%d}" t n
+idPack t n = printf "Pack{%d %d}" t n
 
 ----------------------------------------------------------------------------------
 
@@ -781,15 +781,19 @@ showNodeAtP p st a = case hLookup a h of
                 Just (NameKey n)     -> n
                 Just (ConstrKey t n) -> idPack t n
                 _                     -> errTxtInvalidAddress
-    Just (NAp f x)       -> pprec $ showNodeAtP (p+1) st f <+> showNodeAtP (p+1) st x
+    -- TODO: left-associativity
-        where pprec = maybeParens (p > 0)
+    Just (NAp f x)       -> pprec $ showNodeAtP (p+1) st f
+                                <+> showNodeAtP (p+1) st x
     Just (NInd a')       -> pprec $ "NInd -> " <> showNodeAtP (p+1) st a'
-        where pprec = maybeParens (p > 0)
+    Just (NConstr t as)  -> pprec $ "NConstr"
-    Just (NConstr t as)  -> pprec $ "NConstr" <+> int t <+> text (show as)
+                                <+> int t
-        where pprec = maybeParens (p > 0)
+                                <+> brackets (list $ showNodeAtP 0 st <$> as)
+        where list = hcat . punctuate ", "
     Just NUninitialised  -> "<uninitialised>"
     Nothing              -> errTxtInvalidAddress
-    where h = st ^. gmHeap
+    where
+        h = st ^. gmHeap
+        pprec = maybeParens (p > 0)
 
 showSc :: GmState -> (Name, Addr) -> Doc
 showSc st (k,a) = "Supercomb " <> qquotes (text k) <> colon