|
|
- {-# LANGUAGE LambdaCase #-}
- {-# OPTIONS_GHC -Wno-orphans #-}
- {-# LANGUAGE ViewPatterns #-}
- {-# LANGUAGE NamedFieldPuns #-}
- {-# LANGUAGE CPP #-}
- module Syntax.Pretty where
-
- import qualified Data.Map.Strict as Map
- import qualified Data.Text.Lazy as Lazy
- import qualified Data.Text as T
- import Data.Map.Strict (Map)
-
- import Presyntax.Presyntax (Plicity(..))
-
- import Prettyprinter.Render.Terminal
- import Prettyprinter
-
- import Syntax
-
- instance Pretty Name where
- pretty x = pretty (getNameText x) -- <> pretty '\'' <> pretty (getNameNum x)
-
- prettyTm' :: Bool -> Term -> Doc AnsiStyle
- prettyTm' implicits = go True 0 where
- go t p =
- \case
- Ref v -> pretty v
- Con v -> keyword $ pretty v
- PCon _ v -> keyword $ pretty v
- Data _ v -> keyword $ pretty v
-
- App Im f x
- | implicits -> parenIf (p >= arg_prec) $
- go False fun_prec f
- <+> braces (go False 0 x)
- | otherwise -> go t p f
- App Ex f x ->
- parenIf (p >= arg_prec) $
- go False fun_prec f
- <+> group (go False arg_prec x)
-
- Lam Ex v (App Ex f (Ref v')) | v == v' -> instead f
- Lam i v t ->
- let
- getArgs (Lam i v t) =
- let (as, b) = getArgs t in ((i, v):as, b)
- getArgs (PathIntro _ _ _ (Lam _ v t)) =
- let (as, b) = getArgs t in ((Ex, v):as, b)
- getArgs t = ([], t)
-
- (as, b) = getArgs (Lam i v t)
- in
- parenIf (p >= fun_prec) . group $
- pretty '\\' <> hsep (map (\(i, v) -> braceIf (i == Im) (pretty v)) as)
- <+> arrow
- <+> nest 2 (go False 0 b)
-
- Pi _ (T.unpack . getNameText -> "_") d r ->
- parenIf (p >= fun_prec) $
- group (go False dom_prec d)
- <> space <> arrow <> sp
- <> go t 0 r
-
- Pi i x d r ->
- let
- c = case r of
- Pi _ (getNameText -> x) _ _ | x /= T.pack "_" -> sp
- _ -> space <> arrow <> sp
- in
- parenIf (p >= fun_prec) $
- plic i (pretty x <+> colon <+> go False 0 d)
- <> c <> go t 0 r
-
- Let binds body ->
- parenIf (p >= fun_prec) $
- align $ keyword (pretty "let")
- <> line
- <> indent 2 (prettyBinds False binds)
- <> keyword (pretty "in")
- <+> go False 0 body
-
- Meta MV{mvName} -> keyword (pretty '?' <> pretty mvName)
-
- Type -> keyword (pretty "Type")
- Typeω -> keyword (pretty "Pretype")
-
- Sigma (T.unpack . getNameText -> "_") d r ->
- parenIf (p >= fun_prec) $
- go False dom_prec d
- <+> operator (pretty "*")
- <+> go False dom_prec r
- Sigma v d r ->
- parenIf (p >= fun_prec) . align $
- group (parens (pretty v <+> colon <+> go False 0 d))
- <+> operator (pretty "*") <+> go False dom_prec r
-
- Pair a b -> parens $ go False 0 a <> comma <+> go False 0 b
- Proj1 a -> parenIf (p >= arg_prec) $ go False 0 a <> keyword (pretty ".1")
- Proj2 a -> parenIf (p >= arg_prec) $ go False 0 a <> keyword (pretty ".2")
-
- I -> keyword (pretty "I")
- I0 -> keyword (pretty "i0")
- I1 -> keyword (pretty "i1")
-
- IAnd x y -> parenIf (True || p > and_prec) $
- go False and_prec x <+> operator (pretty "/\\") <+> go False and_prec y
-
- IOr x y -> parenIf (True || p > or_prec) $
- go False or_prec x <+> operator (pretty "\\/") <+> go False or_prec y
-
- INot x -> operator (pretty "~") <> go False p x
-
- PathP _ x y -> parenIf (p >= arg_prec) $
- go False 0 x <+> operator (pretty "≡") <+> go False 0 y
-
- IElim _a _x _y f i -> instead (App Ex f i)
- PathIntro _a _x _y f -> instead f
-
- Partial a p -> apps (con "Partial") [(Ex, a), (Ex, p)]
- PartialP a p -> apps (con "PartialP") [(Ex, a), (Ex, p)]
-
- System fs | Map.null fs -> brackets mempty
- System fs ->
- let
- face (f, t) = go False 0 f <+> operator (pretty "=>") <+> go False 0 t
- in
- brackets (line <> nest 2 (vsep (punctuate comma (map face (Map.toList fs)))) <> line)
-
- Sub a phi u -> apps (con "Sub") [(Ex, a), (Ex, phi), (Ex, u)]
- Inc a phi u -> apps (con "inS") [(Im, a), (Im, phi), (Ex, u)]
- Ouc a phi u a0 -> apps (con "outS") [(Im, a), (Im, phi), (Im, u), (Ex, a0)]
-
- GlueTy a phi t e -> apps (con "primGlue") [(Ex, a), (Ex, phi), (Ex, t), (Ex, e)]
- Glue _a _phi _ty _e t im -> apps (con "glue") [(Ex, t), (Ex, im)]
- Unglue _a _phi _ty _e t -> apps (con "unglue") [(Im, _a), (Im, _phi), (Im, _ty), (Im, _e), (Ex, t)]
-
- Comp a phi u a0 -> apps (con "comp") [(Ex, a), (Im, phi), (Ex, u), (Ex, a0)]
- HComp a phi u a0 -> apps (con "hcomp") [(Im, a), (Im, phi), (Ex, u), (Ex, a0)]
-
- Case _ t cs ->
- let
- oneCase (c, 0, l) = go False 0 c <+> operator (pretty "=>") <+> go False 0 l
- oneCase (c, i, l) =
- let (args, bd) = getLams i l
- in go False 0 c <+> hsep (map pretty args) <+> operator (pretty "=>") <+> go False 0 bd
-
- getLams 0 x = ([], x)
- getLams n (Lam _ v t) = let (as, b) = getLams (n - 1) t in (v:as, b)
- getLams _ x = ([], x)
- in
- parenIf (p >= fun_prec) $
- keyword (pretty "case") <+> go False 0 t <+> keyword (pretty "of")
- <> line
- <> indent 2 (vsep (map oneCase cs))
-
- EqS _ x y -> parenIf (p >= arg_prec) $
- go False 0 x <+> operator (pretty "≡S") <+> go False 0 y
-
- Syntax.Refl _ _ -> keyword (pretty "refl")
- Syntax.AxK _ _ bigp pr eq -> apps (con "K_s") [(Ex, bigp), (Ex, pr), (Ex, eq)]
- Syntax.AxJ _ _ bigp pr _ eq -> apps (con "J_s") [(Ex, bigp), (Ex, pr), (Ex, eq)]
- where
- sp | t = softline
- | otherwise = space
-
- parenIf p x | p = parens x
- | otherwise = x
-
- braceIf p x | p = braces x
- | otherwise = x
-
- con x = Con (Bound (T.pack x) 0)
-
- plic = \case
- Ex -> parens
- Im -> braces
-
- arrow = operator (pretty "->")
-
- instead = go t p
- apps :: Term -> [(Plicity, Term)] -> Doc AnsiStyle
- apps f xs = instead (foldl (\f (p, x) -> App p f x) f xs)
-
- prettyBinds :: Bool -> [(Name, Term, Term)] -> Doc AnsiStyle
- prettyBinds _ [] = mempty
- prettyBinds imp ((x, ty, tm):bs) =
- pretty x <+> colon <+> align (prettyTm' imp ty)
- <> line
- <> pretty x <+> equals <+> align (prettyTm' imp tm)
- <> line
- <> prettyBinds imp bs
-
- showFace :: Bool -> Map Head Bool -> Doc AnsiStyle
- showFace imp = hsep . map go . Map.toList where
- go (h, b) = parens $ prettyTm' imp (quoteWith False mempty (VNe h mempty)) <+> operator (pretty "=") <+> pretty (if b then "i1" else "i0")
-
- prettyVl' :: Bool -> Value -> Doc AnsiStyle
- prettyVl' b = prettyTm' b . quoteWith True mempty
-
- instance Pretty Term where
- pretty = unAnnotate . prettyTm
-
- prettyTm :: Term -> Doc AnsiStyle
- prettyTm = prettyTm' printImplicits
-
- instance Pretty Value where
- pretty = unAnnotate . prettyVl
-
- prettyVl :: Value -> Doc AnsiStyle
- prettyVl = prettyVl' printImplicits
-
- printImplicits :: Bool
- #if defined(RELEASE)
- printImplicits = False
- #else
- printImplicits = True
- #endif
-
- render :: Doc AnsiStyle -> Lazy.Text
- render = renderLazy . layoutSmart defaultLayoutOptions
-
- arg_prec, fun_prec, dom_prec, and_prec, or_prec :: Int
- dom_prec = succ fun_prec
- arg_prec = succ and_prec
- and_prec = succ or_prec
- or_prec = succ fun_prec
- fun_prec = 1
-
- keyword :: Doc AnsiStyle -> Doc AnsiStyle
- keyword = annotate (color Magenta)
-
- operator :: Doc AnsiStyle -> Doc AnsiStyle
- operator = annotate (color Yellow)
|