module Text.PrettyPrint.Leijen.DocExpr
(
Expr(..)
, FromExpr(..)
, lift, var, fun, apply, ($$), Associativity(..), op
, lambdaX, letX, tupleX, ccall, dotX, onDoc
, HasExpr(..), HasExprU(..)
, prettyExpr
, docParen
) where
import Data.Ratio (Ratio)
import Text.PrettyPrint.Leijen
import Text.PrettyPrint.Leijen.PrettyPrec
data Expr = Expr
{ edoc :: Int -> Doc
}
instance Pretty Expr where pretty = prettyPrec 0
instance PrettyPrec Expr where prettyPrec = flip edoc
instance Show Expr where showsPrec = showsPretty
var :: String -> Expr
var = lift
lift :: PrettyPrec a => a -> Expr
lift x = Expr (\ p -> prettyPrec p x)
data Associativity = InfixL | Infix | InfixR deriving Eq
op' :: Bool -> Associativity -> Int -> String -> Expr -> Expr -> Expr
op' spaces fix prec name a b =
withPrec prec $
align (bump InfixL a `pre` text name `post` bump InfixR b)
where
bump fix' c = edoc c (if fix == fix' then prec else prec + 1)
pre | spaces = (<+>)
| otherwise = (<>)
post | spaces && not (null name) = (</>)
| otherwise = (<>)
op :: Associativity -> Int -> String -> Expr -> Expr -> Expr
op = op' True
docParen :: Bool -> Doc -> Doc
docParen True = parens
docParen False = id
withPrec :: Int -> Doc -> Expr
withPrec n b = Expr $ \ p -> docParen (p > n) b
lambdaX :: String -> Expr -> Expr
lambdaX x body = withPrec 0 $
char '\\' <+> text x <+> text "->" <+> pretty body
letX :: String -> Expr -> Expr -> Expr
letX x rhs body = withPrec 0 $ hang 2 $
text "let" <+> text x <+> equals <+> pretty rhs
<+> text "in " <$$> pretty body
tupleX :: [Expr] -> Expr
tupleX = Expr . const . tupled . map (flip edoc 0)
ccall :: String -> [Expr] -> Expr
ccall f args = withPrec 9 $ text f <> edoc (tupleX args) 0
dotX :: String -> Expr -> Expr
dotX str e = op' False InfixR 10 "." e (var str)
onDoc :: (Doc -> Doc) -> (Expr -> Expr)
onDoc f (Expr ed) = Expr (f . ed)
class FromExpr a where
fromExpr :: Expr -> a
instance FromExpr Expr where
fromExpr = id
instance (PrettyPrec a, FromExpr b) => FromExpr (a -> b) where
fromExpr f a = fromExpr (f $$ lift a)
fun :: FromExpr a => String -> a
fun = fromExpr . var
infixr 0 $$
apply, ($$) :: Expr -> Expr -> Expr
apply = op InfixL 10 ""
($$) = apply
noOv :: String -> a
noOv meth = error $ meth ++ ": No overloading for Expr"
instance Eq Expr where
(==) = noOv "(==)"
instance Ord Expr where
compare = noOv "compare"
min = fun "min"
max = fun "max"
instance Num Expr where
fromInteger = lift
(+) = op InfixL 6 "+"
() = op InfixL 6 "-"
(*) = op InfixL 7 "*"
negate = fun "negate"
abs = fun "abs"
signum = fun "signum"
instance Real Expr where
toRational = noOv "toRational"
instance Integral Expr where
toInteger = noOv "toInteger"
quotRem a b = (quot a b, rem a b)
divMod a b = (div a b, mod a b)
quot = op InfixL 7 "`quot`"
rem = op InfixL 7 "`rem`"
div = op InfixL 7 "`div`"
mod = op InfixL 7 "`mod`"
instance Fractional Expr where
(/) = op InfixL 7 "/"
recip = fun "recip"
fromRational = lift
instance Floating Expr where
pi = var "pi"
exp = fun "exp"
sqrt = fun "sqrt"
log = fun "log"
(**) = op InfixR 8 "**"
sin = fun "sin"
cos = fun "cos"
sinh = fun "sinh"
cosh = fun "cosh"
asin = fun "asin"
acos = fun "acos"
atan = fun "atan"
asinh = fun "asinh"
acosh = fun "acosh"
atanh = fun "atanh"
instance Enum Expr where
succ = fun "succ"
pred = fun "pred"
toEnum = fun "toEnum"
fromEnum = noOv "fromEnum"
enumFrom = noOv "enumFrom"
enumFromThen = noOv "enumFromThen"
enumFromTo = noOv "enumFromTo"
enumFromThenTo = noOv "enumFromThenTo"
class Show a => HasExpr a where
expr :: a -> Expr
expr = var . show
instance HasExpr Expr where expr = id
instance HasExpr Doc where expr = lift
instance HasExpr () where expr = lift
instance HasExpr Bool where expr = lift
instance HasExpr Char where expr = lift
instance HasExpr Int where expr = lift
instance HasExpr Integer where expr = lift
instance HasExpr Float where expr = lift
instance HasExpr Double where expr = lift
instance (Show a, PrettyPrec a) => HasExpr [a]
where expr = lift
instance (Show a, Show b, Pretty a,Pretty b) => HasExpr (a,b) where
expr = lift
instance (Show a,Show b,Show c,Pretty a,Pretty b,Pretty c) => HasExpr (a,b,c) where
expr = lift
instance (Show a, PrettyPrec a) => HasExpr (Maybe a) where expr = lift
instance Integral a => HasExpr (Ratio a) where expr = lift
class HasExprU h where
exprU :: forall a. h a -> Expr
prettyExpr :: HasExpr a => Int -> a -> Doc
prettyExpr p x = edoc (expr x) p