You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
229 lines
7.2 KiB
229 lines
7.2 KiB
{-# 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 L
|
|
import qualified Data.Text as T
|
|
import Data.Map.Strict (Map)
|
|
import Data.Text (Text)
|
|
|
|
import Presyntax.Presyntax (Plicity(..))
|
|
|
|
import Prettyprinter.Render.Terminal
|
|
import Prettyprinter
|
|
|
|
import Syntax
|
|
|
|
instance Pretty Name where
|
|
pretty = pretty . getNameText
|
|
|
|
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 (align (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 v d r ->
|
|
parenIf (p >= fun_prec) . align $
|
|
group (parens (pretty v <+> colon <+> go False 0 d))
|
|
<+> operator (pretty "*") <+> go False 0 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 (p > and_prec) $
|
|
go False and_prec x <+> operator (pretty "/\\") <+> go False and_prec y
|
|
|
|
IOr x y -> parenIf (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 -> braces mempty
|
|
System fs ->
|
|
let
|
|
face (f, t) = go False 0 f <+> operator (pretty "=>") <+> align (go False 0 t)
|
|
in
|
|
braces (line <> indent 2 (align (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") [(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 (quote (VNe h mempty)) <+> operator (pretty "=") <+> pretty (if b then "i1" else "i0")
|
|
|
|
prettyVl' :: Bool -> Value -> Doc AnsiStyle
|
|
prettyVl' b = prettyTm' b . quote
|
|
|
|
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 -> Text
|
|
render = L.toStrict . 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)
|