amelia
/
cubical
1
0
Fork 0
Code Issues 0 Pull Requests 0 Projects 0 Releases 0 Wiki Activity
Browse Source

Implement partial elements and systems

master
Amélia Liao 3 years ago
parent
134c24cb13
commit
30b2984e1d
12 changed files with 475 additions and 39 deletions
Unified View
Diff Options
Show Stats Download Patch File Download Diff File
  1. +1
    -0
      cubical.cabal
  2. +105
    -7
      src/Elab.hs
  3. +70
    -12
      src/Elab/Eval.hs
  4. +62
    -0
      src/Elab/Eval/Formula.hs
  5. +36
    -4
      src/Elab/WiredIn.hs
  6. +26
    -10
      src/Presyntax/Lexer.x
  7. +42
    -3
      src/Presyntax/Parser.y
  8. +15
    -0
      src/Presyntax/Presyntax.hs
  9. +10
    -0
      src/Presyntax/Tokens.hs
  10. +39
    -0
      src/Syntax.hs
  11. +24
    -2
      src/Syntax/Pretty.hs
  12. +45
    -1
      test.tt

+ 1
- 0
cubical.cabal View File

@ -43,6 +43,7 @@ executable cubical
, Elab.Eval , Elab.Eval
, Elab.Monad , Elab.Monad
, Elab.WiredIn , Elab.WiredIn
, Elab.Eval.Formula
build-tool-depends: alex:alex >= 3.2.4 && < 4.0 build-tool-depends: alex:alex >= 3.2.4 && < 4.0
, happy:happy >= 1.19.12 && < 2.0 , happy:happy >= 1.19.12 && < 2.0


+ 105
- 7
src/Elab.hs View File

