diff options
Diffstat (limited to 'src/AST/Pretty.hs')
| -rw-r--r-- | src/AST/Pretty.hs | 38 |
1 files changed, 17 insertions, 21 deletions
diff --git a/src/AST/Pretty.hs b/src/AST/Pretty.hs index 5610d36..bf0d350 100644 --- a/src/AST/Pretty.hs +++ b/src/AST/Pretty.hs @@ -17,16 +17,7 @@ import AST.Count import Data -data Val f env where - VTop :: Val f '[] - VPush :: f t -> Val f env -> Val f (t : env) - -type SVal = Val (Const String) - -valprj :: Val f env -> Idx env t -> f t -valprj (VPush x _) IZ = x -valprj (VPush _ env) (IS i) = valprj env i -valprj VTop i = case i of {} +type SVal = SList (Const String) newtype M a = M { runM :: Int -> (a, Int) } deriving (Functor) @@ -51,15 +42,20 @@ genNameIfUsedIn' prefix ty idx ex genNameIfUsedIn :: STy a -> Idx env a -> Expr x env t -> M String genNameIfUsedIn = genNameIfUsedIn' "x" +valprj :: SList f env -> Idx env t -> f t +valprj (x `SCons` _) IZ = x +valprj (_ `SCons` env) (IS i) = valprj env i +valprj SNil i = case i of {} + ppExpr :: SList STy env -> Expr x env t -> String ppExpr senv e = fst (runM (mkVal senv >>= \val -> ppExpr' 0 val e) 1) "" where mkVal :: SList STy env -> M (SVal env) - mkVal SNil = return VTop + mkVal SNil = return SNil mkVal (SCons _ v) = do val <- mkVal v name <- genName - return (VPush (Const name) val) + return (Const name `SCons` val) ppExpr' :: Int -> SVal env -> Expr x env t -> M ShowS ppExpr' d val = \case @@ -94,9 +90,9 @@ ppExpr' d val = \case e' <- ppExpr' 0 val e let STEither t1 t2 = typeOf e name1 <- genNameIfUsedIn t1 IZ a - a' <- ppExpr' 0 (VPush (Const name1) val) a + a' <- ppExpr' 0 (Const name1 `SCons` val) a name2 <- genNameIfUsedIn t2 IZ b - b' <- ppExpr' 0 (VPush (Const name2) val) b + b' <- ppExpr' 0 (Const name2 `SCons` val) b return $ showParen (d > 0) $ showString "case " . e' . showString (" of { Inl " ++ name1 ++ " -> ") . a' . showString (" ; Inr " ++ name2 ++ " -> ") . b' . showString " }" @@ -104,21 +100,21 @@ ppExpr' d val = \case EBuild1 _ a b -> do a' <- ppExpr' 11 val a name <- genNameIfUsedIn (STScal STI64) IZ b - b' <- ppExpr' 0 (VPush (Const name) val) b + b' <- ppExpr' 0 (Const name `SCons` val) b return $ showParen (d > 10) $ showString "build1 " . a' . showString (" (\\" ++ name ++ " -> ") . b' . showString ")" EBuild _ n a b -> do a' <- ppExpr' 11 val a name <- genNameIfUsedIn (tTup (sreplicate n tIx)) IZ b - e' <- ppExpr' 0 (VPush (Const name) val) b + e' <- ppExpr' 0 (Const name `SCons` val) b return $ showParen (d > 10) $ showString "build " . a' . showString (" (\\" ++ name ++ " -> ") . e' . showString ")" EFold1 _ a b -> do name1 <- genNameIfUsedIn (typeOf a) (IS IZ) a name2 <- genNameIfUsedIn (typeOf a) IZ a - a' <- ppExpr' 0 (VPush (Const name2) (VPush (Const name1) val)) a + a' <- ppExpr' 0 (Const name2 `SCons` Const name1 `SCons` val) a b' <- ppExpr' 11 val b return $ showParen (d > 10) $ showString ("fold1 (\\" ++ name1 ++ " " ++ name2 ++ " -> ") . a' @@ -142,13 +138,13 @@ ppExpr' d val = \case EIdx1 _ a b -> do a' <- ppExpr' 9 val a b' <- ppExpr' 9 val b - return $ showParen (d > 8) $ a' . showString " ! " . b' + return $ showParen (d > 8) $ a' . showString " .! " . b' EIdx _ _ a b -> do a' <- ppExpr' 9 val a b' <- ppExpr' 10 val b return $ showParen (d > 8) $ - a' . showString " !! " . b' + a' . showString " ! " . b' EShape _ e -> do e' <- ppExpr' 11 val e @@ -170,7 +166,7 @@ ppExpr' d val = \case EWith e1 e2 -> do e1' <- ppExpr' 11 val e1 name <- genNameIfUsedIn' "ac" (STAccum (typeOf e1)) IZ e2 - e2' <- ppExpr' 0 (VPush (Const name) val) e2 + e2' <- ppExpr' 0 (Const name `SCons` val) e2 return $ showParen (d > 10) $ showString "with " . e1' . showString (" (\\" ++ name ++ " -> ") . e2' . showString ")" @@ -191,7 +187,7 @@ ppExprLet d val etop = do let occ = occCount IZ body name <- genNameIfUsedIn (typeOf rhs) IZ body rhs' <- ppExpr' 0 val' rhs - (binds, core) <- collect (VPush (Const name) val') body + (binds, core) <- collect (Const name `SCons` val') body return ((name, occ, rhs') : binds, core) collect val' e = ([],) <$> ppExpr' 0 val' e |