diff --git a/cubical.cabal b/cubical.cabal index 05e2d0b..bef1588 100644 --- a/cubical.cabal +++ b/cubical.cabal @@ -43,6 +43,7 @@ executable cubical , Elab.Eval , Elab.Monad , Elab.WiredIn + , Elab.Eval.Formula build-tool-depends: alex:alex >= 3.2.4 && < 4.0 , happy:happy >= 1.19.12 && < 2.0 diff --git a/src/Elab.hs b/src/Elab.hs index d846e94..e0bf0e5 100644 --- a/src/Elab.hs +++ b/src/Elab.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TupleSections, OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE ScopedTypeVariables #-} module Elab where @@ -7,8 +7,11 @@ import Control.Monad.Reader import Control.Exception import qualified Data.Map.Strict as Map +import Data.Traversable import Data.Typeable +import Data.Foldable +import Elab.Eval.Formula (possible) import Elab.WiredIn import Elab.Monad import Elab.Eval @@ -17,8 +20,9 @@ import qualified Presyntax.Presyntax as P import Prettyprinter -import Syntax.Pretty import Syntax +import Syntax.Pretty +import qualified Data.Text as T infer :: P.Expr -> ElabM (Term, NFType) 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_nf <- eval x 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 (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 porp <- isPiType p =<< forceIO ty case porp of - It'sProd d r wp -> do + It'sProd d r wp -> assume (Bound v) d $ wp . Lam p v <$> check b (r (VVar (Bound v))) + It'sPath li le ri wp -> do 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 + unify (tm_nf @@ VI0) le `catchElab` (throwElab . WhenCheckingEndpoint le ri VI0) + unify (tm_nf @@ VI1) ri `catchElab` (throwElab . WhenCheckingEndpoint le ri VI1) + 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 (d, r, wp) <- isSigmaType =<< forceIO ty a <- check a d @@ -107,11 +145,52 @@ check (P.Sigma s d r) ty = do r <- check r ty 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 (tm, has) <- switch $ infer exp wp <- isConvertibleTo has ty 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 VType = pure () isSort VTypeω = pure () @@ -128,16 +207,29 @@ data ProdOrPath , pathRight :: Value , 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 (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 (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 meta <- newMeta d porp <- isPiType P.Ex (k meta) pure $ case porp of 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'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 dom <- newMeta VType name <- newName @@ -156,8 +248,14 @@ isSigmaType t = do wp <- isConvertibleTo t (VSigma dom (Closure name (const rng))) 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.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 ty <- getNfType nm unify ty (wiType wi) - `withNote` hsep [ "Previous definition of", pretty nm, "here" ] + `withNote` hsep [ pretty "Previous definition of", pretty nm, pretty "here" ] `seeAlso` nm env <- ask diff --git a/src/Elab/Eval.hs b/src/Elab/Eval.hs index 636be86..5422e19 100644 --- a/src/Elab/Eval.hs +++ b/src/Elab/Eval.hs @@ -18,17 +18,19 @@ import Data.Foldable import Data.IORef import Data.Maybe +import Elab.Eval.Formula import Elab.Monad import Presyntax.Presyntax (Plicity(..)) +import Prettyprinter + import Syntax.Pretty import Syntax import System.IO.Unsafe import {-# SOURCE #-} Elab.WiredIn -import Prettyprinter eval :: Term -> ElabM Value 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 (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 = 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 (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 p (VLam p' 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') | x == x', length a == length a' = traverse_ (uncurry unify'Spine) (Seq.zip a a') - + go (VNe _hd (_ Seq.:|> PIElim _l x y i)) rhs = case force i of VI0 -> unify' x rhs VI1 -> unify' y rhs _ -> 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 t <- VVar . Bound <$> newName 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 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 unify' l l' unify' x x' unify' y y' - + go (VLine l p) p' = do n <- VVar . Bound <$> newName 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 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 @@ -227,8 +271,12 @@ unify' topa topb = join $ go <$> forceIO topa <*> forceIO topb where unify'Spine _ _ = fail + unify'Formula x y + | compareDNFs x y = pure () + | otherwise = fail + 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) 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 (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 scope (PApp Ex (VVar n@(Bound t)) Seq.:<| xs) diff --git a/src/Elab/Eval/Formula.hs b/src/Elab/Eval/Formula.hs new file mode 100644 index 0000000..cfa6ccf --- /dev/null +++ b/src/Elab/Eval/Formula.hs @@ -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 diff --git a/src/Elab/WiredIn.hs b/src/Elab/WiredIn.hs index 317f44b..53a6c37 100644 --- a/src/Elab/WiredIn.hs +++ b/src/Elab/WiredIn.hs @@ -23,10 +23,18 @@ 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 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 @@ -41,6 +49,14 @@ 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 ~> @@ -68,6 +84,14 @@ wiredInNames = Map.fromList , ("ior", WiIOr) , ("inot", WiINot) , ("PathP", WiPathP) + + , ("IsOne", WiIsOne) + , ("itIs1", WiItIsOne) + , ("isOneL", WiIsOne1) + , ("isOneR", WiIsOne2) + + , ("Partial", WiPartial) + , ("PartialP", WiPartialP) ] newtype NoSuchPrimitive = NoSuchPrimitive { getUnknownPrim :: Text } @@ -80,6 +104,10 @@ 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 @@ -88,6 +116,10 @@ iand = \case 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 diff --git a/src/Presyntax/Lexer.x b/src/Presyntax/Lexer.x index a5e116b..a93c588 100644 --- a/src/Presyntax/Lexer.x +++ b/src/Presyntax/Lexer.x @@ -15,6 +15,7 @@ $white_nol = $white # \n tokens :- $white_nol+ ; + "--" .* \n ; <0,prtext> $alpha [$alpha $digit \_ \']* { yield TokVar } @@ -32,13 +33,26 @@ tokens :- <0> \( { always TokOParen } <0> \{ { always TokOBrace } +<0> \[ { always TokOSquare } <0> \) { always TokCParen } <0> \} { always TokCBrace } +<0> \] { always TokCSquare } + <0> \; { always TokSemi } <0> \n { just $ pushStartCode newline } +<0> "&&" { always TokAnd } +<0> "||" { always TokOr } + +<0> "{-" { just $ pushStartCode comment } + + { + "-}" { \i l -> popStartCode *> skip i l } + . ; +} + <0> "{-#" { \i l -> pushStartCode prkw *> always TokOPragma i l } "PRIMITIVE" { \i l -> popStartCode *> pushStartCode prtext *> always TokPrim i l } "#-}" { \i l -> popStartCode *> always TokCPragma i l } @@ -91,14 +105,16 @@ popStartCode = do alexSetStartCode x 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" } \ No newline at end of file diff --git a/src/Presyntax/Parser.y b/src/Presyntax/Parser.y index 28cc2e5..2720a46 100644 --- a/src/Presyntax/Parser.y +++ b/src/Presyntax/Parser.y @@ -1,5 +1,5 @@ { -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances, ViewPatterns #-} module Presyntax.Parser where import qualified Data.Text as T @@ -28,12 +28,17 @@ import Prelude hiding (span) %token var { Token (TokVar _) _ _ } + 'eof' { Token TokEof _ _ } + '(' { Token TokOParen _ _ } ')' { Token TokCParen _ _ } '{' { Token TokOBrace _ _ } '}' { Token TokCBrace _ _ } + '[' { Token TokOSquare _ _ } + ']' { Token TokCSquare _ _ } + '{-#' { Token TokOPragma _ _ } '#-}' { Token TokCPragma _ _ } @@ -46,6 +51,9 @@ import Prelude hiding (span) ',' { Token TokComma _ _ } '*' { Token TokStar _ _ } + '&&' { Token TokAnd _ _ } + '||' { Token TokOr _ _ } + '.1' { Token TokPi1 _ _ } '.2' { Token TokPi2 _ _ } @@ -59,6 +67,7 @@ import Prelude hiding (span) Exp :: { Expr } Exp : '\\' 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 Im (getVar $2) $4 $6 } | ExpApp '->' Exp { span $1 $3 $ Pi Ex (T.singleton '_') $1 $3 } @@ -85,6 +94,7 @@ Tuple :: { Expr } Atom :: { Expr } : var { span $1 $1 $ Var (getVar $1) } | '(' Tuple ')' { span $1 $3 $ $2 } + | '[' Exp ']' { span $1 $3 $ Bracket $2 } ProdTail :: { Expr } : '(' VarList ':' Exp ')' ProdTail { span $1 $6 $ makePis Ex (thd $2) $4 $6 } @@ -119,13 +129,42 @@ ReplStatement :: { Statement } | '{-#' Pragma '#-}' { spanSt $1 $3 $ $2 } Program :: { [Statement] } - : Statement { [$1] } - | Statement ';' Program { $1:$3 } + : Statement { [$1] } + | Statement Semis Program { $1:$3 } + +Semis :: { () } + : ';' { () } + | ';' Semis { () } Pragma :: { Statement } : 'PRIMITIVE' var var { Builtin (getVar $2) (getVar $3) } | '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 diff --git a/src/Presyntax/Presyntax.hs b/src/Presyntax/Presyntax.hs index 2c33e9b..b9292f1 100644 --- a/src/Presyntax/Presyntax.hs +++ b/src/Presyntax/Presyntax.hs @@ -19,9 +19,24 @@ data Expr | Proj1 Expr | Proj2 Expr + -- application of IsOne primitive is written like [ φ ] + | Bracket Expr + + -- System + | LamSystem [(Formula, Expr)] + | Span Expr Posn Posn deriving (Eq, Show, Ord) +data Formula + = FIs1 Text + | FIs0 Text + | FAnd Formula Formula + | FOr Formula Formula + | FTop + | FBot + deriving (Eq, Show, Ord) + data Statement = Decl [Text] Expr | Defn Text Expr diff --git a/src/Presyntax/Tokens.hs b/src/Presyntax/Tokens.hs index 970dccb..2bf2086 100644 --- a/src/Presyntax/Tokens.hs +++ b/src/Presyntax/Tokens.hs @@ -12,8 +12,11 @@ data TokenClass | TokOParen | TokOBrace + | TokOSquare + | TokCParen | TokCBrace + | TokCSquare -- {-# #-} | TokOPragma @@ -32,6 +35,9 @@ data TokenClass | TokPi1 | TokPi2 + | TokAnd + | TokOr + | TokSemi deriving (Eq, Show, Ord) @@ -41,8 +47,10 @@ tokSize TokEof = 0 tokSize TokLambda = 1 tokSize TokOParen = 1 tokSize TokOBrace = 1 +tokSize TokOSquare = 1 tokSize TokCBrace = 1 tokSize TokCParen = 1 +tokSize TokCSquare = 1 tokSize TokCPragma = 3 tokSize TokOPragma = 3 tokSize TokPrim = length "PRIMITIVE" @@ -55,6 +63,8 @@ tokSize TokArrow = 2 tokSize TokPi1 = 2 tokSize TokPi2 = 2 tokSize TokReplLet = 4 +tokSize TokAnd = 2 +tokSize TokOr = 2 tokSize (TokReplT s) = T.length s data Token diff --git a/src/Syntax.hs b/src/Syntax.hs index 9b17dc9..9b99f16 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -11,6 +11,8 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.Sequence (Seq) import qualified Data.Sequence as Seq +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map data WiredIn = WiType @@ -22,6 +24,14 @@ data WiredIn | WiIOr | WiINot | 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) data Term @@ -51,6 +61,16 @@ data Term | PathIntro Term Term -- ^ PathIntro : (A : I -> Type) (f : (i : I) -> A i) -> PathP A (f i0) (f i1) -- ~~~~~~~~~ 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) data MV = @@ -90,6 +110,15 @@ data Value | VPath Value 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) 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 _ VType = Type quoteWith _ VTypeω = Typeω + quoteWith _ VI = I quoteWith _ VI0 = I0 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 (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 s n | T.singleton '_' == n = n diff --git a/src/Syntax/Pretty.hs b/src/Syntax/Pretty.hs index 81872f3..f905688 100644 --- a/src/Syntax/Pretty.hs +++ b/src/Syntax/Pretty.hs @@ -14,6 +14,8 @@ import Prettyprinter.Render.Terminal import Prettyprinter import Syntax +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map instance Pretty Name where 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 unwindLam (Lam p x y) = first ((p, x):) (unwindLam y) + unwindLam (PathIntro _ (Lam p x y)) = first ((p, x):) (unwindLam y) unwindLam t = ([], t) (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 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 (PathP l x y) = keyword (pretty "PathP") <+> parenArg l <+> parenArg x <+> parenArg y prettyTm (IElim _ _ _ f i) = prettyTm (App Ex f i) 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 = annotate (color Magenta) @@ -69,6 +83,10 @@ operator = annotate (color Yellow) parenArg :: Term -> Doc AnsiStyle parenArg x@App{} = 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 prettyDom :: Term -> Doc AnsiStyle @@ -86,3 +104,7 @@ render = L.toStrict . renderLazy . layoutPretty defaultLayoutOptions showValue :: Value -> String 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") \ No newline at end of file diff --git a/test.tt b/test.tt index f468ec0..7513a6e 100644 --- a/test.tt +++ b/test.tt @@ -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 p i = p (inot i) +id : {A : Type} -> A -> A +id x = x + the : (A : Pretype) -> A -> A the A x = x @@ -43,4 +46,45 @@ isContr : Type -> Type isContr A = (x : A) * ((y : A) -> Path x y) 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))) \ No newline at end of file +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) \ No newline at end of file