Instantly share code, notes, and snippets.

@sdiehl /Pretty.hs Secret
Created Jun 7, 2016

Embed
What would you like to do?
name: example
version: 0.1
author: Stephen Diehl
maintainer: stephen.m.diehl@gmail.com
copyright: 2016 Stephen Diehl
category: Documentation
build-type: Simple
cabal-version: >=1.10
tested-with: GHC == 7.6.3
library
build-depends:
base >= 4.6 && <4.10,
text >= 1.2 && <1.3,
wl-pprint-text >= 1.1 && <1.2
default-language: Haskell2010
{-# LANGUAGE OverloadedStrings #-}
import Data.Monoid
import Data.Text.Lazy (Text)
import Data.Text.Lazy.IO as TL
import Text.PrettyPrint.Leijen.Text hiding ((<$>), (<>), Pretty(..))
import qualified Text.PrettyPrint.Leijen.Text as PP
parensIf :: Bool -> Doc -> Doc
parensIf True = parens
parensIf False = id
data Expr
= Var Text
| Lit Lit
| App Expr Expr
| Lam Text Expr
data Lit
= LInt Int
| LBool Bool
class Pretty a where
pretty :: Int -> a -> Doc
instance Pretty Lit where
pretty _ (LInt n) = int n
pretty _ (LBool b) = bool b
instance Pretty Expr where
pretty _ (Var x) = text x
pretty p (Lit x) = pretty p x
pretty p e@(App _ _) =
let (f, xs) = viewApp e in
let args = sep $ map (pretty (p+1)) xs in
parensIf (p>0) $ pretty p f <+> args
pretty p e@(Lam _ _) =
let body = pretty (p+1) (viewBody e) in
let vars = map text (viewVars e) in
parensIf (p>0) $ "\\" <> hsep vars <+> "." <+> body
viewVars :: Expr -> [Text]
viewVars (Lam n a) = n : viewVars a
viewVars _ = []
viewBody :: Expr -> Expr
viewBody (Lam _ a) = viewBody a
viewBody x = x
viewApp :: Expr -> (Expr, [Expr])
viewApp (App e1 e2) = go e1 [e2]
where
go (App a b) xs = go a (b : xs)
go f xs = (f, xs)
viewApp x = (x, [])
ppexpr :: Expr -> Text
ppexpr x = PP.displayT (PP.renderPretty 1.0 70 (pretty 0 x))
s, k, example :: Expr
s = Lam "f" (Lam "g" (Lam "x" (App (Var "f") (App (Var "g") (Var "x")))))
k = Lam "x" (Lam "y" (Var "x"))
example = App s k
main :: IO ()
main = do
TL.putStrLn (ppexpr s)
TL.putStrLn (ppexpr k)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment