Browse Source

Report unsolved metas & composition for the universe

feature/hits
Amélia Liao 3 years ago
parent
commit
2fdd17b847
7 changed files with 92 additions and 55 deletions
  1. +27
    -27
      intro.tt
  2. +24
    -13
      src/Elab/Eval.hs
  3. +9
    -3
      src/Elab/Monad.hs
  4. +6
    -7
      src/Elab/WiredIn.hs
  5. +22
    -3
      src/Main.hs
  6. +3
    -1
      src/Syntax.hs
  7. +1
    -1
      src/Syntax/Pretty.hs

+ 27
- 27
intro.tt View File

@ -520,47 +520,47 @@ IsoToEquiv {A} {B} iso =
lemIso y x0 x1 p0 p1 = lemIso y x0 x1 p0 p1 =
let let
rem0 : Path x0 (g y) rem0 : Path x0 (g y)
rem0 i = comp (\i -> A) (\k [ (i = i0) -> t x0 k, (i = i1) -> g y ]) (inS (g (p0 i)))
rem0 i = hcomp {A} (\k [ (i = i0) -> t x0 k, (i = i1) -> g y ]) (inS (g (p0 i)))
rem1 : Path x1 (g y) rem1 : Path x1 (g y)
rem1 i = comp (\i -> A) (\k [ (i = i0) -> t x1 k, (i = i1) -> g y ]) (inS (g (p1 i)))
rem1 i = hcomp {A} (\k [ (i = i0) -> t x1 k, (i = i1) -> g y ]) (inS (g (p1 i)))
p : Path x0 x1 p : Path x0 x1
p i = comp (\i -> A) (\k [ (i = i0) -> rem0 (inot k), (i = i1) -> rem1 (inot k) ]) (inS (g y))
p i = hcomp {A} (\k [ (i = i0) -> rem0 (inot k), (i = i1) -> rem1 (inot k) ]) (inS (g y))
fill0 : I -> I -> A fill0 : I -> I -> A
fill0 i j = comp (\i -> A) (\k [ (i = i0) -> t x0 (iand j k)
, (i = i1) -> g y
, (j = i0) -> g (p0 i)
])
(inS (g (p0 i)))
fill0 i j = hcomp {A} (\k [ (i = i0) -> t x0 (iand j k)
, (i = i1) -> g y
, (j = i0) -> g (p0 i)
])
(inS (g (p0 i)))
fill1 : I -> I -> A fill1 : I -> I -> A
fill1 i j = comp (\i -> A) (\k [ (i = i0) -> t x1 (iand j k)
, (i = i1) -> g y
, (j = i0) -> g (p1 i) ])
(inS (g (p1 i)))
fill1 i j = hcomp {A} (\k [ (i = i0) -> t x1 (iand j k)
, (i = i1) -> g y
, (j = i0) -> g (p1 i) ])
(inS (g (p1 i)))
fill2 : I -> I -> A fill2 : I -> I -> A
fill2 i j = comp (\i -> A) (\k [ (i = i0) -> rem0 (ior j (inot k))
, (i = i1) -> rem1 (ior j (inot k))
, (j = i1) -> g y ])
(inS (g y))
fill2 i j = hcomp {A} (\k [ (i = i0) -> rem0 (ior j (inot k))
, (i = i1) -> rem1 (ior j (inot k))
, (j = i1) -> g y ])
(inS (g y))
sq : I -> I -> A sq : I -> I -> A
sq i j = comp (\i -> A) (\k [ (i = i0) -> fill0 j (inot k)
, (i = i1) -> fill1 j (inot k)
, (j = i1) -> g y
, (j = i0) -> t (p i) (inot k) ])
(inS (fill2 i j))
sq i j = hcomp {A} (\k [ (i = i0) -> fill0 j (inot k)
, (i = i1) -> fill1 j (inot k)
, (j = i1) -> g y
, (j = i0) -> t (p i) (inot k) ])
(inS (fill2 i j))
sq1 : I -> I -> B sq1 : I -> I -> B
sq1 i j = comp (\i -> B) (\k [ (i = i0) -> s (p0 j) k
, (i = i1) -> s (p1 j) k
, (j = i0) -> s (f (p i)) k
, (j = i1) -> s y k
])
(inS (f (sq i j)))
sq1 i j = hcomp {B} (\k [ (i = i0) -> s (p0 j) k
, (i = i1) -> s (p1 j) k
, (j = i0) -> s (f (p i)) k
, (j = i1) -> s y k
])
(inS (f (sq i j)))
in \i -> (p i, \j -> sq1 i j) in \i -> (p i, \j -> sq1 i j)
fCenter : (y : B) -> fiber f y fCenter : (y : B) -> fiber f y


