Browse Source

initial commit

master
Abigail 8 months ago
commit
f673499664
17 changed files with 1973 additions and 0 deletions
  1. +1
    -0
      .gitignore
  2. +30
    -0
      LICENSE
  3. +1
    -0
      README.md
  4. +2
    -0
      Setup.hs
  5. +2
    -0
      hie.yaml
  6. +34
    -0
      indexed.cabal
  7. +288
    -0
      src/Elab.hs
  8. +456
    -0
      src/Eval.hs
  9. +134
    -0
      src/Main.hs
  10. +71
    -0
      src/Presyntax.hs
  11. +192
    -0
      src/Presyntax/Lexer.hs
  12. +284
    -0
      src/Presyntax/Parser.hs
  13. +250
    -0
      src/Syntax.hs
  14. +96
    -0
      src/Systems.hs
  15. +67
    -0
      stack.yaml
  16. +13
    -0
      stack.yaml.lock
  17. +52
    -0
      test.itt

+ 1
- 0
.gitignore View File

@ -0,0 +1 @@
.stack-work

+ 30
- 0
LICENSE View File

@ -0,0 +1,30 @@
Copyright Abigail Magalhães (c) 2021
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of Abigail Magalhães nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ 1
- 0
README.md View File

@ -0,0 +1 @@
# indexed

+ 2
- 0
Setup.hs View File

@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain

+ 2
- 0
hie.yaml View File

@ -0,0 +1,2 @@
cradle:
stack:

+ 34
- 0
indexed.cabal View File

@ -0,0 +1,34 @@
name: indexed
version: 0.1.0.0
-- synopsis:
-- description:
homepage: https://github.com/plt-hokusai/indexed#readme
license: BSD3
license-file: LICENSE
author: Abigail Magalhães
maintainer: magalhaes.alcantara@pucpr.edu.br
copyright: 2021 Abigail Magalhães
category: Web
build-type: Simple
cabal-version: >=1.10
extra-source-files: README.md
executable indexed
hs-source-dirs: src
main-is: Main.hs
default-language: Haskell2010
build-depends: base >= 4.7 && < 5
, mtl
, text
, haskeline
, exceptions
, containers
, megaparsec
other-modules: Syntax
, Eval
, Elab
, Systems
, Presyntax
, Presyntax.Parser
, Presyntax.Lexer

+ 288
- 0
src/Elab.hs View File

