@ -1,17 +1,15 @@
{- # LANGUAGE LambdaCase # -}
{- # OPTIONS_GHC - Wno - orphans # -}
{- # LANGUAGE ViewPatterns # -}
{- # LANGUAGE NamedFieldPuns # -}
module Syntax.Pretty where
import Control.Arrow ( Arrow ( first ) )
import qualified Data.Map.Strict as Map
import qualified Data.Text.Lazy as L
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Map.Strict ( Map )
import Data.Text ( Text )
import Data.Set ( Set )
import Data.Generics
import Presyntax.Presyntax ( Plicity ( .. ) )
@ -24,187 +22,188 @@ instance Pretty Name where
pretty = pretty . getNameText
prettyTm :: Term -> Doc AnsiStyle
prettyTm = prettyTm . everywhere ( mkT beautify ) where
prettyTm ( Ref v ) =
case T . uncons ( getNameText v ) of
Just ( '.' , w ) -> keyword ( pretty w )
_ -> pretty v
prettyTm ( Con v ) = keyword ( pretty v )
prettyTm ( PCon _ v ) = keyword ( pretty v )
prettyTm ( Data _ v ) = operator ( pretty v )
prettyTm = 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 _ -> 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 binds )
<> keyword ( pretty " in " )
<+> go False 0 body
Meta MV { mvName } -> keyword ( 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
IsOne p -> brackets ( go False 0 p )
ItIsOne -> keyword ( pretty " 1=1 " )
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 ( vsep ( map face ( Map . toList fs ) ) ) <> line )
Sub a phi u -> apps ( con " Sub " ) [ ( Ex , a ) , ( Ex , phi ) , ( Ex , u ) ]
Inc _ _hi u -> apps ( con " inS " ) [ ( Ex , u ) ]
Ouc _ _hi _ a0 -> apps ( con " outS " ) [ ( 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 ) , ( Ex , phi ) , ( Ex , u ) , ( Ex , a0 ) ]
HComp a phi u a0 -> apps ( con " hcomp " ) [ ( Ex , a ) , ( Ex , 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 :: [ ( Name , Term , Term ) ] -> Doc AnsiStyle
prettyBinds [] = mempty
prettyBinds ( ( x , ty , tm ) : bs ) =
pretty x <+> colon <+> align ( prettyTm ty )
<> line
<> pretty x <+> equals <+> align ( prettyTm tm )
<> line
<> prettyBinds bs
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 " -> " <+> nest 2 ( 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
used = freeVars bod
prettyArgList ( Ex , v )
| v ` Set . member ` used = pretty v
| otherwise = pretty " _ "
prettyArgList ( Im , v )
| v ` Set . member ` used = braces $ pretty v
| otherwise = pretty " _ "
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 . getNameText -> " _ " ) d r ) = prettyDom d <+> pretty " -> " <+> prettyTm r
prettyTm ( Pi Im v d r ) = group ( braces ( pretty v <+> colon <+> prettyTm d ) ) <> softline <> pretty " -> " <+> prettyTm r
prettyTm ( Pi Ex v d r ) = group ( parens ( pretty v <+> colon <+> prettyTm d ) ) <> softline <> pretty " -> " <+> prettyTm r
prettyTm ( Sigma ( T . unpack . getNameText -> " _ " ) 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 ( System ( Map . null -> True ) ) = braces mempty
prettyTm ( System xs ) = braces ( line <> indent 2 ( vcat ( punctuate comma ( map go ( Map . toList xs ) ) ) ) <> line ) where
go ( f , t ) = prettyTm f <+> operator ( pretty " => " ) <+> prettyTm t
prettyTm ( Case _ x xs ) = keyword ( pretty " case " ) <+> prettyTm x <+> keyword ( pretty " of " ) <+> braces ( line <> indent 2 ( prettyCase xs ) <> line )
prettyTm ( Let xs e ) = align $ keyword ( pretty " let " ) <+> braces ( line <> indent 2 ( prettyLet xs ) <> line ) <+> keyword ( pretty " in " ) <+> prettyTm e
prettyTm x = error ( show x )
prettyCase = vcat . map go where
go ( x , _ , xs ) = prettyTm x <+> operator ( pretty " => " ) <+> prettyTm xs
prettyLet = vcat . map go where
go ( x , t , y ) = pretty x <+> align ( colon <+> nest ( - 1 ) ( prettyTm t ) ) <> line <> pretty x <+> pretty " = " <+> prettyTm y
beautify ( PathP l x y ) = toFun " PathP " [ l , x , y ]
beautify ( IElim _ _ _ f i ) = App Ex f i
beautify ( PathIntro _ _ _ f ) = f
beautify ( App _ ( Lam _ v b ) _ )
| v ` Set . notMember ` freeVars b = beautify b
beautify ( IsOne phi ) = toFun " IsOne " [ phi ]
beautify ItIsOne = Ref ( Bound ( T . pack " .1=1 " ) 0 )
beautify ( Lam Ex v ( App Ex f ( Ref v' ) ) )
| v == v' , v ` Set . notMember ` freeVars f = f
beautify ( Comp a I0 ( System ( Map . null -> True ) ) a0 ) = toFun " transp " [ a , a0 ]
beautify ( Lam _ _ ( Lam _ _ ( System ( Map . null -> True ) ) ) ) = System mempty
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 " )
beautify ( Partial phi a ) = toFun " Partial " [ phi , a ]
beautify ( PartialP phi a ) = toFun " PartialP " [ phi , a ]
beautify ( Comp a phi u a0 ) = toFun " comp " [ a , phi , u , a0 ]
beautify ( HComp a phi u a0 ) = toFun " hcomp " [ a , phi , u , a0 ]
beautify ( Sub a phi u ) = toFun " Sub " [ a , phi , u ]
beautify ( Inc _ _ u ) = toFun " inS " [ u ]
beautify ( Ouc a phi u u0 ) = toFun " outS " [ a , phi , u , u0 ]
prettyVl :: Value -> Doc AnsiStyle
prettyVl = prettyTm . quote
beautify ( GlueTy _ I1 ( Lam _ _ a ) _ ) = a
beautify ( GlueTy a b c d ) = toFun " Glue " [ a , b , c , d ]
beautify ( Glue a b c d e f ) = toFun " glue " [ a , b , c , d , e , f ]
beautify ( Unglue a b c d e ) = toFun " unglue " [ a , b , c , d , e ]
beautify x = x
render :: Doc AnsiStyle -> Text
render = L . toStrict . renderLazy . layoutSmart defaultLayoutOptions
toFun s a = foldl ( App Ex ) ( Ref ( Bound ( T . pack ( '.' : s ) ) 0 ) ) a
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 )
parenArg :: Term -> Doc AnsiStyle
parenArg x @ App { } = parens ( prettyTm x )
parenArg x @ IElim { } = parens ( prettyTm x )
parenArg x @ IsOne { } = 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 @ Case { } = 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 . layoutSmart defaultLayoutOptions
showValue :: Value -> String
showValue = L . unpack . renderLazy . layoutSmart 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 " )
freeVars :: Term -> Set Name
freeVars ( Ref v ) = Set . singleton v
freeVars ( App _ f x ) = Set . union ( freeVars f ) ( freeVars x )
freeVars ( Pi _ n x y ) = Set . union ( freeVars x ) ( n ` Set . delete ` freeVars y )
freeVars ( Lam _ n x ) = n ` Set . delete ` freeVars x
freeVars ( Let ns x ) = Set . union ( freeVars x ` Set . difference ` bound ) freed where
bound = Set . fromList ( map ( \ ( x , _ , _ ) -> x ) ns )
freed = foldr ( \ ( _ , x , y ) -> Set . union ( Set . union ( freeVars x ) ( freeVars y ) ) ) mempty ns
freeVars Meta { } = mempty
freeVars Con { } = mempty
freeVars PCon { } = mempty
freeVars Data { } = mempty
freeVars Type { } = mempty
freeVars Typeω { } = mempty
freeVars I { } = mempty
freeVars I0 { } = mempty
freeVars I1 { } = mempty
freeVars ( Sigma n x y ) = Set . union ( freeVars x ) ( n ` Set . delete ` freeVars y )
freeVars ( Pair x y ) = Set . unions $ map freeVars [ x , y ]
freeVars ( Proj1 x ) = Set . unions $ map freeVars [ x ]
freeVars ( Proj2 x ) = Set . unions $ map freeVars [ x ]
freeVars ( IAnd x y ) = Set . unions $ map freeVars [ x , y ]
freeVars ( IOr x y ) = Set . unions $ map freeVars [ x , y ]
freeVars ( INot x ) = Set . unions $ map freeVars [ x ]
freeVars ( PathP x y z ) = Set . unions $ map freeVars [ x , y , z ]
freeVars ( IElim x y z a b ) = Set . unions $ map freeVars [ x , y , z , a , b ]
freeVars ( PathIntro x y z a ) = Set . unions $ map freeVars [ x , y , z , a ]
freeVars ( IsOne a ) = Set . unions $ map freeVars [ a ]
freeVars ItIsOne { } = mempty
freeVars ( Partial x y ) = Set . unions $ map freeVars [ x , y ]
freeVars ( PartialP x y ) = Set . unions $ map freeVars [ x , y ]
freeVars ( System fs ) = foldr ( \ ( x , y ) -> Set . union ( Set . union ( freeVars x ) ( freeVars y ) ) ) mempty ( Map . toList fs )
freeVars ( Sub x y z ) = Set . unions $ map freeVars [ x , y , z ]
freeVars ( Inc x y z ) = Set . unions $ map freeVars [ x , y , z ]
freeVars ( Ouc x y z a ) = Set . unions $ map freeVars [ x , y , z , a ]
freeVars ( Comp x y z a ) = Set . unions $ map freeVars [ x , y , z , a ]
freeVars ( HComp x y z a ) = Set . unions $ map freeVars [ x , y , z , a ]
freeVars ( GlueTy x y z a ) = Set . unions $ map freeVars [ x , y , z , a ]
freeVars ( Glue x y z a b c ) = Set . unions $ map freeVars [ x , y , z , a , b , c ]
freeVars ( Unglue x y z a c ) = Set . unions $ map freeVars [ x , y , z , a , c ]
freeVars ( Case rng x y ) = freeVars rng <> freeVars x <> foldMap ( \ ( _ , _ , y ) -> freeVars y ) y
operator = annotate ( color Yellow )
