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

Polish up the type checker

master
Amélia Liao 3 years ago
parent
c4a2fee7a2
commit
9be5402444
10 changed files with 290 additions and 47 deletions
Unified View
Diff Options
Show Stats Download Patch File Download Diff File
  1. +4
    -0
      cubical.cabal
  2. +79
    -5
      src/Elab.hs
  3. +41
    -8
      src/Elab/Eval.hs
  4. +29
    -6
      src/Elab/Monad.hs
  5. +52
    -1
      src/Main.hs
  6. +1
    -1
      src/Presyntax/Lexer.x
  7. +51
    -25
      src/Presyntax/Parser.y
  8. +8
    -0
      src/Presyntax/Presyntax.hs
  9. +18
    -0
      src/Presyntax/Tokens.hs
  10. +7
    -1
      src/Syntax.hs

+ 4
- 0
cubical.cabal View File

@ -25,12 +25,16 @@ executable cubical
, containers ^>= 0.6 , containers ^>= 0.6
, bytestring ^>= 0.10 , bytestring ^>= 0.10
, prettyprinter ^>= 1.7
, prettyprinter-ansi-terminal ^>= 1.1
other-modules: Presyntax.Lexer other-modules: Presyntax.Lexer
, Presyntax.Parser , Presyntax.Parser
, Presyntax.Tokens , Presyntax.Tokens
, Presyntax.Presyntax , Presyntax.Presyntax
, Syntax , Syntax
, Syntax.Pretty
, Elab , Elab
, Elab.Eval , Elab.Eval


+ 79
- 5
src/Elab.hs View File

