|
|
- {-# LANGUAGE BlockArguments #-}
- {-# LANGUAGE LambdaCase #-}
- {-# LANGUAGE OverloadedStrings #-}
- {-# LANGUAGE DerivingStrategies #-}
- {-# LANGUAGE DeriveAnyClass #-}
- {-# LANGUAGE ViewPatterns #-}
- module Elab.WiredIn where
-
- import Control.Exception
-
- import qualified Data.Map.Strict as Map
- import qualified Data.Sequence as Seq
- import qualified Data.Text as T
- import Data.Map.Strict (Map)
- import Data.Text (Text)
- import Data.Typeable
-
- import Elab.Eval
-
- import qualified Presyntax.Presyntax as P
-
- import Syntax
-
- import System.IO.Unsafe
- import GHC.Stack
- import Syntax.Pretty
-
- 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ω
-
- wiType WiSub = dprod VType \a -> dprod VI \phi -> VPartial phi a ~> VTypeω
- wiType WiInS = forAll VType \a -> forAll VI \phi -> dprod a \u -> VSub a phi (fun (const u))
- wiType WiOutS = forAll VType \a -> forAll VI \phi -> forAll (VPartial phi a) \u -> VSub a phi u ~> a
-
- wiType WiComp = dprod' "A" (VI ~> VType) \a -> forAll VI \phi -> dprod (dprod VI \i -> VPartial phi (a @@ i)) \u -> VSub (a @@ VI0) phi (u @@ VI0) ~> a @@ VI1
- -- (A : Type) {phi : I} (T : Partial phi Type) (e : PartialP phi (\o -> Equiv (T o) A)) -> Type
- wiType WiGlue = dprod' "A" VType \a -> forAll' "phi" VI \phi -> dprod' "T" (VPartial phi VType) \t -> VPartialP phi (fun \o -> equiv (t @@ o) a) ~> VType
- -- {A : Type} {phi : I} {T : Partial phi Type} {e : PartialP phi (\o -> Equiv (T o) A)} -> (t : PartialP phi T) -> Sub A phi (\o -> e o (t o)) -> Glue A phi T e
- wiType WiGlueElem = forAll' "A" VType \a -> forAll' "phi" VI \phi -> forAll' "T" (VPartial phi VType) \ty -> forAll' "e" (VPartialP phi (fun \o -> equiv (ty @@ o) a)) \eqv ->
- dprod' "t" (VPartialP phi ty) \t -> VSub a phi (fun \o -> vProj1 (eqv @@ o) @@ (t @@ o)) ~> VGlueTy a phi ty eqv
- -- {A : Type} {phi : I} {T : Partial phi Type} {e : PartialP phi (\o -> Equiv (T o) A)} -> Glue A phi T e -> A
- wiType WiUnglue = forAll' "A" VType \a -> forAll' "phi" VI \phi -> forAll' "T" (VPartial phi VType) \ty -> forAll' "e" (VPartialP phi (fun \o -> equiv (ty @@ o) a)) \e -> VGlueTy a phi ty e ~> a
-
- wiType WiBool = VType
- wiType WiTrue = VBool
- wiType WiFalse = VBool
- wiType WiIf = dprod' "A" (VBool ~> VType) \a -> a @@ VTt ~> a @@ VFf ~> dprod' "b" VBool \b -> a @@ b
-
- 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
- wiValue WiSub = fun \a -> fun \phi -> fun \u -> VSub a phi u
- wiValue WiInS = forallI \a -> forallI \phi -> fun \u -> VInc a phi u
- wiValue WiOutS = forallI \a -> forallI \phi -> forallI \u -> fun \x -> outS a phi u x
- wiValue WiComp = fun \a -> forallI \phi -> fun \u -> fun \x -> comp a phi u x
-
- wiValue WiGlue = fun \a -> forallI \phi -> fun \t -> fun \e -> glueType a phi t e
- wiValue WiGlueElem = forallI \a -> forallI \phi -> forallI \ty -> forallI \eqv -> fun \x -> fun \y -> glueElem a phi ty eqv x y
- wiValue WiUnglue = forallI \a -> forallI \phi -> forallI \ty -> forallI \eqv -> fun \x -> unglue a phi ty eqv x
-
- wiValue WiBool = VBool
- wiValue WiTrue = VTt
- wiValue WiFalse = VFf
- wiValue WiIf = fun \a -> fun \b -> fun \c -> fun \d -> elimBool a b c d
-
- (~>) :: Value -> Value -> Value
- a ~> b = VPi P.Ex a (Closure (Bound "_" 0) (const b))
- infixr 7 ~>
-
- fun, line :: (Value -> Value) -> Value
- fun k = VLam P.Ex $ Closure (Bound "x" 0) (k . force)
- line k = VLam P.Ex $ Closure (Bound "i" 0) (k . force)
-
- forallI :: (Value -> Value) -> Value
- forallI k = VLam P.Im $ Closure (Bound "x" 0) (k . force)
-
- dprod' :: String -> Value -> (Value -> Value) -> Value
- dprod' t a b = VPi P.Ex a (Closure (Bound (T.pack t) 0) b)
-
- dprod :: Value -> (Value -> Value) -> Value
- dprod = dprod' "x"
-
- exists' :: String -> Value -> (Value -> Value) -> Value
- exists' s a b = VSigma a (Closure (Bound (T.pack s) 0) b)
-
- exists :: Value -> (Value -> Value) -> Value
- exists = exists' "x"
-
- forAll' :: String -> Value -> (Value -> Value) -> Value
- forAll' n a b = VPi P.Im a (Closure (Bound (T.pack n) 0) b)
-
- forAll :: Value -> (Value -> Value) -> Value
- forAll = forAll' "x"
-
-
- 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)
- , ("Sub", WiSub)
- , ("inS", WiInS)
- , ("outS", WiOutS)
-
- , ("comp", WiComp)
- , ("Glue", WiGlue)
- , ("glue", WiGlueElem)
- , ("unglue", WiUnglue)
-
- , ("Bool", WiBool)
- , ("true", WiTrue)
- , ("false", WiFalse)
- , ("if", WiIf)
- ]
-
- 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
- x -> case i of
- VI1 -> _right
- VI0 -> _left
- _ -> case x of
- VNe n sp -> VNe n (sp Seq.:|> PIElim _line _left _right i)
- VSystem (Map.toList -> []) -> VSystem (Map.fromList [])
- _ -> error $ "can't ielim " ++ show fn
-
- outS :: HasCallStack => NFSort -> NFEndp -> Value -> Value -> Value
- outS _ (force -> VI1) u _ = u @@ VItIsOne
-
- outS _ _phi _ (VInc _ _ x) = x
- outS _ VI0 _ x = x
-
- outS a phi u (VNe x sp) = VNe x (sp Seq.:|> POuc a phi u)
- outS _ _ _ v = error $ "can't outS " ++ show v
-
- -- Composition
- comp :: NFLine -> NFEndp -> Value -> Value -> Value
- comp _ VI1 u _ = u @@ VI1 @@ VItIsOne
- comp a psi@phi u (compOutS (a @@ VI1) phi (u @@ VI1 @@ VItIsOne) -> a0) =
- case force $ a @@ VVar (Bound (T.pack "neutral composition") 0) of
- VPi{} ->
- let
- plic i = let VPi p _ _ = force (a @@ i) in p
- dom i = let VPi _ d _ = force (a @@ i) in d
- rng i = case force (a @@ i) of
- VPi _ _ (Closure _ r) -> r
- x -> error $ "not pi?? " ++ show x
-
- y' i y = fill (fun (dom . inot)) VI0 (fun \_ -> fun \_ -> VSystem mempty) (VInc (dom VI0) phi y) i
- ybar i y = y' (inot i) y
- in VLam (plic VI1) . Closure (Bound "x" 0) $ \arg ->
- comp (fun \i -> rng i (ybar i arg))
- phi
- (system \i isone -> vApp (plic i) (u @@ i @@ isone) (ybar i arg))
- (VInc (rng VI0 (ybar VI0 arg)) phi (vApp (plic VI0) a0 (ybar VI0 arg)))
- VSigma{} ->
- let
- dom i = let VSigma d _ = a @@ i in d
- rng i = let VSigma _ (Closure _ r) = a @@ i in r
-
- w i = fill (fun dom) phi (system \i isone -> vProj1 (u @@ i @@ isone)) (VInc (dom VI0) phi (vProj1 a0)) i
- c1 = comp (fun dom) phi (system \i isone -> vProj1 (u @@ i @@ isone)) (VInc (dom VI0) phi (vProj1 a0))
- c2 = comp (fun (($ w VI1) . rng)) phi (system \i isone -> vProj1 (u @@ i @@ isone)) (VInc (rng VI0 (dom VI0)) phi (vProj2 a0))
- in
- VPair c1 c2
-
- VPath{} ->
- let
- a' i = let VPath thea _ _ = a @@ i in thea
- u' i = let VPath _ theu _ = a @@ i in theu
- v' i = let VPath _ _ thev = a @@ i in thev
- in
- VLine (a' VI1 @@ VI1) (u' VI1) (v' VI1) $ fun \j ->
- comp (fun a')
- (phi `ior` j `ior` inot j)
- (system \i isone -> mkVSystem (Map.fromList [ (phi, ielim (a' VI0) (u' VI0) (v' VI0) (u @@ i @@ isone) j)
- , (j, v' i)
- , (inot j, u' i)]))
- (VInc (a' VI0 @@ VI0 @@ j) phi (ielim (a' VI0 @@ VI0) (u' VI0) (v' VI0) a0 j))
-
- VGlueTy{} ->
- let
- b = u
- b0 = a0
- fam = a
- in
- let
- base i = let VGlueTy base _ _ _ = force (fam @@ i) in base
- phi i = let VGlueTy _ phi _ _ = force (fam @@ i) in phi
- types i = let VGlueTy _ _ types _ = force (fam @@ i) in types
- equivs i = let VGlueTy _ _ _ equivs = force (fam @@ i) in equivs
-
- a i = fun \u -> unglue (base i) (phi i) (types i @@ u) (equivs i @@ u) (b @@ i @@ u)
- a0 = unglue (base VI0) (phi VI0) (types VI0) (equivs VI0) b0
-
- del = faceForall phi
- a1' = comp (line base) psi (line a) (VInc undefined undefined a0)
- t1' = comp (line types) psi (line (b @@)) (VInc undefined undefined b0)
-
- (omega_st, omega_t, omega_rep) = pres types base equivs psi (b @@) b0
- omega = outS omega_t psi omega_rep omega_st
-
- (t1alpha_st, t1a_t, t1a_rep) = opEquiv (base VI1) (types VI1 @@ VItIsOne) (equivs VI1 @@ VItIsOne) (del `ior` psi) (fun ts) (fun ps) a1'
- t1alpha = outS t1a_t (del `ior` psi) t1a_rep t1alpha_st
-
- (t1, alpha) = (vProj1 t1alpha, vProj2 t1alpha)
-
- ts isone = mkVSystem . Map.fromList $ [(del, t1'), (psi, (b @@ VI1 @@ isone))]
- ps _isone = mkVSystem . Map.fromList $ [(del, omega), (psi, VLine (line (const (base VI1))) a1' a1' (fun (const a1')))]
-
- a1 = comp
- (fun (const (base VI1 @@ VItIsOne)))
- (phi VI1 `ior` psi)
- (system \j _u -> mkVSystem (Map.fromList [ (phi VI1, ielim (base VI1) a1' (vProj1 (equivs VI1 @@ VItIsOne)) alpha j)
- , (psi, a VI1)]))
- a1'
- b1 = glueElem (base VI1) (phi VI1) (types VI1) (equivs VI1) (fun (const t1)) a1
- in b1
-
- -- fibrancy structure of the booleans is trivial
- VBool{} -> a0
-
- _ -> VComp a phi u a0
-
- compOutS :: NFSort -> NFEndp -> Value -> Value -> Value
- compOutS _ _hi _0 vl@VComp{} = vl
- compOutS _ _hi _0 (VInc _ _ x) = x
- compOutS _ _ _ v = v
-
- system :: (Value -> Value -> Value) -> Value
- system k = fun \i -> fun \isone -> k i isone
-
- fill :: NFLine -> NFEndp -> Value -> Value -> NFEndp -> Value
- fill a phi u a0 j =
- comp (fun \i -> a @@ (i `iand` j))
- (phi `ior` inot j)
- (fun \i -> fun \isone -> mkVSystem (Map.fromList [ (phi, u @@ (i `iand` j) @@ isone)
- , (inot j, a0)]))
- a0
-
- glueType :: NFSort -> NFEndp -> NFPartial -> NFPartial -> Value
- glueType a phi tys eqvs = VGlueTy a phi tys eqvs
-
- glueElem :: NFSort -> NFEndp -> NFPartial -> NFPartial -> NFPartial -> Value -> Value
- glueElem _a VI1 _tys _eqvs t _vl = t @@ VItIsOne
- glueElem a phi tys eqvs t vl = VGlue a phi tys eqvs t vl
-
- unglue :: NFSort -> NFEndp -> NFPartial -> NFPartial -> Value -> Value
- unglue _a VI1 _tys eqvs x = vProj1 (eqvs @@ VItIsOne) @@ x
- unglue _a _phi _tys _eqvs (VGlue _ _ _ _ _ vl) = vl
- unglue _ _ _ _ (VSystem (Map.toList -> [])) = VSystem (Map.fromList [])
- unglue a phi tys eqvs vl = VUnglue a phi tys eqvs vl
- -- Definition of equivalences
-
- faceForall :: (NFEndp -> NFEndp) -> Value
- faceForall phi = T.length (getNameText name) `seq` go (phi (VVar name)) where
- {-# NOINLINE name #-}
- name = unsafePerformIO newName
-
- go x@(VVar n)
- | n == name = VI0
- | otherwise = x
- go x@(VINot (VVar n))
- | n == name = VI0
- | otherwise = x
- go (VIAnd x y) = iand (go x) (go y)
- go (VIOr x y) = ior (go x) (go y)
- go (VINot x) = inot (go x)
- go vl = vl
-
- isContr :: Value -> Value
- isContr a = exists' "x" a \x -> dprod' "y" a \y -> VPath (line (const a)) x y
-
- fiber :: NFSort -> NFSort -> Value -> Value -> Value
- fiber a b f y = exists' "x" a \x -> VPath (line (const b)) (f @@ x) y
-
- isEquiv :: NFSort -> NFSort -> Value -> Value
- isEquiv a b f = dprod' "y" b \y -> isContr (fiber a b f y)
-
- equiv :: NFSort -> NFSort -> Value
- equiv a b = exists' "f" (a ~> b) \f -> isEquiv a b f
-
- pres :: (NFEndp -> NFSort) -> (NFEndp -> NFSort) -> (NFEndp -> Value) -> NFEndp -> (NFEndp -> Value) -> Value -> (Value, NFSort, Value)
- pres tyT tyA f phi t t0 = (VInc pathT phi (VLine (tyA VI1) c1 c2 (line path)), pathT, fun $ \u -> VLine (fun (const (tyA VI1))) c1 c2 (fun (const (f VI1 @@ (t VI1 @@ u))))) where
- pathT = VPath (fun (const (tyA VI1))) c1 c2
- c1 = comp (fun tyA) phi (system \i u -> f i @@ (t i @@ u)) (VInc (tyA VI0) phi (f VI0 @@ t0))
- c2 = f VI1 @@ comp (fun tyT) phi (system \i u -> t i @@ u) t0
-
- a0 = f VI0 @@ t0
- v = fill (fun tyT) phi (system \i u -> t i @@ u) t0
-
- path j = comp (fun tyA) (phi `ior` j) (system \i _ -> f i @@ (v i)) a0
-
- opEquiv :: Value -> Value -> Value -> NFEndp -> Value -> Value -> Value -> (Value, NFSort, Value)
- opEquiv aT tT f phi t p a = (VInc ty phi v, ty, fun \u -> VPair (t @@ u) (p @@ u)) where
- fn = vProj1 f
- ty = exists' "f" tT \x -> VPath (line (const aT)) a (fn @@ x)
- v = contr ty (vProj2 f @@ a) phi (\u -> VPair (t @@ u) (p @@ u))
-
- contr :: Value -> Value -> NFEndp -> (Value -> Value) -> Value
- contr a aC phi u =
- comp (line (const a))
- phi
- (system \i is1 -> ielim (line (const a)) a (vProj1 (u is1)) (vProj2 (u is1)) i)
- (vProj1 aC)
-
- elimBool :: NFSort -> Value -> Value -> Value -> Value
- elimBool prop x y bool =
- case force bool of
- VTt -> x
- VFf -> y
- VNe _ (_ Seq.:|> PIElim _ a b c) ->
- case c of
- VI0 -> elimBool prop x y a
- VI1 -> elimBool prop x y b
- _ -> VIf prop x y bool
- _ -> VIf prop x y bool
|