{-# 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

instance Pretty Name where
  pretty (Bound x)     = pretty x
  pretty (Defined x)   = pretty x

prettyTm :: Term -> Doc AnsiStyle
prettyTm (Ref v) = 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 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) = prettyTm x <+> operator (pretty "&&") <+> prettyTm y
prettyTm (IOr x y) = 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

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 = 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