@ -1,4 +1,4 @@
{-# LANGUAGE TupleSections, OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
module Elab where module Elab where
@ -7,8 +7,11 @@ import Control.Monad.Reader
import Control.Exception import Control.Exception
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
import Data.Traversable
import Data.Typeable import Data.Typeable
import Data.Foldable
import Elab.Eval.Formula (possible)
import Elab.WiredIn import Elab.WiredIn
import Elab.Monad import Elab.Monad
import Elab.Eval import Elab.Eval
@ -17,8 +20,9 @@ import qualified Presyntax.Presyntax as P
import Prettyprinter import Prettyprinter
import Syntax.Pretty
import Syntax import Syntax
import Syntax.Pretty
import qualified Data.Text as T
infer :: P.Expr -> ElabM (Term, NFType) infer :: P.Expr -> ElabM (Term, NFType)
infer (P.Span ex a b) = withSpan a b $ infer ex infer (P.Span ex a b) = withSpan a b $ infer ex
@ -40,6 +44,27 @@ infer (P.App p f x) = do
x <- check x VI x <- check x VI
x_nf <- eval x x_nf <- eval x
pure (IElim (quote (fun li)) (quote le) (quote ri) (wp f) x, li x_nf) pure (IElim (quote (fun li)) (quote le) (quote ri) (wp f) x, li x_nf)
It'sPartial phi a w -> do
x <- check x (VIsOne phi)
pure (App P.Ex (w f) x, a)
It'sPartialP phi a w -> do
x <- check x (VIsOne phi)
x_nf <- eval x
pure (App P.Ex (w f) x, a @@ x_nf)
infer (P.Bracket ex) = do
nm <- getNameFor (T.pack "IsOne")
ty <- getNfType nm
porp <- isPiType P.Ex ty
case porp of
It'sProd d r w -> do
t <- check ex d
t_nf <- eval t
pure (App P.Ex (w (Ref nm)) t, r t_nf)
_ -> do
d <- newMeta VType
r <- newMeta VType
throwElab $ NotEqual ty (VPi P.Ex d (Closure (T.pack "x") (const r)))
infer (P.Proj1 x) = do infer (P.Proj1 x) = do
(tm, ty) <- infer x (tm, ty) <- infer x
@ -71,19 +96,32 @@ check tm (VPi P.Im dom (Closure var rng)) =
check (P.Lam p v b) ty = do check (P.Lam p v b) ty = do
porp <- isPiType p =<< forceIO ty porp <- isPiType p =<< forceIO ty
case porp of case porp of
It'sProd d r wp -> do
It'sProd d r wp ->
assume (Bound v) d $ assume (Bound v) d $
wp . Lam p v <$> check b (r (VVar (Bound v))) wp . Lam p v <$> check b (r (VVar (Bound v)))
It'sPath li le ri wp -> do It'sPath li le ri wp -> do
tm <- assume (Bound v) VI $ tm <- assume (Bound v) VI $
Lam P.Ex v <$> check b (li (VVar (Bound v)))
Lam P.Ex v <$> check b (force (li (VVar (Bound v))))
tm_nf <- eval tm tm_nf <- eval tm
unify (tm_nf @@ VI0) le unify (tm_nf @@ VI0) le
`catchElab` (throwElab . WhenCheckingEndpoint le ri VI0) `catchElab` (throwElab . WhenCheckingEndpoint le ri VI0)
unify (tm_nf @@ VI1) ri unify (tm_nf @@ VI1) ri
`catchElab` (throwElab . WhenCheckingEndpoint le ri VI1) `catchElab` (throwElab . WhenCheckingEndpoint le ri VI1)
pure (wp (PathIntro (quote (fun li)) tm)) pure (wp (PathIntro (quote (fun li)) tm))
It'sPartial phi a wp ->
assume (Bound v) (VIsOne phi) $
wp . Lam p v <$> check b a
It'sPartialP phi a wp ->
assume (Bound v) (VIsOne phi) $
wp . Lam p v <$> check b (a @@ VVar (Bound v))
check (P.Pair a b) ty = do check (P.Pair a b) ty = do
(d, r, wp) <- isSigmaType =<< forceIO ty (d, r, wp) <- isSigmaType =<< forceIO ty
a <- check a d a <- check a d
@ -107,11 +145,52 @@ check (P.Sigma s d r) ty = do
r <- check r ty r <- check r ty
pure (Sigma s d r) pure (Sigma s d r)
check (P.LamSystem bs) ty = do
(extent, dom) <- isPartialType ty
eqns <- for (zip [(0 :: Int)..] bs) $ \(n, (formula, rhs)) -> do
formula <- checkFormula formula
rhs <- check rhs dom
pure (n, (formula, rhs))
unify extent (foldl ior VI0 (map (fst . snd) eqns))
for_ eqns $ \(n, (formula, rhs)) ->
for_ eqns $ \(n', (formula', rhs')) -> do
let truth = possible mempty (iand formula formula')
when ((n /= n') && fst truth) $ do
vl <- eval rhs
vl' <- eval rhs'
unify vl vl'
`withNote` vsep [ pretty "These two cases must agree because they are both possible:"
, indent 2 $ pretty '*' <+> prettyTm (quote formula) <+> operator (pretty "=>") <+> prettyTm rhs
, indent 2 $ pretty '*' <+> prettyTm (quote formula') <+> operator (pretty "=>") <+> prettyTm rhs'
]
`withNote` (pretty "Consider this face, where both are true:" <+> showFace (snd truth))
name <- newName
pure (Lam P.Ex name (System (Map.fromList (map (\(_, (x, y)) -> (quote x, y)) eqns))))
check exp ty = do check exp ty = do
(tm, has) <- switch $ infer exp (tm, has) <- switch $ infer exp
wp <- isConvertibleTo has ty wp <- isConvertibleTo has ty
pure (wp tm) pure (wp tm)
checkFormula :: P.Formula -> ElabM Value
checkFormula P.FTop = pure VI1
checkFormula P.FBot = pure VI0
checkFormula (P.FAnd x y) = iand <$> checkFormula x <*> checkFormula y
checkFormula (P.FOr x y) = ior <$> checkFormula x <*> checkFormula y
checkFormula (P.FIs0 x) = do
nm <- getNameFor x
ty <- getNfType nm
unify ty VI
pure (inot (VVar nm))
checkFormula (P.FIs1 x) = do
nm <- getNameFor x
ty <- getNfType nm
unify ty VI
pure (VVar nm)
isSort :: NFType -> ElabM () isSort :: NFType -> ElabM ()
isSort VType = pure () isSort VType = pure ()
isSort VTypeω = pure () isSort VTypeω = pure ()
@ -128,16 +207,29 @@ data ProdOrPath
, pathRight :: Value , pathRight :: Value
, pathWrap :: Term -> Term , pathWrap :: Term -> Term
} }
| It'sPartial { partialExtent :: NFEndp
, partialDomain :: Value
, partialWrap :: Term -> Term
}
| It'sPartialP { partialExtent :: NFEndp
, partialDomain :: Value
, partialWrap :: Term -> Term
}
isPiType :: P.Plicity -> NFType -> ElabM ProdOrPath isPiType :: P.Plicity -> NFType -> ElabM ProdOrPath
isPiType p (VPi p' d (Closure _ k)) | p == p' = pure (It'sProd d k id) isPiType p (VPi p' d (Closure _ k)) | p == p' = pure (It'sProd d k id)
isPiType P.Ex (VPath li le ri) = pure (It'sPath (li @@) le ri id) isPiType P.Ex (VPath li le ri) = pure (It'sPath (li @@) le ri id)
isPiType P.Ex (VPartial phi a) = pure (It'sPartial phi a id)
isPiType P.Ex (VPartialP phi a) = pure (It'sPartialP phi a id)
isPiType P.Ex (VPi P.Im d (Closure _ k)) = do isPiType P.Ex (VPi P.Im d (Closure _ k)) = do
meta <- newMeta d meta <- newMeta d
porp <- isPiType P.Ex (k meta) porp <- isPiType P.Ex (k meta)
pure $ case porp of pure $ case porp of
It'sProd d r w -> It'sProd d r (\f -> w (App P.Im f (quote meta))) It'sProd d r w -> It'sProd d r (\f -> w (App P.Im f (quote meta)))
It'sPath l x y w -> It'sPath l x y (\f -> w (App P.Im f (quote meta))) It'sPath l x y w -> It'sPath l x y (\f -> w (App P.Im f (quote meta)))
It'sPartial phi a w -> It'sPartial phi a (\f -> w (App P.Im f (quote meta)))
It'sPartialP phi a w -> It'sPartialP phi a (\f -> w (App P.Im f (quote meta)))
isPiType p t = do isPiType p t = do
dom <- newMeta VType dom <- newMeta VType
name <- newName name <- newName
@ -156,8 +248,14 @@ isSigmaType t = do
wp <- isConvertibleTo t (VSigma dom (Closure name (const rng))) wp <- isConvertibleTo t (VSigma dom (Closure name (const rng)))
pure (dom, const rng, wp) pure (dom, const rng, wp)
identityTy :: NFType
identityTy = VPi P.Im VType (Closure "A" $ \t -> VPi P.Ex t (Closure "_" (const t)))
isPartialType :: NFType -> ElabM (NFEndp, Value)
isPartialType (VPartial phi a) = pure (phi, a)
isPartialType (VPartialP phi a) = pure (phi, a)
isPartialType t = do
phi <- newMeta VI
dom <- newMeta (VPartial phi VType)
unify t (VPartial phi dom)
pure (phi, dom)
checkStatement :: P.Statement -> ElabM a -> ElabM a checkStatement :: P.Statement -> ElabM a -> ElabM a
checkStatement (P.SpanSt s a b) k = withSpan a b $ checkStatement s k checkStatement (P.SpanSt s a b) k = withSpan a b $ checkStatement s k
@ -194,7 +292,7 @@ checkStatement (P.Builtin winame var) k = do
nm <- getNameFor var nm <- getNameFor var
ty <- getNfType nm ty <- getNfType nm
unify ty (wiType wi) unify ty (wiType wi)
`withNote` hsep [ "Previous definition of", pretty nm, "here" ]
`withNote` hsep [ pretty "Previous definition of", pretty nm, pretty "here" ]
`seeAlso` nm `seeAlso` nm
env <- ask env <- ask


+ 70
- 12
src/Elab/Eval.hs View File

@ -18,17 +18,19 @@ import Data.Foldable
import Data.IORef import Data.IORef
import Data.Maybe import Data.Maybe
import Elab.Eval.Formula
import Elab.Monad import Elab.Monad
import Presyntax.Presyntax (Plicity(..)) import Presyntax.Presyntax (Plicity(..))
import Prettyprinter
import Syntax.Pretty import Syntax.Pretty
import Syntax import Syntax
import System.IO.Unsafe import System.IO.Unsafe
import {-# SOURCE #-} Elab.WiredIn import {-# SOURCE #-} Elab.WiredIn
import Prettyprinter
eval :: Term -> ElabM Value eval :: Term -> ElabM Value
eval t = asks (flip eval' t) eval t = asks (flip eval' t)
@ -86,6 +88,23 @@ zonkIO (VIAnd x y) = iand <$> zonkIO x <*> zonkIO y
zonkIO (VIOr x y) = ior <$> zonkIO x <*> zonkIO y zonkIO (VIOr x y) = ior <$> zonkIO x <*> zonkIO y
zonkIO (VINot x) = inot <$> zonkIO x zonkIO (VINot x) = inot <$> zonkIO x
zonkIO (VIsOne x) = VIsOne <$> zonkIO x
zonkIO (VIsOne1 x) = VIsOne1 <$> zonkIO x
zonkIO (VIsOne2 x) = VIsOne2 <$> zonkIO x
zonkIO VItIsOne = pure VItIsOne
zonkIO (VPartial x y) = VPartial <$> zonkIO x <*> zonkIO y
zonkIO (VPartialP x y) = VPartialP <$> zonkIO x <*> zonkIO y
zonkIO (VSystem fs) =
do
t <- for (Map.toList fs) $ \(a, b) -> (,) <$> zonkIO a <*> zonkIO b
pure (mkVSystem (Map.fromList t))
where
mkVSystem map =
case Map.lookup VI1 map of
Just x -> x
Nothing -> VSystem map
zonk :: Value -> Value zonk :: Value -> Value
zonk = unsafePerformIO . zonkIO zonk = unsafePerformIO . zonkIO
@ -129,6 +148,15 @@ eval' e (PathP l a b) = VPath (eval' e l) (eval' e a) (eval' e b)
eval' e (IElim l x y f i) = ielim (eval' e l) (eval' e x) (eval' e y) (eval' e f) (eval' e i) eval' e (IElim l x y f i) = ielim (eval' e l) (eval' e x) (eval' e y) (eval' e f) (eval' e i)
eval' e (PathIntro p f) = VLine (eval' e p) (eval' e f) eval' e (PathIntro p f) = VLine (eval' e p) (eval' e f)
eval' e (IsOne i) = VIsOne (eval' e i)
eval' e (IsOne1 i) = VIsOne1 (eval' e i)
eval' e (IsOne2 i) = VIsOne2 (eval' e i)
eval' _ ItIsOne = VItIsOne
eval' e (Partial x y) = VPartial (eval' e x) (eval' e y)
eval' e (PartialP x y) = VPartialP (eval' e x) (eval' e y)
eval' e (System fs) = VSystem (Map.fromList $ map (\(x, y) -> (eval' e x, eval' e y)) $ Map.toList $ fs)
vApp :: Plicity -> Value -> Value -> Value vApp :: Plicity -> Value -> Value -> Value
vApp p (VLam p' k) arg vApp p (VLam p' k) arg
| p == p' = clCont k arg | p == p' = clCont k arg
@ -161,13 +189,19 @@ unify' topa topb = join $ go <$> forceIO topa <*> forceIO topb where
go (VNe x a) (VNe x' a') go (VNe x a) (VNe x' a')
| x == x', length a == length a' = | x == x', length a == length a' =
traverse_ (uncurry unify'Spine) (Seq.zip a a') traverse_ (uncurry unify'Spine) (Seq.zip a a')
go (VNe _hd (_ Seq.:|> PIElim _l x y i)) rhs = go (VNe _hd (_ Seq.:|> PIElim _l x y i)) rhs =
case force i of case force i of
VI0 -> unify' x rhs VI0 -> unify' x rhs
VI1 -> unify' y rhs VI1 -> unify' y rhs
_ -> fail _ -> fail
go rhs (VNe _hd (_ Seq.:|> PIElim _l x y i)) =
case force i of
VI0 -> unify' rhs x
VI1 -> unify' rhs y
_ -> fail
go (VLam p (Closure _ k)) vl = do go (VLam p (Closure _ k)) vl = do
t <- VVar . Bound <$> newName t <- VVar . Bound <$> newName
unify' (k t) (vApp p vl t) unify' (k t) (vApp p vl t)
@ -193,18 +227,12 @@ unify' topa topb = join $ go <$> forceIO topa <*> forceIO topb where
go VTypeω VTypeω = pure () go VTypeω VTypeω = pure ()
go VI VI = pure () go VI VI = pure ()
go VI0 VI0 = pure ()
go VI1 VI1 = pure ()
go (VINot x) (VINot y) = unify' x y
go (VIAnd x y) (VIAnd x' y') = unify' x x' *> unify' y y'
go (VIOr x y) (VIOr x' y') = unify' x x' *> unify' y y'
go (VPath l x y) (VPath l' x' y') = do go (VPath l x y) (VPath l' x' y') = do
unify' l l' unify' l l'
unify' x x' unify' x x'
unify' y y' unify' y y'
go (VLine l p) p' = do go (VLine l p) p' = do
n <- VVar . Bound <$> newName n <- VVar . Bound <$> newName
unify (p @@ n) (ielim l (l @@ VI0) (l @@ VI1) p' n) unify (p @@ n) (ielim l (l @@ VI0) (l @@ VI1) p' n)
@ -213,7 +241,23 @@ unify' topa topb = join $ go <$> forceIO topa <*> forceIO topb where
n <- VVar . Bound <$> newName n <- VVar . Bound <$> newName
unify (ielim l (l @@ VI0) (l @@ VI1) p' n) (p @@ n) unify (ielim l (l @@ VI0) (l @@ VI1) p' n) (p @@ n)
go _ _ = fail
go (VIsOne x) (VIsOne y) = unify' x y
-- IsOne is proof-irrelevant:
go VItIsOne _ = pure ()
go _ VItIsOne = pure ()
go VIsOne1{} _ = pure ()
go _ VIsOne1{} = pure ()
go VIsOne2{} _ = pure ()
go _ VIsOne2{} = pure ()
go (VPartial phi r) (VPartial phi' r') = unify' phi phi' *> unify r r'
go (VPartialP phi r) (VPartialP phi' r') = unify' phi phi' *> unify r r'
go x y =
case (toDnf x, toDnf y) of
(Just xs, Just ys) -> unify'Formula xs ys
_ -> fail
fail = liftIO . throwIO $ NotEqual topa topb fail = liftIO . throwIO $ NotEqual topa topb
@ -227,8 +271,12 @@ unify' topa topb = join $ go <$> forceIO topa <*> forceIO topb where
unify'Spine _ _ = fail unify'Spine _ _ = fail
unify'Formula x y
| compareDNFs x y = pure ()
| otherwise = fail
unify :: Value -> Value -> ElabM () unify :: Value -> Value -> ElabM ()
unify a b = unify' a b `catchElab` \(_ :: SomeException) -> liftIO $ throwIO (NotEqual a b)
unify a b = unify' a b `catchElab` \(_ :: NotEqual) -> liftIO $ throwIO (NotEqual a b)
isConvertibleTo :: Value -> Value -> ElabM (Term -> Term) isConvertibleTo :: Value -> Value -> ElabM (Term -> Term)
VPi Im d (Closure _v k) `isConvertibleTo` ty = do VPi Im d (Closure _v k) `isConvertibleTo` ty = do
@ -326,7 +374,17 @@ checkScope s (VIOr x y) = traverse_ (checkScope s) [x, y]
checkScope s (VINot x) = checkScope s x checkScope s (VINot x) = checkScope s x
checkScope s (VPath line a b) = traverse_ (checkScope s) [line, a, b] checkScope s (VPath line a b) = traverse_ (checkScope s) [line, a, b]
checkScope s (VLine _ line) = checkScope s line
checkScope s (VLine _ line) = checkScope s line
checkScope s (VIsOne x) = checkScope s x
checkScope s (VIsOne1 x) = checkScope s x
checkScope s (VIsOne2 x) = checkScope s x
checkScope _ VItIsOne = pure ()
checkScope s (VPartial x y) = traverse_ (checkScope s) [x, y]
checkScope s (VPartialP x y) = traverse_ (checkScope s) [x, y]
checkScope s (VSystem fs) =
for_ (Map.toList fs) $ \(x, y) -> traverse_ (checkScope s) [x, y]
checkSpine :: Set Name -> Seq Projection -> ElabM [T.Text] checkSpine :: Set Name -> Seq Projection -> ElabM [T.Text]
checkSpine scope (PApp Ex (VVar n@(Bound t)) Seq.:<| xs) checkSpine scope (PApp Ex (VVar n@(Bound t)) Seq.:<| xs)


+ 62
- 0
src/Elab/Eval/Formula.hs View File

@ -0,0 +1,62 @@
module Elab.Eval.Formula where
import qualified Data.Map.Strict as Map
import qualified Data.Sequence as Seq
import Data.Map.Strict (Map)
import Syntax
import {-# SOURCE #-} Elab.WiredIn (inot, ior, iand)
import Debug.Trace (traceShow)
toDnf :: Value -> Maybe Value
toDnf (VNe _ _) = Nothing
toDnf x = toDnf x where
toDnf (VIAnd x y) = idist <$> toDnf (inot x) <*> toDnf (inot y)
toDnf (VIOr x y) = ior <$> toDnf x <*> toDnf y
toDnf (VINot x) = inot <$> toDnf x
toDnf VI0 = pure VI0
toDnf VI1 = pure VI1
toDnf v@(VNe _ Seq.Empty) = pure v
toDnf _ = Nothing
compareDNFs :: Value -> Value -> Bool
compareDNFs (VIOr x y) (VIOr x' y') =
let (a, a') = swap x y
(b, b') = swap x' y'
in compareDNFs a b && compareDNFs a' b'
compareDNFs (VIAnd x y) (VIAnd x' y') =
let (a, a') = swap x x'
(b, b') = swap y y'
in compareDNFs a a' && compareDNFs b b'
compareDNFs x y = x == y
swap :: Ord b => b -> b -> (b, b)
swap x y =
if x <= y then (x, y) else (y, x)
possible :: Map Head Bool -> Value -> (Bool, Map Head Bool)
possible sc (VINot (VNe n Seq.Empty)) =
case Map.lookup n sc of
Just True -> (False, sc)
_ -> (True, Map.insert n False sc)
possible sc (VNe n Seq.Empty) =
case Map.lookup n sc of
Just False -> (False, sc)
_ -> (True, Map.insert n True sc)
possible sc (VIAnd x y) =
let (a, sc') = possible sc x
(b, sc'') = possible sc' y
in (a && b, sc'')
possible sc (VIOr x y) =
case possible sc x of
(True, sc') -> (True, sc')
(False, _) -> possible sc y
possible sc VI0 = (False, sc)
possible sc VI1 = (True, sc)
possible sc _ = (False, sc)
idist :: Value -> Value -> Value
idist (VIOr x y) z = (x `idist` z) `ior` (y `idist` z)
idist z (VIOr x y) = (z `idist` x) `ior` (z `idist` y)
idist z x = iand z x

+ 36
- 4
src/Elab/WiredIn.hs View File

@ -23,10 +23,18 @@ wiType WiInterval = VTypeω
wiType WiI0 = VI wiType WiI0 = VI
wiType WiI1 = 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 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 :: WiredIn -> Value
wiValue WiType = VType wiValue WiType = VType
@ -41,6 +49,14 @@ wiValue WiIOr = fun \x -> fun \y -> ior x y
wiValue WiINot = fun inot wiValue WiINot = fun inot
wiValue WiPathP = fun \a -> fun \x -> fun \y -> VPath a x y 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 (~>) :: Value -> Value -> Value
a ~> b = VPi P.Ex a (Closure "_" (const b)) a ~> b = VPi P.Ex a (Closure "_" (const b))
infixr 7 ~> infixr 7 ~>
@ -68,6 +84,14 @@ wiredInNames = Map.fromList
, ("ior", WiIOr) , ("ior", WiIOr)
, ("inot", WiINot) , ("inot", WiINot)
, ("PathP", WiPathP) , ("PathP", WiPathP)
, ("IsOne", WiIsOne)
, ("itIs1", WiItIsOne)
, ("isOneL", WiIsOne1)
, ("isOneR", WiIsOne2)
, ("Partial", WiPartial)
, ("PartialP", WiPartialP)
] ]
newtype NoSuchPrimitive = NoSuchPrimitive { getUnknownPrim :: Text } newtype NoSuchPrimitive = NoSuchPrimitive { getUnknownPrim :: Text }
@ -80,6 +104,10 @@ iand, ior :: Value -> Value -> Value
iand = \case iand = \case
VI1 -> id VI1 -> id
VI0 -> const VI0 VI0 -> const VI0
VIAnd x y -> \case
VI0 -> VI0
VI1 -> VI1
z -> iand x (iand y z)
x -> \case x -> \case
VI0 -> VI0 VI0 -> VI0
VI1 -> x VI1 -> x
@ -88,6 +116,10 @@ iand = \case
ior = \case ior = \case
VI0 -> id VI0 -> id
VI1 -> const VI1 VI1 -> const VI1
VIOr x y -> \case
VI1 -> VI1
VI0 -> VIOr x y
z -> ior x (ior y z)
x -> \case x -> \case
VI1 -> VI1 VI1 -> VI1
VI0 -> x VI0 -> x


+ 26
- 10
src/Presyntax/Lexer.x View File

@ -15,6 +15,7 @@ $white_nol = $white # \n
tokens :- tokens :-
$white_nol+ ; $white_nol+ ;
"--" .* \n ;
<0,prtext> $alpha [$alpha $digit \_ \']* { yield TokVar } <0,prtext> $alpha [$alpha $digit \_ \']* { yield TokVar }
@ -32,13 +33,26 @@ tokens :-
<0> \( { always TokOParen } <0> \( { always TokOParen }
<0> \{ { always TokOBrace } <0> \{ { always TokOBrace }
<0> \[ { always TokOSquare }
<0> \) { always TokCParen } <0> \) { always TokCParen }
<0> \} { always TokCBrace } <0> \} { always TokCBrace }
<0> \] { always TokCSquare }
<0> \; { always TokSemi } <0> \; { always TokSemi }
<0> \n { just $ pushStartCode newline } <0> \n { just $ pushStartCode newline }
<0> "&&" { always TokAnd }
<0> "||" { always TokOr }
<0> "{-" { just $ pushStartCode comment }
<comment> {
"-}" { \i l -> popStartCode *> skip i l }
. ;
}
<0> "{-#" { \i l -> pushStartCode prkw *> always TokOPragma i l } <0> "{-#" { \i l -> pushStartCode prkw *> always TokOPragma i l }
<prkw> "PRIMITIVE" { \i l -> popStartCode *> pushStartCode prtext *> always TokPrim i l } <prkw> "PRIMITIVE" { \i l -> popStartCode *> pushStartCode prtext *> always TokPrim i l }
<prtext> "#-}" { \i l -> popStartCode *> always TokCPragma i l } <prtext> "#-}" { \i l -> popStartCode *> always TokCPragma i l }
@ -91,14 +105,16 @@ popStartCode = do
alexSetStartCode x alexSetStartCode x
offsideRule :: AlexInput -> Int64 -> Alex Token offsideRule :: AlexInput -> Int64 -> Alex Token
offsideRule (AlexPn _ line col, _, _, _) _ = do
~(col':_) <- layoutColumns <$> getUserState
case col `compare` col' of
EQ -> do
popStartCode
pure (Token TokSemi line col)
GT -> do
popStartCode
alexMonadScan
LT -> alexError "wrong ass indentation"
offsideRule (AlexPn _ line col, _, s, _) _
| Lbs.null s = pure (Token TokEof line col)
| otherwise = do
~(col':_) <- layoutColumns <$> getUserState
case col `compare` col' of
EQ -> do
popStartCode
pure (Token TokSemi line col)
GT -> do
popStartCode
alexMonadScan
LT -> alexError "wrong ass indentation"
} }

+ 42
- 3
src/Presyntax/Parser.y View File

@ -1,5 +1,5 @@
{ {
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleInstances, ViewPatterns #-}
module Presyntax.Parser where module Presyntax.Parser where
import qualified Data.Text as T import qualified Data.Text as T
@ -28,12 +28,17 @@ import Prelude hiding (span)
%token %token
var { Token (TokVar _) _ _ } var { Token (TokVar _) _ _ }
'eof' { Token TokEof _ _ }
'(' { Token TokOParen _ _ } '(' { Token TokOParen _ _ }
')' { Token TokCParen _ _ } ')' { Token TokCParen _ _ }
'{' { Token TokOBrace _ _ } '{' { Token TokOBrace _ _ }
'}' { Token TokCBrace _ _ } '}' { Token TokCBrace _ _ }
'[' { Token TokOSquare _ _ }
']' { Token TokCSquare _ _ }
'{-#' { Token TokOPragma _ _ } '{-#' { Token TokOPragma _ _ }
'#-}' { Token TokCPragma _ _ } '#-}' { Token TokCPragma _ _ }
@ -46,6 +51,9 @@ import Prelude hiding (span)
',' { Token TokComma _ _ } ',' { Token TokComma _ _ }
'*' { Token TokStar _ _ } '*' { Token TokStar _ _ }
'&&' { Token TokAnd _ _ }
'||' { Token TokOr _ _ }
'.1' { Token TokPi1 _ _ } '.1' { Token TokPi1 _ _ }
'.2' { Token TokPi2 _ _ } '.2' { Token TokPi2 _ _ }
@ -59,6 +67,7 @@ import Prelude hiding (span)
Exp :: { Expr } Exp :: { Expr }
Exp Exp
: '\\' LambdaList '->' Exp { span $1 $4 $ makeLams $2 $4 } : '\\' LambdaList '->' Exp { span $1 $4 $ makeLams $2 $4 }
| '\\' '{' System '}' { span $1 $4 $ LamSystem $3 }
| '(' var ':' Exp ')' ProdTail { span $1 $6 $ Pi Ex (getVar $2) $4 $6 } | '(' var ':' Exp ')' ProdTail { span $1 $6 $ Pi Ex (getVar $2) $4 $6 }
| '{' var ':' Exp '}' ProdTail { span $1 $6 $ Pi Im (getVar $2) $4 $6 } | '{' var ':' Exp '}' ProdTail { span $1 $6 $ Pi Im (getVar $2) $4 $6 }
| ExpApp '->' Exp { span $1 $3 $ Pi Ex (T.singleton '_') $1 $3 } | ExpApp '->' Exp { span $1 $3 $ Pi Ex (T.singleton '_') $1 $3 }
@ -85,6 +94,7 @@ Tuple :: { Expr }
Atom :: { Expr } Atom :: { Expr }
: var { span $1 $1 $ Var (getVar $1) } : var { span $1 $1 $ Var (getVar $1) }
| '(' Tuple ')' { span $1 $3 $ $2 } | '(' Tuple ')' { span $1 $3 $ $2 }
| '[' Exp ']' { span $1 $3 $ Bracket $2 }
ProdTail :: { Expr } ProdTail :: { Expr }
: '(' VarList ':' Exp ')' ProdTail { span $1 $6 $ makePis Ex (thd $2) $4 $6 } : '(' VarList ':' Exp ')' ProdTail { span $1 $6 $ makePis Ex (thd $2) $4 $6 }
@ -119,13 +129,42 @@ ReplStatement :: { Statement }
| '{-#' Pragma '#-}' { spanSt $1 $3 $ $2 } | '{-#' Pragma '#-}' { spanSt $1 $3 $ $2 }
Program :: { [Statement] } Program :: { [Statement] }
: Statement { [$1] }
| Statement ';' Program { $1:$3 }
: Statement { [$1] }
| Statement Semis Program { $1:$3 }
Semis :: { () }
: ';' { () }
| ';' Semis { () }
Pragma :: { Statement } Pragma :: { Statement }
: 'PRIMITIVE' var var { Builtin (getVar $2) (getVar $3) } : 'PRIMITIVE' var var { Builtin (getVar $2) (getVar $3) }
| 'PRIMITIVE' var { Builtin (getVar $2) (getVar $2) } | 'PRIMITIVE' var { Builtin (getVar $2) (getVar $2) }
System :: { [(Formula, Expr)] }
: {- empty system -} { [] }
| NeSystem { $1 }
NeSystem :: { [(Formula, Expr) ]}
: Formula '->' Exp { [($1, $3)] }
| Formula '->' Exp ',' NeSystem { ($1, $3):$5 }
Formula :: { Formula }
: Disjn { $1 }
| Disjn '&&' Disjn { $1 `FAnd` $3 }
Disjn :: { Formula }
: FAtom { $1 }
| FAtom '||' FAtom { $1 `FOr` $3 }
FAtom :: { Formula }
: '(' var '=' var ')' {%
case $4 of
Token (TokVar x) _ _
| x == T.pack "i0" -> pure (FIs0 (getVar $2))
| x == T.pack "i1" -> pure (FIs1 (getVar $2))
x -> parseError (x, ["i0", "i1"])
}
{ {
lexer cont = alexMonadScan >>= cont lexer cont = alexMonadScan >>= cont


+ 15
- 0
src/Presyntax/Presyntax.hs View File

@ -19,9 +19,24 @@ data Expr
| Proj1 Expr | Proj1 Expr
| Proj2 Expr | Proj2 Expr
-- application of IsOne primitive is written like [ φ ]
| Bracket Expr
-- System
| LamSystem [(Formula, Expr)]
| Span Expr Posn Posn | Span Expr Posn Posn
deriving (Eq, Show, Ord) deriving (Eq, Show, Ord)
data Formula
= FIs1 Text
| FIs0 Text
| FAnd Formula Formula
| FOr Formula Formula
| FTop
| FBot
deriving (Eq, Show, Ord)
data Statement data Statement
= Decl [Text] Expr = Decl [Text] Expr
| Defn Text Expr | Defn Text Expr


+ 10
- 0
src/Presyntax/Tokens.hs View File

@ -12,8 +12,11 @@ data TokenClass
| TokOParen | TokOParen
| TokOBrace | TokOBrace
| TokOSquare
| TokCParen | TokCParen
| TokCBrace | TokCBrace
| TokCSquare
-- {-# #-} -- {-# #-}
| TokOPragma | TokOPragma
@ -32,6 +35,9 @@ data TokenClass
| TokPi1 | TokPi1
| TokPi2 | TokPi2
| TokAnd
| TokOr
| TokSemi | TokSemi
deriving (Eq, Show, Ord) deriving (Eq, Show, Ord)
@ -41,8 +47,10 @@ tokSize TokEof = 0
tokSize TokLambda = 1 tokSize TokLambda = 1
tokSize TokOParen = 1 tokSize TokOParen = 1
tokSize TokOBrace = 1 tokSize TokOBrace = 1
tokSize TokOSquare = 1
tokSize TokCBrace = 1 tokSize TokCBrace = 1
tokSize TokCParen = 1 tokSize TokCParen = 1
tokSize TokCSquare = 1
tokSize TokCPragma = 3 tokSize TokCPragma = 3
tokSize TokOPragma = 3 tokSize TokOPragma = 3
tokSize TokPrim = length "PRIMITIVE" tokSize TokPrim = length "PRIMITIVE"
@ -55,6 +63,8 @@ tokSize TokArrow = 2
tokSize TokPi1 = 2 tokSize TokPi1 = 2
tokSize TokPi2 = 2 tokSize TokPi2 = 2
tokSize TokReplLet = 4 tokSize TokReplLet = 4
tokSize TokAnd = 2
tokSize TokOr = 2
tokSize (TokReplT s) = T.length s tokSize (TokReplT s) = T.length s
data Token data Token


+ 39
- 0
src/Syntax.hs View File

@ -11,6 +11,8 @@ import Data.Set (Set)
import qualified Data.Set as Set import qualified Data.Set as Set
import Data.Sequence (Seq) import Data.Sequence (Seq)
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
data WiredIn data WiredIn
= WiType = WiType
@ -22,6 +24,14 @@ data WiredIn
| WiIOr | WiIOr
| WiINot | WiINot
| WiPathP | WiPathP
| WiIsOne -- Proposition associated with an element of the interval
| WiItIsOne -- 1 = 1
| WiIsOne1 -- i j -> [i] -> [ior i j]
| WiIsOne2 -- i j -> [j] -> [ior i j]
| WiPartial -- (φ : I) -> Type -> Typeω
| WiPartialP -- (φ : I) -> Partial r Type -> Typeω
deriving (Eq, Show, Ord) deriving (Eq, Show, Ord)
data Term data Term
@ -51,6 +61,16 @@ data Term
| PathIntro Term Term | PathIntro Term Term
-- ^ PathIntro : (A : I -> Type) (f : (i : I) -> A i) -> PathP A (f i0) (f i1) -- ^ PathIntro : (A : I -> Type) (f : (i : I) -> A i) -> PathP A (f i0) (f i1)
-- ~~~~~~~~~ not printed at all -- ~~~~~~~~~ not printed at all
| IsOne Term
| IsOne1 Term
| IsOne2 Term
| ItIsOne
| Partial Term Term
| PartialP Term Term
| System (Map Term Term)
deriving (Eq, Show, Ord) deriving (Eq, Show, Ord)
data MV = data MV =
@ -90,6 +110,15 @@ data Value
| VPath Value Value Value | VPath Value Value Value
| VLine Value Value | VLine Value Value
| VIsOne Value
| VItIsOne
| VIsOne1 Value
| VIsOne2 Value
| VPartial NFEndp Value
| VPartialP NFEndp Value
| VSystem (Map Value Value)
deriving (Eq, Show, Ord) deriving (Eq, Show, Ord)
pattern VVar :: Name -> Value pattern VVar :: Name -> Value
@ -120,6 +149,7 @@ quoteWith names (VSigma d (Closure n k)) =
quoteWith names (VPair a b) = Pair (quoteWith names a) (quoteWith names b) quoteWith names (VPair a b) = Pair (quoteWith names a) (quoteWith names b)
quoteWith _ VType = Type quoteWith _ VType = Type
quoteWith _ VTypeω = Typeω quoteWith _ VTypeω = Typeω
quoteWith _ VI = I quoteWith _ VI = I
quoteWith _ VI0 = I0 quoteWith _ VI0 = I0
quoteWith _ VI1 = I1 quoteWith _ VI1 = I1
@ -130,6 +160,15 @@ quoteWith names (VINot x) = INot (quoteWith names x)
quoteWith names (VPath line x y) = PathP (quoteWith names line) (quoteWith names x) (quoteWith names y) quoteWith names (VPath line x y) = PathP (quoteWith names line) (quoteWith names x) (quoteWith names y)
quoteWith names (VLine p f) = PathIntro (quoteWith names p) (quoteWith names f) quoteWith names (VLine p f) = PathIntro (quoteWith names p) (quoteWith names f)
quoteWith names (VIsOne v) = IsOne (quoteWith names v)
quoteWith names (VIsOne1 v) = IsOne1 (quoteWith names v)
quoteWith names (VIsOne2 v) = IsOne2 (quoteWith names v)
quoteWith _ VItIsOne = ItIsOne
quoteWith names (VPartial x y) = Partial (quoteWith names x) (quoteWith names y)
quoteWith names (VPartialP x y) = Partial (quoteWith names x) (quoteWith names y)
quoteWith names (VSystem fs) = System (Map.fromList (map (\(x, y) -> (quoteWith names x, quoteWith names y)) (Map.toList fs)))
refresh :: Set Text -> Text -> Text refresh :: Set Text -> Text -> Text
refresh s n refresh s n
| T.singleton '_' == n = n | T.singleton '_' == n = n


+ 24
- 2
src/Syntax/Pretty.hs View File

@ -14,6 +14,8 @@ import Prettyprinter.Render.Terminal
import Prettyprinter import Prettyprinter
import Syntax import Syntax
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
instance Pretty Name where instance Pretty Name where
pretty (Bound x) = pretty x pretty (Bound x) = pretty x
@ -31,6 +33,7 @@ prettyTm (Proj2 x) = prettyTm x <> operator (pretty ".2")
prettyTm l@(Lam _ _ _) = pretty '\\' <> hsep (map prettyArgList al) <+> pretty "->" <+> prettyTm bod where prettyTm l@(Lam _ _ _) = pretty '\\' <> hsep (map prettyArgList al) <+> pretty "->" <+> prettyTm bod where
unwindLam (Lam p x y) = first ((p, x):) (unwindLam y) unwindLam (Lam p x y) = first ((p, x):) (unwindLam y)
unwindLam (PathIntro _ (Lam p x y)) = first ((p, x):) (unwindLam y)
unwindLam t = ([], t) unwindLam t = ([], t)
(al, bod) = unwindLam l (al, bod) = unwindLam l
@ -52,14 +55,25 @@ prettyTm (Pi Ex v d r) = parens (pretty v <+> colon <+> prettyTm
prettyTm (Sigma (T.unpack -> "_") d r) = prettyDom d <+> pretty "*" <+> prettyTm r prettyTm (Sigma (T.unpack -> "_") d r) = prettyDom d <+> pretty "*" <+> prettyTm r
prettyTm (Sigma v d r) = parens (pretty v <+> colon <+> prettyTm d) <+> pretty "*" <+> prettyTm r prettyTm (Sigma v d r) = parens (pretty v <+> colon <+> prettyTm d) <+> pretty "*" <+> prettyTm r
prettyTm (IAnd x y) = prettyTm x <+> operator (pretty "&&") <+> prettyTm y
prettyTm (IOr x y) = prettyTm x <+> operator (pretty "||") <+> prettyTm y
prettyTm (IAnd x y) = parens $ prettyTm x <+> operator (pretty "&&") <+> prettyTm y
prettyTm (IOr x y) = parens $ prettyTm x <+> operator (pretty "||") <+> prettyTm y
prettyTm (INot x) = operator (pretty '~') <> prettyTm x prettyTm (INot x) = operator (pretty '~') <> prettyTm x
prettyTm (PathP l x y) = keyword (pretty "PathP") <+> parenArg l <+> parenArg x <+> parenArg y prettyTm (PathP l x y) = keyword (pretty "PathP") <+> parenArg l <+> parenArg x <+> parenArg y
prettyTm (IElim _ _ _ f i) = prettyTm (App Ex f i) prettyTm (IElim _ _ _ f i) = prettyTm (App Ex f i)
prettyTm (PathIntro _ f) = prettyTm f prettyTm (PathIntro _ f) = prettyTm f
prettyTm (IsOne phi) = brackets (prettyTm phi)
prettyTm ItIsOne = keyword (pretty "1=1")
prettyTm (IsOne1 phi) = prettyTm (App Ex (Ref (Bound (T.pack "isOne1"))) phi)
prettyTm (IsOne2 phi) = prettyTm (App Ex (Ref (Bound (T.pack "isOne2"))) phi)
prettyTm (Partial phi a) = prettyTm $ foldl (App Ex) (Ref (Bound (T.pack "Partial"))) [phi, a]
prettyTm (PartialP phi a) = prettyTm $ foldl (App Ex) (Ref (Bound (T.pack "PartialP"))) [phi, a]
prettyTm (System xs) = braces (mempty <+> hsep (punctuate comma (map go (Map.toList xs))) <+> mempty) where
go (f, t) = prettyTm f <+> operator (pretty "=>") <+> prettyTm t
keyword :: Doc AnsiStyle -> Doc AnsiStyle keyword :: Doc AnsiStyle -> Doc AnsiStyle
keyword = annotate (color Magenta) keyword = annotate (color Magenta)
@ -69,6 +83,10 @@ operator = annotate (color Yellow)
parenArg :: Term -> Doc AnsiStyle parenArg :: Term -> Doc AnsiStyle
parenArg x@App{} = parens (prettyTm x) parenArg x@App{} = parens (prettyTm x)
parenArg x@IElim{} = parens (prettyTm x) parenArg x@IElim{} = parens (prettyTm x)
parenArg x@IsOne1{} = parens $ prettyTm x
parenArg x@IsOne2{} = parens $ prettyTm x
parenArg x@Partial{} = parens $ prettyTm x
parenArg x@PartialP{} = parens $ prettyTm x
parenArg x = prettyDom x parenArg x = prettyDom x
prettyDom :: Term -> Doc AnsiStyle prettyDom :: Term -> Doc AnsiStyle
@ -86,3 +104,7 @@ render = L.toStrict . renderLazy . layoutPretty defaultLayoutOptions
showValue :: Value -> String showValue :: Value -> String
showValue = L.unpack . renderLazy . layoutPretty defaultLayoutOptions . prettyTm . quote showValue = L.unpack . renderLazy . layoutPretty defaultLayoutOptions . prettyTm . quote
showFace :: Map Head Bool -> Doc AnsiStyle
showFace = hsep . map go . Map.toList where
go (h, b) = parens $ prettyTm (quote (VNe h mempty)) <+> operator (pretty "=") <+> pretty (if b then "i1" else "i0")

+ 45
- 1
test.tt View File

@ -30,6 +30,9 @@ refl {A} {x} i = x
sym : {A : I -> Pretype} {x : A i0} {y : A i1} -> PathP A x y -> PathP (\i -> A (inot i)) y x sym : {A : I -> Pretype} {x : A i0} {y : A i1} -> PathP A x y -> PathP (\i -> A (inot i)) y x
sym p i = p (inot i) sym p i = p (inot i)
id : {A : Type} -> A -> A
id x = x
the : (A : Pretype) -> A -> A the : (A : Pretype) -> A -> A
the A x = x the A x = x
@ -43,4 +46,45 @@ isContr : Type -> Type
isContr A = (x : A) * ((y : A) -> Path x y) isContr A = (x : A) * ((y : A) -> Path x y)
singContr : {A : Type} {a : A} -> isContr (Singl A a) singContr : {A : Type} {a : A} -> isContr (Singl A a)
singContr {A} {a} = ((a, \i -> a), \y i -> (y.2 i, \j -> y.2 (iand i j)))
singContr {A} {a} = ((a, \i -> a), \y i -> (y.2 i, \j -> y.2 (iand i j)))
cong : {A : Type} {B : A -> Type} (f : (x : A) -> B x) {x : A} {y : A} (p : Path x y) -> PathP (\i -> B (p i)) (f x) (f y)
cong f p i = f (p i)
congComp : {A : Type} {B : Type} {C : Type}
{f : A -> B} {g : B -> C} {x : A} {y : A}
(p : Path x y)
-> Path (cong g (cong f p)) (cong (\x -> g (f x)) p)
congComp p = refl
congId : {A : Type} {x : A} {y : A}
(p : Path x y)
-> Path (cong (id {A}) p) p
congId p = refl
IsOne : I -> Type
{-# PRIMITIVE IsOne #-}
itIs1 : IsOne i1
{-# PRIMITIVE itIs1 #-}
isOneL : {i : I} {j : I} -> IsOne i -> IsOne (ior i j)
{-# PRIMITIVE isOneL #-}
isOneR : {i : I} {j : I} -> IsOne j -> IsOne (ior i j)
{-# PRIMITIVE isOneR #-}
Partial : I -> Type -> Pretype
{-# PRIMITIVE Partial #-}
PartialP : (phi : I) -> Partial phi Type -> Pretype
{-# PRIMITIVE PartialP #-}
Bool : Type
tt, ff : Bool
foo : (i : I) -> (j : I) -> Partial (ior (inot i) (ior i (iand i j))) Bool
foo i j = \ { (i = i0) -> tt, (i = i1) -> ff, (i = i1) && (j = i1) -> ff }
apPartial : {B : Type} {A : Type} -> (phi : I) -> (A -> B) -> Partial phi A -> Partial phi B
apPartial phi f p is1 = f (p is1)

Write Preview
Loading…
Cancel
Save