+ 24
- 13
src/Elab/Eval.hs View File

@ -1,7 +1,9 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TupleSections #-}
module Elab.Eval where module Elab.Eval where
import Control.Monad.Reader import Control.Monad.Reader
@ -39,7 +41,7 @@ eval :: Term -> ElabM Value
eval t = asks (flip eval' t) eval t = asks (flip eval' t)
forceIO :: MonadIO m => Value -> m Value forceIO :: MonadIO m => Value -> m Value
forceIO mv@(VNe (HMeta (MV _ cell)) args) = do
forceIO mv@(VNe (HMeta (mvCell -> cell)) args) = do
solved <- liftIO $ readIORef cell solved <- liftIO $ readIORef cell
case solved of case solved of
Just vl -> forceIO $ foldl applProj vl args Just vl -> forceIO $ foldl applProj vl args
@ -66,7 +68,7 @@ zonkIO :: Value -> IO Value
zonkIO (VNe hd sp) = do zonkIO (VNe hd sp) = do
sp' <- traverse zonkSp sp sp' <- traverse zonkSp sp
case hd of case hd of
HMeta (MV _ cell) -> do
HMeta (mvCell -> cell) -> do
solved <- liftIO $ readIORef cell solved <- liftIO $ readIORef cell
case solved of case solved of
Just vl -> zonkIO $ foldl applProj vl sp' Just vl -> zonkIO $ foldl applProj vl sp'
@ -366,10 +368,12 @@ isConvertibleTo a b = isConvertibleTo (force a) (force b) where
pure id pure id
newMeta :: Value -> ElabM Value newMeta :: Value -> ElabM Value
newMeta _dom = do
newMeta dom = do
loc <- liftM2 (,) <$> asks currentFile <*> asks currentSpan
n <- newName n <- newName
c <- liftIO $ newIORef Nothing c <- liftIO $ newIORef Nothing
let m = MV (getNameText n) c
let m = MV (getNameText n) c dom (flatten <$> loc)
flatten (x, (y, z)) = (x, y, z)
env <- asks getEnv env <- asks getEnv
@ -390,16 +394,23 @@ _nameCounter = unsafePerformIO $ newIORef 0
{-# NOINLINE _nameCounter #-} {-# NOINLINE _nameCounter #-}
solveMeta :: MV -> Seq Projection -> Value -> ElabM () solveMeta :: MV -> Seq Projection -> Value -> ElabM ()
solveMeta m@(MV _ cell) sp rhs = do
solveMeta m@(mvCell -> cell) sp rhs = do
env <- ask env <- ask
names <- checkSpine Set.empty sp
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, ())
names <- tryElab $ checkSpine Set.empty sp
case names of
Right names -> do
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 :: Set Name -> Value -> ElabM () checkScope :: Set Name -> Value -> ElabM ()
checkScope scope (VNe h sp) = checkScope scope (VNe h sp) =


+ 9
- 3
src/Elab/Monad.hs View File

