Skip to content

Instantly share code, notes, and snippets.

@sdiehl 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
You can’t perform that action at this time.