module Language.SequentCore.Pretty (
pprTopLevelBinds
) where
import Language.SequentCore.Syntax
import qualified GhcPlugins as GHC
import Outputable
import PprCore ()
import Data.List
ppr_bind :: OutputableBndr b => Bind b -> SDoc
ppr_bind (NonRec val_bdr expr) = ppr_binding (val_bdr, expr)
ppr_bind (Rec binds) = hang (text "rec") 2 (vcat $ intersperse space $ ppr_block "{" ";" "}" (map ppr_binding binds))
ppr_binds_top :: OutputableBndr b => [Bind b] -> SDoc
ppr_binds_top binds = ppr_binds_with "" "" "" binds
pprTopLevelBinds :: OutputableBndr b => [Bind b] -> SDoc
pprTopLevelBinds = ppr_binds_top
ppr_block :: String -> String -> String -> [SDoc] -> [SDoc]
ppr_block open _ close [] = [text open <> text close]
ppr_block open mid close (first : rest)
= text open <+> first : map (text mid <+>) rest ++ [text close]
ppr_binds :: OutputableBndr b => [Bind b] -> SDoc
ppr_binds binds = ppr_binds_with "{" ";" "}" binds
ppr_binds_with :: OutputableBndr b => String -> String -> String -> [Bind b] -> SDoc
ppr_binds_with open mid close binds = vcat $ intersperse space $ ppr_block open mid close (map ppr_bind binds)
ppr_binding :: OutputableBndr b => (b, Value b) -> SDoc
ppr_binding (val_bdr, expr)
= pprBndr LetBind val_bdr $$
hang (ppr val_bdr <+> equals) 2 (pprCoreValue expr)
ppr_comm :: OutputableBndr b => (SDoc -> SDoc) -> Command b -> SDoc
ppr_comm add_par comm
= maybe_add_par $ ppr_let <+> cut (cmdValue comm) (cmdCont comm)
where
ppr_let
= case cmdLet comm of
[] -> empty
binds -> hang (text "let") 2 (ppr_binds binds) $$ text "in"
maybe_add_par = if null (cmdLet comm) then noParens else add_par
cut val Return
= ppr_value add_par val
cut val cont
= cat [text "<" <> pprCoreValue val, vcat $ ppr_block "|" ";" ">" $ ppr_cont_frames cont]
ppr_value :: OutputableBndr b => (SDoc -> SDoc) -> Value b -> SDoc
ppr_value _ (Var name) = ppr name
ppr_value add_par (Type ty) = add_par $ char '@' <+> ppr ty
ppr_value _ (Coercion _) = text "CO ..."
ppr_value add_par (Lit lit) = GHC.pprLiteral add_par lit
ppr_value add_par value@(Lam _ _)
= let
(bndrs, body) = collectLambdas value
in
add_par $
hang (char '\\' <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow)
2 (pprCoreComm body)
ppr_value add_par (Cons ctor args)
= add_par $
hang (ppr ctor) 2 (sep (map (ppr_value parens) args))
ppr_value add_par (Compute comm)
= ppr_comm add_par comm
ppr_value add_par (Cont k)
= ppr_cont add_par k
ppr_cont_frames :: OutputableBndr b => Cont b -> [SDoc]
ppr_cont_frames (App v k)
= char '$' <+> ppr_value noParens v : ppr_cont_frames k
ppr_cont_frames (Case var _ alts k)
= (hang (text "case as" <+> pprBndr CaseBind var <+> text "of") 2 $
vcat $ ppr_block "{" ";" "}" (map pprCoreAlt alts)) : ppr_cont_frames k
ppr_cont_frames (Cast _ k)
= text "cast ..." : ppr_cont_frames k
ppr_cont_frames (Tick _ k)
= text "tick ..." : ppr_cont_frames k
ppr_cont_frames Return
= []
ppr_cont_frames (Jump x)
= [text "jump" <+> ppr x]
ppr_cont :: OutputableBndr b => (SDoc -> SDoc) -> Cont b -> SDoc
ppr_cont add_par k
| null frames
= text "pass"
| otherwise
= add_par $ sep $ punctuate semi (ppr_cont_frames k)
where frames = ppr_cont_frames k
pprCoreAlt :: OutputableBndr b => Alt b -> SDoc
pprCoreAlt (Alt con args rhs)
= hang (ppr_case_pat con args <+> arrow) 2 (pprCoreComm rhs)
ppr_case_pat :: OutputableBndr a => GHC.AltCon -> [a] -> SDoc
ppr_case_pat con args
= ppr con <+> (fsep (map ppr_bndr args))
where
ppr_bndr = pprBndr CaseBind
pprCoreComm :: OutputableBndr b => Command b -> SDoc
pprCoreComm comm = ppr_comm noParens comm
pprCoreValue :: OutputableBndr b => Value b -> SDoc
pprCoreValue val = ppr_value noParens val
noParens :: SDoc -> SDoc
noParens pp = pp
instance OutputableBndr b => Outputable (Bind b) where
ppr = ppr_bind
instance OutputableBndr b => Outputable (Value b) where
ppr = ppr_value noParens
instance OutputableBndr b => Outputable (Command b) where
ppr = ppr_comm noParens
instance OutputableBndr b => Outputable (Cont b) where
ppr = ppr_cont noParens
instance OutputableBndr b => Outputable (Alt b) where
ppr = pprCoreAlt