@ -18,25 +18,31 @@ import Data.Typeable
import qualified Presyntax.Presyntax as P import qualified Presyntax.Presyntax as P
import Syntax import Syntax
import Data.IORef
import Data.Sequence (Seq)
data ElabEnv = data ElabEnv =
ElabEnv { getEnv :: Map Name (NFType, Value) ElabEnv { getEnv :: Map Name (NFType, Value)
, nameMap :: Map Text Name , nameMap :: Map Text Name
, pingPong :: Int
, pingPong :: {-# UNPACK #-} !Int
, commHook :: Value -> IO () , commHook :: Value -> IO ()
, currentSpan :: Maybe (P.Posn, P.Posn) , currentSpan :: Maybe (P.Posn, P.Posn)
, currentFile :: Maybe Text
, whereBound :: Map Name (P.Posn, P.Posn) , whereBound :: Map Name (P.Posn, P.Posn)
, definedNames :: Set Name , definedNames :: Set Name
, unsolvedMetas :: {-# UNPACK #-} !(IORef (Map MV [(Seq Projection, Value)]))
} }
newtype ElabM a = ElabM { runElab :: ElabEnv -> IO a } newtype ElabM a = ElabM { runElab :: ElabEnv -> IO a }
deriving (Functor, Applicative, Monad, MonadReader ElabEnv, MonadIO) deriving (Functor, Applicative, Monad, MonadReader ElabEnv, MonadIO)
via ReaderT ElabEnv IO via ReaderT ElabEnv IO
emptyEnv :: ElabEnv
emptyEnv = ElabEnv mempty mempty 0 (const (pure ())) Nothing mempty mempty
emptyEnv :: IO ElabEnv
emptyEnv = ElabEnv mempty mempty 0 (const (pure ())) Nothing Nothing mempty mempty <$> newIORef mempty
assume :: Name -> Value -> (Name -> ElabM a) -> ElabM a assume :: Name -> Value -> (Name -> ElabM a) -> ElabM a
assume nm ty k = defineInternal nm ty VVar k assume nm ty k = defineInternal nm ty VVar k


+ 6
- 7
src/Elab/WiredIn.hs View File

@ -228,11 +228,9 @@ comp a psi@phi u (compOutS (a @@ VI1) phi (u @@ VI1 @@ VItIsOne) -> a0) =
case force $ a @@ VVar (Bound (T.pack "neutral composition") 0) of case force $ a @@ VVar (Bound (T.pack "neutral composition") 0) of
VPi{} -> VPi{} ->
let let
plic i = let VPi p _ _ = force (a @@ i) in p
dom i = let VPi _ d _ = force (a @@ i) in d
rng i = case force (a @@ i) of
VPi _ _ (Closure _ r) -> r
x -> error $ "not pi?? " ++ show x
plic i = let VPi p _ _ = force (a @@ i) in p
dom i = let VPi _ d _ = force (a @@ i) in d
rng i = let VPi _ _ (Closure _ r) = force (a @@ i) in r
y' i y = fill (fun (dom . inot)) VI0 (fun \_ -> fun \_ -> VSystem mempty) (VInc (dom VI0) phi y) i y' i y = fill (fun (dom . inot)) VI0 (fun \_ -> fun \_ -> VSystem mempty) (VInc (dom VI0) phi y) i
ybar i y = y' (inot i) y ybar i y = y' (inot i) y
@ -300,12 +298,13 @@ comp a psi@phi u (compOutS (a @@ VI1) phi (u @@ VI1 @@ VItIsOne) -> a0) =
(fun (const (base VI1 @@ VItIsOne))) (fun (const (base VI1 @@ VItIsOne)))
(phi VI1 `ior` psi) (phi VI1 `ior` psi)
(system \j _u -> mkVSystem (Map.fromList [ (phi VI1, ielim (base VI1) a1' (vProj1 (equivs VI1 @@ VItIsOne)) alpha j) (system \j _u -> mkVSystem (Map.fromList [ (phi VI1, ielim (base VI1) a1' (vProj1 (equivs VI1 @@ VItIsOne)) alpha j)
, (psi, a VI1)]))
, (psi, a VI1)]))
a1' a1'
b1 = glueElem (base VI1) (phi VI1) (types VI1) (equivs VI1) (fun (const t1)) a1 b1 = glueElem (base VI1) (phi VI1) (types VI1) (equivs VI1) (fun (const t1)) a1
in b1 in b1
VType -> VGlueTy a0 phi (system \_ _ -> u @@ VI1 @@ VItIsOne) (system \_ _ -> makeEquiv (\j -> (u @@ inot j)))
VType -> VGlueTy a0 phi (system \_ _ -> mkVSystem (Map.fromList [(phi, u @@ VI1 @@ VItIsOne)]))
(system \_ _ -> mkVSystem (Map.fromList [(phi, makeEquiv (\j -> (u @@ inot j)))]))
-- fibrancy structure of the booleans is trivial -- fibrancy structure of the booleans is trivial
VBool{} -> a0 VBool{} -> a0


+ 22
- 3
src/Main.hs View File

