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.
135 lines
4.0 KiB
135 lines
4.0 KiB
{-# LANGUAGE ViewPatterns #-}
|
|
module Syntax.Pretty where
|
|
|
|
import Syntax
|
|
import Data.Text ( Text )
|
|
import qualified Data.Text as T
|
|
import Elaboration.Monad
|
|
type Prec = Int
|
|
|
|
domainPrec, funcPrec, argPrec :: Int
|
|
domainPrec = 3
|
|
argPrec = 2
|
|
funcPrec = 1
|
|
|
|
showWithPrec :: [Text] -> Int -> Term -> ShowS
|
|
showWithPrec names p (App Ex x y) =
|
|
showParen (p >= argPrec) $
|
|
showWithPrec names funcPrec x
|
|
. showChar ' '
|
|
. showWithPrec names argPrec y
|
|
|
|
showWithPrec names p (App Im x _) = showWithPrec names p x
|
|
|
|
showWithPrec _ _ Type = showString "Type"
|
|
showWithPrec _ _ Top = showString "⊤"
|
|
showWithPrec _ _ Unit = showString "()"
|
|
|
|
-- Reflexivity
|
|
showWithPrec _ _ Refl = showString "refl"
|
|
-- Casting
|
|
showWithPrec _ _ Coe = showString "coe"
|
|
-- Congruence (x == y → f x == f y)
|
|
showWithPrec _ _ Cong = showString "cong"
|
|
-- Symmetry
|
|
showWithPrec _ _ Sym = showString "sym"
|
|
|
|
showWithPrec _ _ (Meta (MV i)) = showChar '?' . shows i
|
|
showWithPrec _ _ (NewMeta (MV i) _) = showChar '?' . shows i
|
|
|
|
showWithPrec names _ (Bv i) =
|
|
if i < 0
|
|
then showString "α"
|
|
else showString (T.unpack (names !! i))
|
|
|
|
showWithPrec names _ (Proj1 x) = showWithPrec names funcPrec x . showString ".1"
|
|
showWithPrec names _ (Proj2 x) = showWithPrec names funcPrec x . showString ".2"
|
|
|
|
showWithPrec names p (Lam i t e) =
|
|
showParen (p >= funcPrec) $
|
|
showChar 'λ'
|
|
. showsPlicity i id (showString (T.unpack t))
|
|
. showString " → "
|
|
. showWithPrec (t:names) 0 e
|
|
|
|
showWithPrec names p (Pi Ex (T.unpack -> "_") d r) =
|
|
showParen (p >= argPrec) $
|
|
showWithPrec names domainPrec d
|
|
. showString " -> "
|
|
. showWithPrec (T.singleton '_':names) 0 r
|
|
|
|
showWithPrec names p (Pi i n d r) =
|
|
showParen (p >= argPrec) $
|
|
showsPlicity i (showParen True)
|
|
( showString (T.unpack n)
|
|
. showString " : "
|
|
. showWithPrec names 0 d
|
|
)
|
|
. showString " -> "
|
|
. showWithPrec (n:names) 0 r
|
|
|
|
showWithPrec names p (Sigma (T.unpack -> "_") d r) =
|
|
showParen (p >= argPrec) $
|
|
showWithPrec names domainPrec d
|
|
. showString " × "
|
|
. showWithPrec (T.singleton '_':names) 0 r
|
|
|
|
showWithPrec names p (Sigma n d r) =
|
|
showParen (p >= argPrec) $
|
|
showParen True
|
|
( showString (T.unpack n)
|
|
. showString " : "
|
|
. showWithPrec names 0 d
|
|
)
|
|
. showString " × "
|
|
. showWithPrec (n:names) 0 r
|
|
|
|
showWithPrec names _ (Pair a b) =
|
|
showParen True $
|
|
showWithPrec names 0 a
|
|
. showString " , "
|
|
. showWithPrec names 0 b
|
|
|
|
showWithPrec names p (Id _ b c) =
|
|
showParen (p >= funcPrec) $
|
|
showWithPrec names argPrec b . showString " == " . showWithPrec names argPrec c
|
|
|
|
showWithPrec names p (Let x t d e) =
|
|
showParen (p >= funcPrec) $
|
|
showString "let\n"
|
|
. showString (" " ++ T.unpack x)
|
|
. showString " : "
|
|
. showWithPrec names 0 t
|
|
. showChar '\n'
|
|
. showString (" " ++ T.unpack x ++ " = ")
|
|
. showWithPrec names 0 d
|
|
. showString ";\n"
|
|
. showWithPrec (x:names) 0 e
|
|
|
|
showTerm :: Int -> Term -> ShowS
|
|
showTerm = showWithPrec (iterate (`T.snoc` '\'') (T.pack "x"))
|
|
|
|
showsPlicity :: Plicity -> (ShowS -> ShowS) -> ShowS -> ShowS
|
|
showsPlicity Ex f k = f k
|
|
showsPlicity Im _ k = showChar '{' . k . showChar '}'
|
|
|
|
showElabError :: ElabError -> ShowS
|
|
showElabError (NotInScope t) = showString "Variable not in scope: " . shows t
|
|
showElabError (NotFunction names t) =
|
|
showString "Type is not a function type: "
|
|
. showWithPrec (names ++ exes) 0 t
|
|
where
|
|
exes = iterate (`T.snoc` '\'') (T.pack "x")
|
|
showElabError (NotEqual names a b) =
|
|
showString "Types are not equal:"
|
|
. showString "\n * " . showWithPrec (names ++ exes) 0 a
|
|
. showString "\n vs"
|
|
. showString "\n * " . showWithPrec (names ++ exes) 0 b
|
|
where
|
|
exes = iterate (`T.snoc` '\'') (T.pack "x")
|
|
showElabError (CantSolveMeta ns q t) =
|
|
showString "Equation has no (unique) solution: "
|
|
. showString "\n " . showWithPrec (ns ++ exes) 0 q
|
|
. showString " ≡? " . showWithPrec (ns ++ exes) 0 t
|
|
where
|
|
exes = iterate (`T.snoc` '\'') (T.pack "x")
|