@ -1,15 +1,36 @@
{-# LANGUAGE TupleSections, OverloadedStrings #-} {-# LANGUAGE TupleSections, OverloadedStrings #-}
{-# LANGUAGE DeriveAnyClass #-}
module Elab where module Elab where
import Control.Monad.Reader
import Control.Exception
import qualified Data.Map.Strict as Map
import Data.Typeable
import Elab.Monad import Elab.Monad
import Elab.Eval
import qualified Presyntax.Presyntax as P import qualified Presyntax.Presyntax as P
import Syntax import Syntax
import Elab.Eval
infer :: P.Expr -> ElabM (Term, NFType) infer :: P.Expr -> ElabM (Term, NFType)
infer (P.Var t) = (Ref (Bound t),) <$> getNfType (Bound t)
infer (P.Span ex a b) = do
env <- ask
liftIO $
runElab (infer ex) env
`catches` [ Handler $ \e@WhileChecking{} -> throwIO e
, Handler $ \e -> throwIO (WhileChecking a b e)
]
infer (P.Var t) = do
name <- getNameFor t
case name of
Builtin _ wi -> elabWiredIn wi name
_ -> do
nft <- getNfType name
pure (Ref name, nft)
infer (P.App p f x) = do infer (P.App p f x) = do
(f, f_ty) <- infer f (f, f_ty) <- infer f
@ -32,12 +53,31 @@ infer (P.Sigma s d r) = do
r <- check r VType r <- check r VType
pure (Sigma s d r, VType) pure (Sigma s d r, VType)
infer (P.Proj1 x) = do
(tm, ty) <- infer x
(d, _, wp) <- isSigmaType ty
pure (Proj1 (wp tm), d)
infer (P.Proj2 x) = do
(tm, ty) <- infer x
tm_nf <- eval tm
(_, r, wp) <- isSigmaType ty
pure (Proj2 (wp tm), r (vProj1 tm_nf))
infer exp = do infer exp = do
t <- newMeta VType t <- newMeta VType
tm <- check exp t
tm <- switch $ check exp t
pure (tm, t) pure (tm, t)
check :: P.Expr -> NFType -> ElabM Term check :: P.Expr -> NFType -> ElabM Term
check (P.Span ex a b) ty = do
env <- ask
liftIO $
runElab (check ex ty) env
`catches` [ Handler $ \e@WhileChecking{} -> throwIO e
, Handler $ \e -> throwIO (WhileChecking a b e)
]
check (P.Lam p var body) (VPi p' dom (Closure _ rng)) | p == p' = check (P.Lam p var body) (VPi p' dom (Closure _ rng)) | p == p' =
assume (Bound var) dom $ assume (Bound var) dom $
Lam p var <$> check body (rng (VVar (Bound var))) Lam p var <$> check body (rng (VVar (Bound var)))
@ -59,10 +99,13 @@ check (P.Pair a b) ty = do
pure (wp (Pair a b)) pure (wp (Pair a b))
check exp ty = do check exp ty = do
(tm, has) <- infer exp
(tm, has) <- switch $ infer exp
unify has ty unify has ty
pure tm pure tm
elabWiredIn :: WiredIn -> Name -> ElabM (Term, NFType)
elabWiredIn WiType _ = pure (Type, VType)
isPiType :: P.Plicity -> NFType -> ElabM (Value, NFType -> NFType, Term -> Term) isPiType :: P.Plicity -> NFType -> ElabM (Value, NFType -> NFType, Term -> Term)
isPiType p (VPi p' d (Closure _ k)) | p == p' = pure (d, k, id) isPiType p (VPi p' d (Closure _ k)) | p == p' = pure (d, k, id)
isPiType p t = do isPiType p t = do
@ -84,4 +127,35 @@ isSigmaType t = do
pure (dom, const rng, wp) pure (dom, const rng, wp)
identityTy :: NFType identityTy :: NFType
identityTy = VPi P.Im VType (Closure "A" $ \t -> VPi P.Ex t (Closure "_" (const t)))
identityTy = VPi P.Im VType (Closure "A" $ \t -> VPi P.Ex t (Closure "_" (const t)))
checkStatement :: P.Statement -> ElabM a -> ElabM a
checkStatement (P.Decl name ty) k = do
ty <- check ty VType
ty_nf <- eval ty
assume (Defined name) ty_nf k
checkStatement (P.Defn name rhs) k = do
ty <- asks (Map.lookup (Defined name) . getEnv)
case ty of
Nothing -> do
(tm, ty) <- infer rhs
tm_nf <- eval tm
define (Defined name) ty tm_nf k
Just (ty_nf, nm) -> do
unless (nm == VVar (Defined name)) . liftIO . throwIO $
Redefinition (Defined name)
rhs <- check rhs ty_nf
rhs_nf <- eval rhs
define (Defined name) ty_nf rhs_nf k
checkProgram :: [P.Statement] -> ElabM ElabEnv
checkProgram [] = ask
checkProgram (st:sts) = checkStatement st $ checkProgram sts
newtype Redefinition = Redefinition { getRedefName :: Name }
deriving (Show, Typeable, Exception)
data WhileChecking = WhileChecking { startPos :: P.Posn, endPos :: P.Posn, exc :: SomeException }
deriving (Show, Typeable, Exception)

+ 41
- 8
src/Elab/Eval.hs View File

@ -42,6 +42,30 @@ applProj fun PProj2 = vProj2 fun
force :: Value -> Value force :: Value -> Value
force = unsafePerformIO . forceIO force = unsafePerformIO . forceIO
-- everywhere force
zonkIO :: Value -> IO Value
zonkIO (VNe hd sp) = do
sp' <- traverse zonkSp sp
case hd of
HMeta (MV _ cell) -> do
solved <- liftIO $ readIORef cell
case solved of
Just vl -> zonkIO $ foldl applProj vl (reverse sp')
Nothing -> pure $ VNe hd sp'
hd -> pure $ VNe hd sp'
where
zonkSp (PApp p x) = PApp p <$> zonkIO x
zonkSp PProj1 = pure PProj1
zonkSp PProj2 = pure PProj2
zonkIO (VLam p (Closure s k)) = pure $ VLam p (Closure s (zonk . k))
zonkIO (VPi p d (Closure s k)) = VPi p <$> zonkIO d <*> pure (Closure s (zonk . k))
zonkIO (VSigma d (Closure s k)) = VSigma <$> zonkIO d <*> pure (Closure s (zonk . k))
zonkIO (VPair a b) = VPair <$> zonkIO a <*> zonkIO b
zonkIO VType = pure VType
zonk :: Value -> Value
zonk = unsafePerformIO . zonkIO
evalWithEnv :: ElabEnv -> Term -> Value evalWithEnv :: ElabEnv -> Term -> Value
evalWithEnv env (Ref x) = evalWithEnv env (Ref x) =
case Map.lookup x (getEnv env) of case Map.lookup x (getEnv env) of
@ -51,17 +75,17 @@ evalWithEnv env (App p f x) = vApp p (evalWithEnv env f) (evalWithEnv env x)
evalWithEnv env (Lam p s t) = evalWithEnv env (Lam p s t) =
VLam p $ Closure s $ \a -> VLam p $ Closure s $ \a ->
evalWithEnv (ElabEnv (Map.insert (Bound s) (error "type of abs", a) (getEnv env))) t
evalWithEnv env { getEnv = Map.insert (Bound s) (error "type of abs", a) (getEnv env) } t
evalWithEnv env (Pi p s d t) = evalWithEnv env (Pi p s d t) =
VPi p (evalWithEnv env d) $ Closure s $ \a -> VPi p (evalWithEnv env d) $ Closure s $ \a ->
evalWithEnv (ElabEnv (Map.insert (Bound s) (error "type of abs", a) (getEnv env))) t
evalWithEnv env { getEnv = (Map.insert (Bound s) (error "type of abs", a) (getEnv env))} t
evalWithEnv _ (Meta m) = VNe (HMeta m) [] evalWithEnv _ (Meta m) = VNe (HMeta m) []
evalWithEnv env (Sigma s d t) = evalWithEnv env (Sigma s d t) =
VSigma (evalWithEnv env d) $ Closure s $ \a -> VSigma (evalWithEnv env d) $ Closure s $ \a ->
evalWithEnv (ElabEnv (Map.insert (Bound s) (error "type of abs", a) (getEnv env))) t
evalWithEnv env { getEnv = Map.insert (Bound s) (error "type of abs", a) (getEnv env) } t
evalWithEnv e (Pair a b) = VPair (evalWithEnv e a) (evalWithEnv e b) evalWithEnv e (Pair a b) = VPair (evalWithEnv e a) (evalWithEnv e b)
@ -91,6 +115,7 @@ data NotEqual = NotEqual Value Value
unify :: Value -> Value -> ElabM () unify :: Value -> Value -> ElabM ()
unify topa topb = join $ go <$> forceIO topa <*> forceIO topb where unify topa topb = join $ go <$> forceIO topa <*> forceIO topb where
go (VNe (HMeta mv) sp) rhs = solveMeta mv sp rhs go (VNe (HMeta mv) sp) rhs = solveMeta mv sp rhs
go rhs (VNe (HMeta mv) sp) = solveMeta mv sp rhs
go (VNe x a) (VNe x' a') go (VNe x a) (VNe x' a')
| x == x', length a == length a' = | x == x', length a == length a' =
@ -118,12 +143,18 @@ unify topa topb = join $ go <$> forceIO topa <*> forceIO topb where
unify d d' unify d d'
unify (k t) (k' t) unify (k t) (k' t)
go VType VType = pure ()
go _ _ = fail go _ _ = fail
fail = liftIO . throwIO $ NotEqual topa topb fail = liftIO . throwIO $ NotEqual topa topb
unifySpine (PApp a v) (PApp a' v') unifySpine (PApp a v) (PApp a' v')
| a == a' = unify v v' | a == a' = unify v v'
unifySpine PProj1 PProj1 = pure ()
unifySpine PProj2 PProj2 = pure ()
unifySpine _ _ = fail unifySpine _ _ = fail
isConvertibleTo :: Value -> Value -> ElabM (Term -> Term) isConvertibleTo :: Value -> Value -> ElabM (Term -> Term)
@ -143,9 +174,9 @@ newMeta _dom = do
env <- asks getEnv env <- asks getEnv
t <- for (Map.toList env) $ \(n, (_, c)) -> pure $
case c of
VVar n' | n == n' -> Just (PApp Ex (VVar n'))
t <- for (Map.toList env) $ \(n, _) -> pure $
case n of
Bound{} -> Just (PApp Ex (VVar n))
_ -> Nothing _ -> Nothing
pure (VNe (HMeta m) (catMaybes t)) pure (VNe (HMeta m) (catMaybes t))
@ -161,11 +192,12 @@ _nameCounter = unsafePerformIO $ newIORef 0
solveMeta :: MV -> [Projection] -> Value -> ElabM () solveMeta :: MV -> [Projection] -> Value -> ElabM ()
solveMeta m@(MV _ cell) sp rhs = do solveMeta m@(MV _ cell) sp rhs = do
env <- ask
liftIO $ print (m, sp, rhs) liftIO $ print (m, sp, rhs)
names <- checkSpine Set.empty sp names <- checkSpine Set.empty sp
checkScope (Set.fromList (Bound <$> names)) rhs checkScope (Set.fromList (Bound <$> names)) rhs
let tm = quote rhs let tm = quote rhs
lam = evalWithEnv emptyEnv $ foldr (Lam Ex) tm names
lam = evalWithEnv env $ foldr (Lam Ex) tm names
liftIO . atomicModifyIORef' cell $ \case liftIO . atomicModifyIORef' cell $ \case
Just _ -> error "filled cell in solvedMeta" Just _ -> error "filled cell in solvedMeta"
Nothing -> (Just lam, ()) Nothing -> (Just lam, ())
@ -174,9 +206,10 @@ checkScope :: Set Name -> Value -> ElabM ()
checkScope scope (VNe h sp) = checkScope scope (VNe h sp) =
do do
case h of case h of
HVar v ->
HVar v@Bound{} ->
unless (v `Set.member` scope) . liftIO . throwIO $ unless (v `Set.member` scope) . liftIO . throwIO $
NotInScope v NotInScope v
HVar{} -> pure ()
HMeta{} -> pure () HMeta{} -> pure ()
traverse_ checkProj sp traverse_ checkProj sp
where where


+ 29
- 6
src/Elab/Monad.hs View File

@ -1,6 +1,7 @@
{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DerivingVia #-} {-# LANGUAGE DerivingVia #-}
{-# LANGUAGE DeriveAnyClass #-}
module Elab.Monad where module Elab.Monad where
import Control.Monad.Reader import Control.Monad.Reader
@ -8,30 +9,37 @@ import Control.Exception
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
import Data.Map.Strict (Map) import Data.Map.Strict (Map)
import Data.Text (Text)
import Data.Typeable import Data.Typeable
import Syntax import Syntax
import qualified Data.Text as T
newtype ElabEnv = ElabEnv { getEnv :: Map Name (NFType, Value) }
data ElabEnv = ElabEnv { getEnv :: Map Name (NFType, Value), nameMap :: Map Text Name, pingPong :: Int }
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
newtype NotInScope = NotInScope { getName :: Name }
newtype NotInScope = NotInScope { nameNotInScope :: Name }
deriving (Show, Typeable) deriving (Show, Typeable)
deriving anyclass (Exception) deriving anyclass (Exception)
emptyEnv :: ElabEnv emptyEnv :: ElabEnv
emptyEnv = ElabEnv mempty
emptyEnv = ElabEnv mempty (Map.singleton (T.pack "Type") (Builtin (T.pack "Type") WiType)) 0
assume :: Name -> Value -> ElabM a -> ElabM a assume :: Name -> Value -> ElabM a -> ElabM a
assume nm ty = local go where assume nm ty = local go where
go = ElabEnv . Map.insert nm (ty, VVar nm) . getEnv
go x = x { getEnv = Map.insert nm (ty, VVar nm) (getEnv x), nameMap = Map.insert (getNameText nm) nm (nameMap x) }
getNameText :: Name -> Text
getNameText (Bound x) = x
getNameText (Defined x) = x
getNameText (Builtin x _) = x
define :: Name -> Value -> Value -> ElabM a -> ElabM a define :: Name -> Value -> Value -> ElabM a -> ElabM a
define nm ty vl = local go where define nm ty vl = local go where
go = ElabEnv . Map.insert nm (ty, vl) . getEnv
go x = x { getEnv = Map.insert nm (ty, vl) (getEnv x), nameMap = Map.insert (getNameText nm) nm (nameMap x) }
getValue :: Name -> ElabM Value getValue :: Name -> ElabM Value
getValue nm = do getValue nm = do
@ -45,4 +53,19 @@ getNfType nm = do
vl <- asks (Map.lookup nm . getEnv) vl <- asks (Map.lookup nm . getEnv)
case vl of case vl of
Just v -> pure (fst v) Just v -> pure (fst v)
Nothing -> liftIO . throwIO $ NotInScope nm
Nothing -> liftIO . throwIO $ NotInScope nm
getNameFor :: Text -> ElabM Name
getNameFor x = do
vl <- asks (Map.lookup x . nameMap)
case vl of
Just v -> pure v
Nothing -> liftIO . throwIO $ NotInScope (Bound x)
switch :: ElabM a -> ElabM a
switch k =
do
depth <- asks pingPong
when (depth >= 128) $ liftIO $ throwIO StackOverflow
local go k
where go e = e { pingPong = pingPong e + 1 }

+ 52
- 1
src/Main.hs View File

@ -1,14 +1,65 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Main where module Main where
import Control.Exception
import qualified Data.ByteString.Lazy as Bsl import qualified Data.ByteString.Lazy as Bsl
import qualified Data.Text.Encoding as T
import qualified Data.Map.Strict as Map
import qualified Data.Text.IO as T
import qualified Data.Text as T
import Data.Text ( Text )
import Data.Foldable import Data.Foldable
import Elab.Monad
import Elab.Eval
import Elab
import Presyntax.Presyntax (Posn(Posn))
import Presyntax.Parser import Presyntax.Parser
import Presyntax.Tokens import Presyntax.Tokens
import Presyntax.Lexer import Presyntax.Lexer
import System.Exit
import Syntax.Pretty
main :: IO () main :: IO ()
main = do main = do
t <- Bsl.readFile "test.tt" t <- Bsl.readFile "test.tt"
let Right tks = runAlex t parseProg let Right tks = runAlex t parseProg
traverse_ print tks
env <- runElab (checkProgram tks) emptyEnv `catch` \e -> displayAndDie (T.decodeUtf8 (Bsl.toStrict t)) (e :: SomeException)
for_ (Map.toList (getEnv env)) $ \(n, x) -> putStrLn $ show n ++ " : " ++ showValue (zonk (fst x))
displayAndDie :: Exception e => Text -> e -> IO a
displayAndDie lines e = do
() <- throwIO e `catches` displayExceptions lines
exitFailure
displayExceptions :: Text -> [Handler ()]
displayExceptions lines =
[ Handler \(WhileChecking a b e) -> do
T.putStrLn $ squiggleUnder a b lines
displayExceptions' lines e
, Handler \(NotEqual ta tb) -> do
putStrLn . unlines $
[ "\x1b[1;31merror\x1b[0m: Mismatch between actual and expected types:"
, " * \x1b[1mActual\x1b[0m: " ++ showValue (zonk ta)
, " * \x1b[1mExpected\x1b[0m: " ++ showValue (zonk tb)
]
]
displayExceptions' :: Exception e => Text -> e -> IO ()
displayExceptions' lines e = displayAndDie lines e `catch` \(_ :: ExitCode) -> pure ()
squiggleUnder :: Posn -> Posn -> Text -> Text
squiggleUnder (Posn l c) (Posn l' c') file
| l == l' =
let
line = T.pack (show l) <> " | " <> T.lines file !! (l - 1)
padding = T.replicate (length (show l)) (T.singleton ' ') <> " |"
squiggle = T.replicate c " " <> T.pack "\x1b[1;31m" <> T.replicate (c' - c) "~" <> T.pack "\x1b[0m"
in T.unlines [ padding, line, padding <> squiggle ]
| otherwise = T.pack (show (Posn l c, Posn l' c'))

+ 1
- 1
src/Presyntax/Lexer.x View File

@ -37,7 +37,7 @@ tokens :-
<0> \} { always TokCBrace } <0> \} { always TokCBrace }
<0> \; { always TokSemi } <0> \; { always TokSemi }
<0> \n { begin newline }
<0> \n { just $ pushStartCode newline }
-- newline: emit a semicolon when de-denting -- newline: emit a semicolon when de-denting
<newline> { <newline> {


+ 51
- 25
src/Presyntax/Parser.y View File

@ -8,6 +8,8 @@ import Presyntax.Presyntax
import Presyntax.Tokens import Presyntax.Tokens
import Presyntax.Lexer import Presyntax.Lexer
import Prelude hiding (span)
} }
%name parseExp Exp %name parseExp Exp
@ -23,7 +25,7 @@ import Presyntax.Lexer
%error { parseError } %error { parseError }
%token %token
var { Token (TokVar $$) _ _ }
var { $$@(Token (TokVar _) _ _) }
'(' { Token TokOParen _ _ } '(' { Token TokOParen _ _ }
')' { Token TokCParen _ _ } ')' { Token TokCParen _ _ }
@ -46,51 +48,55 @@ import Presyntax.Lexer
Exp :: { Expr } Exp :: { Expr }
Exp Exp
: Exp ExpProj { App Ex $1 $2 }
| Exp '{' Exp '}' { App Im $1 $3 }
: Exp ExpProj { span $1 $2 $ App Ex $1 $2 }
| Exp '{' Exp '}' { span $1 $4 $ App Im $1 $3 }
| '\\' LambdaList '->' Exp { makeLams $2 $4 }
| '(' VarList ':' Exp ')' ProdTail { makePis Ex $2 $4 $6 }
| '{' VarList ':' Exp '}' ProdTail { makePis Im $2 $4 $6 }
| ExpProj '->' Exp { Pi Ex (T.singleton '_') $1 $3 }
| '\\' LambdaList '->' Exp { span $1 $4 $ makeLams $2 $4 }
| '(' VarList ':' Exp ')' ProdTail { span $1 $6 $ makePis Ex $2 $4 $6 }
| '{' VarList ':' Exp '}' ProdTail { span $1 $6 $ makePis Im $2 $4 $6 }
| ExpProj '->' Exp { span $1 $3 $ Pi Ex (T.singleton '_') $1 $3 }
| '(' VarList ':' Exp ')' '*' Exp { makeSigmas $2 $4 $7 }
| ExpProj '*' Exp { Sigma (T.singleton '_') $1 $3 }
| '(' VarList ':' Exp ')' '*' Exp { span $1 $7 $ makeSigmas $2 $4 $7 }
| ExpProj '*' Exp { span $1 $3 $ Sigma (T.singleton '_') $1 $3 }
| ExpProj { $1 } | ExpProj { $1 }
ProdTail :: { Expr } ProdTail :: { Expr }
: '(' VarList ':' Exp ')' ProdTail { makePis Ex $2 $4 $6 }
| '{' VarList ':' Exp '}' ProdTail { makePis Im $2 $4 $6 }
| '->' Exp { $2 }
: '(' VarList ':' Exp ')' ProdTail { span $1 $6 $ makePis Ex $2 $4 $6 }
| '{' VarList ':' Exp '}' ProdTail { span $1 $6 $ makePis Im $2 $4 $6 }
| '->' Exp { span $2 $2 $ $2 }
LambdaList :: { [(Plicity, Text)] } LambdaList :: { [(Plicity, Text)] }
: var { [(Ex, $1)] }
| var LambdaList { (Ex, $1):$2 }
: var { [(Ex, getVar $1)] }
| var LambdaList { (Ex, getVar $1):$2 }
| '{'var'}' { [(Im, getVar $2)] }
| '{'var'}' LambdaList { (Im, getVar $2):$4 }
| '{'var'}' { [(Im, $2)] }
| '{'var'}' LambdaList { (Im, $2):$4 }
LhsList :: { [(Plicity, Text)] }
: { [] }
| LambdaList { $1 }
VarList :: { [Text] } VarList :: { [Text] }
: var { [$1] }
| var VarList { $1:$2 }
: var { [getVar $1] }
| var VarList { getVar $1:$2 }
ExpProj :: { Expr } ExpProj :: { Expr }
: ExpProj '.1' { Proj1 $1 }
| ExpProj '.2' { Proj2 $1 }
: ExpProj '.1' { span $1 $2 $ Proj1 $1 }
| ExpProj '.2' { span $1 $2 $ Proj2 $1 }
| Atom { $1 } | Atom { $1 }
Atom :: { Expr } Atom :: { Expr }
: var { Var $1 }
| '(' Tuple ')' { $2 }
: var { span $1 $1 $ Var (getVar $1) }
| '(' Tuple ')' { span $1 $3 $ $2 }
Tuple :: { Expr } Tuple :: { Expr }
: Exp { $1 } : Exp { $1 }
| Exp ',' Tuple { Pair $1 $3 }
| Exp ',' Tuple { span $1 $3 $ Pair $1 $3 }
Statement :: { Statement } Statement :: { Statement }
: var ':' Exp { Decl $1 $3 }
| var '=' Exp { Defn $1 $3 }
: var ':' Exp { Decl (getVar $1) $3 }
| var LhsList '=' Exp { Defn (getVar $1) (makeLams $2 $4) }
Program :: { [Statement] } Program :: { [Statement] }
: Statement { [$1] } : Statement { [$1] }
@ -104,4 +110,24 @@ parseError x = alexError (show x)
makeLams xs b = foldr (uncurry Lam) b xs makeLams xs b = foldr (uncurry Lam) b xs
makePis p xs t b = foldr (flip (Pi p) t) b xs makePis p xs t b = foldr (flip (Pi p) t) b xs
makeSigmas xs t b = foldr (flip Sigma t) b xs makeSigmas xs t b = foldr (flip Sigma t) b xs
class HasPosn a where
startPosn :: a -> Posn
endPosn :: a -> Posn
instance HasPosn Token where
startPosn (Token _ l c) = Posn l c
endPosn (Token t l c) = Posn l (c + tokSize t)
instance HasPosn Expr where
startPosn (Span _ s _) = s
startPosn _ = error "no start posn in parsed expression?"
endPosn (Span _ _ e) = e
endPosn _ = error "no end posn in parsed expression?"
span s e ex = Span ex (startPosn s) (endPosn e)
getVar (Token (TokVar s) _ _) = s
getVar _ = error "getVar non-var"
} }

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

@ -17,9 +17,17 @@ data Expr
| Pair Expr Expr | Pair Expr Expr
| Proj1 Expr | Proj1 Expr
| Proj2 Expr | Proj2 Expr
| Span Expr Posn Posn
deriving (Eq, Show, Ord) deriving (Eq, Show, Ord)
data Statement data Statement
= Decl Text Expr = Decl Text Expr
| Defn Text Expr | Defn Text Expr
deriving (Eq, Show, Ord)
data Posn
= Posn { posnLine :: {-# UNPACK #-} !Int
, posnColm :: {-# UNPACK #-} !Int
}
deriving (Eq, Show, Ord) deriving (Eq, Show, Ord)

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

@ -1,6 +1,7 @@
module Presyntax.Tokens where module Presyntax.Tokens where
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T
data TokenClass data TokenClass
= TokVar Text = TokVar Text
@ -25,6 +26,23 @@ data TokenClass
| TokSemi | TokSemi
deriving (Eq, Show, Ord) deriving (Eq, Show, Ord)
tokSize :: TokenClass -> Int
tokSize (TokVar x) = T.length x
tokSize TokEof = 0
tokSize TokLambda = 1
tokSize TokOParen = 1
tokSize TokOBrace = 1
tokSize TokCBrace = 1
tokSize TokCParen = 1
tokSize TokStar = 1
tokSize TokColon = 1
tokSize TokEqual = 1
tokSize TokComma = 1
tokSize TokSemi = 1
tokSize TokArrow = 2
tokSize TokPi1 = 2
tokSize TokPi2 = 2
data Token data Token
= Token { tokenClass :: TokenClass = Token { tokenClass :: TokenClass
, tokStartLine :: !Int , tokStartLine :: !Int


+ 7
- 1
src/Syntax.hs View File

@ -35,7 +35,13 @@ instance Show MV where
show = ('?':) . T.unpack . mvName show = ('?':) . T.unpack . mvName
data Name data Name
= Bound Text
= Bound Text
| Defined Text
| Builtin Text WiredIn
deriving (Eq, Show, Ord)
data WiredIn
= WiType
deriving (Eq, Show, Ord) deriving (Eq, Show, Ord)
type NFType = Value type NFType = Value


Write Preview
Loading…
Cancel
Save