diff options
Diffstat (limited to 'src/AST')
| -rw-r--r-- | src/AST/Pretty.hs | 72 |
1 files changed, 64 insertions, 8 deletions
diff --git a/src/AST/Pretty.hs b/src/AST/Pretty.hs index c1d6c88..e793ce1 100644 --- a/src/AST/Pretty.hs +++ b/src/AST/Pretty.hs @@ -10,6 +10,7 @@ module AST.Pretty where import Control.Monad (ap) import Data.List (intersperse) +import Data.Foldable (toList) import Data.Functor.Const import AST @@ -26,6 +27,10 @@ valprj (VPush x _) IZ = x valprj (VPush _ env) (IS i) = valprj env i valprj VTop i = case i of {} +vpushN :: Vec n a -> Val (Const a) env -> Val (Const a) (ConsN n TIx env) +vpushN VNil v = v +vpushN (name :< names) v = VPush (Const name) (vpushN names v) + newtype M a = M { runM :: Int -> (a, Int) } deriving (Functor) instance Applicative M where { pure x = M (\i -> (x, i)) ; (<*>) = ap } @@ -88,11 +93,11 @@ ppExpr' d val = \case EInl _ _ e -> do e' <- ppExpr' 11 val e - return $ showParen (d > 10) $ showString "inl " . e' + return $ showParen (d > 10) $ showString "Inl " . e' EInr _ _ e -> do e' <- ppExpr' 11 val e - return $ showParen (d > 10) $ showString "inr " . e' + return $ showParen (d > 10) $ showString "Inr " . e' ECase _ e a b -> do e' <- ppExpr' 0 val e @@ -104,9 +109,50 @@ ppExpr' d val = \case showString "case " . e' . showString (" of { Inl " ++ name1 ++ " -> ") . a' . showString (" ; Inr " ++ name2 ++ " -> ") . b' . showString " }" + EBuild1 _ a b -> do + a' <- ppExpr' 11 val a + name <- genName + b' <- ppExpr' 0 (VPush (Const name) val) b + return $ showParen (d > 10) $ + showString "build1 " . a' . showString (" (\\" ++ name ++ " -> ") . b' . showString ")" + + EBuild _ es e -> do + es' <- mapM (ppExpr' 0 val) es + names <- mapM (const genName) es + e' <- ppExpr' 0 (vpushN names val) e + return $ showParen (d > 10) $ + showString "build [" + . foldr (.) id (intersperse (showString ", ") (reverse (toList es'))) + . showString "] (\\[" + . foldr (.) id (intersperse (showString ",") (map showString (reverse (toList names)))) + . showString ("] -> ") . e' . showString ")" + + EFold1 _ a b -> do + name1 <- genName + name2 <- genName + a' <- ppExpr' 0 (VPush (Const name2) (VPush (Const name1) val)) a + b' <- ppExpr' 11 val b + return $ showParen (d > 10) $ + showString ("fold1 (\\" ++ name1 ++ " " ++ name2 ++ " -> ") . a' + . showString ") " . b' + EConst _ ty v -> return $ showString $ case ty of STI32 -> show v ; STI64 -> show v ; STF32 -> show v ; STF64 -> show v ; STBool -> show v + EIdx1 _ a b -> do + a' <- ppExpr' 9 val a + b' <- ppExpr' 9 val b + return $ showParen (d > 8) $ a' . showString " ! " . b' + + EIdx _ e es -> do + e' <- ppExpr' 9 val e + es' <- traverse (ppExpr' 0 val) es + return $ showParen (d > 8) $ + e' . showString " ! " + . showString "[" + . foldr (.) id (intersperse (showString ", ") (reverse (toList es'))) + . showString "]" + EOp _ op (EPair _ a b) | (Infix, ops) <- operator op -> do a' <- ppExpr' 9 val a @@ -139,6 +185,22 @@ ppExpr' d val = \case e' <- ppExpr' 11 val e return $ showParen (d > 10) $ showString ("return ") . e' + etop@(EMBind _ EMBind{}) -> do + let collect :: SVal env -> Expr x env t -> M ([(String, ShowS)], ShowS) + collect val' (EMBind lhs cont) = do + name <- genName + (binds, core) <- collect (VPush (Const name) val') cont + lhs' <- ppExpr' 0 val' lhs + return ((name, lhs') : binds, core) + collect val' e = ([],) <$> ppExpr' 0 val' e + + (binds, core) <- collect val etop + return $ showParen (d > 0) $ + showString "do { " + . foldr (.) id (intersperse (showString " ; ") + (map (\(name, rhs) -> showString (name ++ " <- ") . rhs) binds)) + . showString " ; " . core . showString " }" + EMBind a b -> do a' <- ppExpr' 0 val a name <- genName @@ -147,8 +209,6 @@ ppExpr' d val = \case EError _ s -> return $ showParen (d > 10) $ showString ("error " ++ show s) - _ -> undefined - data Fixity = Prefix | Infix deriving (Show) @@ -160,7 +220,3 @@ operator OLt{} = (Infix, "<") operator OLe{} = (Infix, "<=") operator OEq{} = (Infix, "==") operator ONot = (Prefix, "not") - -idx2int :: Idx env t -> Int -idx2int IZ = 0 -idx2int (IS n) = 1 + idx2int n |