Add structured printing for G-Machine

Author: jlam55555

src/CorePrelude.hs

@@ -91,4 +91,10 @@ extraPreludeDefs =
 
 -- Extra prelude defs (for GM)
 extraPreludeDefsGM :: CoreProgram
-extraPreludeDefsGM = parse "if c t f = case c of <1> -> f ; <2> -> t"
+extraPreludeDefsGM = parse $ concat
+  [ "if c t f = case c of <1> -> f ; <2> -> t ;"
+  , "False = Pack{1,0} ;"
+  , "True = Pack{2,0} ;"
+  , "Nil = Pack{3,0} ;"
+  , "Cons = Pack{4,2}"
+  ]

src/Evaluators/GMachine/Compiler.hs

@@ -19,7 +19,7 @@ type GmCompiledSC = (Name, Int, GmCode)
 type GmCompiler = CoreExpr -> GmEnv Int -> GmCode
 
 compile :: CoreProgram -> GmState
-compile prog = GmState "" initialCode [] [] h e statInitial
+compile prog = GmState [] initialCode [] [] h e statInitial
   where (h, e) = buildInitialHeap prog
 
 buildInitialHeap :: CoreProgram -> (GmHeap, GmEnv Addr)

src/Evaluators/GMachine/Evaluator.hs

@@ -297,8 +297,11 @@ printI state = state { gmCode = is', gmOutput = o', gmStack = s' }
   node          = hLookup (gmHeap state) a
   -- Updated stack and instructions depends on the data node
   (is', o', s') = printI' node
-  printI' (NNum n) = (gmCode state, gmOutput state ++ " " ++ show n, as)
-  printI' (NConstr _ args) =
-    (printIs (length args) ++ gmCode state, gmOutput state, args ++ as)
+  printI' (NNum n) = (gmCode state, gmOutput state ++ [PPNNum n], as)
+  printI' (NConstr tag args) =
+    ( printIs (length args) ++ gmCode state
+    , gmOutput state ++ [PPNStruct tag (length args)]
+    , args ++ as
+    )
     where printIs n = concat $ take n $ repeat [Eval, Print]
   printI' _ = error "print: non-data node"

src/Evaluators/GMachine/PrintUtils.hs

@@ -53,10 +53,10 @@ instance Show Instruction where
   show (Split n) = "split " ++ show n
   show Print     = "print"
 
--- TODO: show output in "structured form" (Exercise 3.36); also requires
+-- Show output in "structured form" (Exercise 3.36); also requires
 -- changes in the print opcode
 showOutput :: [GmState] -> String
-showOutput trace = gmOutput state where state = last trace
+showOutput trace = printTree $ gmOutput state where state = last trace
 
 showTrace :: [GmState] -> String
 showTrace states = iDisplay $ iConcat
@@ -96,7 +96,7 @@ showInstructions is = iConcat
 
 showState :: GmState -> Iseq
 showState state = iConcat
-  [ showOutput' state
+  [ showOutput'
   , iNewline
   , showStack state
   , iNewline
@@ -105,12 +105,9 @@ showState state = iConcat
   , showInstructions $ gmCode state
   , iNewline
   ]
-
--- Show the GmOutput (different from `showOutput`, which is part of the
--- interface for the compiler); introduced in Mark 6
-showOutput' :: GmState -> Iseq
-showOutput' state =
-  iConcat [iStr "Output:\"", iStr $ gmOutput state, iStr "\""]
+ where
+  showOutput' =
+    iConcat [iStr "Output: \"\n", iStr $ showOutput [state], iStr "\""]
 
 showStack :: GmState -> Iseq
 showStack state = iConcat
@@ -170,3 +167,58 @@ shortShowStack s =
 showStats :: GmState -> Iseq
 showStats state =
   iConcat [iStr "Steps taken = ", iNum $ statGetSteps $ gmStats state]
+
+-- Inorder to tree
+printToTree :: [PrintPreorderNode] -> Maybe PrintTreeNode
+printToTree []    = Nothing
+printToTree inord = getResult $ printToTree' [(1, PTNStruct (-1) [])] inord
+ where
+  getResult (Just [(0, PTNStruct (-1) [n])]) = Just $ reverseTree n
+  getResult Nothing                          = Nothing
+  getResult _                                = error "printToTree: invalid tree"
+  reverseTree n@(PTNNum _) = n
+  reverseTree (PTNStruct tag children) =
+    PTNStruct tag $ reverse $ reverseTree <$> children
+
+-- Helper function for inorder -> tree
+printToTree'
+  :: [(Int, PrintTreeNode)]
+  -> [PrintPreorderNode]
+  -> Maybe [(Int, PrintTreeNode)]
+-- Done
+printToTree' final@[(0, _)] [] = Just final
+-- 0 elements left, pop the stack
+printToTree' ((0, n) : (arity, PTNStruct tag children) : ppns) inord =
+  printToTree' ((arity, PTNStruct tag (n : children)) : ppns) inord
+printToTree' ((arity, PTNStruct tag children) : ppns) (n : ns) = printToTree''
+  n
+ where
+  printToTree'' (PPNNum n') =
+    printToTree' ((arity - 1, PTNStruct tag (PTNNum n' : children)) : ppns) ns
+  printToTree'' (PPNStruct tag' arity') = printToTree'
+    ((arity', PTNStruct tag' []) : (arity - 1, PTNStruct tag children) : ppns)
+    ns
+printToTree' _ _ = Nothing
+
+-- Print tree
+printTree :: [PrintPreorderNode] -> String
+printTree = toString . printToTree
+ where
+  toString Nothing     = ""
+  toString (Just tree) = iDisplay $ printTree' tree
+
+printTree' :: PrintTreeNode -> Iseq
+printTree' (PTNNum n              ) = iNum n
+printTree' (PTNStruct tag children) = printNode tag $ length children
+ where
+  printNode 1 0 = iStr "False"
+  printNode 2 0 = iStr "True"
+  printNode 3 0 = iStr "Nil"
+  printNode 4 2 = regularStruct $ iStr "Cons"
+  printNode n _ = regularStruct $ iNum n
+  regularStruct tag' = iConcat
+    [ tag'
+    , iStr "{"
+    , iIndent $ iInterleave (iStr ",\n") $ printTree' <$> children
+    , iStr "}"
+    ]

src/Evaluators/GMachine/State.hs

@@ -8,6 +8,8 @@ module Evaluators.GMachine.State
   , GmEnv
   , GmState(..)
   , Node(..)
+  , PrintPreorderNode(..)
+  , PrintTreeNode(..)
   , statInitial
   , statIncSteps
   , statGetSteps
@@ -41,7 +43,11 @@ data Instruction
   | Print
   deriving Eq
 
-type GmOutput = String
+data PrintPreorderNode = PPNStruct Int Int | PPNNum Int
+  deriving Show
+data PrintTreeNode = PTNStruct Int [PrintTreeNode] | PTNNum Int
+  deriving Show
+type GmOutput = [PrintPreorderNode]
 
 type GmStack = [Addr]
 type GmHeap = Heap Node