amelia
/
cubical


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