less prototype, less bad code implementation of CCHM type theory
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.
 
 
 

129 lines
4.9 KiB

{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE ViewPatterns #-}
module Syntax.Pretty where
import Control.Arrow (Arrow(first))
import qualified Data.Text.Lazy as L
import qualified Data.Text as T
import Data.Text (Text)
import Presyntax.Presyntax (Plicity(..))
import Prettyprinter.Render.Terminal
import Prettyprinter
import Syntax
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
instance Pretty Name where
pretty (Bound x) = pretty x
pretty (Defined x) = pretty x
prettyTm :: Term -> Doc AnsiStyle
prettyTm (Ref v) =
case T.uncons (getNameText v) of
Just ('.', w) -> keyword (pretty w)
_ -> pretty v
prettyTm (App Im f x) = parenFun f <+> braces (prettyTm x)
prettyTm (App Ex f x) = parenFun f <+> parenArg x
prettyTm (Pair x y) = parens $ prettyTm x <> operator comma <+> prettyTm y
prettyTm (Proj1 x) = prettyTm x <> operator (pretty ".1")
prettyTm (Proj2 x) = prettyTm x <> operator (pretty ".2")
prettyTm l@(Lam _ _ _) = pretty '\\' <> hsep (map prettyArgList al) <+> pretty "->" <+> prettyTm bod where
unwindLam (Lam p x y) = first ((p, x):) (unwindLam y)
unwindLam (PathIntro _ _ _ (Lam p x y)) = first ((p, x):) (unwindLam y)
unwindLam t = ([], t)
(al, bod) = unwindLam l
prettyArgList (Ex, v) = pretty v
prettyArgList (Im, v) = braces (pretty v)
prettyTm (Meta x) = keyword $ pretty '?' <> pretty (mvName x)
prettyTm Type{} = keyword $ pretty "Type"
prettyTm Typeω{} = keyword $ pretty "Typeω"
prettyTm I{} = keyword $ pretty "I"
prettyTm I0{} = keyword $ pretty "i0"
prettyTm I1{} = keyword $ pretty "i1"
prettyTm (Pi Ex (T.unpack -> "_") d r) = prettyDom d <+> pretty "->" <+> prettyTm r
prettyTm (Pi Im v d r) = braces (pretty v <+> colon <+> prettyTm d) <+> pretty "->" <+> prettyTm r
prettyTm (Pi Ex v d r) = parens (pretty v <+> colon <+> prettyTm d) <+> pretty "->" <+> prettyTm r
prettyTm (Sigma (T.unpack -> "_") d r) = prettyDom d <+> pretty "*" <+> prettyTm r
prettyTm (Sigma v d r) = parens (pretty v <+> colon <+> prettyTm d) <+> pretty "*" <+> prettyTm r
prettyTm (IAnd x y) = parens $ prettyTm x <+> operator (pretty "&&") <+> prettyTm y
prettyTm (IOr x y) = parens $ prettyTm x <+> operator (pretty "||") <+> prettyTm y
prettyTm (INot x) = operator (pretty '~') <> prettyTm x
prettyTm (PathP l x y) = keyword (pretty "PathP") <+> parenArg l <+> parenArg x <+> parenArg y
prettyTm (IElim _ _ _ f i) = prettyTm (App Ex f i)
prettyTm (PathIntro _ _ _ f) = prettyTm f
prettyTm (IsOne phi) = prettyTm (App Ex (Ref (Bound (T.pack ".IsOne"))) phi)
prettyTm ItIsOne = keyword (pretty "1=1")
prettyTm (IsOne1 phi) = prettyTm (App Ex (Ref (Bound (T.pack ".isOne1"))) phi)
prettyTm (IsOne2 phi) = prettyTm (App Ex (Ref (Bound (T.pack ".isOne2"))) phi)
prettyTm (Partial phi a) = prettyTm $ foldl (App Ex) (Ref (Bound (T.pack ".Partial"))) [phi, a]
prettyTm (PartialP phi a) = prettyTm $ foldl (App Ex) (Ref (Bound (T.pack ".PartialP"))) [phi, a]
prettyTm (Comp a phi u a0) = prettyTm $ foldl (App Ex) (Ref (Bound (T.pack ".comp"))) [a, phi, u, a0]
prettyTm (Sub a phi u) = prettyTm a <> brackets (prettyTm phi <+> operator (pretty "->") <+> prettyTm u)
prettyTm (Inc _ _ u) = prettyTm $ foldl (App Ex) (Ref (Bound (T.pack ".inS"))) [u]
prettyTm (Ouc _ _ _ u) = prettyTm $ foldl (App Ex) (Ref (Bound (T.pack ".outS"))) [u]
prettyTm (System xs) = braces (mempty <+> hsep (punctuate comma (map go (Map.toList xs))) <+> mempty) where
go (f, t) = prettyTm f <+> operator (pretty "=>") <+> prettyTm t
keyword :: Doc AnsiStyle -> Doc AnsiStyle
keyword = annotate (color Magenta)
operator :: Doc AnsiStyle -> Doc AnsiStyle
operator = annotate (color Yellow)
parenArg :: Term -> Doc AnsiStyle
parenArg x@App{} = parens (prettyTm x)
parenArg x@IElim{} = parens (prettyTm x)
parenArg x@IsOne{} = parens $ prettyTm x
parenArg x@IsOne1{} = parens $ prettyTm x
parenArg x@IsOne2{} = parens $ prettyTm x
parenArg x@Partial{} = parens $ prettyTm x
parenArg x@PartialP{} = parens $ prettyTm x
parenArg x@Sub{} = parens $ prettyTm x
parenArg x@Inc{} = parens $ prettyTm x
parenArg x@Ouc{} = parens $ prettyTm x
parenArg x@Comp{} = parens $ prettyTm x
parenArg x = prettyDom x
prettyDom :: Term -> Doc AnsiStyle
prettyDom x@Pi{} = parens (prettyTm x)
prettyDom x@Sigma{} = parens (prettyTm x)
prettyDom x = parenFun x
parenFun :: Term -> Doc AnsiStyle
parenFun x@Lam{} = parens $ prettyTm x
parenFun x@PathIntro{} = parens $ prettyTm x
parenFun x = prettyTm x
render :: Doc AnsiStyle -> Text
render = L.toStrict . renderLazy . layoutPretty defaultLayoutOptions
showValue :: Value -> String
showValue = L.unpack . renderLazy . layoutPretty defaultLayoutOptions . prettyTm . quote
showFace :: Map Head Bool -> Doc AnsiStyle
showFace = hsep . map go . Map.toList where
go (h, b) = parens $ prettyTm (quote (VNe h mempty)) <+> operator (pretty "=") <+> pretty (if b then "i1" else "i0")
getNameText :: Name -> Text
getNameText (Bound x) = x
getNameText (Defined x) = x