Compare commits

...

No commits in common. 'master' and 'feature/web' have entirely different histories.

36 changed files with 5214 additions and 2806 deletions
Split View
  1. +14
    -0
      .gitignore
  2. +28
    -0
      Makefile
  3. +17
    -6
      cubical.cabal
  4. +236
    -1537
      intro.tt
  5. +0
    -45
      src/Debug.hs
  6. +90
    -94
      src/Elab.hs
  7. +192
    -292
      src/Elab/Eval.hs
  8. +11
    -31
      src/Elab/Eval/Formula.hs
  9. +0
    -18
      src/Elab/Eval/Formula.hs-boot
  10. +5
    -32
      src/Elab/Monad.hs
  11. +133
    -260
      src/Elab/WiredIn.hs
  12. +11
    -18
      src/Elab/WiredIn.hs-boot
  13. +56
    -123
      src/Main.hs
  14. +2
    -20
      src/Presyntax/Lexer.x
  15. +22
    -20
      src/Presyntax/Parser.y
  16. +11
    -3
      src/Presyntax/Presyntax.hs
  17. +0
    -2
      src/Presyntax/Tokens.hs
  18. +55
    -97
      src/Syntax.hs
  19. +179
    -202
      src/Syntax/Pretty.hs
  20. +135
    -0
      src/Web.hs
  21. +8
    -0
      src/wrapper.mjs
  22. +64
    -2
      stack.yaml
  23. +4
    -4
      stack.yaml.lock
  24. +7
    -0
      web/.gitignore
  25. +13
    -0
      web/deploy.sh
  26. +17
    -0
      web/html/index.html
  27. +3549
    -0
      web/package-lock.json
  28. +27
    -0
      web/package.json
  29. +71
    -0
      web/src/editor.ts
  30. +98
    -0
      web/src/index.ts
  31. +30
    -0
      web/src/language.ts
  32. +15
    -0
      web/src/toast.ts
  33. +14
    -0
      web/styles/main.css
  34. +33
    -0
      web/tsconfig.json
  35. +31
    -0
      web/typings/cubical.ts
  36. +36
    -0
      web/webpack.config.js

+ 14
- 0
.gitignore View File

@ -1 +1,15 @@
.stack-work/
dist-newstyle
*.hi-boot
*.o
*.o-boot
*.hi
src/Presyntax/Lexer.hs
src/Presyntax/Parser.hs
*.js
!web/interaction.js
*.wasm
cabal.project.local

+ 28
- 0
Makefile View File

@ -0,0 +1,28 @@
FUNCTIONS := $(shell grep -R "foreign" src/ | cut -d' ' -f4)
HS_FILES := $(shell find src -type f -name '*.hs' -or -name '*.hs-boot')
CABAL_OPTL := $(foreach function,$(FUNCTIONS),--ghc-option=-optl--export-function=$(function)) -f asterius
AHCD_OPTL := $(foreach function,$(FUNCTIONS),--export-function=$(function))
CABAL := ahc-cabal
AHCD := ahc-dist
web/dist/cubical.wasm: web/dist/cubical.js
cp dist-newstyle/cubical.wasm $@
web/dist/cubical.js: dist-newstyle/cubical.js
cp dist-newstyle/cubical.js $@
dist-newstyle/cubical.js: dist-newstyle/cubical src/wrapper.mjs
mkdir -p dist-newstyle/ahcd-spam
$(AHCD) $(AHCD_OPTL) --input-exe $< --browser --bundle --input-mjs src/wrapper.mjs
dist-newstyle/cubical: src/Presyntax/Lexer.hs src/Presyntax/Parser.hs $(HS_FILES)
$(CABAL) v2-install $(CABAL_OPTL) --installdir dist-newstyle exe:cubical --overwrite-policy=always
src/Presyntax/Lexer.hs: src/Presyntax/Lexer.x
alex $<
src/Presyntax/Parser.hs: src/Presyntax/Parser.y
happy $<

+ 17
- 6
cubical.cabal View File

@ -10,19 +10,25 @@ maintainer: [email protected]
copyright: 2021 Abigail Magalhães
category: Web
build-type: Simple
cabal-version: >=2.0
cabal-version: 2.0
extra-source-files: README.md
flag asterius
description: Is this build for the web?
manual: True
default: False
executable cubical
hs-source-dirs: src
main-is: Main.hs
default-language: Haskell2010
build-depends: base ^>= 4.14
build-depends: base >= 4.13
, mtl ^>= 2.2
, syb ^>= 0.7
, text ^>= 1.2
, array ^>= 0.5
, aeson >= 1.4
, containers ^>= 0.6
, bytestring ^>= 0.10
@ -46,9 +52,14 @@ executable cubical
, Elab.WiredIn
, Elab.Eval.Formula
, Debug
-- Asterius wrapper
, Web
if !flag(asterius)
build-tool-depends: alex:alex >= 3.2.4 && < 4.0
, happy:happy >= 1.19.12 && < 2.0
build-tool-depends: alex:alex >= 3.2.4 && < 4.0
, happy:happy >= 1.19.12 && < 2.0
if flag(asterius)
build-depends: asterius-prelude == 0.0.1
ghc-options: -Wall -Wextra -Wno-name-shadowing -rtsopts
ghc-options: -Wall -Wextra -Wno-name-shadowing

+ 236
- 1537
intro.tt
File diff suppressed because it is too large
View File


+ 0
- 45
src/Debug.hs View File

@ -1,45 +0,0 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE BangPatterns #-}
#undef RELEASE
module Debug where
import qualified Debug.Trace as D
#if defined(RELEASE)
import GHC.Exts
#endif
import GHC.Stack
import Prettyprinter
import qualified Data.Text.Lazy as T
import Data.Text.Prettyprint.Doc.Render.Text (renderLazy)
traceDoc :: Doc a -> b -> b
#if defined(RELEASE)
type DebugCallStack = (() :: Constraint)
traceDoc !_ v = v
#else
type DebugCallStack = HasCallStack
traceDoc x = D.trace (T.unpack (renderLazy (layoutPretty defaultLayoutOptions x)))
#endif
trace :: Pretty a => a -> b -> b
trace x = traceDoc (pretty x)
traceWith :: Pretty a => String -> a -> b -> b
traceWith s x = traceDoc (pretty s <+> pretty x)
traceId :: Pretty a => a -> a
traceId x = traceDoc (pretty x) x
traceWithId :: Pretty a => String -> a -> a
traceWithId s x = traceWith s x x
traceDocM :: (Applicative m) => Doc a -> m ()
traceDocM x = traceDoc x (pure ())
traceM :: (Applicative m, Pretty a) => a -> m ()
traceM = traceDocM . pretty

+ 90
- 94
src/Elab.hs View File

