Select Git revision
Expression.hs
-
Sean Gillespie authoredSean Gillespie authored
Code owners
Assign users and groups as approvers for specific file changes. Learn more.
Expression.hs 3.53 KiB
{-# LANGUAGE FlexibleInstances #-}
module Language.SystemF.Expression where
import Language.Lambda.Util.PrettyPrint
data SystemFExpr name ty
= Var name -- Variable
| App (SystemFExpr name ty) (SystemFExpr name ty) -- Application
| Abs name ty (SystemFExpr name ty) -- Abstraction
| TyAbs ty (SystemFExpr name ty) -- Type Abstraction
-- \X. body
| TyApp (SystemFExpr name ty) ty -- Type Application
-- x [X]
deriving (Eq, Show)
-- Pretty printing
instance (PrettyPrint n, PrettyPrint t) => PrettyPrint (SystemFExpr n t) where
prettyPrint = prettyPrint . pprExpr empty
-- Same as prettyPrint, but we assume the same type for names and types. Useful
-- for testing.
prettyPrint' :: PrettyPrint n => SystemFExpr n n -> String
prettyPrint' = prettyPrint
-- Pretty print a system f expression
pprExpr :: (PrettyPrint n, PrettyPrint t)
=> PDoc String
-> SystemFExpr n t
-> PDoc String
pprExpr pdoc (Var n) = prettyPrint n `add` pdoc
pprExpr pdoc (App e1 e2) = pprApp pdoc e1 e2
pprExpr pdoc (Abs n t body) = pprAbs pdoc n t body
pprExpr pdoc (TyAbs t body) = pprTAbs pdoc t body
pprExpr pdoc (TyApp e ty) = pprTApp pdoc e ty
-- Pretty print an application
pprApp :: (PrettyPrint n, PrettyPrint t)
=> PDoc String
-> SystemFExpr n t
-> SystemFExpr n t
-> PDoc String
pprApp pdoc e1@Abs{} e2@Abs{} = betweenParens (pprExpr pdoc e1) pdoc
`mappend` addSpace (betweenParens (pprExpr pdoc e2) pdoc)
pprApp pdoc e1 e2@App{} = pprExpr pdoc e1
`mappend` addSpace (betweenParens (pprExpr pdoc e2) pdoc)
pprApp pdoc e1 e2@Abs{} = pprExpr pdoc e1
`mappend` addSpace (betweenParens (pprExpr pdoc e2) pdoc)
pprApp pdoc e1@Abs{} e2 = betweenParens (pprExpr pdoc e1) pdoc
`mappend` addSpace (pprExpr pdoc e2)
pprApp pdoc e1 e2
= pprExpr pdoc e1 `mappend` addSpace (pprExpr pdoc e2)
pprTApp :: (PrettyPrint n, PrettyPrint t)
=> PDoc String
-> SystemFExpr n t
-> t
-> PDoc String
pprTApp pdoc expr ty = expr' `mappend` addSpace (between ty' "[" "]" empty)
where expr' = pprExpr pdoc expr
ty' = add (prettyPrint ty) empty
-- Pretty print an abstraction
pprAbs :: (PrettyPrint n, PrettyPrint t)
=> PDoc String
-> n
-> t
-> SystemFExpr n t
-> PDoc String
pprAbs pdoc name ty body = between vars' lambda' ". " (pprExpr pdoc body')