cool! (core language mostly works)

src/Core.hs

@@ -13,7 +13,11 @@ data Expr = Var Name
           | Case Expr [Alter]
           | Lam [Name] Expr
           | App Expr Expr
-          | IntP Int
+          | Prim Prim
+          deriving Show
+
+data Prim = IntP Int
+          | IntAddP
           deriving Show
 
 infixl 2 :$
@@ -43,51 +47,46 @@ newtype Program = Program [ScDef]
 ----------------------------------------------------------------------------------
 
 instance Pretty Expr where
-    prettyPrec _ (Var k)      = IStr k
-    prettyPrec _ (IntP n)     = IStr $ show n
-    prettyPrec _ (Con _ _)    = undefined
-    prettyPrec _ (Let r bs e) =
+    prettyPrec (Var k)      = withPrec maxBound $ IStr k
+    prettyPrec (Prim n)     = prettyPrec n
+    prettyPrec (Con _ _)    = undefined
+    prettyPrec (Let r bs e) = withPrec 0 $
         IStr (if r == Rec then "letrec " else "let ")
         <> binds <> IBreak
-        <> "in " <> prettyPrec 0 e
+        <> "in " <> pretty e
         where
             binds = mconcat (f <$> init bs)
-                 <> IIndent (prettyPrec 0 $ last bs)
-            f b = IIndent $ prettyPrec 0 b <> IBreak
-    prettyPrec p (Lam ns e)
-        | p > 0               = iBracket l
-        | otherwise           =          l
+                 <> IIndent (pretty $ last bs)
+            f b = IIndent $ pretty b <> IBreak
+    prettyPrec (Lam ns e)   = withPrec 0 $ 
+        IStr "λ" <> binds <> " -> " <> pretty e
         where
-            l = IStr "λ" <> binds <> " -> " <> prettyPrec 0 e
             binds = fmap IStr ns & intersperse " " & mconcat
-    prettyPrec p (Case e as)
-        | p > 0               = iBracket c
-        | otherwise           =          c
+    prettyPrec (Case e as)   = withPrec 0 $
+            "case " <> IIndent (pretty e <> " of" <> IBreak <> alts)
         where
-            c = "case " <> IIndent (prettyPrec 0 e <> " of" <> IBreak <> alts)
             -- TODO: don't break on last alt
             alts = mconcat $ fmap palt as
-            palt x = IIndent $ prettyPrec 0 x <> IBreak
-    prettyPrec p (App f x)
-        | p > 0               = iBracket a
-        | otherwise           =          a
-        where
-            a = case f of
+            palt x = IIndent $ pretty x <> IBreak
+    prettyPrec (App f x) = \p -> bracketPrec 0 p $
+        case f of
             -- application is left-associative; don't increase prec if the
             -- expression being applied is itself an application
-                (_:$_) -> prettyPrec       p  f <> " " <> prettyPrec (succ p) x
-                _      -> prettyPrec (succ p) f <> " " <> prettyPrec (succ p) x
+            (_:$_) -> precPretty       p  f <> " " <> precPretty (succ p) x
+            _      -> precPretty (succ p) f <> " " <> precPretty (succ p) x
 
 instance Pretty Alter where
-    prettyPrec p (Alter t bs e)
-        | p > 0     = iBracket a
-        | otherwise =          a
+    prettyPrec (Alter t bs e) = withPrec 0 $
+            "<" <> IStr (show t) <> "> " <> binds <> " -> " <> pretty e
         where
-            a = "<" <> IStr (show t) <> "> " <> binds <> " -> " <> prettyPrec 0 e
             binds = mconcat $ intersperse " " (fmap IStr bs)
 
 instance Pretty Binding where
-    prettyPrec _ (k := v) = IStr k <> " = " <> prettyPrec 0 v
+    prettyPrec (k := v) = withPrec 0 $ IStr k <> " = " <> precPretty 0 v
+
+instance Pretty Prim where
+    prettyPrec (IntP n) = withPrec maxBound $ IStr $ show n ++ "#"
+    prettyPrec IntAddP  = withPrec maxBound $ "+#"
 
 ----------------------------------------------------------------------------------
 

src/Data/Pretty.hs