@ -0,0 +1,288 @@
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE DeriveAnyClass #-}
module Elab where
import Control.Exception
import qualified Data.Map.Strict as Map
import Data.Typeable
import qualified Presyntax as P
import Syntax
import Eval
import Control.Monad
import Systems
import Data.Traversable
import qualified Data.Set as Set
import Data.Set (Set)
import Data.Foldable
data TypeError
= NotInScope String
| UnifyError UnifyError
| WrongFaces Value [([Value], Value, Elab.TypeError)]
| InSpan (Int, Int) (Int, Int) Elab.TypeError
| IncompleteSystem P.Formula P.Formula
| IncompatibleFaces (P.Formula, Term) (P.Formula, Term) Elab.TypeError
| InvalidSystem (Set Face) (Set Face)
deriving (Show, Typeable, Exception)
check :: Env -> P.Exp -> Value -> IO Term
check env (P.Span s e exp) wants =
check env exp wants
`catch` \case
InSpan s e err -> throwIO $ InSpan s e err
err -> throwIO $ InSpan s e err
check env exp (VSub a fm@(toFormula -> Just phi) el) = do
tm <- check env exp a
for (addFormula phi env) \env ->
let tm' = eval env tm
in unifyTC env tm' el
pure (InclSub (quote a) (quote fm) (quote el) tm)
check env (P.Lam s b) expected = do
expc <- isPiOrPathType expected
case expc of
Left (_, d, r) -> do -- function
bd <- check env { names = Map.insert s (makeValueGluingSub d s) (names env) } b (r (VVar s))
pure (Lam s (quote d) bd)
Right (a, x, y) -> do
bd <- check env { names = Map.insert s (VI, VVar s) (names env) } b (a @@ VVar s)
let t = Lam s I bd
t' = eval env t
checkBoundary env [s] t'
[ ([VI0], x)
, ([VI1], y)
]
pure (PathI (quote a) (quote x) (quote y) s bd)
check env (P.Let v t d b) expected = do
ty <- check env t VType
let ty' = eval env ty
d <- check env d ty'
let d' = eval env d
b <- check env { names = Map.insert v (ty', d') (names env) } b expected
pure (Let v (quote ty') d b)
check env (P.Pair a b) expected = do
(_, fst, snd) <- isSigmaType expected
a <- check env a fst
let a' = eval env a
b <- check env b (snd a')
pure (Pair a b)
check env (P.Partial fs) ty = do
let formula = orFormula (map fst fs)
(extent, ty) <- isPartialType formula ty
let ourFaces = Systems.faces formula
extentFaces = Systems.faces extent
unless (formula == extent) $
throwIO $ IncompleteSystem formula extent
let range = formulaToTm $ toDNF formula
rangeTm <- check env range VI
let rangeTy = eval env rangeTm
ts <- for fs $ \(fn, tn) -> do
tms <- for (addFormula fn env) \env -> check env tn ty
pure (fn, head tms)
fmap (System . FMap . Map.fromList) $ for ts \(fn, tn) -> do
for ts \(fm, tm) -> do
when (possible (fn `P.And` fm)) do
for_ (addFormula (fn `P.And` fm) env) $ \env ->
unifyTC (env) (eval env tn) (eval env tm)
`catch` \e -> throwIO (IncompatibleFaces (fn, tn) (fm, tm) e)
pure (fn, tn)
check env exp expected = do
(term, actual) <- infer env exp
unifyTC env actual expected
pure term
makeValueGluingSub :: Value -> String -> (Value, Value)
makeValueGluingSub ty@(VSub a phi a0) s = (ty, VOfSub a phi a0 (VVar s))
makeValueGluingSub ty s = (ty, VVar s)
addFormula :: P.Formula -> Env -> [Env]
addFormula (P.And x y) = addFormula x >=> addFormula y
addFormula (P.Or x y) = (++) <$> addFormula x <*> addFormula y
addFormula P.Top = pure
addFormula P.Bot = const []
addFormula (P.Is0 x) = \env -> pure env{ names = Map.insert x (VI, VI0) (names env) }
addFormula (P.Is1 x) = \env -> pure env{ names = Map.insert x (VI, VI1) (names env) }
unifyTC :: Env -> Value -> Value -> IO ()
unifyTC env a b = unify env a b `catch` \e -> const (throwIO (UnifyError (Mismatch a b))) (e :: UnifyError)
checkBoundary :: Env -> [String] -> Value -> [([Value], Value)] -> IO ()
checkBoundary env ns f = finish <=< go where
go :: [([Value], Value)] -> IO [([Value], Value, Elab.TypeError)]
go [] = pure []
go ((ixs, vl):faces) = do
let env' = foldr (\(x, t) env -> env { names = Map.insert x t (names env) }) env (zip ns (zip (repeat VI) ixs))
t <- try $ unifyTC env' (foldl (@@) f ixs) vl
case t of
Right _ -> go faces
Left e -> ((ixs, vl, e):) <$> go faces
finish [] = pure ()
finish xs = throwIO $ WrongFaces f xs
infer :: Env -> P.Exp -> IO (Term, Value)
infer env (P.Span s e exp) =
infer env exp
`catch` \case
InSpan s e err -> throwIO $ InSpan s e err
err -> throwIO $ InSpan s e err
infer env (P.Var s) =
case Map.lookup s (names env) of
Just (t, _) -> pure (Var s, t)
Nothing -> throwIO (NotInScope s)
infer env (P.App f x) = do
(fun, ty) <- infer env f
funt <- isPiOrPathType ty
case funt of
Left (_, dom, rng) -> do
arg <- check env x dom
let arg' = eval env arg
pure (App fun arg, rng arg')
Right (a, ai0, ai1) -> do
arg <- check env x VI
let arg' = eval env arg
pure (PathP (quote a) (quote ai0) (quote ai1) fun arg, a @@ arg')
infer env (P.Pi s d r) = do
dom <- check env d VType
let d' = eval env dom
rng <- check env { names = Map.insert s (d', VVar s) (names env) } r VType
pure (Pi s dom rng, VType)
infer env (P.Sigma s d r) = do
dom <- check env d VType
let d' = eval env dom
rng <- check env { names = Map.insert s (d', VVar s) (names env) } r VType
pure (Sigma s dom rng, VType)
infer env P.Type = pure (Type, VType)
infer env P.I = pure (I, VType)
infer env P.I0 = pure (I0, VI)
infer env P.I1 = pure (I1, VI)
infer env (P.Cut e t) = do
t <- check env t VType
let t' = eval env t
(, t') <$> check env e t'
infer env (P.IAnd x y) = do
x <- check env x VI
y <- check env y VI
pure (IAnd x y, VI)
infer env (P.IOr x y) = do
x <- check env x VI
y <- check env y VI
pure (IOr x y, VI)
infer env P.Path = do
pure
( Lam "A" (quote index_t) $
Lam "x" (App (Var "A") I0) $
Lam "y" (App (Var "A") I1) $
Path (Var "A") (Var "x") (Var "y")
, VPi "A" index_t \a ->
VPi "x" (a @@ VI0) \_ ->
VPi "y" (a @@ VI1) (const VType))
infer env P.PartialT = do
pure
( Lam "r" I $
Lam "A" Type $
Partial (Var "r") (Var "A")
, VPi "I" VI \i ->
VPi "A" VType (const VType))
infer env P.Comp = do
let u_t a r = VPi "i" VI \i -> VPartial r (a @@ i)
pure
( Lam "A" (quote index_t) $
Lam "phi" I $
Lam "u" (quote (u_t (VVar "A") (VVar "r"))) $
Lam "a0" (Sub (App (Var "A") I0) (Var "phi") (App (Var "u") I0)) $
Comp (Var "A") (Var "phi") (Var "u") (Var "a0")
, VPi "A" index_t \a ->
VPi "phi" VI \phi ->
VPi "u" (u_t a phi) \u ->
VPi "_" (VSub (a @@ VI0) phi (u @@ VI0)) \_ ->
a @@ VI1
)
infer env P.SubT = do
pure
( Lam "A" Type $
Lam "phi" I $
Lam "u" (Partial (Var "phi") (Var "A")) $
Sub (Var "A") (Var "phi") (Var "u")
, VPi "A" VType \a ->
VPi "phi" VI \phi ->
VPi "_" (VPartial phi a) (const VType)
)
infer env (P.INot x) = (, VI) . INot <$> check env x VI
infer env P.Lam{} = error "can't infer type for lambda"
infer env (P.Let v t d b) = do
ty <- check env t VType
let ty' = eval env ty
d <- check env d ty'
let d' = eval env d
(b, t) <- infer env{ names = Map.insert v (ty', d') (names env) } b
pure (Let v ty d b, t)
infer env (P.Proj1 x) = do
(t, ty) <- infer env x
(_, d, _) <- isSigmaType ty
pure (Proj1 t, d)
infer env (P.Proj2 x) = do
(t, ty) <- infer env x
let t' = eval env t
(_, _, r) <- isSigmaType ty
pure (Proj2 t, r (proj1 t'))
formulaToTm :: P.Formula -> P.Exp
formulaToTm (P.Is0 i) = P.INot (P.Var i)
formulaToTm (P.Is1 i) = P.Var i
formulaToTm (P.And x y) = P.IAnd (formulaToTm x) (formulaToTm y)
formulaToTm (P.Or x y) = P.IOr (formulaToTm x) (formulaToTm y)
formulaToTm P.Top = P.I1
formulaToTm P.Bot = P.I0
checkFormula :: Env -> P.Formula -> IO ()
checkFormula env P.Top = pure ()
checkFormula env P.Bot = pure ()
checkFormula env (P.And x y) = checkFormula env x *> checkFormula env y
checkFormula env (P.Or x y) = checkFormula env x *> checkFormula env y
checkFormula env (P.Is0 x) =
case Map.lookup x (names env) of
Just (ty, _) -> unifyTC env ty VI
Nothing -> throwIO (NotInScope x)
checkFormula env (P.Is1 x) =
case Map.lookup x (names env) of
Just (ty, _) -> unifyTC env ty VI
Nothing -> throwIO (NotInScope x)
index_t :: Value
index_t = VPi "_" VI (const VType)

+ 456
- 0
src/Eval.hs View File

@ -0,0 +1,456 @@
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-}
module Eval where
import Syntax
import qualified Data.Map.Strict as Map
import Data.Foldable
import Control.Exception
import Data.Typeable
import System.IO.Unsafe (unsafePerformIO)
import Data.IORef
import Systems
import Presyntax (Formula)
import qualified Presyntax as P
import Data.Maybe
import Debug.Trace
import GHC.Stack
iand :: Value -> Value -> Value
iand = \case
VI1 -> id
VI0 -> const VI0
x -> \case
VI0 -> VI0
VI1 -> x
y -> VIAnd x y
ior :: Value -> Value -> Value
ior = \case
VI0 -> id
VI1 -> const VI1
x -> \case
VI1 -> VI1
VI0 -> x
y -> VIOr x y
inot :: Value -> Value
inot VI1 = VI0
inot VI0 = VI1
inot (VIOr x y) = iand (inot x) (inot y)
inot (VIAnd x y) = ior (inot x) (inot y)
inot (VINot x) = x
inot x = VINot x
(@@) :: Value -> Value -> Value
VNe hd xs @@ vl = VNe hd (PApp vl:xs)
VLam _ _ k @@ vl = k vl
VEqGlued a b @@ vl = VEqGlued (a @@ vl) (b @@ vl)
VOfSub a phi u0 x @@ vl = x @@ vl
f @@ _ = error $ "can't apply argument to " ++ show f
proj1 :: Value -> Value
proj1 (VPair x _) = x
proj1 (VEqGlued x y) = VEqGlued (proj1 x) (proj1 y)
proj1 (VNe s xs) = VNe s (PProj1:xs)
proj1 (VOfSub (VSigma _ d _) phi u0 x) = VOfSub d phi (proj1 u0) (proj1 x)
proj1 x = error $ "can't proj1 " ++ show x
proj2 :: Value -> Value
proj2 (VPair _ y) = y
proj2 (VEqGlued x y) = VEqGlued (proj1 x) (proj1 y)
proj2 (VNe s xs) = VNe s (PProj2:xs)
proj2 (VOfSub (VSigma _ d r) phi u0 x) =
VOfSub (r (proj1 x)) phi (proj2 u0) (proj2 x)
proj2 x = error $ "can't proj2 " ++ show x
pathp :: Env -> Value -> Value -> Value -> Value -> Value -> Value
pathp env p x y f@(VLine _a _x _y e) i =
case reduceCube env i of
Just P.Bot -> VEqGlued (e i) x
Just P.Top -> VEqGlued (e i) y
_ -> e i
pathp env p x y (VEqGlued e e') i = VEqGlued (pathp env p x y e i) (pathp env p x y e' i)
pathp env p x y (VNe hd sp) i =
case reduceCube env i of
Just P.Bot -> VEqGlued (VNe hd (PPathP p x y i:sp)) x
Just P.Top -> VEqGlued (VNe hd (PPathP p x y i:sp)) y
_ -> VNe hd (PPathP p x y i:sp)
pathp env p x y (VOfSub _ _ _ v) i = pathp env p x y v i
comp :: Env -> Value -> Formula -> Value -> Value -> Value
comp env a@(VLam ivar VI fam) phi u a0 = go (fam undefined) phi u a0 where
i = VVar ivar
stuck :: Value
stuck = maybeAddEq $ VComp a (toValue phi) u a0
maybeAddEq :: Value -> Value
maybeAddEq =
if phi == P.Top
then flip VEqGlued (u @@ VI1)
else id
go :: HasCallStack => Value -> Formula -> Value -> Value -> Value
go VPi{} phi u a0 =
let
dom x = let VPi _ d _ = fam x in d
rng x = let VPi _ d _ = fam x in d
ai1 = dom VI0
y' i y = fill env i (dom . inot . fam) P.Bot (VSystem emptySystem) y
ybar i y = y' (inot i) y
in VLam "x" ai1 \arg ->
comp env
(VLam ivar VI (\i -> rng (ybar i arg)))
phi
(VLam "i" VI \i -> mapVSystem (u @@ i) (@@ ybar i arg))
(a0 @@ ybar VI0 arg)
go VSigma{} phi u a0 =
let
dom x = let VSigma _ d _ = fam x in d
rng x = let VSigma _ d _ = fam x in d
a i = fill env i (dom . fam) phi (VLam "j" VI \v -> mapVSystem (u @@ v) proj1) (proj1 a0)
c1 = comp env (VLam ivar VI (getd . fam)) phi (VLam "i" VI \v -> mapVSystem (u @@ v) proj1) (proj1 a0)
c2 = comp env (VLam ivar VI (apr (a VI1) . fam)) phi (VLam "i" VI \v -> mapVSystem (u @@ v) proj2) (proj2 a0)
getd (VSigma _ d _) = d
apr x (VSigma _ _ r) = r x
in VPair c1 c2
go VPath{} phi p p0 =
let
~(VPath ai1 u1 v1) = fam VI1
~(VPath ai0 u0 v0) = fam VI0
getA (VPath a _ _) = a
u' x = let ~(VPath _ u _) = fam x in u
v' x = let ~(VPath _ _ v) = fam x in v
in
VLine (ai1 @@ VI1) u1 v1 \j ->
let
jc = reduceCube' env j
in comp env (VLam ivar VI (getA . fam))
(orFormula [phi, jc, notFormula jc])
(VLam "j" VI \v ->
let
VSystem (FMap sys) = p @@ v
sys' = fmap (flip (pathp env ai0 u0 v0) j) sys
in mkVSystem $ Map.fromList [(phi, mapVSystem (p @@ v) (flip (pathp env ai0 u0 v0) j))
, (notFormula jc, u' v), (jc, v' v)])
(pathp env (ai0 @@ VI0) u0 v0 p0 j)
go a P.Top u a0 = u @@ VI1
go a phi u a0 = maybeAddEq stuck
comp env va phi u a0 =
if phi == P.Top
then VEqGlued (VComp va phi' u a0) (u @@ VI1)
else VComp va phi' u a0
where
phi' = toValue phi
mkVSystem :: Map.Map Formula Value -> Value
mkVSystem mp
| Just e <- Map.lookup P.Top mp = e
| otherwise = VSystem $ FMap $ Map.filterWithKey f mp
where
f P.Bot _ = False
f _ _ = True
reduceCube' :: Env -> Value -> Formula
reduceCube' env = fromJust . reduceCube env
mapVSystem :: Value -> (Value -> Value) -> Value
mapVSystem (VSystem ss) f = VSystem (mapSystem ss f)
mapVSystem x f = f x
evalSystem :: Env -> Map.Map Formula Term -> Value
evalSystem env face = mk . Map.mapMaybeWithKey go $ face where
go :: Formula -> Term -> Maybe Value
go face tm
| VI0 <- toValue' env face = Nothing
| otherwise = Just (eval env tm)
differsFromEnv :: String -> Bool -> Bool
differsFromEnv x True =
case Map.lookup x (names env) of
Just (VI, VI0) -> True
_ -> False
differsFromEnv x False =
case Map.lookup x (names env) of
Just (VI, VI1) -> True
_ -> False
mk x = case Map.toList x of
[(_, x)] -> x
_ -> mkVSystem x
eval :: Env -> Term -> Value
eval env = \case
Var v ->
case Map.lookup v (names env) of
Just (_, vl) -> vl
Nothing -> error $ "variable not in scope: " ++ show v
App f x -> eval env f @@ eval env x
Lam s d b ->
let d' = eval env d
in VLam s d' \a -> eval env{ names = Map.insert s (d', a) (names env) } b
Let s t b d ->
let b' = eval env b
t' = eval env t
in eval env{ names = Map.insert s (t', b') (names env) } d
Pi s d r ->
let d' = eval env d
in VPi s d' \a -> eval env{ names = Map.insert s (d', a) (names env) } r
Sigma s d r ->
let d' = eval env d
in VSigma s d' \a -> eval env{ names = Map.insert s (d', a) (names env) } r
Pair a b -> VPair (eval env a) (eval env b)
Proj1 x -> proj1 (eval env x)
Proj2 y -> proj2 (eval env y)
Type -> VType
I -> VI
I0 -> VI0
I1 -> VI1
Path p x y -> VPath (eval env p) (eval env x) (eval env y)
Partial r a -> VPartial (eval env r) (eval env a)
PathI p x y s e -> VLine (eval env p) (eval env x) (eval env y) (\ a -> eval env{ names = Map.insert s (VI, a) (names env) } e)
PathP p x y f i -> pathp env (eval env p) (eval env x) (eval env y) (eval env f) (eval env i)
Sub p x y -> VSub (eval env p) (eval env x) (eval env y)
InclSub a phi u a0 -> VOfSub (eval env a) (eval env phi) (eval env u) (eval env a0)
IAnd x y -> iand (eval env x) (eval env y)
IOr x y -> ior (eval env x) (eval env y)
INot x -> inot (eval env x)
Comp a phi u a0 ->
case reduceCube env (eval env phi) of
Just formula -> comp env (eval env a) formula (eval env u) (eval env a0)
Nothing -> VComp (eval env a) (eval env phi) (eval env u) (eval env a0)
System fs -> evalSystem env (getSystem fs)
data UnifyError
= Mismatch Value Value
| NotPiType Value
| NotPartialType Formula Value
| NotSigmaType Value
deriving (Show, Typeable, Exception)
unify :: Env -> Value -> Value -> IO ()
unify env (VEqGlued a b) c =
unify env a c `catch` \e -> const (unify env b c) (e :: UnifyError)
unify env c (VEqGlued a b) =
unify env c a `catch` \e -> const (unify env c b) (e :: UnifyError)
unify env (VLine a x y f) e = unify env (f (VVar "i")) (pathp env a x y e (VVar "i"))
unify env e (VLine a x y f) = unify env (f (VVar "i")) (pathp env a x y e (VVar "i"))
unify env (VPartial r b) (VPartial r' b') = do
unify env b b'
case sameCube env r r' of
Just True -> pure ()
_ -> unify env r r'
unify env (VPartial r b) x = do
case sameCube env r VI1 of
Just True -> pure ()
_ -> unify env r VI1
unify env b x
unify env x (VPartial r b) = do
case sameCube env r VI1 of
Just True -> pure ()
_ -> unify env r VI1
unify env x b
unify env (VSub a phi _u0) vl = unify env a vl
unify env u1 (VOfSub _a phi u0 a) = do
case sameCube env phi VI1 of
Just True -> unify env u1 u0
_ -> unify env u1 a
unify env (VOfSub _a phi u0 a) u1 = do
case sameCube env phi VI1 of
Just True -> unify env u1 u0
_ -> unify env u1 a
unify env vl1@(VNe x sp) vl2@(VNe y sp')
| x == y = traverse_ (uncurry unifySp) (zip sp sp')
| otherwise = throwIO $ Mismatch vl1 vl2
where
unifySp (PApp x) (PApp y) = unify env x y
unifySp (PPathP _a _x _y i) (PPathP _a' _x' _y' i') = unify env i i'
unifySp PProj1 PProj1 = pure ()
unifySp PProj2 PProj2 = pure ()
unify env (VLam x _ k) e = unify env (k (VVar x)) (e @@ VVar x)
unify env e (VLam x _ k) = unify env (e @@ VVar x) (k (VVar x))
unify env (VPi x d r) (VPi _ d' r') = do
unify env d d'
unify env (r (VVar x)) (r' (VVar x))
unify env (VSigma x d r) (VSigma _ d' r') = do
unify env d d'
unify env (r (VVar x)) (r' (VVar x))
unify env VType VType = pure ()
unify env VI VI = pure ()
unify env (VPair a b) (VPair c d) = unify env a c *> unify env b d
unify env (VPath a x y) (VPath a' x' y') = unify env a a' *> unify env x x' *> unify env y y'
unify env (VSystem fs) vl
| ((_, vl'):_) <- Map.toList (Map.filterWithKey (\f _ -> isTrue (toValue' env f)) (getSystem fs))
= unify env vl' vl
unify env vl (VSystem fs)
| ((_, vl'):_) <- Map.toList (Map.filterWithKey (\f _ -> isTrue (toValue' env f)) (getSystem fs))
= unify env vl' vl
unify env x y =
case sameCube env x y of
Just True -> pure ()
_ -> throwIO $ Mismatch x y
reduceCube :: Env -> Value -> Maybe Formula
reduceCube env x = fmap (toDNF . simplify) (toFormula x) where
simplify :: Formula -> Formula
simplify (P.Is0 x) =
case Map.lookup x (names env) of
Just (VI, VI0) -> P.Top
Just (VI, VI1) -> P.Bot
_ -> P.Is0 x
simplify (P.Is1 x) =
case Map.lookup x (names env) of
Just (VI, VI1) -> P.Top
Just (VI, VI0) -> P.Bot
_ -> P.Is0 x
simplify (P.And x y) = P.And (simplify x) (simplify y)
simplify (P.Or x y) = P.Or (simplify x) (simplify y)
simplify x = x
sameCube :: Env -> Value -> Value -> Maybe Bool
sameCube env x y =
case (reduceCube env x, reduceCube env y) of
(Just x, Just y) -> Just (x == y)
_ -> Nothing
toFormula :: Value -> Maybe Formula
toFormula VI0 = Just P.Bot
toFormula VI1 = Just P.Top
toFormula (VNe x []) = Just (P.Is1 x)
toFormula (VINot f) = notFormula <$> toFormula f
toFormula (VIAnd x y) = do
s <- toFormula y
t <- toFormula x
pure $ andFormula [s, t]
toFormula (VIOr x y) = do
s <- toFormula y
t <- toFormula x
pure $ orFormula [s, t]
toFormula _ = Nothing
faceInEnv :: Env -> Face -> Bool
faceInEnv e f = Map.isSubmapOf (getFace f) (faceOfEnv (names e)) where
faceOfEnv = Map.map (\(_, v) -> case v of { VI1 -> True; VEqGlued _ VI1 -> True; _ -> False }) . Map.filter (\(_, v) -> isI v)
isI VI1 = True
isI VI0 = True
isI (VEqGlued _ x) = isI x
isI _ = False
isPiType :: Value -> IO (String, Value, Value -> Value)
isPiType (VPi x d r) = pure (x, d, r)
isPiType x = throwIO $ NotPiType x
isSigmaType :: Value -> IO (String, Value, Value -> Value)
isSigmaType (VSigma x d r) = pure (x, d, r)
isSigmaType x = throwIO $ NotSigmaType x
isPiOrPathType :: Value -> IO (Either (String, Value, Value -> Value) (Value, Value, Value))
isPiOrPathType (VPi x d r) = pure (Left (x, d, r))
isPiOrPathType (VPath x d r) = pure (Right (x, d, r))
isPiOrPathType x = throwIO $ NotPiType x
isPartialType :: Formula -> Value -> IO (Formula, Value)
isPartialType f p@(VPartial x y) =
case toFormula x of
Just x -> pure (x, y)
Nothing -> throwIO $ NotPartialType f p
isPartialType f x = throwIO $ NotPartialType f x
getVar :: IO Value
getVar =
do
n <- atomicModifyIORef ref \x -> (x + 1, x)
pure (VVar (show n))
where
ref :: IORef Int
ref = unsafePerformIO (newIORef 0)
{-# NOINLINE ref #-}
fill :: Env
-> Value
-> (Value -> Value) -- (Γ i : I, A : Type)
-> Formula -- (phi : I)
-> Value -- (u : (i : I) -> Partial phi (A i))
-> Value -- (Sub (A i0) phi (u i0))
-> Value -- -> A i
fill env i a phi u a0 =
comp env
(VLam "j" VI \j -> a (i `iand` j))
(phi `P.Or` ifc)
(VLam "j" VI \j ->
mkVSystem (Map.fromList [ (phi, uiand j)
, (notFormula ifc, a0) ]))
a0
where
uiand j = u @@ (i `iand` j)
ifc = fromJust (reduceCube env i)
toValue :: Formula -> Value
toValue P.Top = VI1
toValue P.Bot = VI0
toValue (P.And x y) = toValue x `iand` toValue y
toValue (P.Or x y) = toValue x `ior` toValue y
toValue (P.Is0 x) = inot (VVar x)
toValue (P.Is1 x) = VVar x
toValue' :: Env -> Formula -> Value
toValue' env P.Top = VI1
toValue' env P.Bot = VI0
toValue' env (P.And x y) = toValue x `iand` toValue y
toValue' env (P.Or x y) = toValue x `ior` toValue y
toValue' env (P.Is0 x) =
case Map.lookup x (names env) of
Just (VI, VI0) -> VI1
Just (VI, VI1) -> VI0
Just (VI, x) -> inot x
_ -> error $ "type error in toValue'"
toValue' env (P.Is1 x) =
case Map.lookup x (names env) of
Just (VI, x) -> x
_ -> error $ "type error in toValue'"
isTrue :: Value -> Bool
isTrue VI1 = True
isTrue _ = False

+ 134
- 0
src/Main.hs View File

@ -0,0 +1,134 @@
{-# LANGUAGE LambdaCase #-}
module Main where
import Presyntax.Parser
import Elab
import Control.Monad.Catch
import System.Exit
import Syntax
import System.Console.Haskeline (runInputT, defaultSettings, getInputLine)
import Control.Monad.IO.Class
import Presyntax
import qualified Data.Map.Strict as Map
import Eval (eval, UnifyError (..))
import Systems (formulaOfFace, Face)
import Data.List
showTypeError :: Maybe [String] -> Elab.TypeError -> String
showTypeError lines (NotInScope l_c) = "Variable not in scope: " ++ l_c
showTypeError lines (UnifyError (NotPiType vl)) = "Not a function type: " ++ show vl
showTypeError lines (UnifyError (NotSigmaType vl)) = "Not a sigma type: " ++ show vl
showTypeError lines (UnifyError (Mismatch a b)) =
unlines [ "Types are not equal: "
, " " ++ show (quote a)
, " vs "
, " " ++ show (quote b)
]
showTypeError lines (WrongFaces _ faces) = unlines (map face faces) where
face :: ([Value], Value, Elab.TypeError) -> String
face (ixs, rhs, err) =
"When checking face described by " ++ show ixs ++ ":\n" ++ showTypeError Nothing err
showTypeError lines (InSpan start end err)
| Just lines <- lines, fst start == fst end
= makeRange (lines !! fst start) start end ++ '\n':showTypeError Nothing err
| otherwise = showTypeError Nothing err
showTypeError lines (IncompleteSystem formula extent) =
unlines $
[ "Incomplete system: "
, "it is defined by " ++ show formula
, "but the context mandates extent " ++ show extent ]
showTypeError lines (IncompatibleFaces (fa, ta) (fb, tb) err) =
unlines [ showTypeError lines err
, "while checking that these overlapping faces are compatible:"
, "* " ++ show fa ++ " -> " ++ show ta
, "* " ++ show fb ++ " -> " ++ show tb
]
showTypeError _ x = show x
makeRange :: String -> (Int, Int) -> (Int, Int) -> String
makeRange line (_, sc) (_, ec) = line ++ "\n" ++ replicate (sc + 1) ' ' ++ replicate (ec - sc) '~'
main :: IO ()
main = do
code <- readFile "test.itt"
case parseString body code of
Left e -> print e
Right x -> do
(tm, _) <- infer (Env mempty ) x `catch` \e -> do
putStrLn $ showTypeError (Just (lines code)) e
exitFailure
print tm
repl :: IO ()
repl = runInputT defaultSettings (go (Env mempty)) where
go env = getInputLine "λ " >>= \case
Just i | ":sq " `isPrefixOf` i -> do
case parseString body (replicate 4 ' ' ++ drop 4 i) of
Right exp ->
(do
(tm, ty) <- liftIO $ infer env exp
liftIO $ drawExtent ty (eval env tm)
`catch` \e -> liftIO $ putStrLn (showTypeError (Just [i]) e))
`catch` \e -> liftIO $ print (e :: SomeException)
Left e -> liftIO (print e)
go env
Just i ->
case parseString statement i of
Left e -> liftIO (print e) *> go env
Right (Assume vs) ->
let
loop env ((v, t):vs) = do
tm <- liftIO $ check env t VType
let ty = eval env tm
loop env{ names = Map.insert v (ty, VVar v) (names env) } vs
loop env [] = go env
in (loop env vs
`catch` \e -> (liftIO $ putStrLn (showTypeError (Just [i]) e)) *> go env)
`catch` \e -> (liftIO $ print (e :: SomeException)) *> go env
Right (Eval v) -> do
liftIO $
(do
(tm, ty) <- infer env v
let v_nf = eval env tm
putStrLn $ show v_nf ++ " : " ++ show ty
`catch` \e -> putStrLn (showTypeError (Just [i]) e))
`catch` \e -> print (e :: SomeException)
go env
Right (Declare n t e) -> do
(do
t <- liftIO $ check env t VType
let t' = eval env t
b <- liftIO $ check env e t'
let b' = eval env b
go env{ names = Map.insert n (t', b') (names env) })
`catch` \e -> (liftIO $ putStrLn (showTypeError (Just [i]) e)) *> go env
`catch` \e -> (liftIO $ print (e :: SomeException)) *> go env
Nothing -> pure ()
drawExtent :: Value -> Value -> IO ()
drawExtent ty vl = nicely $ getDirections ty vl where
getDirections :: Value -> Value -> [([(String, Bool)], Value, Value)]
getDirections (VPi _ VI r) (VLam s VI k) =
let trues = getDirections (r VI1) (k VI1)
falses = getDirections (r VI0) (k VI0)
in map (\(p, t, v) -> ((s, True):p, t, v)) trues
++ map (\(p, t, v) -> ((s, False):p, t, v)) falses
getDirections ty t = [([], ty, t)]
nicely :: [([(String, Bool)], Value, Value)] -> IO ()
nicely [] = pure ()
nicely ((bs, ty, el):fcs) = do
putStr . unwords $ theFace bs
putStrLn $ " => " ++ show el ++ " : " ++ show ty
nicely fcs
theFace = map (\(i, b) ->
if b
then "(" ++ i ++ "1)"
else "(" ++ i ++ "0)")

+ 71
- 0
src/Presyntax.hs View File

@ -0,0 +1,71 @@
{-# LANGUAGE LambdaCase #-}
module Presyntax where
data Exp
= Var String
| App Exp Exp
| Lam String Exp
| Let String Exp Exp Exp
| Sigma String Exp Exp
| Pair Exp Exp
| Proj1 Exp
| Proj2 Exp
| Pi String Exp Exp
| Type
| I
| I0 | I1
| IAnd Exp Exp
| IOr Exp Exp
| INot Exp
| Path
| Cut Exp Exp
| Span (Int, Int) (Int, Int) Exp
-- Formulas, partial elements, and the type of formulas
| Partial [(Formula, Exp)]
| PartialT
-- Compositions
| Comp
-- Cubical subtypes
| SubT
deriving (Eq, Show, Ord)
data Formula
= Is0 String
| Is1 String
| And Formula Formula
| Or Formula Formula
| Top | Bot
deriving (Eq, Ord)
instance Show Formula where
showsPrec p =
\case
Is1 i -> showString i
Is0 i -> showString ('~':i)
And x y -> showParen (p > and_prec) $
showsPrec or_prec x
. showString " && "
. showsPrec or_prec y
Or x y -> showParen (p > or_prec) $
showsPrec or_prec x
. showString " || "
. showsPrec or_prec y
Top -> showString "i1"
Bot -> showString "i0"
where
and_prec = 2
or_prec = 1
data Statement
= Assume [(String, Exp)]
| Declare String Exp Exp
| Eval Exp

+ 192
- 0
src/Presyntax/Lexer.hs View File

@ -0,0 +1,192 @@
{-# LANGUAGE BangPatterns #-}
module Presyntax.Lexer where
import Data.Text (Text)
import Data.Char
import qualified Data.Text as T
{- HLINT ignore -}
data TokenClass
= Tok_var Text
| Tok_lambda
| Tok_type
| Tok_path
| Tok_phi
| Tok_sub
| Tok_comp
| Tok_tr
| Tok_I
| Tok_I0
| Tok_I1
| Tok_oparen
| Tok_cparen
| Tok_osquare
| Tok_csquare
| Tok_colon
| Tok_arrow
| Tok_let
| Tok_equal
| Tok_in
| Tok_and
| Tok_not
| Tok_or
| Tok_fand
| Tok_for
| Tok_assume
| Tok_p1
| Tok_p2
| Tok_comma
| Tok_times
deriving (Eq, Show, Ord)
data Token
= Token { tokLine :: {-# UNPACK #-} !Int
, tokCol :: {-# UNPACK #-} !Int
, tokSOff :: {-# UNPACK #-} !Int
, tokOff :: {-# UNPACK #-} !Int
, tokClass :: !TokenClass
}
deriving (Eq, Show, Ord)
data LexError
= LexError { leChar :: {-# UNPACK #-} !Char
, leLine :: {-# UNPACK #-} !Int
, leCol :: {-# UNPACK #-} !Int
}
| EOFInComment { leLine :: {-# UNPACK #-} !Int
, leCol :: {-# UNPACK #-} !Int
}
deriving (Eq, Show, Ord)
lexString :: String -> Either LexError [Token]
lexString = go 0 0 0 where
go :: Int -> Int -> Int -> String -> Either LexError [Token]
go !off !line !_ ('\n':xs) =
go (off + 1) (line + 1) 0 xs
go !off !line !col (' ':xs) =
go (off + 1) line (col + 1) xs
go !off !line !_ ('-':'-':xs) =
let (a, b) = span (/= '\n') xs
in go (off + length a) line 0 b
go !off !line !col ('{':'-':xs) = skipComment off line col 1 xs
go !off !line !col ('~':cs) =
Token line col off (off + 1) Tok_not `yield` go (off + 1) line (col + 1) cs
go !off !line !col ('(':cs) =
Token line col off (off + 1) Tok_oparen `yield` go (off + 1) line (col + 1) cs
go !off !line !col (')':cs) =
Token line col off (off + 1) Tok_cparen `yield` go (off + 1) line (col + 1) cs
go !off !line !col ('[':cs) =
Token line col off (off + 1) Tok_osquare `yield` go (off + 1) line (col + 1) cs
go !off !line !col (']':cs) =
Token line col off (off + 1) Tok_csquare `yield` go (off + 1) line (col + 1) cs
go !off !line !col (':':cs) =
Token line col off (off + 1) Tok_colon `yield` go (off + 1) line (col + 1) cs
go !off !line !col (',':cs) =
Token line col off (off + 1) Tok_comma `yield` go (off + 1) line (col + 1) cs
go !off !line !col ('=':cs) =
Token line col off (off + 1) Tok_equal `yield` go (off + 1) line (col + 1) cs
go !off !line !col ('\\':'/':cs) =
Token line col off (off + 2) Tok_for `yield` go (off + 2) line (col + 2) cs
go !off !line !col ('\\':cs) =
Token line col off (off + 1) Tok_lambda `yield` go (off + 1) line (col + 1) cs
go !off !line !col ('*':cs) =
Token line col off (off + 1) Tok_times `yield` go (off + 1) line (col + 1) cs
go !off !line !col ('λ':cs) =
Token line col off (off + 1) Tok_lambda `yield` go (off + 1) line (col + 1) cs
go !off !line !col ('→':cs) =
Token line col off (off + 1) Tok_lambda `yield` go (off + 1) line (col + 1) cs
go !off !line !col ('-':'>':cs) =
Token line col off (off + 2) Tok_arrow `yield` go (off + 2) line (col + 2) cs
go !off !line !col ('&':'&':cs) =
Token line col off (off + 2) Tok_and `yield` go (off + 2) line (col + 2) cs
go !off !line !col ('&':cs) =
Token line col off (off + 1) Tok_fand `yield` go (off + 1) line (col + 1) cs
go !off !line !col ('/':'\\':cs) =
Token line col off (off + 1) Tok_fand `yield` go (off + 1) line (col + 1) cs
go !off !line !col ('|':'|':cs) =
Token line col off (off + 2) Tok_or `yield` go (off + 2) line (col + 2) cs
go !off !line !col ('|':cs) =
Token line col off (off + 1) Tok_for `yield` go (off + 1) line (col + 1) cs
go !off !line !col ('.':'1':cs) =
Token line col off (off + 2) Tok_p1 `yield` go (off + 2) line (col + 2) cs
go !off !line !col ('.':'2':cs) =
Token line col off (off + 2) Tok_p2 `yield` go (off + 2) line (col + 2) cs
go !off !line !col (c:cs)
| isAlpha c = goIdent off off line col (T.singleton c) cs
go !_ !line !col (c:_) = Left (LexError c line col)
go _ _ _ [] = pure []
goIdent !soff !off !line !col !acc [] =
pure [Token line col soff off (finishIdent acc)]
goIdent !soff !off !line !col !acc (c:cs)
| isAlphaNum c || c == '\''
= goIdent soff (off + 1) line (col + 1) (T.snoc acc c) cs
| otherwise
= Token line col soff off (finishIdent acc) `yield` go (off + 1) line (col + 1) (c:cs)
skipComment off line col level ('-':'}':cs)
| level == 1 = go (off + 2) line (col + 2) cs
| otherwise = skipComment (off + 2) line (col + 2) (level - 1) cs
skipComment off line col level ('{':'-':cs) =
skipComment (off + 2) line (col + 2) (level + 1) cs
skipComment off line col level ('\n':cs) =
skipComment (off + 1) (line + 1) 0 level cs
skipComment off line col level (c:cs) =
skipComment (off + 1) line (col + 1) level cs
skipComment _ line col _ [] = Left (EOFInComment line col)
yield c = fmap (c:)
finishIdent c
| T.pack "Type" == c = Tok_type
| T.pack "Path" == c = Tok_path
| T.pack "Partial" == c = Tok_phi
| T.pack "Sub" == c = Tok_sub
| T.pack "comp" == c = Tok_comp
| T.pack "tr" == c = Tok_tr
| T.pack "I" == c = Tok_I
| T.pack "i0" == c = Tok_I0
| T.pack "i1" == c = Tok_I1
| T.pack "let" == c = Tok_let
| T.pack "in" == c = Tok_in
| T.pack "assume" == c = Tok_assume
| otherwise = Tok_var c

+ 284
- 0
src/Presyntax/Parser.hs View File

@ -0,0 +1,284 @@
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DerivingVia #-}
module Presyntax.Parser where
import Control.Applicative
import Control.Monad.State
import qualified Data.Text as T
import Data.Text (Text)
import Presyntax.Lexer
import Presyntax
data ParseError
= UnexpectedEof Int Int
| Unexpected Token
| Empty
| AltError ParseError ParseError
deriving (Show)
data ParseState
= ParseState { ptTs :: [Token]
, ptLine :: !Int
, ptCol :: !Int
}
newtype Parser a =
Parser { runParser :: ParseState -> Either ParseError (a, ParseState) }
deriving
( Functor
, Applicative
, Monad
, MonadState ParseState
)
via (StateT ParseState (Either ParseError))
eof :: Parser ()
eof = Parser $ \state ->
case ptTs state of
[] -> Right ((), state)
(x:_) -> Left (Unexpected x)
parseString :: Parser a -> String -> Either (Either LexError ParseError) a
parseString (Parser k) s =
case lexString s of
Left e -> Left (Left e)
Right xs ->
case k (ParseState xs 0 0) of
Left e -> Left (pure e)
Right (x, _) -> Right x
selectToken :: (Token -> Maybe a) -> Parser a
selectToken k = Parser \case
ParseState [] l c -> Left (UnexpectedEof l c)
ParseState (x:xs) _ _ ->
case k x of
Just p -> pure (p, ParseState xs (tokLine x) (tokCol x))
Nothing -> Left (Unexpected x)
expect :: TokenClass -> Parser ()
expect t = selectToken (\x -> if tokClass x == t then Just () else Nothing)
var :: Parser Text
var = selectToken \case
Token _ _ _ _ (Tok_var v) -> pure v
_ -> Nothing
optionally :: Parser a -> Parser (Maybe a)
optionally p = fmap Just p <|> pure Nothing
parens :: Parser a -> Parser a
parens k = do
expect Tok_oparen
x <- k
expect Tok_cparen
pure x
square :: Parser a -> Parser a
square k = do
expect Tok_osquare
x <- k
expect Tok_csquare
pure x
instance Alternative Parser where
empty = Parser \_ -> Left Empty
Parser kx <|> Parser ky = Parser \x ->
case kx x of
Right x -> Right x
Left e ->
case ky x of
Left _ -> Left e
Right y -> Right y
attachPos :: Parser Exp -> Parser Exp
attachPos k = do
start <- gets (\(ParseState ~(x:_) _ _) -> (tokLine x, tokCol x - (tokOff x - tokSOff x)))
x <- k
end <- gets (\(ParseState _ l c) -> (l, c))
pure (Span start end x)
body :: Parser Exp
body = attachPos letExpr <|> attachPos lamExpr <|> attachPos exprPi where
lamExpr = do
expect Tok_lambda
vs <- some arg
expect Tok_arrow
e <- body
pure (foldr Lam e vs)
letExpr = do
expect Tok_let
v <- T.unpack <$> var
expect Tok_colon
t <- body
expect Tok_equal
b <- body
expect Tok_in
Let v t b <$> body
arg = T.unpack <$> var
exprPi :: Parser Exp
exprPi = attachPos $
do
bs <- optionally binder
case bs of
Just k -> foldl (.) id k <$> attachPos exprPi
Nothing -> attachPos exprArr
where
binder = (some (parens bind) <* expect Tok_arrow)
<|> (fmap pure (parens sigma) <* expect Tok_times)
bind = do
names <- some (T.unpack <$> var)
expect Tok_colon
t <- exprPi
pure (foldr (\n k -> Pi n t . k) id names)
sigma = do
names <- some (T.unpack <$> var)
expect Tok_colon
t <- exprPi
pure (foldr (\n k -> Sigma n t . k) id names)
exprArr :: Parser Exp
exprArr = attachPos $ do
t <- attachPos exprConj
c <- optionally (fmap (const True) (expect Tok_arrow) <|> fmap (const False) (expect Tok_times))
case c of
Just True -> Pi "_" t <$> exprPi
Just False -> Sigma "_" t <$> exprPi
Nothing -> pure t
exprApp :: Parser Exp
exprApp = attachPos $
do
head <- atom
spine <- many spineEntry
pure (foldl app head spine)
where
spineEntry = atom
app f s = App f s
exprDisj :: Parser Exp
exprDisj = attachPos $
do
first <- exprApp
rest <- many disjunct
pure (foldl IOr first rest)
where
disjunct = expect Tok_or *> exprApp
exprConj :: Parser Exp
exprConj = attachPos $
do
first <- exprDisj
rest <- many conjunct
pure (foldl IAnd first rest)
where
conjunct = expect Tok_and *> exprDisj
atom0 :: Parser Exp
atom0 = attachPos $
fmap (Var . T.unpack) var
<|> fmap (const Type) (expect Tok_type)
<|> fmap (const I) (expect Tok_I)
<|> fmap (const I0) (expect Tok_I0)
<|> fmap (const I1) (expect Tok_I1)
<|> fmap (const Path) (expect Tok_path)
<|> fmap (const SubT) (expect Tok_sub)
<|> fmap (const PartialT) (expect Tok_phi)
<|> fmap (const Comp) (expect Tok_comp)
<|> fmap INot (expect Tok_not *> atom)
<|> parens pair
<|> square (Partial <$> (system <|> pure []))
atom :: Parser Exp
atom = attachPos $
do
e <- atom0
c <- many (selectToken (projection . tokClass))
pure $ case c of
[] -> e
sls -> foldl (flip ($)) e sls
where
projection Tok_p1 = pure Proj1
projection Tok_p2 = pure Proj2
projection _ = Nothing
system :: Parser [(Formula, Exp)]
system =
do
t <- comp
x <- optionally (expect Tok_comma)
case x of
Just () -> (t:) <$> system
Nothing -> pure [t]
where
comp = do
t <- formula
expect Tok_arrow
(t,) <$> body
pair :: Parser Exp
pair = do
t <- body
x <- optionally (expect Tok_comma)
case x of
Just () -> Pair t <$> pair
Nothing -> pure t
statement :: Parser Statement
statement = (assume <|> declare <|> (Eval <$> body)) <* eof where
assume = do
expect Tok_assume
Assume <$> vars
declare = do
expect Tok_let
x <- T.unpack <$> var
expect Tok_colon
ty <- body
expect Tok_equal
Declare x ty <$> body
bind = do
var <- some (T.unpack <$> var)
expect Tok_colon
body <- body
pure $ map ((, body)) var
vars = do
var <- bind
t <- optionally (expect Tok_comma)
case t of
Nothing -> pure var
Just x -> (var ++) <$> vars
formula :: Parser Formula
formula = conjunction where
conjunction, disjunction, atom :: Parser Formula
conjunction = do
d <- disjunction
t <- optionally (expect Tok_and)
case t of
Nothing -> pure d
Just x -> And d <$> conjunction
disjunction = do
d <- atom
t <- optionally (expect Tok_or)
case t of
Nothing -> pure d
Just x -> Or d <$> disjunction
atom = (Is1 . T.unpack) <$> var
<|> (Is0 . T.unpack) <$> (expect Tok_not *> var)
<|> Top <$ expect Tok_I1
<|> Bot <$ expect Tok_I0

+ 250
- 0
src/Syntax.hs View File

@ -0,0 +1,250 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternSynonyms #-}
module Syntax where
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Map.Strict (Map)
import Systems
import qualified Data.Map.Strict as Map
import Text.Show (showListWith)
import Presyntax (Formula)
type Space = Term
data Term
= Var String
| App Term Term
| Lam String Term Term
| Let String Term Term Term
| Pi String Term Term
| Type
| I
| I0 | I1
| IAnd Term Term
| IOr Term Term
| INot Term
| Path Space Term Term
| PathI Space Term Term String Term
| PathP Space Term Term Term Term
| Sigma String Term Term
| Pair Term Term
| Proj1 Term
| Proj2 Term
| System (System Term)
| Partial Term Ter