@ -4,7 +4,6 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE EmptyCase #-}
module Elab where
import Control.Arrow (Arrow(first))
@ -15,7 +14,6 @@ import qualified Data.Map.Strict as Map
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Maybe (fromMaybe)
import Data.Traversable
import Data.Text (Text)
import Data.Map (Map)
@ -33,6 +31,7 @@ import Prettyprinter
import Syntax.Pretty
import Syntax
import Data.Maybe (fromMaybe)
infer :: P.Expr -> ElabM (Term, NFType)
infer (P.Span ex a b) = withSpan a b $ infer ex
@ -55,10 +54,10 @@ infer (P.App p f x) = do
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 (VEqStrict VI phi VI1)
x <- check x (VIsOne phi)
pure (App P.Ex (w f) x, a)
It'sPartialP phi a w -> do
x <- check x (VEqStrict VI phi VI1)
x <- check x (VIsOne phi)
x_nf <- eval x
pure (App P.Ex (w f) x, a @@ x_nf)
@ -102,17 +101,20 @@ check (P.Lam p v b) ty = do
tm_nf <- eval tm
unify (tm_nf @@ VI0) le `catchElab` (throwElab . WhenCheckingEndpoint (Bound v 0) le ri VI0)
unify (tm_nf @@ VI1) ri `catchElab` (throwElab . WhenCheckingEndpoint (Bound v 0) le ri VI1)
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)) (quote le) (quote ri) tm))
It'sPartial phi a wp ->
assume (Bound v 0) (VEqStrict VI phi VI1) $ \var ->
assume (Bound v 0) (VIsOne phi) $ \var ->
wp . Lam p var <$> check b a
It'sPartialP phi a wp ->
assume (Bound v 0) (VEqStrict VI phi VI1) $ \var ->
assume (Bound v 0) (VIsOne phi) $ \var ->
wp . Lam p var <$> check b (a @@ VVar var)
check (P.Pair a b) ty = do
@ -145,36 +147,54 @@ check (P.Let items body) ty = do
check (P.LamSystem bs) ty = do
(extent, dom) <- isPartialType ty
env <- ask
eqns <- for bs \(formula, rhs) -> do
(phi, fv) <- checkFormula formula
n <- newName
rhses <- for (truthAssignments phi (getEnv env)) $ \e -> do
let env' = env{ getEnv = e }
local (const env') $
check rhs (substitute (snd <$> Map.restrictKeys e fv) (dom (VVar n)))
let dom_q = quote dom
eqns <- for (zip [(0 :: Int)..] bs) $ \(n, (formula, rhs)) -> do
phi <- checkFormula (P.condF formula)
rhses <-
case P.condV formula of
Just t -> assume (Bound t 0) (VIsOne phi) $ \var -> do
env <- ask
for (truthAssignments phi (getEnv env)) $ \e -> do
let env' = env{ getEnv = e }
(Just var,) <$> check rhs (eval' env' dom_q)
Nothing -> do
env <- ask
for (truthAssignments phi (getEnv env)) $ \e -> do
let env' = env{ getEnv = e }
(Nothing,) <$> check rhs (eval' env' dom_q)
pure (n, (phi, head rhses))
unify extent (foldl ior VI0 (map (fst . snd) eqns))
for_ eqns \(n, (formula, rhs)) -> do
for_ eqns $ \(n', (formula', rhs')) -> do
for_ eqns $ \(n, (formula, (binding, rhs))) -> do
let
k = case binding of
Just v -> assume v (VIsOne formula) . const
Nothing -> id
k $ for_ eqns $ \(n', (formula', (binding, rhs'))) -> do
let
k = case binding of
Just v -> assume v (VIsOne formula) . const
Nothing -> id
truth = possible mempty (iand formula formula')
when ((n /= n') && fst truth) . for_ (truthAssignments (iand formula formula') (getEnv env)) $ \e -> do
let env' = env { getEnv = e }
vl = eval' env' rhs
vl' = eval' env' rhs'
add [] = id
add ((~(HVar x), True):xs) = redefine x VI VI1 . add xs
add ((~(HVar x), False):xs) = redefine x VI VI0 . add xs
k $ when ((n /= n') && fst truth) . add (Map.toList (snd 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 "=>") <+> pretty vl
, indent 2 $ pretty '*' <+> prettyTm (quote formula') <+> operator (pretty "=>") <+> pretty (zonk vl')
, 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 False (snd truth))
`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))))
let
mkB name (Just v, b) = App P.Ex (Lam P.Ex v b) (Ref name)
mkB _ (Nothing, b) = b
pure (Lam P.Ex name (System (Map.fromList (map (\(_, (x, y)) -> (quote x, mkB name y)) eqns))))
check (P.LamCase pats) ty =
do
@ -212,14 +232,12 @@ check (P.LamCase pats) ty =
let rhs = cases @@ side
for_ (truthAssignments formula mempty) $ \i -> do
let vl = foldl (\v n -> vApp P.Ex v (lookup n)) base (getBoundaryNames boundary)
lookup n = fromMaybe (VVar n) (snd <$> (Map.lookup n i))
lookup n = fromMaybe VI0 (snd <$> (Map.lookup n i))
unify vl rhs
`withNote` (pretty "From the boundary conditions of the constructor" <+> prettyTm (quote pat_nf) <> pretty ":")
`withNote` vcat [ pretty "These must be the same because of the face"
, indent 2 $ prettyVl (zonk formula) <+> operator (pretty "=>") <+> prettyVl (zonk side)
, pretty "which is mapped to"
, indent 2 $ prettyVl (zonk formula) <+> operator (pretty "=>") <+> prettyVl (zonk rhs)
, indent 2 $ prettyTm (quote formula) <+> operator (pretty "=>") <+> prettyTm (quote (zonk side))
]
`withNote` (pretty "Mandated by the constructor" <+> prettyTm (quote pat_nf))
_ -> pure ()
pure (pat, n_lams, wp rhs)
@ -246,10 +264,6 @@ check (P.LamCase pats) ty =
boundaryFormulas (x:xs) k = boundaryFormulas xs $ k @@ VVar x
boundaryFormulas a b = error (show (a, b))
check P.Hole ty = do
t <- newMeta' True ty
pure (quote t)
check exp ty = do
(tm, has) <- switch $ infer exp
wp <- isConvertibleTo has ty
@ -316,11 +330,7 @@ skipLams k = do
(Lam P.Im n . ) <$> skipLams (k - 1)
checkLetItems :: Map Text (Maybe (Name, NFType)) -> [P.LetItem] -> ([(Name, Term, Term)] -> ElabM a) -> ElabM a
checkLetItems map [] cont = do
for_ (Map.toList map) $ \case
(_, Nothing) -> pure ()
(n, Just _) -> throwElab $ DeclaredUndefined (Bound n 0)
cont []
checkLetItems _ [] cont = cont []
checkLetItems map (P.LetDecl v t:xs) cont = do
t <- check t VTypeω
t_nf <- eval t
@ -343,27 +353,21 @@ checkLetItems map (P.LetBind name rhs:xs) cont = do
checkLetItems (Map.insert (getNameText name) Nothing map) xs \xs ->
cont ((name, quote ty_nf, rhs):xs)
checkFormula :: P.Formula -> ElabM (Value, Set.Set Name)
checkFormula P.FTop = pure (VI1, mempty)
checkFormula P.FBot = pure (VI0, mempty)
checkFormula (P.FAnd x y) = do
(x, f) <- checkFormula x
(y, f') <- checkFormula y
pure (iand x y, f <> f')
checkFormula (P.FOr x y) = do
(x, f) <- checkFormula x
(y, f') <- checkFormula y
pure (ior x y, f <> f')
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), Set.singleton nm)
pure (inot (VVar nm))
checkFormula (P.FIs1 x) = do
nm <- getNameFor x
ty <- getNfType nm
unify ty VI
pure (VVar nm, Set.singleton nm)
pure (VVar nm)
isSort :: NFType -> ElabM ()
isSort t = isSort (force t) where
@ -425,15 +429,15 @@ isSigmaType t = isSigmaType (force t) where
wp <- isConvertibleTo t (VSigma dom (Closure name (const rng)))
pure (dom, const rng, wp)
isPartialType :: NFType -> ElabM (NFEndp, Value -> Value)
isPartialType :: NFType -> ElabM (NFEndp, Value)
isPartialType t = isPartialType (force t) where
isPartialType (VPartial phi a) = pure (phi, const a)
isPartialType (VPartialP phi a) = pure (phi, (a @@))
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 (VPartialP phi dom)
pure (phi, (dom @@))
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
@ -492,21 +496,21 @@ checkStatement (P.ReplNf e) k = do
(e, _) <- infer e
e_nf <- eval e
h <- asks commHook
liftIO $ h . prettyVl =<< zonkIO e_nf
liftIO (h e_nf)
k
checkStatement (P.ReplTy e) k = do
(t, ty) <- infer e
(_, ty) <- infer e
h <- asks commHook
liftIO (h (prettyTm t <+> colon <+> align (prettyVl (zonk ty))))
liftIO (h ty)
k
checkStatement (P.Data name tele retk constrs) k =
do
checkTeleRetk tele retk \retk kind tele undef -> do
checkTeleRetk True tele retk \kind tele undef -> do
kind_nf <- eval kind
defineInternal (Defined name 0) kind_nf (\name' -> GluedVl (mkHead name') mempty (VNe (mkHead name') mempty)) \name' ->
checkCons retk tele (VNe (mkHead name') (Seq.fromList (map makeProj tele))) constrs (local (markAsDef name' . undef) k)
defineInternal (Defined name 0) kind_nf (\name' -> VNe (mkHead name') mempty) \name' ->
checkCons tele (VNe (mkHead name') (Seq.fromList (map makeProj tele))) constrs (local (markAsDef name' . undef) k)
where
makeProj (x, p, _) = PApp p (VVar x)
@ -516,22 +520,26 @@ checkStatement (P.Data name tele retk constrs) k =
| any (\case { (_, _, P.Path{}) -> True; _ -> False}) constrs = HData True name
| otherwise = HData False name
checkTeleRetk [] retk cont = do
checkTeleRetk allKan [] retk cont = do
t <- check retk VTypeω
r <- eval t
cont r t [] id
checkTeleRetk ((x, p, t):xs) retk cont = do
t_nf <- eval t
when allKan $ unify t_nf VType
cont t [] id
checkTeleRetk allKan ((x, p, t):xs) retk cont = do
(t, ty) <- infer t
_ <- isConvertibleTo ty VTypeω
let
allKan' = case ty of
VType -> allKan
_ -> False
t_nf <- eval t
let rm nm e = e{ nameMap = Map.delete (getNameText nm) (nameMap e), getEnv = Map.delete nm (getEnv e) }
assume (Bound x 0) t_nf $ \nm -> checkTeleRetk xs retk \ret k xs w -> cont ret (Pi p nm t k) ((nm, p, t_nf):xs) (rm nm . w)
assume (Bound x 0) t_nf $ \nm -> checkTeleRetk allKan' xs retk \k xs w -> cont (Pi p nm t k) ((nm, p, t_nf):xs) (rm nm . w)
checkCons _ _ _et [] k = k
checkCons _ _et [] k = k
checkCons retk n ret ((s, e, P.Point x ty):xs) k = withSpan s e $ do
t <- check ty retk
checkCons n ret ((s, e, P.Point x ty):xs) k = withSpan s e $ do
t <- check ty VTypeω
ty_nf <- eval t
let
(args, ret') = splitPi ty_nf
@ -539,12 +547,11 @@ checkStatement (P.Data name tele retk constrs) k =
n' = map (\(x, _, y) -> (x, P.Im, y)) n
unify ret' ret
closed_nf <- eval closed
defineInternal (ConName x 0 (length n') (length args)) closed_nf (makeCon closed_nf mempty n' args) \_ -> checkCons retk n ret xs k
defineInternal (ConName x 0 (length n') (length args)) closed_nf (makeCon closed_nf mempty n' args) \_ -> checkCons n ret xs k
checkCons retk n ret ((s, e, P.Path name indices return faces):xs) k = withSpan s e $ do
fibrant retk
checkCons n ret ((s, e, P.Path name indices return faces):xs) k = withSpan s e $ do
(con, closed_nf, value, boundary) <- assumes (flip Bound 0 <$> indices) VI \indices -> do
t <- check return retk
t <- check return VTypeω
ty_nf <- eval t
let
(args, ret') = splitPi ty_nf
@ -561,17 +568,17 @@ checkStatement (P.Data name tele retk constrs) k =
unify ret' ret
faces <- envArgs args $ for faces \(f, t) -> do
(phi, _) <- checkFormula f
phi <- checkFormula f
t <- check t ret
pure (phi, (quote phi, t))
system <- eval $ foldr (\x -> Lam P.Ex x) (System (Map.fromList (map snd faces))) (map (\(x, _, _) -> x) n' ++ map (\(x, _, _) -> x) args ++ indices)
unify (foldl ior VI0 (map fst faces)) (totalProp indices)
unify (foldr ior VI0 (map fst faces)) (totalProp indices)
`withNote` pretty "The formula determining the endpoints of a higher constructor must be a classical tautology"
pure (ConName name 0 (length n') (length args + length indices), closed_nf, makePCon closed_nf mempty n' args indices system, Boundary indices system)
defineInternal con closed_nf value \name -> addBoundary name boundary $ checkCons retk n ret xs k
defineInternal con closed_nf value \name -> addBoundary name boundary $ checkCons n ret xs k
close [] t = t
close ((x, _, y):xs) t = Pi P.Im x (quote y) (close xs t)
@ -588,13 +595,9 @@ checkStatement (P.Data name tele retk constrs) k =
makePCon cty sp [] ((nm, p, _):ys) zs sys con = VLam p $ Closure nm \a -> makePCon cty (sp Seq.:|> PApp p a) [] ys zs (sys @@ a) con
makePCon cty sp [] [] (nm:zs) sys con = VLam P.Ex $ Closure nm \a -> makePCon cty (sp Seq.:|> PApp P.Ex a) [] [] zs (sys @@ a) con
totalProp (x:xs) = ior (VVar x) (inot (VVar x) `ior` totalProp xs)
totalProp (x:xs) = ior (inot (VVar x)) (VVar x) `ior` totalProp xs
totalProp [] = VI0
fibrant VTypeω = throwElab PathConPretype
fibrant VType = pure ()
fibrant x = error $ "not a constructor kind: " ++ show x
checkProgram :: [P.Statement] -> ElabM a -> ElabM a
checkProgram [] k = k
@ -603,7 +606,7 @@ checkProgram (st:sts) k = checkStatement st $ checkProgram sts k
newtype Redefinition = Redefinition { getRedefName :: Name }
deriving (Show, Typeable, Exception)
data WhenCheckingEndpoint = WhenCheckingEndpoint { direction :: Name, leftEndp :: Value, rightEndp :: Value, whichIsWrong :: NFEndp, exc :: SomeException }
data WhenCheckingEndpoint = WhenCheckingEndpoint { leftEndp :: Value, rightEndp :: Value, whichIsWrong :: NFEndp, exc :: SomeException }
deriving (Show, Typeable, Exception)
data UnsaturatedCon = UnsaturatedCon { theConstr :: Name }
@ -613,10 +616,3 @@ data UnsaturatedCon = UnsaturatedCon { theConstr :: Name }
data NotACon = NotACon { theNotConstr :: Name }
deriving (Show, Typeable)
deriving anyclass (Exception)
data PathConPretype = PathConPretype
deriving (Show, Typeable)
deriving anyclass (Exception)
newtype DeclaredUndefined = DeclaredUndefined { declaredUndefName :: Name }
deriving (Eq, Show, Exception)

+ 192
- 292
src/Elab/Eval.hs View File

@ -23,25 +23,26 @@ import Data.Foldable
import Data.IORef
import Data.Maybe
import {>n class="err">-# SOURCE #-} Elab.Eval.Formula
import Elab.Eval.Formula
import Elab.Monad
import GHC.Stack
import Presyntax.Presyntax (Plicity(..))
import Prettyprinter
import Syntax.Pretty
import Syntax
import System.IO.Unsafe ( unsafePerformIO )
import System.IO.Unsafe
import {-# SOURCE #-} Elab.WiredIn
import Debug (traceM, traceDocM)
import Prettyprinter (pretty, (<+>))
eval :: HasCallStack => Term -> ElabM Value
eval t = asks (flip eval' t)
-- everywhere force
zonkIO :: Value -> IO Value
zonkIO (VNe hd sp) = do
sp' <- traverse zonkSp sp
@ -63,6 +64,7 @@ zonkIO (VPair a b) = VPair <$> zonkIO a <*> zonkIO b
zonkIO (VPath line x y) = VPath <$> zonkIO line <*> zonkIO x <*> zonkIO y
zonkIO (VLine line x y f) = VLine <$> zonkIO line <*> zonkIO x <*> zonkIO y <*> zonkIO f
-- Sorts
zonkIO VType = pure VType
zonkIO VTypeω = pure VTypeω
@ -74,30 +76,30 @@ 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 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))
zonkIO (VSub a b c) = VSub <$> zonkIO a <*> zonkIO b <*> zonkIO c
zonkIO (VInc a b c) = incS <$> zonkIO a <*> zonkIO b <*> zonkIO c
zonkIO (VComp a b c d) = pure $ VComp a b c d
zonkIO (VHComp a b c d) = pure $ VHComp a b c d
zonkIO (VInc a b c) = VInc <$> zonkIO a <*> zonkIO b <*> zonkIO c
zonkIO (VComp a b c d) = comp <$> zonkIO a <*> zonkIO b <*> zonkIO c <*> zonkIO d
zonkIO (VHComp a b c d) = hComp <$> zonkIO a <*> zonkIO b <*> zonkIO c <*> zonkIO d
zonkIO (VGlueTy a phi ty e) = glueType <$> zonkIO a <*> zonkIO phi <*> zonkIO ty <*> zonkIO e
zonkIO (VGlue a phi ty e t x) = glueElem <$> zonkIO a <*> zonkIO phi <*> zonkIO ty <*> zonkIO e <*> zonkIO t <*> zonkIO x
zonkIO (VUnglue a phi ty e x) = unglue <$> zonkIO a <*> zonkIO phi <*> zonkIO ty <*> zonkIO e <*> zonkIO x
zonkIO (VCase env t x xs) = pure $ VCase env t x xs
zonkIO (VEqStrict a x y) = VEqStrict <$> zonkIO a <*> zonkIO x <*> zonkIO y
zonkIO (VReflStrict a x) = VReflStrict <$> zonkIO a <*> zonkIO x
zonkIO (VCase env t x xs) = do
env' <- emptyEnv
evalCase env'{getEnv = env} . (@@) <$> zonkIO t <*> zonkIO x <*> pure xs
zonkSp :: Projection -> IO Projection
zonkSp (PApp p x) = PApp p <$> zonkIO x
zonkSp (PIElim l x y i) = PIElim <$> zonkIO l <*> zonkIO x <*> zonkIO y <*> zonkIO i
zonkSp (POuc a phi u) = POuc <$> zonkIO a <*> zonkIO phi <*> zonkIO u
zonkSp (PK a x p pr) = PK <$> zonkIO a <*> zonkIO x <*> zonkIO p <*> zonkIO pr
zonkSp (PJ a x p pr y) = PJ <$> zonkIO a <*> zonkIO x <*> zonkIO p <*> zonkIO pr <*> zonkIO y
zonkSp PProj1 = pure PProj1
zonkSp PProj2 = pure PProj2
@ -120,22 +122,23 @@ eval' env (PCon sys x) =
Just (ty, _) -> VNe (HPCon (eval' env sys) ty x) mempty
Nothing -> error $ "constructor " ++ show x ++ " has no type in scope"
eval' _ (Data n x) = VNe (HData n x) mempty
eval' env (App p f x) = vApp p (eval' env f) (eval' env x)
eval' env (Lam p s t) =
VLam p $ Closure s $ \a ->
eval' env { getEnv = Map.insert s (idkT, a) (getEnv env) } t
eval' env { getEnv = Map.insert s (error "type of abs", a) (getEnv env) } t
eval' env (Pi p s d t) =
VPi p (eval' env d) $ Closure s $ \a ->
eval' env { getEnv = (Map.insert s (idkT, a) (getEnv env))} t
eval' env { getEnv = (Map.insert s (error "type of abs", a) (getEnv env))} t
eval' _ (Meta m) = VNe (HMeta m) mempty
eval' env (Sigma s d t) =
VSigma (eval' env d) $ Closure s $ \a ->
eval' env { getEnv = Map.insert s (idkT, a) (getEnv env) } t
eval' env { getEnv = Map.insert s (error "type of abs", a) (getEnv env) } t
eval' e (Pair a b) = VPair (eval' e a) (eval' e b)
@ -156,12 +159,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 x y f) = VLine (eval' e p) (eval' e x) (eval' e y) (eval' e f)
eval' e (IsOne i) = VIsOne (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) = mkVSystem (Map.fromList $ map (\(x, y) -> (eval' e x, eval' e y)) $ Map.toList $ fs)
eval' e (System fs) = VSystem (Map.fromList $ map (\(x, y) -> (eval' e x, eval' e y)) $ Map.toList $ fs)
eval' e (Sub a phi u) = VSub (eval' e a) (eval' e phi) (eval' e u)
eval' e (Inc a phi u) = incS (eval' e a) (eval' e phi) (eval' e u)
eval' e (Inc a phi u) = VInc (eval' e a) (eval' e phi) (eval' e u)
eval' e (Ouc a phi u x) = outS (eval' e a) (eval' e phi) (eval' e u) (eval' e x)
eval' e (Comp a phi u a0) = comp (eval' e a) (eval' e phi) (eval' e u) (eval' e a0)
@ -180,122 +186,75 @@ eval' e (Let ns x) =
eval' e (Case range sc xs) = evalCase e (eval' e range @@) (force (eval' e sc)) xs
eval' e (EqS a x y) = VEqStrict (eval' e a) (eval' e x) (eval' e y)
eval' e (Syntax.Refl a x) = VReflStrict (eval' e a) (eval' e x)
eval' e (Syntax.AxK a x p pr eq) = strictK (eval' e a) (eval' e x) (eval' e p) (eval' e pr) (eval' e eq)
eval' e (Syntax.AxJ a x p pr y eq) = strictJ (eval' e a) (eval' e x) (eval' e p) (eval' e pr) (eval' e y) (eval' e eq)
idkT :: NFType
idkT = VVar (Defined (T.pack "dunno") (negate 1))
isIdkT :: NFType -> Bool
isIdkT (VVar (Defined (T.unpack -> "dunno") (negate -> 1))) = True
isIdkT _ = False
evalCase :: ElabEnv -> (Value -> Value) -> Value -> [(Term, Int, Term)] -> Value
evalCase env rng sc [] = VCase (getEnv env) (fun rng) sc []
evalCase _ _ sc [] = error $ "unmatched pattern for value: " ++ show (prettyTm (quote sc))
evalCase env rng (VSystem fs) cases = VSystem (fmap (flip (evalCase env rng) cases) fs)
evalCase env rng (VHComp a φ u u0) cases =
comp (fun \i -> rng (v i))
φ
(system \i is1 -> α (u @@ i @@ is1))
(VInc (rng a) φ (α (outS a φ (u @@ VI0) u0)))
evalCase env rng (VHComp a phi u a0) cases =
comp (fun \i -> rng (v i)) phi (system \i is1 -> evalCase env rng (u @@ i @@ is1) cases)
(VInc (rng a) phi (evalCase env rng (outS a0 phi (u @@ VI0) a0) cases))
where
v = Elab.WiredIn.fill (fun (const a)) φ u u0
α x = evalCase env rng x cases
v = Elab.WiredIn.fill (fun (const a)) phi u a0
evalCase env _ sc ((Ref _, _, k):_) = eval' env k @@ sc
evalCase env rng (force -> val@(VNe (HCon _ x) sp)) ((Con x', _, k):xs)
evalCase env rng (val@(VNe (HCon _ x) sp)) ((Con x', _, k):xs)
| x == x' = foldl applProj (eval' env k) sp
| otherwise = evalCase env rng val xs
evalCase env rng (force -> val@(VNe (HPCon _ _ x) sp)) ((Con x', _, k):xs)
evalCase env rng (val@(VNe (HPCon _ _ x) sp)) ((Con x', _, k):xs)
| x == x' = foldl applProj (eval' env k) sp
| otherwise = evalCase env rng val xs
evalCase _ _ (VVar ((== trueCaseSentinel) -> True)) _ = VI1
evalCase env rng sc xs = VCase (getEnv env) (fun rng) sc xs
-- This is a great big HACK; When we see a system [ case x of ... => p
-- ], we somehow need to make the 'case x of ...' become VI1. The way we
-- do this is by substituting x/trueCaseSentinel in truthAssignments,
-- and then making case trueCaseSentinel of ... => VI1 always.
trueCaseSentinel :: Name
trueCaseSentinel = Bound (T.pack "sentinel for true cases") (-1000)
evalFix' :: HasCallStack => ElabEnv -> Name -> NFType -> Term -> Value
evalFix' env name nft term = fix $ \val -> eval' env{ getEnv = Map.insert name (nft, GluedVl (HVar name) mempty val) (getEnv env) } term
evalFix' :: ElabEnv -> Name -> NFType -> Term -> Value
evalFix' env name nft term = fix $ \val -> eval' env{ getEnv = Map.insert name (nft, val) (getEnv env) } term
evalFix :: HasCallStack => Name -> NFType -> Term -> ElabM Value
evalFix :: Name -> NFType -> Term -> ElabM Value
evalFix name nft term = do
t <- ask
pure (evalFix' t name (GluedVl (HVar name) mempty nft) term)
pure (evalFix' t name nft term)
data NotEqual = NotEqual Value Value
deriving (Show, Typeable, Exception)
unify' :: HasCallStack => Bool -> Value -> Value -> ElabM ()
unify' cs topa@(GluedVl h sp a) topb@(GluedVl h' sp' b)
| h == h', length sp == length sp' =
traverse_ (uncurry (unify'Spine cs topa topb)) (Seq.zip sp sp')
`catchElab` \(_ :: SomeException) -> unify' cs a b
unify' canSwitch topa topb = join $ go <$> forceIO topa <*> forceIO topb where
unify' :: HasCallStack => Value -> Value -> ElabM ()
unify' topa topb = join $ go <$> forceIO topa <*> forceIO topb where
go (VNe (HMeta mv) sp) rhs = solveMeta mv sp rhs
go rhs (VNe (HMeta mv) sp) = solveMeta mv sp rhs
go topa@(VNe (HPCon _ _ x) sp) topb@(VNe (HPCon _ _ y) sp')
| x == y = traverse_ (uncurry (unify'Spine canSwitch topa topb)) (Seq.zip sp sp')
go (VNe (HPCon s _ _) _) rhs
| VSystem _ <- s = go (force s) rhs
go (VNe (HPCon s _ _) _) rhs | Just v <- trivialSystem s = go v rhs
go lhs (VNe (HPCon s _ _) _) | Just v <- trivialSystem s = go lhs v
go lhs (VNe (HPCon s _ _) _)
| VSystem _ <- s = go lhs (force s)
go (VCase e _ _ b) (VCase e' _ _ b') = do
env <- ask
let
go (_, _, a) (_, _, b)
| a == b = pure ()
| otherwise = unify' canSwitch (eval' env{getEnv=moreDefinedFrom e e' <$> e} a) (eval' env{getEnv=moreDefinedFrom e e' <$> e'} b)
zipWithM_ go (sortOn (\(x, _, _) -> x) b) (sortOn (\(x, _, _) -> x) b')
go (VCase e _ _ b) y = do
env <- ask
let
go (_, n, a') = do
ns <- replicateM n (VVar <$> newName)
let a = foldl (vApp Ex) (eval' env{getEnv=e} a') ns
unify' canSwitch a y
traverse_ go b
go topa@(VNe x a) topb@(VNe x' a')
go (VNe x a) (VNe x' a')
| x == x', length a == length a' =
traverse_ (uncurry (unify'Spine canSwitch topa topb)) (Seq.zip a a')
traverse_ (uncurry unify'Spine) (Seq.zip a a')
go (VLam p (Closure n k)) vl = do
t <- VVar <$> newName' n
unify' canSwitch (k t) (vApp p vl t)
unify' (k t) (vApp p vl t)
go vl (VLam p (Closure n k)) = do
t <- VVar <$> newName' n
unify' canSwitch (vApp p vl t) (k t)
unify' (vApp p vl t) (k t)
go (VPair a b) vl = unify' canSwitch a (vProj1 vl) *> unify' canSwitch b (vProj2 vl)
go vl (VPair a b) = unify' canSwitch (vProj1 vl) a *> unify' canSwitch (vProj2 vl) b
go (VPair a b) vl = unify' a (vProj1 vl) *> unify' b (vProj2 vl)
go vl (VPair a b) = unify' (vProj1 vl) a *> unify' (vProj2 vl) b
go (VPi p d (Closure n k)) (VPi p' d' (Closure _ k')) | p == p' = do
t <- VVar <$> newName' n
unify' canSwitch d d'
unify' canSwitch (k t) (k' t)
go (VPi p d (Closure _ k)) (VPi p' d' (Closure _ k')) | p == p' = do
t <- VVar <$> newName
unify' d d'
unify' (k t) (k' t)
go (VSigma d (Closure n k)) (VSigma d' (Closure _ k')) = do
t <- VVar <$> newName' n
unify' canSwitch d d'
unify' canSwitch (k t) (k' t)
go (VSigma d (Closure _ k)) (VSigma d' (Closure _ k')) = do
t <- VVar <$> newName
unify' d d'
unify' (k t) (k' t)
go VType VType = pure ()
go VTypeω VTypeω = pure ()
@ -303,63 +262,56 @@ unify' canSwitch topa topb = join $ go <$> forceIO topa <*> forceIO topb where
go VI VI = pure ()
go (VPath l x y) (VPath l' x' y') = do
unify' canSwitch l l'
unify' canSwitch x x'
unify' canSwitch y y'
unify' l l'
unify' x x'
unify' y y'
go (VLine l x y p) p' = do
n <- VVar <$> newName' (Bound (T.singleton 'i') (- 1))
unify' canSwitch (p @@ n) (ielim l x y p' n)
n <- VVar <$> newName
unify' (p @@ n) (ielim l x y p' n)
go p' (VLine l x y p) = do
n <- VVar <$> newName
unify' canSwitch (ielim l x y p' n) (p @@ n)
unify' (ielim l x y p' n) (p @@ n)
go (VPartial phi r) (VPartial phi' r') = unify' canSwitch phi phi' *> unify' canSwitch r r'
go (VPartialP phi r) (VPartialP phi' r') = unify' canSwitch phi phi' *> unify' canSwitch r r'
go (VIsOne x) (VIsOne y) = unify' x y
go (VSub a phi u) (VSub a' phi' u') = traverse_ (uncurry (unify' canSwitch)) [(a, a'), (phi, phi'), (u, u')]
go (VInc a phi u) (VInc a' phi' u') = traverse_ (uncurry (unify' canSwitch)) [(a, a'), (phi, phi'), (u, u')]
-- IsOne is proof-irrelevant:
go VItIsOne _ = pure ()
go _ VItIsOne = pure ()
go (VComp a phi u a0) (VComp a' phi' u' a0') =
traverse_ (uncurry (unify' canSwitch)) [(a, a'), (phi, phi'), (u, u'), (a0, a0')]
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 (VSub a phi u) (VSub a' phi' u') = traverse_ (uncurry unify') [(a, a'), (phi, phi'), (u, u')]
go (VInc a phi u) (VInc a' phi' u') = traverse_ (uncurry unify') [(a, a'), (phi, phi'), (u, u')]
go (VHComp a phi u a0) (VHComp a' phi' u' a0') =
traverse_ (uncurry (unify' canSwitch)) [(a, a'), (phi, phi'), (u, u'), (a0, a0')]
go (VComp a phi u a0) (VComp a' phi' u' a0') =
traverse_ (uncurry unify') [(a, a'), (phi, phi'), (u, u'), (a0, a0')]
go (VGlueTy _ (force -> VI1) u _0) rhs = unify' canSwitch (u @@ VReflStrict VI VI1) rhs
go lhs (VGlueTy _ (force -> VI1) u _0) = unify' canSwitch lhs (u @@ VReflStrict VI VI1)
go (VGlueTy _ (force -> VI1) u _0) rhs = unify' (u @@ VItIsOne) rhs
go lhs (VGlueTy _ (force -> VI1) u _0) = unify' lhs (u @@ VItIsOne)
go (VGlueTy a phi u a0) (VGlueTy a' phi' u' a0') =
traverse_ (uncurry (unify' canSwitch)) [(a, a'), (phi, phi'), (u, u'), (a0, a0')]
traverse_ (uncurry unify') [(a, a'), (phi, phi'), (u, u'), (a0, a0')]
go (VGlue a phi u a0 t x) (VGlue a' phi' u' a0' t' x') =
traverse_ (uncurry (unify' canSwitch)) [(a, a'), (phi, phi'), (u, u'), (a0, a0'), (t, t'), (x, x')]
go (VUnglue a phi u a0 x) (VUnglue a' phi' u' a0' x') =
traverse_ (uncurry (unify' canSwitch)) [(a, a'), (phi, phi'), (u, u'), (a0, a0'), (x, x')]
go (VSystem sys) rhs = goSystem (unify' canSwitch) sys rhs
go rhs (VSystem sys) = goSystem (flip (unify' canSwitch)) sys rhs
go (VEqStrict a x y) (VEqStrict a' x' y') = traverse_ (uncurry (unify' canSwitch)) [(a, a'), (x, x'), (y, y')]
go (VReflStrict a x) (VReflStrict a' x') = traverse_ (uncurry (unify' canSwitch)) [(a, a'), (x, x')]
go _ VReflStrict{} = pure ()
go VReflStrict{} _ = pure ()
traverse_ (uncurry unify') [(a, a'), (phi, phi'), (u, u'), (a0, a0'), (t, t'), (x, x')]
go (VINot x) (VINot y) = unify' canSwitch x y
go (VSystem sys) rhs = goSystem unify' sys rhs
go rhs (VSystem sys) = goSystem (flip unify') sys rhs
go x y =
case (toDnf x, toDnf y) of
(Just xs, Just ys) -> unify'Formula xs ys
_ ->
if canSwitch
then goDumb x y
else fail
go (VCase _ _ a b) (VCase _ _ a' b') = do
unify' a a'
let go (_, _, a) (_, _, b) = join $ unify' <$> eval a <*> eval b
zipWithM_ go (sortOn (\(x, _, _) -> x) b) (sortOn (\(x, _, _) -> x) b')
goDumb (VIOr a b) (VIOr a' b') = unify' canSwitch a a' *> goDumb b b'
goDumb (VIAnd a b) (VIAnd a' b') = unify' canSwitch a a' *> goDumb b b'
goDumb x y = switch $ unify' False x y
go x y
| x == y = pure ()
| otherwise =
case (toDnf x, toDnf y) of
(Just xs, Just ys) -> unify'Formula xs ys
_ -> fail
goSystem :: (Value -> Value -> ElabM ()) -> Map.Map Value Value -> Value -> ElabM ()
goSystem k sys rhs = do
@ -367,58 +319,29 @@ unify' canSwitch topa topb = join $ go <$> forceIO topa <*> forceIO topb where
env <- ask
for_ (Map.toList sys) $ \(f, i) -> do
let i_q = quote i
for (truthAssignments f (getEnv env)) $ \e -> do
for (truthAssignments f (getEnv env)) $ \e ->
k (eval' env{getEnv = e} i_q) (eval' env{getEnv = e} rhs_q)
fail = throwElab $ NotEqual topa topb
unify'Formula x y
| compareDNFs x y = pure ()
| otherwise = fail
moreDefinedFrom :: Map Name (NFType, Value) -> Map Name (NFType, Value) -> (NFType, Value) -> (NFType, Value)
moreDefinedFrom map1 map2 ours@(_, VNe (HVar name) _) =
case Map.lookup name map1 of
Just (_, VNe HVar{} _) -> map2's
Just (ty, x) -> (ty, x)
Nothing -> map2's
where
map2's = case Map.lookup name map2 of
Just (_, VNe HVar{} _) -> ours
Just (ty, x) -> (ty, x)
Nothing -> ours
moreDefinedFrom _ _ ours = ours
trivialSystem :: Value -> Maybe Value
trivialSystem = go . force where
go VSystem{} = Nothing
go x = Just x
unify'Spine (PApp a v) (PApp a' v')
| a == a' = unify' v v'
unify'Spine :: Bool -> Value -> Value -> Projection -> Projection -> ElabM ()
unify'Spine cs _ _ (PApp a v) (PApp a' v')
| a == a' = unify' cs v v'
unify'Spine PProj1 PProj1 = pure ()
unify'Spine PProj2 PProj2 = pure ()
unify'Spine _ _ _ PProj1 PProj1 = pure ()
unify'Spine _ _ _ PProj2 PProj2 = pure ()
unify'Spine (PIElim _ _ _ i) (PIElim _ _ _ j) = unify' i j
unify'Spine (POuc a phi u) (POuc a' phi' u') =
traverse_ (uncurry unify') [(a, a'), (phi, phi'), (u, u')]
unify'Spine cs _ _ (PIElim _ _ _ i) (PIElim _ _ _ j) = unify' cs i j
unify'Spine cs _ _ (POuc a phi u) (POuc a' phi' u') =
traverse_ (uncurry (unify' cs)) [(a, a'), (phi, phi'), (u, u')]
unify'Spine _ _ = fail
unify'Spine cs _ _ (PK a x p pr) (PK a' x' p' pr') =
traverse_ (uncurry (unify' cs)) [(a, a'), (x, x'), (p, p'), (pr, pr')]
unify'Spine cs _ _ (PJ a x p pr y) (PJ a' x' p' pr' y') =
traverse_ (uncurry (unify' cs)) [(a, a'), (x, x'), (p, p'), (pr, pr'), (y, y')]
unify'Spine _ x y _ _ = throwElab (NotEqual x y)
unify'Formula x y
| compareDNFs x y = pure ()
| otherwise = fail
unify :: HasCallStack => Value -> Value -> ElabM ()
unify x y = shallowly $ go x y where
go topa@(GluedVl h sp a) topb@(GluedVl h' sp' b)
| h == h', length sp == length sp' =
traverse_ (uncurry (unify'Spine True topa topb)) (Seq.zip sp sp')
`catchElab` \(_ :: SomeException) -> unify' True a b
go a b = unify' True a b `catchElab` \(_ :: SomeException) -> liftIO $ throwIO (NotEqual a b)
unify a b = unify' a b `catchElab` \(_ :: SomeException) -> liftIO $ throwIO (NotEqual a b)
isConvertibleTo :: Value -> Value -> ElabM (Term -> Term)
isConvertibleTo a b = isConvertibleTo (force a) (force b) where
@ -436,42 +359,26 @@ isConvertibleTo a b = isConvertibleTo (force a) (force b) where
wp' <- k (VVar n) `isConvertibleTo` k' (wp_n @@ VVar n)
pure (\f -> Lam p n (wp' (App p f (wp (Ref n)))))
VPath a x y `isConvertibleTo` VPi Ex d (Closure _ k') = do
unify d VI
nm <- newName
wp <- isConvertibleTo (a @@ VVar nm) (k' (VVar nm))
pure (\f -> Lam Ex nm (wp (IElim (quote a) (quote x) (quote y) f (Ref nm))))
isConvertibleTo a b = do
unify' True a b
unify' a b
pure id
newMeta' :: Bool -> Value -> ElabM Value
newMeta' int dom = do
newMeta :: Value -> ElabM Value
newMeta dom = do
loc <- liftM2 (,) <$> asks currentFile <*> asks currentSpan
n <- newName
c <- liftIO $ newIORef Nothing
let m = MV (getNameText n) c dom (flatten <$> loc) int
let m = MV (getNameText n) c dom (flatten <$> loc)
flatten (x, (y, z)) = (x, y, z)
env <- asks getEnv
t <- fmap catMaybes . for (Map.toList env) $ \(n, t) -> pure $
t <- for (Map.toList env) $ \(n, _) -> pure $
case n of
Bound{} -> Just (PApp Ex (VVar n), n, t)
Bound{} -> Just (PApp Ex (VVar n))
_ -> Nothing
let
ts = Map.fromList $ fmap (\(_, n, (t, _)) -> (n, t)) t
t' = fmap (\(x, _, _) -> x) t
um <- asks unsolvedMetas
liftIO . atomicModifyIORef um $ \um -> (Map.insert (m ts) [] um, ())
pure (VNe (HMeta (m ts)) (Seq.fromList t'))
newMeta :: Value -> ElabM Value
newMeta = newMeta' False
pure (VNe (HMeta m) (Seq.fromList (catMaybes t)))
newName :: MonadIO m => m Name
newName = liftIO $ do
@ -488,103 +395,91 @@ _nameCounter = unsafePerformIO $ newIORef 0
{-# NOINLINE _nameCounter #-}
solveMeta :: MV -> Seq Projection -> Value -> ElabM ()
solveMeta m Seq.Empty (VNe (HMeta m') Seq.Empty) | m == m' = pure ()
solveMeta m@(mvCell -> cell) sp rhs = do
when (mvName m == T.pack "2801") do
traceM (VNe (HMeta m) sp)
traceM rhs
env <- ask
names <- tryElab $ checkSpine Set.empty sp
case names of
Right names -> do
scope <- tryElab $ checkScope m (Set.fromList names) rhs
case scope of
Right () -> do
let tm = quote rhs
lam = eval' env $ foldr (Lam Ex) tm names
liftIO . atomicModifyIORef (unsolvedMetas env) $ \mp -> (Map.delete m mp, ())
liftIO . atomicModifyIORef' cell $ \case
Just _ -> error "filled cell in solvedMeta"
Nothing -> (Just lam, ())
Left (_ :: MetaException) -> abort env
Left (_ :: MetaException) -> abort env
where
abort env =
checkScope (Set.fromList names) rhs
`withNote` hsep [prettyTm (quote (VNe (HMeta m) sp)), pretty '≡', prettyTm (quote rhs)]
let tm = quote rhs
lam = eval' env $ foldr (Lam Ex) tm names
liftIO . atomicModifyIORef' cell $ \case
Just _ -> error "filled cell in solvedMeta"
Nothing -> (Just lam, ())
Left (_ :: SpineProjection) -> do
liftIO . atomicModifyIORef' (unsolvedMetas env) $ \x -> (, ()) $
case Map.lookup m x of
Just qs -> Map.insert m ((sp, rhs):qs) x
Nothing -> Map.insert m [(sp, rhs)] x
checkScope :: MV -> Set Name -> Value -> ElabM ()
checkScope mv scope (VNe h sp) =
checkScope :: Set Name -> Value -> ElabM ()
checkScope scope (VNe h sp) =
do
case h of
HVar v@Bound{} ->
unless (v `Set.member` scope) . throwElab $
ScopeCheckingFail v
NotInScope v
HVar{} -> pure ()
HCon{} -> pure ()
HPCon{} -> pure ()
HMeta m' -> when (mv == m') $ throwElab $ CircularSolution mv
HMeta{} -> pure ()
HData{} -> pure ()
traverse_ checkProj sp
where
checkProj (PApp _ t) = checkScope mv scope t
checkProj (PIElim l x y i) = traverse_ (checkScope mv scope) [l, x, y, i]
checkProj (PK l x y i) = traverse_ (checkScope mv scope) [l, x, y, i]
checkProj (PJ l x y i j) = traverse_ (checkScope mv scope) [l, x, y, i, j]
checkProj (POuc a phi u) = traverse_ (checkScope mv scope) [a, phi, u]
checkProj (PApp _ t) = checkScope scope t
checkProj (PIElim l x y i) = traverse_ (checkScope scope) [l, x, y, i]
checkProj (POuc a phi u) = traverse_ (checkScope scope) [a, phi, u]
checkProj PProj1 = pure ()
checkProj PProj2 = pure ()
checkScope mv scope (GluedVl _ _p vl) = checkScope mv scope vl
checkScope scope (GluedVl _ _p vl) = checkScope scope vl
checkScope mv scope (VLam _ (Closure n k)) =
checkScope mv (Set.insert n scope) (k (VVar n))
checkScope scope (VLam _ (Closure n k)) =
checkScope (Set.insert n scope) (k (VVar n))
checkScope mv scope (VPi _ d (Closure n k)) = do
checkScope mv scope d
checkScope mv (Set.insert n scope) (k (VVar n))
checkScope scope (VPi _ d (Closure n k)) = do
checkScope scope d
checkScope (Set.insert n scope) (k (VVar n))
checkScope mv scope (VSigma d (Closure n k)) = do
checkScope mv scope d
checkScope mv (Set.insert n scope) (k (VVar n))
checkScope scope (VSigma d (Closure n k)) = do
checkScope scope d
checkScope (Set.insert n scope) (k (VVar n))
checkScope mv s (VPair a b) = traverse_ (checkScope mv s) [a, b]
checkScope s (VPair a b) = traverse_ (checkScope s) [a, b]
checkScope _ _ VType = pure ()
checkScope _ _ VTypeω = pure ()
checkScope _ VType = pure ()
checkScope _ VTypeω = pure ()
checkScope _ _ VI = pure ()
checkScope _ _ VI0 = pure ()
checkScope _ _ VI1 = pure ()
checkScope _ VI = pure ()
checkScope _ VI0 = pure ()
checkScope _ VI1 = pure ()
checkScope mv s (VIAnd x y) = traverse_ (checkScope mv s) [x, y]
checkScope mv s (VIOr x y) = traverse_ (checkScope mv s) [x, y]
checkScope mv s (VINot x) = checkScope mv s x
checkScope s (VIAnd x y) = traverse_ (checkScope s) [x, y]
checkScope s (VIOr x y) = traverse_ (checkScope s) [x, y]
checkScope s (VINot x) = checkScope s x
checkScope mv s (VPath line a b) = traverse_ (checkScope mv s) [line, a, b]
checkScope mv s (VLine _ _ _ line) = checkScope mv s line
checkScope s (VPath line a b) = traverse_ (checkScope s) [line, a, b]
checkScope s (VLine _ _ _ line) = checkScope s line
checkScope mv s (VPartial x y) = traverse_ (checkScope mv s) [x, y]
checkScope mv s (VPartialP x y) = traverse_ (checkScope mv s) [x, y]
checkScope mv s (VSystem fs) =
for_ (Map.toList fs) $ \(x, y) -> traverse_ (checkScope mv s) [x, y]
checkScope s (VIsOne x) = checkScope s x
checkScope _ VItIsOne = pure ()
checkScope mv s (VSub a b c) = traverse_ (checkScope mv s) [a, b, c]
checkScope mv s (VInc a b c) = traverse_ (checkScope mv s) [a, b, c]
checkScope mv s (VComp a phi u a0) = traverse_ (checkScope mv s) [a, phi, u, a0]
checkScope mv s (VHComp a phi u a0) = traverse_ (checkScope mv s) [a, phi, u, a0]
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]
checkScope mv s (VGlueTy a phi ty eq) = traverse_ (checkScope mv s) [a, phi, ty, eq]
checkScope mv s (VGlue a phi ty eq inv x) = traverse_ (checkScope mv s) [a, phi, ty, eq, inv, x]
checkScope mv s (VUnglue a phi ty eq vl) = traverse_ (checkScope mv s) [a, phi, ty, eq, vl]
checkScope s (VSub a b c) = traverse_ (checkScope s) [a, b, c]
checkScope s (VInc a b c) = traverse_ (checkScope s) [a, b, c]
checkScope s (VComp a phi u a0) = traverse_ (checkScope s) [a, phi, u, a0]
checkScope s (VHComp a phi u a0) = traverse_ (checkScope s) [a, phi, u, a0]
checkScope mv s (VCase _ _ v _) = checkScope mv s v
checkScope s (VGlueTy a phi ty eq) = traverse_ (checkScope s) [a, phi, ty, eq]
checkScope s (VGlue a phi ty eq inv x) = traverse_ (checkScope s) [a, phi, ty, eq, inv, x]
checkScope s (VUnglue a phi ty eq vl) = traverse_ (checkScope s) [a, phi, ty, eq, vl]
checkScope mv s (VEqStrict a x y) = traverse_ (checkScope mv s) [a, x, y]
checkScope mv s (VReflStrict a x) = traverse_ (checkScope mv s) [a, x]
checkScope s (VCase _ _ v _) = checkScope s v
checkSpine :: Set Name -> Seq Projection -> ElabM [Name]
checkSpine scope (PApp Ex (VVar n@Bound{}) Seq.:<| xs)
@ -593,10 +488,10 @@ checkSpine scope (PApp Ex (VVar n@Bound{}) Seq.:<| xs)
checkSpine _ (p Seq.:<| _) = throwElab $ SpineProj p
checkSpine _ Seq.Empty = pure []
data MetaException = NonLinearSpine { getDupeName :: Name }
| SpineProj { getSpineProjection :: Projection }
| CircularSolution { getCycle :: MV }
| ScopeCheckingFail { outOfScope :: Name }
newtype NonLinearSpine = NonLinearSpine { getDupeName :: Name }
deriving (Show, Typeable, Exception)
newtype SpineProjection = SpineProj { getSpineProjection :: Projection }
deriving (Show, Typeable, Exception)
substituteIO :: Map.Map Name Value -> Value -> IO Value
@ -604,10 +499,15 @@ substituteIO sub = substituteIO . force where
substituteIO (VNe hd sp) = do
sp' <- traverse (substituteSp sub) sp
case hd of
HMeta (mvCell -> cell) -> do
solved <- liftIO $ readIORef cell
case solved of
Just vl -> substituteIO $ foldl applProj vl sp'
Nothing -> pure $ VNe hd sp'
HVar v ->
case Map.lookup v sub of
Just vl -> substituteIO $ foldl applProj vl sp'
Nothing -> pure $ foldl applProj (VNe hd mempty) sp'
Nothing -> pure $ VNe hd sp'
hd -> pure $ VNe hd sp'
substituteIO (GluedVl h sp vl) = GluedVl h <$> traverse (substituteSp sub) sp <*> substituteIO vl
@ -620,6 +520,7 @@ substituteIO sub = substituteIO . force where
substituteIO (VPath line x y) = VPath <$> substituteIO line <*> substituteIO x <*> substituteIO y
substituteIO (VLine line x y f) = VLine <$> substituteIO line <*> substituteIO x <*> substituteIO y <*> substituteIO f
-- Sorts
substituteIO VType = pure VType
substituteIO VTypeω = pure VTypeω
@ -631,13 +532,16 @@ substituteIO sub = substituteIO . force where
substituteIO (VIOr x y) = ior <$> substituteIO x <*> substituteIO y
substituteIO (VINot x) = inot <$> substituteIO x
substituteIO (VIsOne x) = VIsOne <$> substituteIO x
substituteIO VItIsOne = pure VItIsOne
substituteIO (VPartial x y) = VPartial <$> substituteIO x <*> substituteIO y
substituteIO (VPartialP x y) = VPartialP <$> substituteIO x <*> substituteIO y
substituteIO (VSystem fs) = do
t <- for (Map.toList fs) $ \(a, b) -> (,) <$> substituteIO a <*> substituteIO b
pure (mkVSystem (Map.fromList t))
substituteIO (VSub a b c) = VSub <$> substituteIO a <*> substituteIO b <*> substituteIO c
substituteIO (VInc a b c) = incS <$> substituteIO a <*> substituteIO b <*> substituteIO c
substituteIO (VInc a b c) = VInc <$> substituteIO a <*> substituteIO b <*> substituteIO c
substituteIO (VComp a b c d) = comp <$> substituteIO a <*> substituteIO b <*> substituteIO c <*> substituteIO d
substituteIO (VHComp a b c d) = hComp <$> substituteIO a <*> substituteIO b <*> substituteIO c <*> substituteIO d
@ -645,8 +549,6 @@ substituteIO sub = substituteIO . force where
substituteIO (VGlue a phi ty e t x) = glueElem <$> substituteIO a <*> substituteIO phi <*> substituteIO ty <*> substituteIO e <*> substituteIO t <*> substituteIO x
substituteIO (VUnglue a phi ty e x) = unglue <$> substituteIO a <*> substituteIO phi <*> substituteIO ty <*> substituteIO e <*> substituteIO x
substituteIO (VCase env t x xs) = VCase env <$> substituteIO t <*> substituteIO x <*> pure xs
substituteIO (VEqStrict a x y) = VEqStrict <$> substituteIO a <*> substituteIO x <*> substituteIO y
substituteIO (VReflStrict a x) = VReflStrict <$> substituteIO a <*> substituteIO x
substitute :: Map Name Value -> Value -> Value
substitute sub = unsafePerformIO . substituteIO sub
@ -654,23 +556,16 @@ substitute sub = unsafePerformIO . substituteIO sub
substituteSp :: Map Name Value -> Projection -> IO Projection
substituteSp sub (PApp p x) = PApp p <$> substituteIO sub x
substituteSp sub (PIElim l x y i) = PIElim <$> substituteIO sub l <*> substituteIO sub x <*> substituteIO sub y <*> substituteIO sub i
substituteSp sub (PK l x y i) = PK <$> substituteIO sub l <*> substituteIO sub x <*> substituteIO sub y <*> substituteIO sub i
substituteSp sub (PJ l x y i j) = PJ <$> substituteIO sub l <*> substituteIO sub x <*> substituteIO sub y <*> substituteIO sub i <*> substituteIO sub j
substituteSp sub (POuc a phi u) = POuc <$> substituteIO sub a <*> substituteIO sub phi <*> substituteIO sub u
substituteSp _ PProj1 = pure PProj1
substituteSp _ PProj2 = pure PProj2
mkVSystem :: Map.Map Value Value -> Value
mkVSystem vals =
let map' = Map.fromList (Map.toList vals >>= go)
go (x, y) =
case (force x, y) of
(VI0, _) -> []
(VIOr _ _, VSystem y) -> Map.toList y >>= go
(a, b) -> [(a, b)]
in case Map.lookup VI1 map' of
let map' = Map.fromList (map (\(a, b) -> (force a, b)) (Map.toList vals)) in
case Map.lookup VI1 map' of
Just x -> x
Nothing -> VSystem map'
Nothing -> VSystem (Map.filterWithKey (\k _ -> k /= VI0) map')
forceIO :: MonadIO m => Value -> m Value
forceIO mv@(VNe (HMeta (mvCell -> cell)) args) = do
@ -684,7 +579,6 @@ forceIO vl@(VSystem fs) =
Nothing -> pure vl
forceIO (GluedVl _ _ vl) = forceIO vl
forceIO (VComp line phi u a0) = comp <$> forceIO line <*> forceIO phi <*> pure u <*> pure a0
forceIO (VHComp line phi u a0) = hComp <$> forceIO line <*> forceIO phi <*> pure u <*> pure a0
forceIO (VCase env rng v vs) = do
env' <- liftIO emptyEnv
r <- forceIO rng
@ -694,25 +588,24 @@ forceIO x = pure x
force :: Value -> Value
force = unsafePerformIO . forceIO
applProj :: HasCallStack => Value -> Projection -> Value
applProj :: Value -> Projection -> Value
applProj fun (PApp p arg) = vApp p fun arg
applProj fun (PIElim l x y i) = ielim l x y fun i
applProj fun (POuc a phi u) = outS a phi u fun
applProj fun (PK a x p pr) = strictK a x p pr fun
applProj fun (PJ a x p pr y) = strictJ a x p pr y fun
applProj fun PProj1 = vProj1 fun
applProj fun PProj2 = vProj2 fun
vApp :: HasCallStack => Plicity -> Value -> Value -> Value
vApp _ (VLam _ k) arg = clCont k arg
vApp p (VNe (HData True n) _) _ | T.unpack (getNameText n) == "S1" = undefined
vApp p (VNe h sp) arg = VNe h (sp Seq.:|> PApp p arg)
vApp p (VLam p' k) arg
| p == p' = clCont k arg
| otherwise = error $ "wrong plicity " ++ show p ++ " vs " ++ show p' ++ " in app " ++ show (App p (quote (VLam p' k)) (quote arg))
vApp p (VNe h sp) arg = VNe h (sp Seq.:|> PApp p arg)
vApp p (GluedVl h sp vl) arg = GluedVl h (sp Seq.:|> PApp p arg) (vApp p vl arg)
vApp p (VSystem fs) arg = mkVSystem (fmap (flip (vApp p) arg) fs)
vApp p (VSystem fs) arg = VSystem (fmap (flip (vApp p) arg) fs)
vApp p (VInc (VPi _ _ (Closure _ r)) phi f) arg = VInc (r (vApp p f arg)) phi (vApp p f arg)
vApp p (VCase env rng sc branches) arg =
VCase env (fun \x -> let VPi _ _ (Closure _ r) = rng @@ x in r arg) sc
(map (projIntoCase (flip (App p) (quote arg))) branches)
-- vApp _ (VLine _ _ _ (VLam _ k)) arg = clCont k arg
vApp _ x _ = error $ "can't apply " ++ show (prettyTm (quote x))
(@@) :: HasCallStack => Value -> Value -> Value
@ -724,17 +617,24 @@ vProj1 (VPair a _) = a
vProj1 (VNe h sp) = VNe h (sp Seq.:|> PProj1)
vProj1 (GluedVl h sp vl) = GluedVl h (sp Seq.:|> PProj1) (vProj1 vl)
vProj1 (VSystem fs) = VSystem (fmap vProj1 fs)
vProj1 (VInc (VSigma a _) b c) = incS a b (vProj1 c)
vProj1 (VInc (VSigma a _) b c) = VInc a b (vProj1 c)
vProj1 (VCase env rng sc branches) =
VCase env rng sc (map (projIntoCase Proj1) branches)
vProj1 x = error $ "can't proj1 " ++ show x
vProj1 x = error $ "can't proj1 " ++ show (prettyTm (quote x))
vProj2 :: HasCallStack => Value -> Value
vProj2 (VPair _ b) = b
vProj2 (VNe h sp) = VNe h (sp Seq.:|> PProj2)
vProj2 (GluedVl h sp vl) = GluedVl h (sp Seq.:|> PProj2) (vProj2 vl)
vProj2 (VSystem fs) = VSystem (fmap vProj2 fs)
vProj2 (VInc (VSigma _ (Closure _ r)) b c) = incS (r (vProj1 c)) b (vProj2 c)
vProj2 (VInc (VSigma _ (Closure _ r)) b c) = VInc (r (vProj1 c)) b (vProj2 c)
vProj2 (VCase env rng sc branches) =
VCase env rng sc (map (projIntoCase Proj2) branches)
vProj2 x = error $ "can't proj2 " ++ show (prettyTm (quote x))
projIntoCase :: (Term -> Term) -> (Term, Int, Term) -> (Term, Int, Term)
projIntoCase fun (pat, nLams, term) = (pat, nLams, go nLams term) where
go 0 x = fun x
go n (Lam p x r) = Lam p x (go (n - 1) r)
go n (PathIntro l a b r) = PathIntro l a b (go (n - 1) r)
go _ x = x

+ 11
- 31
src/Elab/Eval/Formula.hs View File

@ -2,38 +2,22 @@ module Elab.Eval.Formula where
import qualified Data.Map.Strict as Map
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import Data.Map.Strict (Map)
import Data.Set (Set)
import Syntax
import {-# SOURCE #-} Elab.WiredIn (inot, ior, iand)
import Elab.Eval (substitute, trueCaseSentinel)
toDnf :: Value -> Maybe Value
toDnf = fmap (dnf2Val . normalise) . val2Dnf where
val2Dnf (VNe _ _) = Nothing
val2Dnf 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
dnf2Val xs = Set.foldl ior VI0 (Set.map (Set.foldl iand VI1) xs)
type Nf = Set (Set Value)
normalise :: Value -> Nf
normalise = normaliseOr where
normaliseOr (VIOr x y) = Set.singleton (normaliseAnd x) <> normaliseOr y
normaliseOr x = Set.singleton (normaliseAnd x)
normaliseAnd (VIAnd x y) = Set.insert x (normaliseAnd y)
normaliseAnd x = Set.singleton x
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') =
@ -76,14 +60,10 @@ truthAssignments VI0 _ = []
truthAssignments VI1 m = pure m
truthAssignments (VIOr x y) m = truthAssignments x m ++ truthAssignments y m
truthAssignments (VIAnd x y) m = truthAssignments x =<< truthAssignments y m
truthAssignments (VNe (HVar x) Seq.Empty) m = pure (Map.insert x (VI, VI1) (sub x VI1 <$> m))
truthAssignments (VINot (VNe (HVar x) Seq.Empty)) m = pure (Map.insert x (VI, VI0) (sub x VI0 <$> m))
truthAssignments (VCase _ _ (VNe (HVar x) _) _) m = pure (Map.insert x (VI, VVar trueCaseSentinel) m)
truthAssignments (VNe (HVar x) Seq.Empty) m = pure (Map.insert x (VI, VI1) m)
truthAssignments (VINot (VNe (HVar x) Seq.Empty)) m = pure (Map.insert x (VI, VI0) m)
truthAssignments _ m = pure m
sub :: Name -> Value -> (NFType, NFEndp) -> (Value, Value)
sub x v (a, b) = (substitute (Map.singleton x v) a, substitute (Map.singleton x v) b)
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)


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

@ -1,18 +0,0 @@
module Elab.Eval.Formula where
import Syntax
import Data.Map.Strict (Map)
import Data.Set (Set)
toDnf :: Value -> Maybe Value
type Nf = Set (Set Value)
normalise :: Value -> Nf
compareDNFs :: Value -> Value -> Bool