@@ -1,7 +1,12 @@
+{-# LANGUAGE OverloadedStrings #-}
 module Data.Pretty
     ( Pretty(..)
     , ISeq(..)
+    , precPretty
+    , prettyPrint
     , iBracket
+    , withPrec
+    , bracketPrec
     )
     where
 ----------------------------------------------------------------------------------
@@ -9,12 +14,18 @@ import Data.String      (IsString(..))
 ----------------------------------------------------------------------------------
 
 class Pretty a where
-    pretty :: a -> String
-    prettyPrec :: Int -> a -> ISeq
+    pretty :: a -> ISeq
+    prettyPrec :: a -> Int -> ISeq
 
-    pretty = squash . prettyPrec 0
-    prettyPrec _ a = iBracket (IStr $ pretty a)
     {-# MINIMAL pretty | prettyPrec #-}
+    pretty a = prettyPrec a 0
+    prettyPrec a _ = iBracket (pretty a)
+
+precPretty :: (Pretty a) => Int -> a -> ISeq
+precPretty = flip prettyPrec
+
+prettyPrint :: (Pretty a) => a -> IO ()
+prettyPrint = putStr . squash . pretty
 
 data ISeq where
     INil :: ISeq
@@ -46,3 +57,16 @@ flatten c ((IIndent s,   i) : ss) = flatten c ((s,c) : ss)
 iBracket :: ISeq -> ISeq
 iBracket s = IStr "(" <> s <> IStr ")"
 
+withPrec :: Int -> ISeq -> Int -> ISeq
+withPrec n s p
+    | p > n     = iBracket s
+    | otherwise =          s
+
+bracketPrec :: Int -> Int -> ISeq -> ISeq
+bracketPrec n p s = withPrec n s p
+
+----------------------------------------------------------------------------------
+
+instance (Pretty a) => Pretty (Maybe a) where
+    prettyPrec (Just a) p = prettyPrec a p
+    prettyPrec Nothing  p = "<Nothing>"

src/TI.hs

@@ -1,4 +1,5 @@
-{-# LANGUAGE LambdaCase, BlockArguments, ViewPatterns #-}
+{-# LANGUAGE LambdaCase, BlockArguments #-}
+{-# LANGUAGE OverloadedStrings #-}
 module TI
     where
 ----------------------------------------------------------------------------------
@@ -10,6 +11,7 @@ import Data.Maybe               (fromJust, fromMaybe)
 import Data.List                (mapAccumL)
 import Control.Monad            (guard)
 import Data.Function            ((&))
+import Data.Pretty
 import Data.Heap
 import Control.DFA
 import Core
@@ -67,7 +69,6 @@ getArgs h (sc:s) = fmap f s
             _                -> error "glados yuri"
 
 instantiate :: Expr -> TiHeap -> [(Name, Addr)] -> (TiHeap, Addr)
-instantiate (IntP n)   h _ = alloc h (NNum n)
 instantiate (App f x)  h g = alloc h'' (NAp f' x')
     where
         (h', f') = instantiate f h g
@@ -75,6 +76,9 @@ instantiate (App f x)  h g = alloc h'' (NAp f' x')
 instantiate (Var k)    h g = (h, fromMaybe (error "variable not in scope") v)
     where v = lookup k g
 instantiate (Case _ _) _ _ = error "cannot instantiate case expressions"
+
+instantiate (Prim (IntP n)) h _ = alloc h (NNum n)
+
 instantiate _          _ _ = error "unimplemented"
 
 ----------------------------------------------------------------------------------
@@ -99,7 +103,7 @@ step st =
         numStep _ _ = error "number applied as function..."
 
         apStep :: Addr -> Addr -> TiState -> TiState
-        apStep f x (TiState s d h g sts) =
+        apStep f _ (TiState s d h g sts) =
             TiState (f:s) d h g sts
 
         ncStep :: Name -> [Name] -> Expr -> TiState -> TiState
@@ -124,10 +128,21 @@ isDataNode (NNum _) = True
 isDataNode _        = False
 
 doAdmin :: TiState -> TiState
-doAdmin (TiState s d h g stats) = TiState s d h g (stats+1)
+doAdmin (TiState s d h g sts) = TiState s d h g (sts+1)
 
 testProg :: Program
 testProg = Program
-    [ ScDef "main" [] $ IntP 2
+    -- [ ScDef "main" [] $ Prim IntAddP :$ Prim (IntP 2) :$ Prim (IntP 3)
+    [ ScDef "main" [] $ Var "id" :$ Prim (IntP 2)
     ]
 
+instance Pretty TiState where
+    prettyPrec (TiState s d h g sts) _ =
+        "==== TiState Stack ====" <> IBreak
+        <> mconcat (fmap ((<>IBreak) . showAddr) s)
+        where
+            showAddr a = IStr (show a) <> ": " <> precPretty 0 (hLookup a h)
+
+instance Pretty Node where
+    prettyPrec a _ = IStr $ show a
+