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

Implement proper inductive types

feature/hits
Amélia Liao 3 years ago
parent
97613613be
commit
b42384125d
12 changed files with 321 additions and 138 deletions
Unified View
Diff Options
Show Stats Download Patch File Download Diff File
  1. +23
    -20
      intro.tt
  2. +133
    -1
      src/Elab.hs
  3. +23
    -29
      src/Elab/Eval.hs
  4. +1
    -0
      src/Elab/Monad.hs
  5. +37
    -34
      src/Elab/WiredIn.hs
  6. +2
    -5
      src/Elab/WiredIn.hs-boot
  7. +2
    -0
      src/Presyntax/Lexer.x
  8. +27
    -1
      src/Presyntax/Parser.y
  9. +8
    -0
      src/Presyntax/Presyntax.hs
  10. +5
    -0
      src/Presyntax/Tokens.hs
  11. +49
    -31
      src/Syntax.hs
  12. +11
    -17
      src/Syntax/Pretty.hs

+ 23
- 20
intro.tt View File

@ -152,13 +152,7 @@ IsOne : I -> Pretype
-- The value itIs1 witnesses the fact that i1 = i1. -- The value itIs1 witnesses the fact that i1 = i1.
itIs1 : IsOne i1 itIs1 : IsOne i1
-- Furthermore, if either of i or j are one, then so is (i or j).
isOneL : {i : I} {j : I} -> IsOne i -> IsOne (ior i j)
isOneR : {i : I} {j : I} -> IsOne j -> IsOne (ior i j)
{-# PRIMITIVE itIs1 #-} {-# PRIMITIVE itIs1 #-}
{-# PRIMITIVE isOneL #-}
{-# PRIMITIVE isOneR #-}
-- Partial elements -- Partial elements
------------------- -------------------
@ -579,24 +573,24 @@ involToIso {A} f inv = (f, inv, inv)
-- --
-- We define it here. -- We define it here.
Bool : Type
{-# PRIMITIVE Bool #-}
data Bool : Type where
true : Bool
false : Bool
true, false : Bool
{-# PRIMITIVE true #-}
{-# PRIMITIVE false #-}
not : Bool -> Bool
not = \case
true -> false
false -> true
-- Pattern matching for booleans: If a proposition holds for true and
-- for false, then it holds for every bool.
elimBool : (P : Bool -> Type) -> P true -> P false -> (b : Bool) -> P b elimBool : (P : Bool -> Type) -> P true -> P false -> (b : Bool) -> P b
{-# PRIMITIVE if elimBool #-}
elimBool P x y = \case
true -> x
false -> y
-- Non-dependent elimination of booleans
if : {A : Type} -> A -> A -> Bool -> A if : {A : Type} -> A -> A -> Bool -> A
if {A} = elimBool (\b -> A)
not : Bool -> Bool
not = if false true
if x y = \case
true -> x
false -> y
-- By pattern matching it suffices to prove (not (not true)) ≡ true and -- By pattern matching it suffices to prove (not (not true)) ≡ true and
-- not (not false) ≡ false. Since not (not true) computes to true (resp. -- not (not false) ≡ false. Since not (not true) computes to true (resp.
@ -686,4 +680,13 @@ pathIsHom {A} {B} {f} {g} =
let let
theIso : Iso (Path f g) (Hom f g) theIso : Iso (Path f g) (Hom f g)
theIso = (happly {A} {B} {f} {g}, happlyIsIso {A} {B} {f} {g}) theIso = (happly {A} {B} {f} {g}, happlyIsIso {A} {B} {f} {g})
in univalence (IsoToEquiv theIso)
in univalence (IsoToEquiv theIso)
data List (A : Type) : Type where
nil : List A
cons : A -> List A -> List A
map : {A : Type} {B : Type} -> (A -> B) -> List A -> List B
map f = \case
nil -> nil
cons x xs -> cons (f x) (map f xs)

+ 133
- 1
src/Elab.hs View File

@ -2,13 +2,17 @@
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DerivingStrategies #-}
module Elab where module Elab where
import Control.Arrow (Arrow(first))
import Control.Monad.Reader import Control.Monad.Reader
import Control.Exception import Control.Exception
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
import qualified Data.Sequence as Seq
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Traversable import Data.Traversable
import Data.Text (Text) import Data.Text (Text)
import Data.Map (Map) import Data.Map (Map)
@ -190,11 +194,79 @@ check (P.LamSystem bs) ty = do
mkB _ (Nothing, b) = b mkB _ (Nothing, b) = b
pure (Lam P.Ex name (System (Map.fromList (map (\(_, (x, y)) -> (quote x, mkB name y)) eqns)))) pure (Lam P.Ex name (System (Map.fromList (map (\(_, (x, y)) -> (quote x, mkB name y)) eqns))))
check (P.LamCase pats) ty = do
porp <- isPiType P.Ex ty
case porp of
It'sProd dom rng wp -> do
name <- newName
liftIO . print $ show pats
cases <- for pats $ \(pat, rhs) -> do
checkPattern pat dom \pat wp -> do
pat_nf <- eval pat
rhs <- check rhs (rng pat_nf)
pure (pat, wp rhs)
pure (wp (Lam P.Ex name (Case (Ref name) cases)))
_ -> do
dom <- newMeta VTypeω
n <- newName' (Bound (T.singleton 'x') 0)
assume n dom \_ -> do
rng <- newMeta VTypeω
throwElab $ NotEqual (VPi P.Ex dom (Closure n (const rng))) ty
check exp ty = do check exp ty = do
(tm, has) <- switch $ infer exp (tm, has) <- switch $ infer exp
wp <- isConvertibleTo has ty wp <- isConvertibleTo has ty
pure (wp tm) pure (wp tm)
checkPattern :: P.Pattern -> NFSort -> (Term -> (Term -> Term) -> ElabM a) -> ElabM a
checkPattern (P.PCap var) dom cont = do
name <- asks (Map.lookup var . nameMap)
case name of
Just name@(ConName _ _ skip arity) -> do
unless (arity == 0) $ throwElab $ UnsaturatedCon name
ty <- instantiate =<< getNfType name
_ <- isConvertibleTo ty dom
wrap <- skipLams skip
cont (Con name) wrap
Just name -> throwElab $ NotACon name
Nothing -> assume (Bound var 0) dom \name -> cont (Ref name) (Lam P.Ex name)
checkPattern (P.PCon var args) dom cont =
do
name <- asks (Map.lookup var . nameMap)
case name of
Just name@(ConName _ _ nskip arity) -> do
unless (arity == length args) $ throwElab $ UnsaturatedCon name
ty <- instantiate =<< getNfType name
_ <- isConvertibleTo (skipBinders arity ty) dom
skip <- skipLams nskip
bindNames args ty $ \_ wrap ->
cont (Con name) (skip . wrap)
Just name -> throwElab $ NotACon name
_ -> throwElab $ NotInScope (Bound var 0)
where
skipBinders :: Int -> NFType -> NFType
skipBinders 0 t = t
skipBinders n (VPi _ _ (Closure v r)) = skipBinders (n - 1) (r (VVar v))
skipBinders _ _ = error $ "constructor type is wrong?"
bindNames (n:ns) (VPi p d (Closure _ r)) k =
assume (Bound n 0) d \n -> bindNames ns (r (VVar n)) \ns w ->
k (n:ns) (Lam p n . w)
bindNames [] _ k = k [] id
bindNames xs t _ = error $ show (xs, t)
instantiate :: NFType -> ElabM NFType
instantiate (VPi P.Im d (Closure _ k)) = do
t <- newMeta d
instantiate (k t)
instantiate x = pure x
skipLams :: Int -> ElabM (Term -> Term)
skipLams 0 = pure id
skipLams k = do
n <- newName
(Lam P.Im n . ) <$> skipLams (k - 1)
checkLetItems :: Map Text (Maybe NFType) -> [P.LetItem] -> ([(Name, Term, Term)] -> ElabM a) -> ElabM a checkLetItems :: Map Text (Maybe NFType) -> [P.LetItem] -> ([(Name, Term, Term)] -> ElabM a) -> ElabM a
checkLetItems _ [] cont = cont [] checkLetItems _ [] cont = cont []
checkLetItems map (P.LetDecl v t:xs) cont = do checkLetItems map (P.LetDecl v t:xs) cont = do
@ -333,7 +405,7 @@ checkStatement (P.Defn name rhs) k = do
when t $ throwElab (Redefinition (Defined name 0)) when t $ throwElab (Redefinition (Defined name 0))
rhs <- check rhs ty_nf rhs <- check rhs ty_nf
rhs_nf <- eval rhs
rhs_nf <- evalFix (Defined name 0) ty_nf rhs
makeLetDef (Defined name 0) ty_nf rhs_nf $ \name -> makeLetDef (Defined name 0) ty_nf rhs_nf $ \name ->
local (\e -> e { definedNames = Set.insert name (definedNames e) }) k local (\e -> e { definedNames = Set.insert name (definedNames e) }) k
@ -371,6 +443,58 @@ checkStatement (P.ReplTy e) k = do
liftIO (h ty) liftIO (h ty)
k k
checkStatement (P.Data name tele retk constrs) k =
do
checkTeleRetk True tele retk \kind tele -> do
kind_nf <- eval kind
defineInternal (Bound name 0) kind_nf (\name' -> VNe (HData name') mempty) \name' -> do
checkCons tele (VNe (HData name') (Seq.fromList (map makeProj tele))) constrs k
where
makeProj (x, p, _) = PApp p (VVar x)
checkTeleRetk allKan [] retk cont = do
t <- check retk VTypeω
t_nf <- eval t
when allKan $ unify t_nf VType
cont t []
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
assume (Bound x 0) t_nf $ \nm -> checkTeleRetk allKan' xs retk \k xs -> cont (Pi p nm t k) ((nm, p, t_nf):xs)
checkCons _ _et [] k = k
checkCons n ret ((x, ty):xs) k = do
t <- check ty VTypeω
ty_nf <- eval t
let
(args, ret') = splitPi ty_nf
closed = close n t
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 n ret xs k
close [] t = t
close ((x, _, y):xs) t = Pi P.Im x (quote y) (close xs t)
splitPi (VPi p y (Closure x k)) = first ((x, p, y):) $ splitPi (k (VVar x))
splitPi t = ([], t)
makeCon cty sp [] [] con = VNe (HCon cty con) sp
makeCon cty sp ((nm, p, _):xs) ys con = VLam p $ Closure nm \a -> makeCon cty (sp Seq.:|> PApp p a) xs ys con
makeCon cty sp [] ((nm, p, _):ys) con = VLam p $ Closure nm \a -> makeCon cty (sp Seq.:|> PApp p a) [] ys con
evalFix :: Name -> NFType -> Term -> ElabM Value
evalFix name nft term = do
env <- ask
pure . fix $ \val -> eval' env{ getEnv = Map.insert name (nft, val) (getEnv env) } term
checkProgram :: [P.Statement] -> ElabM a -> ElabM a checkProgram :: [P.Statement] -> ElabM a -> ElabM a
checkProgram [] k = k checkProgram [] k = k
checkProgram (st:sts) k = checkStatement st $ checkProgram sts k checkProgram (st:sts) k = checkStatement st $ checkProgram sts k
@ -380,3 +504,11 @@ newtype Redefinition = Redefinition { getRedefName :: Name }
data WhenCheckingEndpoint = WhenCheckingEndpoint { leftEndp :: Value, rightEndp :: Value, whichIsWrong :: NFEndp, exc :: SomeException } data WhenCheckingEndpoint = WhenCheckingEndpoint { leftEndp :: Value, rightEndp :: Value, whichIsWrong :: NFEndp, exc :: SomeException }
deriving (Show, Typeable, Exception) deriving (Show, Typeable, Exception)
data UnsaturatedCon = UnsaturatedCon { theConstr :: Name }
deriving (Show, Typeable)
deriving anyclass (Exception)
data NotACon = NotACon { theNotConstr :: Name }
deriving (Show, Typeable)
deriving anyclass (Exception)

+ 23
- 29
src/Elab/Eval.hs View File

@ -6,6 +6,7 @@
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
module Elab.Eval where module Elab.Eval where
import Control.Arrow (Arrow(second))
import Control.Monad.Reader import Control.Monad.Reader
import Control.Exception import Control.Exception
@ -51,7 +52,7 @@ forceIO vl@(VSystem fs) =
Just x -> forceIO x Just x -> forceIO x
Nothing -> pure vl Nothing -> pure vl
forceIO (GluedVl _ _ vl) = forceIO vl forceIO (GluedVl _ _ vl) = forceIO vl
forceIO (VComp line phi u a0) = comp line <$> forceIO phi <*> pure u <*> pure a0
forceIO (VComp line phi u a0) = comp <$> forceIO line <*> forceIO phi <*> pure u <*> pure a0
forceIO x = pure x forceIO x = pure x
applProj :: Value -> Projection -> Value applProj :: Value -> Projection -> Value
@ -99,8 +100,6 @@ zonkIO (VIOr x y) = ior <$> zonkIO x <*> zonkIO y
zonkIO (VINot x) = inot <$> zonkIO x zonkIO (VINot x) = inot <$> zonkIO x
zonkIO (VIsOne x) = VIsOne <$> zonkIO x zonkIO (VIsOne x) = VIsOne <$> zonkIO x
zonkIO (VIsOne1 x) = VIsOne1 <$> zonkIO x
zonkIO (VIsOne2 x) = VIsOne2 <$> zonkIO x
zonkIO VItIsOne = pure VItIsOne zonkIO VItIsOne = pure VItIsOne
zonkIO (VPartial x y) = VPartial <$> zonkIO x <*> zonkIO y zonkIO (VPartial x y) = VPartial <$> zonkIO x <*> zonkIO y
@ -115,11 +114,7 @@ zonkIO (VComp a b c d) = comp <$> zonkIO a <*> zonkIO b <*> zonkIO c <*> zonkIO
zonkIO (VGlueTy a phi ty e) = glueType <$> zonkIO a <*> zonkIO phi <*> zonkIO ty <*> zonkIO e 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 (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 (VUnglue a phi ty e x) = unglue <$> zonkIO a <*> zonkIO phi <*> zonkIO ty <*> zonkIO e <*> zonkIO x
zonkIO VBool = pure VBool
zonkIO VTt = pure VTt
zonkIO VFf = pure VFf
zonkIO (VIf a b c d) = elimBool <$> zonkIO a <*> zonkIO b <*> zonkIO c <*> zonkIO d
zonkIO (VCase x xs) = VCase <$> zonkIO x <*> traverse (\(x, y) -> (x,) <$> zonkIO y) xs
zonkSp :: Projection -> IO Projection zonkSp :: Projection -> IO Projection
zonkSp (PApp p x) = PApp p <$> zonkIO x zonkSp (PApp p x) = PApp p <$> zonkIO x
@ -143,6 +138,13 @@ eval' env (Ref x) =
case Map.lookup x (getEnv env) of case Map.lookup x (getEnv env) of
Just (_, vl) -> vl Just (_, vl) -> vl
_ -> VNe (HVar x) mempty _ -> VNe (HVar x) mempty
eval' env (Con x) =
case Map.lookup x (getEnv env) of
Just (ty, _) -> VNe (HCon ty x) mempty
Nothing -> error $ "constructor " ++ show x ++ " has no type in scope"
eval' _ (Data x) = VNe (HData x) mempty
eval' env (App p f x) = vApp p (eval' env f) (eval' env x) eval' env (App p f x) = vApp p (eval' env f) (eval' env x)
eval' env (Lam p s t) = eval' env (Lam p s t) =
@ -179,8 +181,6 @@ eval' e (IElim l x y f i) = ielim (eval' e l) (eval' e x) (eval' e y) (eval' e f
eval' e (PathIntro p x y f) = VLine (eval' e p) (eval' e x) (eval' e y) (eval' e f) 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' 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' _ ItIsOne = VItIsOne
eval' e (Partial x y) = VPartial (eval' e x) (eval' e y) eval' e (Partial x y) = VPartial (eval' e x) (eval' e y)
@ -200,10 +200,15 @@ eval' e (Let ns x) =
let env' = foldl (\newe (n, ty, x) -> newe { getEnv = Map.insert n (eval' newe ty, eval' newe x) (getEnv newe) }) e ns let env' = foldl (\newe (n, ty, x) -> newe { getEnv = Map.insert n (eval' newe ty, eval' newe x) (getEnv newe) }) e ns
in eval' env' x in eval' env' x
eval' e (If a b c d) = elimBool (eval' e a) (eval' e b) (eval' e c) (eval' e d)
eval' _ Bool = VBool
eval' _ Tt = VTt
eval' _ Ff = VFf
eval' e (Case sc xs) = evalCase e (eval' e sc) xs
evalCase :: ElabEnv -> Value -> [(Term, Term)] -> Value
evalCase _ sc [] = error $ "unmatched pattern for value: " ++ show (prettyTm (quote sc))
evalCase env sc ((Ref _, k):_) = eval' env k @@ sc
evalCase env (force -> val@(VNe (HCon _ x) sp)) ((Con x', k):xs)
| x == x' = foldl applProj (eval' env k) sp
| otherwise = evalCase env val xs
evalCase env sc xs = VCase sc (map (second (eval' env)) xs)
vApp :: HasCallStack => Plicity -> Value -> Value -> Value vApp :: HasCallStack => Plicity -> Value -> Value -> Value
vApp p (VLam p' k) arg vApp p (VLam p' k) arg
@ -291,10 +296,6 @@ unify' topa topb = join $ go <$> forceIO topa <*> forceIO topb where
-- IsOne is proof-irrelevant: -- IsOne is proof-irrelevant:
go VItIsOne _ = pure () go VItIsOne _ = pure ()
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 (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 (VPartialP phi r) (VPartialP phi' r') = unify' phi phi' *> unify' r r'
@ -317,10 +318,6 @@ unify' topa topb = join $ go <$> forceIO topa <*> forceIO topb where
go (VSystem sys) rhs = goSystem unify' sys rhs go (VSystem sys) rhs = goSystem unify' sys rhs
go rhs (VSystem sys) = goSystem (flip unify') sys rhs go rhs (VSystem sys) = goSystem (flip unify') sys rhs
go VTt VTt = pure ()
go VFf VFf = pure ()
go VBool VBool = pure ()
go x y go x y
| x == y = pure () | x == y = pure ()
| otherwise = | otherwise =
@ -356,7 +353,7 @@ unify' topa topb = join $ go <$> forceIO topa <*> forceIO topb where
| otherwise = fail | otherwise = fail
unify :: HasCallStack => Value -> Value -> ElabM () unify :: HasCallStack => Value -> Value -> ElabM ()
unify a b = unify' 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 :: Value -> Value -> ElabM (Term -> Term)
isConvertibleTo a b = isConvertibleTo (force a) (force b) where isConvertibleTo a b = isConvertibleTo (force a) (force b) where
@ -436,7 +433,9 @@ checkScope scope (VNe h sp) =
unless (v `Set.member` scope) . throwElab $ unless (v `Set.member` scope) . throwElab $
NotInScope v NotInScope v
HVar{} -> pure () HVar{} -> pure ()
HCon{} -> pure ()
HMeta{} -> pure () HMeta{} -> pure ()
HData{} -> pure ()
traverse_ checkProj sp traverse_ checkProj sp
where where
checkProj (PApp _ t) = checkScope scope t checkProj (PApp _ t) = checkScope scope t
@ -475,8 +474,6 @@ 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 (VIsOne x) = checkScope s x
checkScope s (VIsOne1 x) = checkScope s x
checkScope s (VIsOne2 x) = checkScope s x
checkScope _ VItIsOne = pure () checkScope _ VItIsOne = pure ()
checkScope s (VPartial x y) = traverse_ (checkScope s) [x, y] checkScope s (VPartial x y) = traverse_ (checkScope s) [x, y]
@ -492,10 +489,7 @@ 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 (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 s (VUnglue a phi ty eq vl) = traverse_ (checkScope s) [a, phi, ty, eq, vl]
checkScope s (VIf a b c d) = traverse_ (checkScope s) [a, b, c, d]
checkScope _ VBool = pure ()
checkScope _ VTt = pure ()
checkScope _ VFf = pure ()
checkScope s (VCase v xs) = checkScope s v *> traverse_ (checkScope s . snd) xs
checkSpine :: Set Name -> Seq Projection -> ElabM [Name] checkSpine :: Set Name -> Seq Projection -> ElabM [Name]
checkSpine scope (PApp Ex (VVar n@Bound{}) Seq.:<| xs) checkSpine scope (PApp Ex (VVar n@Bound{}) Seq.:<| xs)


+ 1
- 0
src/Elab/Monad.hs View File

@ -169,3 +169,4 @@ throwElab = liftIO . throwIO
incName :: Name -> Name -> Name incName :: Name -> Name -> Name
incName (Bound x _) n = Bound x (getNameNum n + 1) incName (Bound x _) n = Bound x (getNameNum n + 1)
incName (Defined x _) n = Defined x (getNameNum n + 1) incName (Defined x _) n = Defined x (getNameNum n + 1)
incName (ConName x _ s a) n = ConName x (getNameNum n + 1) s a

+ 37
- 34
src/Elab/WiredIn.hs View File

@ -17,13 +17,14 @@ import Data.Typeable
import Elab.Eval import Elab.Eval
import GHC.Stack (HasCallStack)
import qualified Presyntax.Presyntax as P import qualified Presyntax.Presyntax as P
import Syntax.Pretty (prettyTm)
import Syntax import Syntax
import System.IO.Unsafe import System.IO.Unsafe
import Syntax.Pretty (prettyTm)
import GHC.Stack (HasCallStack)
wiType :: WiredIn -> NFType wiType :: WiredIn -> NFType
wiType WiType = VType wiType WiType = VType
@ -40,8 +41,6 @@ wiType WiPathP = dprod (VI ~> VType) \a -> a @@ VI0 ~> a @@ VI1 ~> VType
wiType WiIsOne = VI ~> VTypeω wiType WiIsOne = VI ~> VTypeω
wiType WiItIsOne = VIsOne VI1 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 WiPartial = VI ~> VType ~> VTypeω
wiType WiPartialP = dprod VI \x -> VPartial x VType ~> VTypeω wiType WiPartialP = dprod VI \x -> VPartial x VType ~> VTypeω
@ -59,11 +58,6 @@ wiType WiGlueElem = forAll' "A" VType \a -> forAll' "phi" VI \phi -> forAll' "T"
-- {A : Type} {phi : I} {T : Partial phi Type} {e : PartialP phi (\o -> Equiv (T o) A)} -> Glue A phi T e -> A -- {A : Type} {phi : I} {T : Partial phi Type} {e : PartialP phi (\o -> Equiv (T o) A)} -> Glue A phi T e -> A
wiType WiUnglue = forAll' "A" VType \a -> forAll' "phi" VI \phi -> forAll' "T" (VPartial phi VType) \ty -> forAll' "e" (VPartialP phi (fun \o -> equiv (ty @@ o) a)) \e -> VGlueTy a phi ty e ~> a wiType WiUnglue = forAll' "A" VType \a -> forAll' "phi" VI \phi -> forAll' "T" (VPartial phi VType) \ty -> forAll' "e" (VPartialP phi (fun \o -> equiv (ty @@ o) a)) \e -> VGlueTy a phi ty e ~> a
wiType WiBool = VType
wiType WiTrue = VBool
wiType WiFalse = VBool
wiType WiIf = dprod' "A" (VBool ~> VType) \a -> a @@ VTt ~> a @@ VFf ~> dprod' "b" VBool \b -> a @@ b
wiValue :: WiredIn -> Value wiValue :: WiredIn -> Value
wiValue WiType = VType wiValue WiType = VType
wiValue WiPretype = VTypeω wiValue WiPretype = VTypeω
@ -79,8 +73,6 @@ wiValue WiPathP = fun \a -> fun \x -> fun \y -> VPath a x y
wiValue WiIsOne = fun VIsOne wiValue WiIsOne = fun VIsOne
wiValue WiItIsOne = VItIsOne 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 WiPartial = fun \phi -> fun \r -> VPartial phi r
wiValue WiPartialP = fun \phi -> fun \r -> VPartialP phi r wiValue WiPartialP = fun \phi -> fun \r -> VPartialP phi r
@ -93,11 +85,6 @@ wiValue WiGlue = fun \a -> forallI \phi -> fun \t -> fun \e -> glueType a ph
wiValue WiGlueElem = forallI \a -> forallI \phi -> forallI \ty -> forallI \eqv -> fun \x -> fun \y -> glueElem a phi ty eqv x y wiValue WiGlueElem = forallI \a -> forallI \phi -> forallI \ty -> forallI \eqv -> fun \x -> fun \y -> glueElem a phi ty eqv x y
wiValue WiUnglue = forallI \a -> forallI \phi -> forallI \ty -> forallI \eqv -> fun \x -> unglue a phi ty eqv x wiValue WiUnglue = forallI \a -> forallI \phi -> forallI \ty -> forallI \eqv -> fun \x -> unglue a phi ty eqv x
wiValue WiBool = VBool
wiValue WiTrue = VTt
wiValue WiFalse = VFf
wiValue WiIf = fun \a -> fun \b -> fun \c -> fun \d -> elimBool a b c d
(~>) :: Value -> Value -> Value (~>) :: Value -> Value -> Value
a ~> b = VPi P.Ex a (Closure (Bound "_" 0) (const b)) a ~> b = VPi P.Ex a (Closure (Bound "_" 0) (const b))
infixr 7 ~> infixr 7 ~>
@ -142,8 +129,6 @@ wiredInNames = Map.fromList
, ("IsOne", WiIsOne) , ("IsOne", WiIsOne)
, ("itIs1", WiItIsOne) , ("itIs1", WiItIsOne)
, ("isOneL", WiIsOne1)
, ("isOneR", WiIsOne2)
, ("Partial", WiPartial) , ("Partial", WiPartial)
, ("PartialP", WiPartialP) , ("PartialP", WiPartialP)
@ -155,11 +140,6 @@ wiredInNames = Map.fromList
, ("Glue", WiGlue) , ("Glue", WiGlue)
, ("glue", WiGlueElem) , ("glue", WiGlueElem)
, ("unglue", WiUnglue) , ("unglue", WiUnglue)
, ("Bool", WiBool)
, ("true", WiTrue)
, ("false", WiFalse)
, ("if", WiIf)
] ]
newtype NoSuchPrimitive = NoSuchPrimitive { getUnknownPrim :: Text } newtype NoSuchPrimitive = NoSuchPrimitive { getUnknownPrim :: Text }
@ -215,6 +195,7 @@ ielim line left right fn i =
VNe n sp -> VNe n (sp Seq.:|> PIElim line left right i) VNe n sp -> VNe n (sp Seq.:|> PIElim line left right i)
VSystem map -> VSystem (fmap (flip (ielim line left right) i) map) VSystem map -> VSystem (fmap (flip (ielim line left right) i) map)
VInc (VPath _ _ _) _ u -> ielim line left right u i VInc (VPath _ _ _) _ u -> ielim line left right u i
VCase x xs -> VCase x (fmap (fmap (flip (ielim line left right) i)) xs)
_ -> error $ "can't ielim " ++ show (prettyTm (quote fn)) _ -> error $ "can't ielim " ++ show (prettyTm (quote fn))
outS :: NFSort -> NFEndp -> Value -> Value -> Value outS :: NFSort -> NFEndp -> Value -> Value -> Value
@ -228,7 +209,7 @@ outS a phi u (VNe x sp) = VNe x (sp Seq.:|> POuc a phi u)
outS _ _ _ v = error $ "can't outS " ++ show (prettyTm (quote v)) outS _ _ _ v = error $ "can't outS " ++ show (prettyTm (quote v))
-- Composition -- Composition
comp :: HasCallStack => NFLine -> NFEndp -> Value -> Value -> Value
comp :: NFLine -> NFEndp -> Value -> Value -> Value
comp _ VI1 u _ = u @@ VI1 @@ VItIsOne comp _ VI1 u _ = u @@ VI1 @@ VItIsOne
comp a psi@phi u (compOutS (a @@ VI1) phi (u @@ VI1 @@ VItIsOne) -> a0) = comp a psi@phi u (compOutS (a @@ VI1) phi (u @@ VI1 @@ VItIsOne) -> a0) =
case force $ a @@ VVar (Bound (T.pack "i") 0) of case force $ a @@ VVar (Bound (T.pack "i") 0) of
@ -253,7 +234,7 @@ comp a psi@phi u (compOutS (a @@ VI1) phi (u @@ VI1 @@ VItIsOne) -> a0) =
w i = fill (fun dom) phi (system \i isone -> vProj1 (u @@ i @@ isone)) (VInc (dom VI0) phi (vProj1 a0)) i w i = fill (fun dom) phi (system \i isone -> vProj1 (u @@ i @@ isone)) (VInc (dom VI0) phi (vProj1 a0)) i
c1 = comp (fun dom) phi (system \i isone -> vProj1 (u @@ i @@ isone)) (VInc (dom VI0) phi (vProj1 a0)) c1 = comp (fun dom) phi (system \i isone -> vProj1 (u @@ i @@ isone)) (VInc (dom VI0) phi (vProj1 a0))
c2 = comp (fun \x -> rng x (w x)) phi (system \i isone -> vProj2 (u @@ i @@ isone)) (VInc (rng VI0 (w VI0)) phi (vProj2 a0)) c2 = comp (fun \x -> rng x (w x)) phi (system \i isone -> vProj2 (u @@ i @@ isone)) (VInc (rng VI0 (w VI0)) phi (vProj2 a0))
in
in
VPair c1 c2 VPair c1 c2
VPath{} -> VPath{} ->
@ -312,11 +293,40 @@ comp a psi@phi u (compOutS (a @@ VI1) phi (u @@ VI1 @@ VItIsOne) -> a0) =
VType -> VGlueTy a0 phi (system \_ _ -> mkVSystem (Map.fromList [(phi, u @@ VI1 @@ VItIsOne)])) VType -> VGlueTy a0 phi (system \_ _ -> mkVSystem (Map.fromList [(phi, u @@ VI1 @@ VItIsOne)]))
(system \_ _ -> mkVSystem (Map.fromList [(phi, makeEquiv (\j -> (u @@ inot j)))])) (system \_ _ -> mkVSystem (Map.fromList [(phi, makeEquiv (\j -> (u @@ inot j)))]))
-- fibrancy structure of the booleans is trivial
VBool{} -> a0
VNe HData{} args ->
case force a0 of
VNe (HCon con_type con_name) con_args ->
VNe (HCon con_type con_name) $ compConArgs (length args) (a @@) con_type con_args phi u
_ -> VComp a phi u (VInc (a @@ VI0) phi a0)
_ -> VComp a phi u (VInc (a @@ VI0) phi a0) _ -> VComp a phi u (VInc (a @@ VI0) phi a0)
compConArgs :: Int -> (NFEndp -> Value) -> Value -> Seq.Seq Projection -> NFEndp -> Value -> Seq.Seq Projection
compConArgs total_args fam = go total_args where
go _ _ Seq.Empty _ _ = Seq.Empty
go nargs (VPi p dom (Closure _ rng)) (PApp p' y Seq.:<| xs) phi u
| nargs > 0 = assert (p == p') $ go (nargs - 1) (rng (smuggle (fun (\i -> nthArg (total_args - nargs) (fam i))))) xs phi u
| otherwise = assert (p == p') $
let fill = makeFiller nargs dom phi u y
in PApp p' (fill @@ VI1) Seq.:<| go (nargs - 1) (rng fill) xs phi u
go _ _ _ _ _ = error $ "invalid constructor"
nthArg i (VNe hd s) =
case s Seq.!? i of
Just (PApp _ t) -> t
_ -> error $ "invalid " ++ show i ++ "th argument to data type " ++ show hd
nthArg i (VSystem vs) = VSystem (fmap (nthArg i) vs)
nthArg i xs = error $ "can't get " ++ show i ++ "th argument of " ++ show (prettyTm (quote xs))
makeFiller nth (VNe (HData (Bound _ (negate -> 10))) args) phi u a0 =
fun $ fill (makeDomain args) phi (system \i is1 -> nthArg nth (u @@ i @@ is1) ) a0
makeFiller _ _ _ _ a0 = fun (const a0)
makeDomain (PApp _ x Seq.:<| xs) = fun \i -> foldl (\t (~(PApp _ x)) -> t @@ (x @@ i)) (x @@ i) xs
makeDomain _ = error "somebody smuggled something that smells"
smuggle x = VNe (HData (Bound "__comp_con_tyarg" (negate 10))) (Seq.singleton (PApp P.Ex x))
compOutS :: NFSort -> NFEndp -> Value -> Value -> Value compOutS :: NFSort -> NFEndp -> Value -> Value -> Value
compOutS a b c d = compOutS a b c (force d) where compOutS a b c d = compOutS a b c (force d) where
compOutS _ _hi _0 vl@VComp{} = vl compOutS _ _hi _0 vl@VComp{} = vl
@ -412,10 +422,3 @@ makeEquiv line = comp (fun \i -> equiv a (line i)) VI0 (system \_ _ -> VSystem m
ielim (fun (const a)) y y (vProj2 u) (iand i j) ielim (fun (const a)) y y (vProj2 u) (iand i j)
id_fiber y = VPair y (VLine a y y (fun (const y))) id_fiber y = VPair y (VLine a y y (fun (const y)))
elimBool :: NFSort -> Value -> Value -> Value -> Value
elimBool prop x y bool =
case force bool of
VTt -> x
VFf -> y
_ -> VIf prop x y bool

+ 2
- 5
src/Elab/WiredIn.hs-boot View File

@ -1,7 +1,6 @@
module Elab.WiredIn where module Elab.WiredIn where
import Syntax import Syntax
import GHC.Stack
wiType :: WiredIn -> NFType wiType :: WiredIn -> NFType
wiValue :: WiredIn -> NFType wiValue :: WiredIn -> NFType
@ -11,10 +10,8 @@ inot :: NFEndp -> NFEndp
ielim :: NFSort -> Value -> Value -> Value -> NFEndp -> Value ielim :: NFSort -> Value -> Value -> Value -> NFEndp -> Value
outS :: NFSort -> NFEndp -> Value -> Value -> Value outS :: NFSort -> NFEndp -> Value -> Value -> Value
comp :: HasCallStack => NFLine -> NFEndp -> Value -> Value -> Value
comp :: NFLine -> NFEndp -> Value -> Value -> Value
glueType :: NFSort -> NFEndp -> NFPartial -> NFPartial -> Value glueType :: NFSort -> NFEndp -> NFPartial -> NFPartial -> Value
glueElem :: NFSort -> NFEndp -> NFPartial -> NFPartial -> NFPartial -> Value -> Value glueElem :: NFSort -> NFEndp -> NFPartial -> NFPartial -> NFPartial -> Value -> Value
unglue :: NFSort -> NFEndp -> NFPartial -> NFPartial -> Value -> Value
elimBool :: NFSort -> Value -> Value -> Value -> Value
unglue :: NFSort -> NFEndp -> NFPartial -> NFPartial -> Value -> Value

+ 2
- 0
src/Presyntax/Lexer.x View File

@ -152,10 +152,12 @@ variableOrKeyword (AlexPn _ l c, _, s, _) size =
case T.unpack text of case T.unpack text of
"as" -> pure (Token TokAs l c) "as" -> pure (Token TokAs l c)
"in" -> pure (Token TokIn l c) "in" -> pure (Token TokIn l c)
"data" -> pure (Token TokData l c)
"postulate" -> laidOut TokPostulate l c "postulate" -> laidOut TokPostulate l c
"let" -> laidOut TokLet l c "let" -> laidOut TokLet l c
"where" -> laidOut TokWhere l c "where" -> laidOut TokWhere l c
"case" -> laidOut TokCase l c
_ -> pure (Token (TokVar text) l c) _ -> pure (Token (TokVar text) l c)


+ 27
- 1
src/Presyntax/Parser.y View File

@ -59,6 +59,8 @@ import Debug.Trace
'let' { Token TokLet _ _ } 'let' { Token TokLet _ _ }
'in' { Token TokIn _ _ } 'in' { Token TokIn _ _ }
'data' { Token TokData _ _ }
'case' { Token TokCase _ _ }
'where' { Token TokWhere _ _ } 'where' { Token TokWhere _ _ }
'&&' { Token TokAnd _ _ } '&&' { Token TokAnd _ _ }
@ -79,6 +81,7 @@ Exp :: { Expr }
Exp Exp
: '\\' LambdaList '->' Exp { span $1 $4 $ makeLams $2 $4 } : '\\' LambdaList '->' Exp { span $1 $4 $ makeLams $2 $4 }
| '\\' MaybeLambdaList '[' System ']' { span $1 $5 $ makeLams $2 $ LamSystem $4 } | '\\' MaybeLambdaList '[' System ']' { span $1 $5 $ makeLams $2 $ LamSystem $4 }
| '\\' 'case' START CaseList END { span $1 $5 $ LamCase $4 }
| '(' var ':' Exp ')' ProdTail { span $1 $6 $ Pi Ex (getVar $2) $4 $6 } | '(' var ':' Exp ')' ProdTail { span $1 $6 $ Pi Ex (getVar $2) $4 $6 }
| '{' var ':' Exp '}' ProdTail { span $1 $6 $ Pi Im (getVar $2) $4 $6 } | '{' var ':' Exp '}' ProdTail { span $1 $6 $ Pi Im (getVar $2) $4 $6 }
| ExpApp '->' Exp { span $1 $3 $ Pi Ex (T.singleton '_') $1 $3 } | ExpApp '->' Exp { span $1 $3 $ Pi Ex (T.singleton '_') $1 $3 }
@ -142,11 +145,32 @@ LetList :: { [LetItem] }
| LetItem { [$1] } | LetItem { [$1] }
| LetItem ';' LetList { $1:$3 } | LetItem ';' LetList { $1:$3 }
CaseItem :: { (Pattern, Expr) }
: Pattern '->' Exp { ($1, $3) }
CaseList :: { [(Pattern, Expr)] }
: CaseItem { [$1] }
| CaseItem Semis CaseList { $1:$3 }
Pattern :: { Pattern }
: PatVarList { makePattern $1 }
PatVarList :: { (Posn, Posn, [Text]) }
: var { (startPosn $1, endPosn $1, [getVar $1]) }
| var PatVarList { case $2 of (_, end, xs) -> (startPosn $1, end, getVar $1:xs) }
Statement :: { Statement } Statement :: { Statement }
: VarList ':' Exp { spanSt $1 $3 $ Decl (thd $1) $3 } : VarList ':' Exp { spanSt $1 $3 $ Decl (thd $1) $3 }
| var LhsList '=' Rhs { spanSt $1 $4 $ Defn (getVar $1) (makeLams $2 $4) } | var LhsList '=' Rhs { spanSt $1 $4 $ Defn (getVar $1) (makeLams $2 $4) }
| '{-#' Pragma '#-}' { spanSt $1 $3 $ $2 } | '{-#' Pragma '#-}' { spanSt $1 $3 $ $2 }
| 'postulate' START Postulates END { spanSt $1 $4 $ Postulate $3 } | 'postulate' START Postulates END { spanSt $1 $4 $ Postulate $3 }
| 'data' var Parameters ':' Exp 'where' START Postulates END
{ spanSt $1 $9 $ Data (getVar $2) $3 $5 $8 }
Parameters :: { [(Text, Plicity, Expr)] }
: {- empty -} { [] }
| '(' var ':' Exp ')' Parameters { (getVar $2, Ex, $4):$6 }
| '{' var ':' Exp '}' Parameters { (getVar $2, Im, $4):$6 }
Rhs :: { Expr } Rhs :: { Expr }
: Exp { $1 } : Exp { $1 }
@ -242,10 +266,12 @@ instance HasPosn (Posn, Posn, a) where
thd :: (a, b, c) -> c thd :: (a, b, c) -> c
thd (x, y, z) = z thd (x, y, z) = z
span s e ex = Span ex (startPosn s) (endPosn e) span s e ex = Span ex (startPosn s) (endPosn e)
spanSt s e ex = SpanSt ex (startPosn s) (endPosn e) spanSt s e ex = SpanSt ex (startPosn s) (endPosn e)
getVar (Token (TokVar s) _ _) = s getVar (Token (TokVar s) _ _) = s
getVar _ = error "getVar non-var" getVar _ = error "getVar non-var"
makePattern (_, _, [x]) = PCap x
makePattern (_, _, (x:xs)) = PCon x xs
} }

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

@ -21,6 +21,7 @@ data Expr
| Proj2 Expr | Proj2 Expr
| LamSystem [(Condition, Expr)] | LamSystem [(Condition, Expr)]
| LamCase [(Pattern, Expr)]
| Let [LetItem] Expr | Let [LetItem] Expr
| Span Expr Posn Posn | Span Expr Posn Posn
@ -44,6 +45,11 @@ data Formula
| FBot | FBot
deriving (Eq, Show, Ord) deriving (Eq, Show, Ord)
data Pattern
= PCon Text [Text]
| PCap Text
deriving (Eq, Show, Ord)
data Statement data Statement
= Decl [Text] Expr = Decl [Text] Expr
| Defn Text Expr | Defn Text Expr
@ -54,6 +60,8 @@ data Statement
| ReplNf Expr -- REPL eval | ReplNf Expr -- REPL eval
| ReplTy Expr -- REPL :t | ReplTy Expr -- REPL :t
| Data Text [(Text, Plicity, Expr)] Expr [(Text, Expr)]
| SpanSt Statement Posn Posn | SpanSt Statement Posn Posn
deriving (Eq, Show, Ord) deriving (Eq, Show, Ord)


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

@ -44,7 +44,10 @@ data TokenClass
| TokAs | TokAs
| TokWhere | TokWhere
| TokCase
| TokPostulate | TokPostulate
| TokData
| TokSemi | TokSemi
deriving (Eq, Show, Ord) deriving (Eq, Show, Ord)
@ -80,6 +83,8 @@ tokSize TokIn = 2
tokSize TokLStart = 0 tokSize TokLStart = 0
tokSize TokLEnd = 0 tokSize TokLEnd = 0
tokSize TokWhere = length "where" tokSize TokWhere = length "where"
tokSize TokData = length "data"
tokSize TokCase = length "case"
tokSize TokPostulate = length "postulate" tokSize TokPostulate = length "postulate"
data Token data Token


+ 49
- 31
src/Syntax.hs View File

@ -3,6 +3,8 @@
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
module Syntax where module Syntax where
import Control.Arrow (Arrow(second))
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
import qualified Data.Set as Set import qualified Data.Set as Set
@ -30,8 +32,6 @@ data WiredIn
| WiIsOne -- Proposition associated with an element of the interval | WiIsOne -- Proposition associated with an element of the interval
| WiItIsOne -- 1 = 1 | WiItIsOne -- 1 = 1
| WiIsOne1 -- i j -> [i] -> [ior i j]
| WiIsOne2 -- i j -> [j] -> [ior i j]
| WiPartial -- (φ : I) -> Type -> Typeω | WiPartial -- (φ : I) -> Type -> Typeω
| WiPartialP -- (φ : I) -> Partial r Type -> Typeω | WiPartialP -- (φ : I) -> Partial r Type -> Typeω
@ -47,15 +47,12 @@ data WiredIn
| WiGlue -- (A : Type) {phi : I} (T : Partial phi Type) (e : PartialP phi (\o -> Equiv (T o) A)) -> Type | WiGlue -- (A : Type) {phi : I} (T : Partial phi Type) (e : PartialP phi (\o -> Equiv (T o) A)) -> Type
| WiGlueElem -- {A : Type} {phi : I} {T : Partial phi Type} {e : PartialP phi (\o -> Equiv (T o) A)} -> (t : PartialP phi T) -> Sub A phi (\o -> e o (t o)) -> Glue A phi T e | WiGlueElem -- {A : Type} {phi : I} {T : Partial phi Type} {e : PartialP phi (\o -> Equiv (T o) A)} -> (t : PartialP phi T) -> Sub A phi (\o -> e o (t o)) -> Glue A phi T e
| WiUnglue -- {A : Type} {phi : I} {T : Partial phi Type} {e : PartialP phi (\o -> Equiv (T o) A)} -> Glue A phi T e -> A | WiUnglue -- {A : Type} {phi : I} {T : Partial phi Type} {e : PartialP phi (\o -> Equiv (T o) A)} -> Glue A phi T e -> A
| WiBool
| WiTrue
| WiFalse
| WiIf
deriving (Eq, Show, Ord) deriving (Eq, Show, Ord)
data Term data Term
= Ref Name = Ref Name
| Con Name
| Data Name
| App Plicity Term Term | App Plicity Term Term
| Lam Plicity Name Term | Lam Plicity Name Term
| Pi Plicity Name Term Term | Pi Plicity Name Term Term
@ -84,8 +81,6 @@ data Term
-- ~~~~~~~~~ not printed at all -- ~~~~~~~~~ not printed at all
| IsOne Term | IsOne Term
| IsOne1 Term
| IsOne2 Term
| ItIsOne | ItIsOne
| Partial Term Term | Partial Term Term
@ -103,8 +98,7 @@ data Term
| Glue Term Term Term Term Term Term | Glue Term Term Term Term Term Term
| Unglue Term Term Term Term Term | Unglue Term Term Term Term Term
-- ugly. TODO: proper inductive types
| Bool | Tt | Ff | If Term Term Term Term
| Case Term [(Term, Term)]
deriving (Eq, Show, Ord, Data) deriving (Eq, Show, Ord, Data)
data MV = data MV =
@ -130,7 +124,14 @@ instance Data MV where
data Name data Name
= Bound {getNameText :: Text, getNameNum :: !Int} = Bound {getNameText :: Text, getNameNum :: !Int}
| Defined {getNameText :: Text, getNameNum :: !Int} | Defined {getNameText :: Text, getNameNum :: !Int}
deriving (Eq, Show, Ord, Data)
| ConName {getNameText :: Text, getNameNum :: !Int, conSkip :: !Int, conArity :: !Int}
deriving (Show, Data)
instance Eq Name where
x == y = getNameText x == getNameText y && getNameNum x == getNameNum y
instance Ord Name where
compare x y = getNameText x `compare` getNameText y <> getNameNum x `compare` getNameNum y
type NFType = Value type NFType = Value
type NFEndp = Value type NFEndp = Value
@ -160,8 +161,6 @@ data Value
| VIsOne NFEndp | VIsOne NFEndp
| VItIsOne | VItIsOne
| VIsOne1 NFEndp
| VIsOne2 NFEndp
| VPartial NFEndp Value | VPartial NFEndp Value
| VPartialP NFEndp Value | VPartialP NFEndp Value
@ -176,10 +175,7 @@ data Value
| VGlue NFSort NFEndp NFPartial NFPartial NFPartial Value | VGlue NFSort NFEndp NFPartial NFPartial NFPartial Value
| VUnglue NFSort NFEndp NFPartial NFPartial Value | VUnglue NFSort NFEndp NFPartial NFPartial Value
| VBool
| VTt
| VFf
| VIf Value Value Value Value
| VCase Value [(Term, Value)]
deriving (Eq, Show, Ord) deriving (Eq, Show, Ord)
pattern VVar :: Name -> Value pattern VVar :: Name -> Value
@ -187,8 +183,10 @@ pattern VVar x = VNe (HVar x) Seq.Empty
quoteWith :: Set Name -> Value -> Term quoteWith :: Set Name -> Value -> Term
quoteWith names (VNe h sp) = foldl goSpine (goHead h) sp where quoteWith names (VNe h sp) = foldl goSpine (goHead h) sp where
goHead (HVar v) = Ref v
goHead (HMeta m) = Meta m
goHead (HVar v) = Ref v
goHead (HMeta m) = Meta m
goHead (HCon _ v) = Con v
goHead (HData v) = Data v
goSpine t (PApp p v) = App p t (quoteWith names v) goSpine t (PApp p v) = App p t (quoteWith names v)
goSpine t (PIElim l x y i) = IElim (quote l) (quote x) (quote y) t (quote i) goSpine t (PIElim l x y i) = IElim (quote l) (quote x) (quote y) t (quote i)
@ -232,8 +230,6 @@ quoteWith names (VPath line x y) = PathP (quoteWith names line) (quoteWith names
quoteWith names (VLine p x y f) = PathIntro (quoteWith names p) (quoteWith names x) (quoteWith names y) (quoteWith names f) quoteWith names (VLine p x y f) = PathIntro (quoteWith names p) (quoteWith names x) (quoteWith names y) (quoteWith names f)
quoteWith names (VIsOne v) = IsOne (quoteWith names v) 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 _ VItIsOne = ItIsOne
quoteWith names (VPartial x y) = Partial (quoteWith names x) (quoteWith names y) quoteWith names (VPartial x y) = Partial (quoteWith names x) (quoteWith names y)
@ -247,15 +243,10 @@ quoteWith names (VGlueTy a phi t e) = GlueTy (quoteWith names a) (quoteWith n
quoteWith names (VGlue a phi ty e t x) = Glue (quoteWith names a) (quoteWith names phi) (quoteWith names ty) (quoteWith names e) (quoteWith names t) (quoteWith names x) quoteWith names (VGlue a phi ty e t x) = Glue (quoteWith names a) (quoteWith names phi) (quoteWith names ty) (quoteWith names e) (quoteWith names t) (quoteWith names x)
quoteWith names (VUnglue a phi ty e x) = Unglue (quoteWith names a) (quoteWith names phi) (quoteWith names ty) (quoteWith names e) (quoteWith names x) quoteWith names (VUnglue a phi ty e x) = Unglue (quoteWith names a) (quoteWith names phi) (quoteWith names ty) (quoteWith names e) (quoteWith names x)
quoteWith _ames VBool = Bool
quoteWith _ames VTt = Tt
quoteWith _ames VFf = Ff
quoteWith names (VIf a b c d) = If (quoteWith names a) (quoteWith names b) (quoteWith names c) (quoteWith names d)
quoteWith names (VCase v xs) = Case (quoteWith names v) (map (second (quoteWith names)) xs)
alwaysShort :: Value -> Bool alwaysShort :: Value -> Bool
alwaysShort VBool{} = True
alwaysShort VTt{} = True
alwaysShort VFf{} = True
alwaysShort (VNe HCon{} _) = True
alwaysShort VVar{} = True alwaysShort VVar{} = True
alwaysShort _ = False alwaysShort _ = False
@ -288,8 +279,35 @@ instance Ord Closure where
data Head data Head
= HVar Name = HVar Name
| HCon Value Name
| HMeta MV | HMeta MV
deriving (Eq, Show, Ord)
| HData Name
deriving (Show)
instance Eq Head where
HVar x == HVar y = x == y
HCon _ x == HCon _ y = x == y
HMeta x == HMeta y = x == y
HData x == HData y = x == y
_ == _ = False
instance Ord Head where
compare x y =
case x of
HVar n -> case y of
HVar n' -> compare n n'
_ -> LT
HCon _ n -> case y of
HVar _ -> GT
HCon _ n' -> compare n n'
_ -> LT
HMeta n -> case y of
HMeta n' -> compare n n'
HData _ -> LT
_ -> GT
HData n -> case y of
HData n' -> compare n n'
_ -> GT
data Projection data Projection
= PApp Plicity Value = PApp Plicity Value
@ -297,4 +315,4 @@ data Projection
| PProj1 | PProj1
| PProj2 | PProj2
| POuc NFSort NFEndp Value | POuc NFSort NFEndp Value
deriving (Eq, Show, Ord)
deriving (Eq, Show, Ord)

+ 11
- 17
src/Syntax/Pretty.hs View File

@ -21,8 +21,7 @@ import Prettyprinter
import Syntax import Syntax
instance Pretty Name where instance Pretty Name where
pretty (Bound x _) = pretty x
pretty (Defined x _) = pretty x
pretty = pretty . getNameText
prettyTm :: Term -> Doc AnsiStyle prettyTm :: Term -> Doc AnsiStyle
prettyTm = prettyTm . everywhere (mkT beautify) where prettyTm = prettyTm . everywhere (mkT beautify) where
@ -30,6 +29,8 @@ prettyTm = prettyTm . everywhere (mkT beautify) where
case T.uncons (getNameText v) of case T.uncons (getNameText v) of
Just ('.', w) -> keyword (pretty w) Just ('.', w) -> keyword (pretty w)
_ -> pretty v _ -> pretty v
prettyTm (Con v) = keyword (pretty v)
prettyTm (Data v) = operator (pretty v)
prettyTm (App Im f x) = parenFun f <+> braces (prettyTm x) prettyTm (App Im f x) = parenFun f <+> braces (prettyTm x)
prettyTm (App Ex f x) = parenFun f <+> parenArg x prettyTm (App Ex f x) = parenFun f <+> parenArg x
@ -75,21 +76,19 @@ prettyTm = prettyTm . everywhere (mkT beautify) where
prettyTm (System xs) = braces (mempty <+> hsep (punctuate comma (map go (Map.toList xs))) <+> mempty) where prettyTm (System xs) = braces (mempty <+> hsep (punctuate comma (map go (Map.toList xs))) <+> mempty) where
go (f, t) = prettyTm f <+> operator (pretty "=>") <+> prettyTm t go (f, t) = prettyTm f <+> operator (pretty "=>") <+> prettyTm t
prettyTm (Case x xs) = keyword (pretty "case") <+> prettyTm x <+> keyword (pretty "of") <+> braces (prettyCase xs)
prettyTm x = error (show x) prettyTm x = error (show x)
prettyCase = vsep . map go where
go (x, xs) = prettyTm x <+> operator (pretty "=>") <+> prettyTm xs
beautify (PathP l x y) = toFun "PathP" [l, x, y] beautify (PathP l x y) = toFun "PathP" [l, x, y]
beautify (IElim _ _ _ f i) = App Ex f i beautify (IElim _ _ _ f i) = App Ex f i
beautify (PathIntro _ _ _ f) = f beautify (PathIntro _ _ _ f) = f
beautify (IsOne phi) = toFun "IsOne" [phi] beautify (IsOne phi) = toFun "IsOne" [phi]
beautify ItIsOne = Ref (Bound (T.pack ".1=1") 0) beautify ItIsOne = Ref (Bound (T.pack ".1=1") 0)
beautify (IsOne1 phi) = toFun "isOne1" [phi]
beautify (IsOne2 phi) = toFun "isOne2" [phi]
beautify Bool = Ref (Bound (T.pack ".Bool") 0)
beautify Tt = Ref (Bound (T.pack ".true") 0)
beautify Ff = Ref (Bound (T.pack ".false") 0)
beautify (If a b c d) = toFun "if" [a, b, c, d]
beautify (Lam Ex v (App Ex f (Ref v'))) beautify (Lam Ex v (App Ex f (Ref v')))
| v == v', v `Set.notMember` freeVars f = f | v == v', v `Set.notMember` freeVars f = f
@ -119,8 +118,6 @@ parenArg :: Term -> Doc AnsiStyle
parenArg x@App{} = parens (prettyTm x) parenArg x@App{} = parens (prettyTm x)
parenArg x@IElim{} = parens (prettyTm x) parenArg x@IElim{} = parens (prettyTm x)
parenArg x@IsOne{} = parens $ prettyTm x parenArg x@IsOne{} = parens $ prettyTm x
parenArg x@IsOne1{} = parens $ prettyTm x
parenArg x@IsOne2{} = parens $ prettyTm x
parenArg x@Partial{} = parens $ prettyTm x parenArg x@Partial{} = parens $ prettyTm x
parenArg x@PartialP{} = parens $ prettyTm x parenArg x@PartialP{} = parens $ prettyTm x
@ -161,6 +158,8 @@ freeVars (Let ns x) = Set.union (freeVars x `Set.difference` bound) freed where
bound = Set.fromList (map (\(x, _, _) -> x) ns) bound = Set.fromList (map (\(x, _, _) -> x) ns)
freed = foldr (\(_, x, y) -> Set.union (Set.union (freeVars x) (freeVars y))) mempty ns freed = foldr (\(_, x, y) -> Set.union (Set.union (freeVars x) (freeVars y))) mempty ns
freeVars Meta{} = mempty freeVars Meta{} = mempty
freeVars Con{} = mempty
freeVars Data{} = mempty
freeVars Type{} = mempty freeVars Type{} = mempty
freeVars Typeω{} = mempty freeVars Typeω{} = mempty
freeVars I{} = mempty freeVars I{} = mempty
@ -177,8 +176,6 @@ freeVars (PathP x y z) = Set.unions $ map freeVars [x, y, z]
freeVars (IElim x y z a b) = Set.unions $ map freeVars [x, y, z, a, b] freeVars (IElim x y z a b) = Set.unions $ map freeVars [x, y, z, a, b]
freeVars (PathIntro x y z a) = Set.unions $ map freeVars [x, y, z, a] freeVars (PathIntro x y z a) = Set.unions $ map freeVars [x, y, z, a]
freeVars (IsOne a) = Set.unions $ map freeVars [a] freeVars (IsOne a) = Set.unions $ map freeVars [a]
freeVars (IsOne1 a) = Set.unions $ map freeVars [a]
freeVars (IsOne2 a) = Set.unions $ map freeVars [a]
freeVars ItIsOne{} = mempty freeVars ItIsOne{} = mempty
freeVars (Partial x y) = Set.unions $ map freeVars [x, y] freeVars (Partial x y) = Set.unions $ map freeVars [x, y]
freeVars (PartialP x y) = Set.unions $ map freeVars [x, y] freeVars (PartialP x y) = Set.unions $ map freeVars [x, y]
@ -191,7 +188,4 @@ freeVars (Comp x y z a) = Set.unions $ map freeVars [x, y, z, a]
freeVars (GlueTy x y z a) = Set.unions $ map freeVars [x, y, z, a] freeVars (GlueTy x y z a) = Set.unions $ map freeVars [x, y, z, a]
freeVars (Glue x y z a b c) = Set.unions $ map freeVars [x, y, z, a, b, c] freeVars (Glue x y z a b c) = Set.unions $ map freeVars [x, y, z, a, b, c]
freeVars (Unglue x y z a c) = Set.unions $ map freeVars [x, y, z, a, c] freeVars (Unglue x y z a c) = Set.unions $ map freeVars [x, y, z, a, c]
freeVars Bool{} = mempty
freeVars Tt{} = mempty
freeVars Ff{} = mempty
freeVars (If x y z a) = Set.unions $ map freeVars [x, y, z, a]
freeVars (Case x y) = freeVars x <> foldMap (freeVars . snd) y

Write Preview
Loading…
Cancel
Save