@ -39,6 +39,8 @@ import qualified Data.Set as Set
import Data.Maybe import Data.Maybe
import Presyntax.Tokens import Presyntax.Tokens
import Debug.Trace import Debug.Trace
import Data.IORef
import Data.Sequence (Seq)
main :: IO () main :: IO ()
main = do main = do
@ -50,7 +52,7 @@ main = do
Check files verbose -> do Check files verbose -> do
env <- checkFiles files env <- checkFiles files
when verbose $ dumpEnv env when verbose $ dumpEnv env
Repl -> enterReplIn emptyEnv
Repl -> enterReplIn =<< emptyEnv
enterReplIn :: ElabEnv -> IO () enterReplIn :: ElabEnv -> IO ()
enterReplIn env = runInputT defaultSettings (loop env') where enterReplIn env = runInputT defaultSettings (loop env') where
@ -75,7 +77,7 @@ enterReplIn env = runInputT defaultSettings (loop env') where
loop env loop env
checkFiles :: [String] -> IO ElabEnv checkFiles :: [String] -> IO ElabEnv
checkFiles files = runElab (go files ask) emptyEnv where
checkFiles files = runElab (go files ask) =<< emptyEnv where
go [] k = do go [] k = do
env <- ask env <- ask
for_ (Map.toList (nameMap env)) \case for_ (Map.toList (nameMap env)) \case
@ -86,13 +88,18 @@ checkFiles files = runElab (go files ask) emptyEnv where
pos = fromJust (Map.lookup v (whereBound env)) pos = fromJust (Map.lookup v (whereBound env))
in withSpan (fst pos) (snd pos) $ throwElab $ DeclaredUndefined v in withSpan (fst pos) (snd pos) $ throwElab $ DeclaredUndefined v
_ -> pure () _ -> pure ()
metas <- liftIO $ readIORef (unsolvedMetas env)
unless (Map.null metas) $ do
liftIO $ reportUnsolved metas
k k
go (x:xs) k = do go (x:xs) k = do
code <- liftIO $ Bsl.readFile x code <- liftIO $ Bsl.readFile x
case runAlex (code <> Bsl.singleton 10) parseProg of case runAlex (code <> Bsl.singleton 10) parseProg of
Left e -> liftIO $ print e *> error (show e) Left e -> liftIO $ print e *> error (show e)
Right prog -> Right prog ->
checkProgram prog (go xs k)
local (\e -> e { currentFile = Just (T.pack x) }) (checkProgram prog (go xs k))
`catchElab` \e -> liftIO $ displayAndDie (T.decodeUtf8 (Bsl.toStrict code)) (e :: SomeException) `catchElab` \e -> liftIO $ displayAndDie (T.decodeUtf8 (Bsl.toStrict code)) (e :: SomeException)
dumpEnv :: ElabEnv -> IO () dumpEnv :: ElabEnv -> IO ()
@ -160,6 +167,18 @@ displayExceptions lines =
putStrLn $ "Name declared but not defined: " ++ show (pretty n) putStrLn $ "Name declared but not defined: " ++ show (pretty n)
] ]
reportUnsolved :: Foldable t => Map.Map MV (t (Seq Projection, Value)) -> IO ()
reportUnsolved metas = do
for_ (Map.toList metas) \(m, p) -> do
case mvSpan m of
Just (f, s, e) -> T.putStrLn . squiggleUnder s e =<< T.readFile (T.unpack f)
Nothing -> pure ()
T.putStrLn . render $
"Unsolved metavariable" <+> prettyTm (Meta m) <+> pretty ':' <+> prettyTm (quote (mvType m)) <+> "should satisfy:"
for_ p \p ->
T.putStrLn . render $ indent 2 $ prettyTm (quote (VNe (HMeta m) (fst p))) <+> pretty '≡' <+> prettyTm (quote (snd p))
displayExceptions' :: Exception e => Text -> e -> IO () displayExceptions' :: Exception e => Text -> e -> IO ()
displayExceptions' lines e = displayAndDie lines e `catch` \(_ :: ExitCode) -> pure () displayExceptions' lines e = displayAndDie lines e `catch` \(_ :: ExitCode) -> pure ()


+ 3
- 1
src/Syntax.hs View File

@ -14,7 +14,7 @@ import Data.Text (Text)
import Data.Set (Set) import Data.Set (Set)
import Data.Data import Data.Data
import Presyntax.Presyntax (Plicity(..))
import Presyntax.Presyntax (Plicity(..), Posn)
data WiredIn data WiredIn
= WiType = WiType
@ -109,6 +109,8 @@ data Term
data MV = data MV =
MV { mvName :: Text MV { mvName :: Text
, mvCell :: {-# UNPACK #-} !(IORef (Maybe Value)) , mvCell :: {-# UNPACK #-} !(IORef (Maybe Value))
, mvType :: NFType
, mvSpan :: Maybe (Text, Posn, Posn)
} }
instance Eq MV where instance Eq MV where


+ 1
- 1
src/Syntax/Pretty.hs View File

@ -88,7 +88,7 @@ prettyTm = prettyTm . everywhere (mkT beautify) where
beautify (Comp a phi u a0) = toFun "comp" [a, phi, u, a0] beautify (Comp a phi u a0) = toFun "comp" [a, phi, u, a0]
beautify (Sub a phi u) = toFun "Sub" [a, phi, u] beautify (Sub a phi u) = toFun "Sub" [a, phi, u]
beautify (Inc _ _ u) = toFun "inS" [u] beautify (Inc _ _ u) = toFun "inS" [u]
beautify (Ouc _ phi u0 u) = toFun "outS" [u]
beautify (Ouc _ _ _ u) = toFun "outS" [u]
beautify (GlueTy a I1 _ _) = a beautify (GlueTy a I1 _ _) = a
beautify (GlueTy a b c d) = toFun "Glue" [a,b,c,d] beautify (GlueTy a b c d) = toFun "Glue" [a,b,c,d]


Loading…
Cancel
Save