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

data WiredIn
  = WiType
  | WiPretype
  | WiInterval
  | WiI0
  | WiI1
  | WiIAnd
  | WiIOr
  | WiINot
  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
  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

data Value
  = VNe    Head            [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
  deriving (Eq, Show, Ord)

pattern VVar :: Name -> Value
pattern VVar x = VNe (HVar x) []

quoteWith :: Set Text -> Value -> Term
quoteWith names (VNe h sp) = foldl goSpine (goHead h) (reverse 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 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)

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
  | PProj1
  | PProj2
  deriving (Eq, Show, Ord)