{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DeriveAnyClass #-}
module Elab.WiredIn where

import Syntax
import Data.Map.Strict (Map)
import Data.Text (Text)
import qualified Data.Map.Strict as Map
import Control.Exception
import Data.Typeable
import qualified Presyntax.Presyntax as P
import Elab.Eval

wiType :: WiredIn -> NFType
wiType WiType     = VType
wiType WiPretype  = VTypeω

wiType WiInterval = VTypeω
wiType WiI0       = VI
wiType WiI1       = VI

wiType WiIAnd      = VI ~> VI ~> VI
wiType WiIOr       = VI ~> VI ~> VI
wiType WiINot      = VI ~> VI

wiValue :: WiredIn -> Value
wiValue WiType     = VType
wiValue WiPretype  = VTypeω

wiValue WiInterval = VI
wiValue WiI0       = VI0
wiValue WiI1       = VI1

wiValue WiIAnd      = fun \x -> fun \y -> iand x y
wiValue WiIOr       = fun \x -> fun \y -> ior x y
wiValue WiINot      = fun inot

(~>) :: Value -> Value -> Value
a ~> b = VPi P.Ex a (Closure "_" (const b))
infixr 7 ~>

fun :: (Value -> Value) -> Value
fun k = VLam P.Ex $ Closure "x" (k . force)

dprod :: Value -> (Value -> Value) -> Value
dprod a b = VPi P.Ex a (Closure "x" b)

wiredInNames :: Map Text WiredIn
wiredInNames = Map.fromList
  [ ("pretype", WiPretype)
  , ("type", WiType)
  , ("interval", WiInterval)
  , ("i0", WiI0)
  , ("i1", WiI1)
  , ("iand", WiIAnd)
  , ("ior",  WiIOr)
  , ("inot", WiINot)
  ]

newtype NoSuchPrimitive = NoSuchPrimitive { getUnknownPrim :: Text }
  deriving (Show, Typeable)
  deriving anyclass (Exception)

-- Interval operations

iand, ior :: Value -> Value -> Value
iand = \case
  VI1 -> id
  VI0 -> const VI0
  x -> \case
    VI0 -> VI0
    VI1 -> x
    y -> VIAnd x y

ior = \case
  VI0 -> id
  VI1 -> const VI1
  x -> \case
    VI1 -> VI1
    VI0 -> x
    y -> VIOr x y

inot :: Value -> Value
inot = \case
  VI0 -> VI1
  VI1 -> VI0
  VIOr x y -> VIAnd (inot x) (inot y)
  VIAnd x y -> VIOr (inot x) (inot y)
  VINot x -> x
  x -> VINot x