|
|
- {-# 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
- import qualified Data.Sequence as Seq
-
- 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
- wiType WiPathP = dprod (VI ~> VTypeω) \a -> a @@ VI0 ~> a @@ VI1 ~> VType
-
- wiType WiIsOne = VI ~> VType
- wiType WiItIsOne = VIsOne VI1
- wiType WiIsOne1 = forAll VI \i -> forAll VI \j -> VIsOne i ~> VIsOne (ior i j)
- wiType WiIsOne2 = forAll VI \i -> forAll VI \j -> VIsOne j ~> VIsOne (ior i j)
-
- wiType WiPartial = VI ~> VType ~> VTypeω
- wiType WiPartialP = dprod VI \x -> VPartial x VType ~> VTypeω
-
- 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
- wiValue WiPathP = fun \a -> fun \x -> fun \y -> VPath a x y
-
- wiValue WiIsOne = fun VIsOne
- wiValue WiItIsOne = VItIsOne
- wiValue WiIsOne1 = forallI \_ -> forallI \_ -> fun VIsOne1
- wiValue WiIsOne2 = forallI \_ -> forallI \_ -> fun VIsOne2
-
- wiValue WiPartial = fun \phi -> fun \r -> VPartial phi r
- wiValue WiPartialP = fun \phi -> fun \r -> VPartialP phi r
-
- (~>) :: 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)
-
- forallI :: (Value -> Value) -> Value
- forallI k = VLam P.Im $ Closure "x" (k . force)
-
- dprod :: Value -> (Value -> Value) -> Value
- dprod a b = VPi P.Ex a (Closure "x" b)
-
- forAll :: Value -> (Value -> Value) -> Value
- forAll a b = VPi P.Im 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)
- , ("PathP", WiPathP)
-
- , ("IsOne", WiIsOne)
- , ("itIs1", WiItIsOne)
- , ("isOneL", WiIsOne1)
- , ("isOneR", WiIsOne2)
-
- , ("Partial", WiPartial)
- , ("PartialP", WiPartialP)
- ]
-
- 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
- VIAnd x y -> \case
- VI0 -> VI0
- VI1 -> VI1
- z -> iand x (iand y z)
- x -> \case
- VI0 -> VI0
- VI1 -> x
- y -> VIAnd x y
-
- ior = \case
- VI0 -> id
- VI1 -> const VI1
- VIOr x y -> \case
- VI1 -> VI1
- VI0 -> VIOr x y
- z -> ior x (ior y z)
- 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
-
- ielim :: Value -> Value -> Value -> Value -> NFEndp -> Value
- ielim _line _left _right fn i =
- case force fn of
- VLine _ fun -> fun @@ i
- VNe n sp -> VNe n (sp Seq.:|> PIElim _line _left _right i)
- _ -> error $ "can't ielim " ++ show fn
|