diff --git a/src/Elab/Monad.hs b/src/Elab/Monad.hs index eafe2a2..8e645da 100644 --- a/src/Elab/Monad.hs +++ b/src/Elab/Monad.hs @@ -159,4 +159,4 @@ throwElab = liftIO . throwIO incName :: Name -> Name -> Name incName (Bound x _) n = Bound x (getNameNum n + 1) -incName (Defined x k) n = Defined x (getNameNum n + 1) +incName (Defined x _) n = Defined x (getNameNum n + 1) diff --git a/src/Elab/WiredIn.hs b/src/Elab/WiredIn.hs index 9994428..5a76d90 100644 --- a/src/Elab/WiredIn.hs +++ b/src/Elab/WiredIn.hs @@ -22,8 +22,6 @@ import qualified Presyntax.Presyntax as P import Syntax import System.IO.Unsafe -import GHC.Stack -import Syntax.Pretty wiType :: WiredIn -> NFType wiType WiType = VType @@ -214,7 +212,7 @@ ielim _line _left _right fn i = VSystem (Map.toList -> []) -> VSystem (Map.fromList []) _ -> error $ "can't ielim " ++ show fn -outS :: HasCallStack => NFSort -> NFEndp -> Value -> Value -> Value +outS :: NFSort -> NFEndp -> Value -> Value -> Value outS _ (force -> VI1) u _ = u @@ VItIsOne outS _ _phi _ (VInc _ _ x) = x @@ -245,8 +243,8 @@ comp a psi@phi u (compOutS (a @@ VI1) phi (u @@ VI1 @@ VItIsOne) -> a0) = (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 + dom i = let VSigma d _ = force (a @@ i) in d + rng i = let VSigma _ (Closure _ r) = force (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)) @@ -256,9 +254,9 @@ comp a psi@phi u (compOutS (a @@ VI1) phi (u @@ VI1 @@ VItIsOne) -> a0) = 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 + a' i = let VPath thea _ _ = force (a @@ i) in thea + u' i = let VPath _ theu _ = force (a @@ i) in theu + v' i = let VPath _ _ thev = force (a @@ i) in thev in VLine (a' VI1 @@ VI1) (u' VI1) (v' VI1) $ fun \j -> comp (fun a') @@ -306,7 +304,9 @@ comp a psi@phi u (compOutS (a @@ VI1) phi (u @@ VI1 @@ VItIsOne) -> a0) = a1' b1 = glueElem (base VI1) (phi VI1) (types VI1) (equivs VI1) (fun (const t1)) a1 in b1 - + + VType -> VGlueTy a0 phi (system \_ _ -> u @@ VI1 @@ VItIsOne) (system \_ _ -> makeEquiv (\j -> (u @@ inot j))) + -- fibrancy structure of the booleans is trivial VBool{} -> a0 @@ -394,14 +394,22 @@ contr a aC phi u = (system \i is1 -> ielim (line (const a)) a (vProj1 (u is1)) (vProj2 (u is1)) i) (vProj1 aC) +makeEquiv :: (NFEndp -> Value) -> Value +makeEquiv line = comp (fun \i -> equiv a (line i)) VI0 (system \_ _ -> VSystem mempty) (VPair idfun idisequiv) where + a = line VI0 + idfun = fun id +-- idEquiv y = ((y, \i -> y), \u i -> (u.2 (inot i), \j -> u.2 (ior (inot i) j))) + u_ty = exists' "y" a \x -> VPath (fun (const a)) x x + idisequiv = fun \y -> VPair (id_fiber y) $ fun \u -> + VLine u_ty (id_fiber y) u $ fun \i -> VPair (ielim (fun (const a)) y y (vProj2 u) i) $ + VLine (fun (const a)) y (vProj1 u) $ fun \j -> + ielim (fun (const a)) y y (vProj2 u) (iand i j) + + id_fiber y = VPair y (VLine a y y (fun (const y))) + 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 \ No newline at end of file diff --git a/src/Elab/WiredIn.hs-boot b/src/Elab/WiredIn.hs-boot index d01be31..9193c1b 100644 --- a/src/Elab/WiredIn.hs-boot +++ b/src/Elab/WiredIn.hs-boot @@ -1,7 +1,6 @@ module Elab.WiredIn where import Syntax -import GHC.Stack wiType :: WiredIn -> NFType wiValue :: WiredIn -> NFType @@ -10,7 +9,7 @@ iand, ior :: NFEndp -> NFEndp -> NFEndp inot :: NFEndp -> NFEndp ielim :: NFSort -> Value -> Value -> Value -> NFEndp -> Value -outS :: HasCallStack => NFSort -> NFEndp -> Value -> Value -> Value +outS :: NFSort -> NFEndp -> Value -> Value -> Value comp :: NFLine -> NFEndp -> Value -> Value -> Value glueType :: NFSort -> NFEndp -> NFPartial -> NFPartial -> Value diff --git a/src/Main.hs b/src/Main.hs index 7a97b9b..3f97c60 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -8,7 +8,6 @@ module Main where import Control.Monad.IO.Class import Control.Monad.Reader import Control.Exception -import Control.Monad import qualified Data.ByteString.Lazy as Bsl import qualified Data.Text.Encoding as T