From 71a82974512d77e39b2e3627b0d3e90ac7e1670e Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Fri, 10 Nov 2023 13:36:17 -0700 Subject: [PATCH] cool! (core language mostly works) --- src/Core.hs | 61 +++++++++++++++++++++++----------------------- src/Data/Pretty.hs | 32 +++++++++++++++++++++--- src/TI.hs | 25 +++++++++++++++---- 3 files changed, 78 insertions(+), 40 deletions(-) diff --git a/src/Core.hs b/src/Core.hs index a978dee..6c5b05a 100644 --- a/src/Core.hs +++ b/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 - -- 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 + 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 + (_:$_) -> 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 $ "+#" ---------------------------------------------------------------------------------- diff --git a/src/Data/Pretty.hs b/src/Data/Pretty.hs index c7374dc..e022c32 100644 --- a/src/Data/Pretty.hs +++ b/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 = "" diff --git a/src/TI.hs b/src/TI.hs index 87b7d08..219c248 100644 --- a/src/TI.hs +++ b/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 +