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