Pretty.hs

-- | Pretty printer for Textual AST.

{-# LANGUAGE FlexibleInstances #-}

module Language.Wasm.Pretty (
  pretty,
  display,
) where

import Prelude hiding ((<$>))

import Language.Wasm.Syntax
import qualified Data.Text as T
import Text.PrettyPrint.ANSI.Leijen

instance Pretty Name where
  pretty (Name t) = text (T.unpack t)
  pretty (UnName n) = pretty (fromIntegral n :: Int)

instance Pretty Expr where
  prettyList = nest 4 . vsep . map (parens . pretty)
  pretty expr = case expr of
    Nop                    -> text "nop"
    Unreachable            -> text "unreachable"
    Block name e           -> text "block" <+> maybe empty pretty name <$> pretty e
    If cond true           -> text "if" <+> pretty [cond,true]
    IfElse cond true false -> text "if_else" <+> pretty [cond,true,false]
    BrIf cond name e       -> text "todo"
    Loop{}                 -> text "todo"
    Br name e              -> pretty [text "br" <+> pretty name]
    Return e               -> text "return" <+> parens (pretty e)
    Call name _            -> text "todo"
    Const typ value        -> pretty typ <> dot <> text "const" <+> pretty value
    Lit value              -> pretty value
    Load memop e           -> text "todo"
    Store memop e          -> text "todo"
    GetLocal name          -> text "get_local" <+> pretty name
    SetLocal name e        -> text "set_local" <+> pretty name <+> parens (pretty e)
    LoadExtend extop e     -> text "todo"
    StoreWrap wrapop e1 e2 -> text "todo"
    Bin binop typ e1 e2    -> pretty typ <> dot <> pretty binop <+> parens (pretty e1) <+> parens( pretty e2)
    Un unop typ e          -> pretty typ <> dot <> pretty unop <+> parens (pretty e)
    Rel relop typ e1 e2    -> pretty typ <> dot <> pretty relop <+> parens (pretty e1) <+> parens( pretty e2)
    Sel selop e1 e2 e3     -> text "todo"
    Convert cvtop ty e     -> text "todo"
    Host hostop _          -> text "todo"

instance Pretty BinOp where
  pretty binop = text $ case binop of
    Add      -> "add"
    Sub      -> "sub"
    Mul      -> "mul"
    DivS     -> "divs"
    DivU     -> "divu"
    RemS     -> "rems"
    RemU     -> "remu"
    And      -> "and"
    Or       -> "or"
    Xor      -> "xor"
    Shl      -> "shl"
    ShrU     -> "shr_u"
    ShrS     -> "shr_s"
    RotL     -> "rotl"
    RotR     -> "Rotr"
    Div      -> "div"
    CopySign -> "copysign"
    Min      -> "min"
    Max      -> "max"

instance Pretty UnOp where
  pretty unop = text $ case unop of
    Clz     -> "clz"
    Ctz     -> "ctz"
    Popcnt  -> "popcnt"
    Neg     -> "neg"
    Abs     -> "abs"
    Ceil    -> "ceil"
    Floor   -> "floor"
    Trunc   -> "trunc"
    Nearest -> "nearest"
    Sqrt    -> "sqrt"

instance Pretty RelOp where
  pretty relop = text $ case relop of
    Eqz -> "eqz"
    Eq  -> "eq"
    Ne  -> "ne"
    LtS -> "lts"
    LtU -> "ltu"
    LeS -> "les"
    LeU -> "leu"
    GtS -> "gts"
    GtU -> "gtu"
    GeS -> "ges"
    GeU -> "geu"
    Lt  -> "lt"
    Le  -> "le"
    Gt  -> "gt"
    Ge  -> "ge"

instance Pretty Value where
  pretty value = text $ case value of
    VI32 v -> show v
    VI64 v -> show v
    VF32 v -> show v
    VF64 v -> show v

instance Pretty Func where
  prettyList = vsep . map (parens . pretty)
  pretty f = case f of
    Export name value     -> text "export" <+> pretty name <+> pretty value
    Import name value     -> text "Import" <+> pretty name <+> pretty value
    Func name params body -> nest 4 (text "func" <+> maybe empty pretty name <+> pretty params <$> pretty body )

instance Pretty Decl where
  pretty d = case d of
    ModDecl m     -> pretty m
    ExprDecl expr -> pretty expr

instance Pretty Module where
  pretty Module { _funcs=funcs } = parens (nest 4 (text "module" <$> pretty funcs))

instance Pretty Param where
  prettyList = fillSep . map (parens . pretty)
  pretty param = case param of
    Param (Just name) typ -> text  "param" <+> pretty name <+> pretty typ
    Param Nothing typ     -> text  "param" <+> pretty typ
    Result typ            -> text  "result" <+> pretty typ
    Body expr             -> pretty expr

instance Pretty Type where
  pretty ty = text $ case ty of
    I32      -> "i32"
    I64      -> "i64"
    F32      -> "f32"
    F64      -> "f64"
    FuncType -> "func"

display :: Pretty a => a -> String
display x = displayS (renderPretty 0.4 180 (pretty x)) ""