{-# LANGUAGE PatternSynonyms #-}
module Syntax where

import Data.Function (on)
import Data.Text (Text)

import Presyntax.Presyntax (Plicity(..))
import qualified Data.Text as T
import Data.IORef (IORef)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq

data WiredIn
  = WiType
  | WiPretype
  | WiInterval
  | WiI0
  | WiI1
  | WiIAnd
  | WiIOr
  | WiINot
  | WiPathP
  deriving (Eq, Show, Ord)

data Term
  = Ref  Name
  | App  Plicity Term Term
  | Lam  Plicity Text Term
  | Pi   Plicity Text Term Term
  | Meta MV
  | Type
  | Typeω

  | Sigma Text Term Term
  | Pair Term Term
  | Proj1 Term
  | Proj2 Term

  | I
  | I0 | I1
  | IAnd Term Term
  | IOr  Term Term
  | INot Term

  | PathP     Term Term Term
  -- ^ PathP : (A : I -> Type) -> A i0 -> A i1 -> Type
  | IElim     Term Term Term Term Term
  -- ^ IElim : {A : I -> Type} {x : A i0} {y : A i1} (p : PathP A x y) (i : I) -> A i
  | PathIntro Term Term
  -- ^ PathIntro : (A : I -> Type) (f : (i : I) -> A i) -> PathP A (f i0) (f i1)
  --   ~~~~~~~~~ not printed at all
  deriving (Eq, Show, Ord)

data MV =
  MV { mvName :: Text
     , mvCell :: {-# UNPACK #-} !(IORef (Maybe Value))
     }

instance Eq MV where
  (==) = (==) `on` mvName
instance Ord MV where
  (<=) = (<=) `on` mvName
instance Show MV where
  show = ('?':) . T.unpack . mvName

data Name
  = Bound   Text
  | Defined Text
  deriving (Eq, Show, Ord)

type NFType = Value
type NFEndp = Value

data Value
  = VNe    Head            (Seq Projection)
  | VLam   Plicity         Closure
  | VPi    Plicity Value   Closure
  | VSigma Value   Closure
  | VPair  Value   Value

  | VType | VTypeω

  | VI
  | VI0 | VI1
  | VIAnd Value Value
  | VIOr  Value Value
  | VINot Value

  | VPath Value Value Value
  | VLine Value Value
  deriving (Eq, Show, Ord)

pattern VVar :: Name -> Value
pattern VVar x = VNe (HVar x) Seq.Empty

quoteWith :: Set Text -> Value -> Term
quoteWith names (VNe h sp) = foldl goSpine (goHead h) sp where
  goHead (HVar v) = Ref v
  goHead (HMeta m) = Meta m

  goSpine t (PApp p v)       = App p t (quoteWith names v)
  goSpine t (PIElim l x y i) = IElim (quote l) (quote x) (quote y) t (quote i)
  goSpine t PProj1 = Proj1 t
  goSpine t PProj2 = Proj2 t

quoteWith names (VLam p (Closure n k)) =
  let n' = refresh names n
   in Lam p n' (quoteWith (Set.insert n' names) (k (VVar (Bound n'))))

quoteWith names (VPi p d (Closure n k)) =
  let n' = refresh names n
   in Pi p n' (quoteWith names d) (quoteWith (Set.insert n' names) (k (VVar (Bound n'))))

quoteWith names (VSigma d (Closure n k)) =
  let n' = refresh names n
   in Sigma n' (quoteWith names d) (quoteWith (Set.insert n' names) (k (VVar (Bound n'))))

quoteWith names (VPair a b) = Pair (quoteWith names a) (quoteWith names b)
quoteWith _ VType = Type
quoteWith _ VTypeω = Typeω
quoteWith _ VI     = I
quoteWith _ VI0    = I0
quoteWith _ VI1    = I1
quoteWith names (VIAnd x y) = IAnd (quoteWith names x) (quoteWith names y)
quoteWith names (VIOr x y) = IOr (quoteWith names x) (quoteWith names y)
quoteWith names (VINot x) = INot (quoteWith names x)

quoteWith names (VPath line x y) = PathP (quoteWith names line) (quoteWith names x) (quoteWith names y)
quoteWith names (VLine p f)      = PathIntro (quoteWith names p) (quoteWith names f)

refresh :: Set Text -> Text -> Text
refresh s n
  | T.singleton '_' == n = n
  | n `Set.notMember` s = n
  | otherwise = refresh s (n <> T.singleton '\'')

quote :: Value -> Term
quote = quoteWith mempty

data Closure
  = Closure
    { clArgName :: Text
    , clCont    :: Value -> Value
    }

instance Show Closure where
  show (Closure n c) = "Closure \\" ++ show n ++ " -> " ++ show (c (VVar (Bound n)))

instance Eq Closure where
  Closure _ k == Closure _ k' =
    k (VVar (Bound (T.pack "_"))) == k' (VVar (Bound (T.pack "_")))

instance Ord Closure where
  Closure _ k <= Closure _ k' =
    k (VVar (Bound (T.pack "_"))) <= k' (VVar (Bound (T.pack "_")))

data Head
  = HVar Name
  | HMeta MV
  deriving (Eq, Show, Ord)

data Projection
  = PApp   Plicity Value
  | PIElim Value Value Value NFEndp
  | PProj1
  | PProj2
  deriving (Eq, Show, Ord)