wball/perga
1
0
Fork 0
Code Issues 15 Pull requests Projects Releases Packages Wiki Activity Actions

IR success!

Browse source
This commit is contained in:
William Ball 2024-12-01 15:28:57 -08:00
parent cdafab0d94
commit 9f5c308131
2 changed files with 31 additions and 22 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

22
lib/Elaborator.hs
View file

@ -8,6 +8,13 @@ import qualified IR as I
type Binders = [Text] type Binders = [Text]
saveBinders :: State Binders a -> State Binders a
saveBinders action = do
binders <- get
res <- action
put binders
pure res
elaborate :: IRExpr -> Expr elaborate :: IRExpr -> Expr
elaborate ir = evalState (elaborate' ir) [] elaborate ir = evalState (elaborate' ir) []
where where
@ -17,13 +24,20 @@ elaborate ir = evalState (elaborate' ir) []
pure $ E.Var n . fromIntegral <$> elemIndex n binders ?: E.Free n pure $ E.Var n . fromIntegral <$> elemIndex n binders ?: E.Free n
elaborate' (I.Level level) = pure $ E.Level level elaborate' (I.Level level) = pure $ E.Level level
elaborate' (I.App m n) = E.App <$> elaborate' m <*> elaborate' n elaborate' (I.App m n) = E.App <$> elaborate' m <*> elaborate' n
elaborate' (I.Abs x t b) = do elaborate' (I.Abs x t b) = saveBinders $ do
t' <- elaborate' t t' <- elaborate' t
modify (x :) modify (x :)
E.Abs x t' <$> elaborate' b E.Abs x t' <$> elaborate' b
elaborate' (I.Pi x t b) = do elaborate' (I.Pi x t b) = saveBinders $ do
t' <- elaborate' t t' <- elaborate' t
modify (x :) modify (x :)
E.Pi x t' <$> elaborate' b E.Pi x t' <$> elaborate' b
elaborate' (I.Let name Nothing val body) = E.Let name Nothing <$> elaborate' val <*> elaborate' body elaborate' (I.Let name Nothing val body) = saveBinders $ do
elaborate' (I.Let name (Just t) val body) = E.Let name . Just <$> elaborate' t <*> elaborate' val <*> elaborate' body val' <- elaborate' val
modify (name :)
E.Let name Nothing val' <$> elaborate' body
elaborate' (I.Let name (Just ty) val body) = saveBinders $ do
val' <- elaborate' val
ty' <- elaborate' ty
modify (name :)
E.Let name (Just ty') val' <$> elaborate' body

29
lib/Parser.hs
View file

@ -3,13 +3,12 @@
module Parser where module Parser where
import Control.Monad.Except import Control.Monad.Except
import Data.Char
import Data.List (foldl1) import Data.List (foldl1)
import qualified Data.Text as T import qualified Data.Text as T
import Errors (Error (..)) import Errors (Error (..))
import IR import IR
import Preprocessor import Preprocessor
import Text.Megaparsec (Parsec, ShowErrorComponent (..), between, choice, chunk, errorBundlePretty, label, runParser, satisfy, try) import Text.Megaparsec (Parsec, ShowErrorComponent (..), between, choice, chunk, errorBundlePretty, label, runParser, try)
import Text.Megaparsec.Char import Text.Megaparsec.Char
import qualified Text.Megaparsec.Char.Lexer as L import qualified Text.Megaparsec.Char.Lexer as L
@ -42,12 +41,13 @@ reservedChars = "();:"
pIdentifier :: Parser Text pIdentifier :: Parser Text
pIdentifier = try $ label "identifier" $ lexeme $ do pIdentifier = try $ label "identifier" $ lexeme $ do
chars <- many $ satisfy isAllowed firstChar <- letterChar <|> char '_'
let ident = T.pack chars rest <- many $ alphaNumChar <|> char '_'
when (ident `elem` keywords) $ fail $ "Reserved word: " ++ T.unpack ident let ident = T.pack (firstChar : rest)
when (ident `elem` keywords) $
fail $
"Reserved word: " ++ T.unpack ident
pure ident pure ident
where
isAllowed c = isLetter c || isNumber c || c == '_' || isSymbol c && c `notElem` reservedChars
pVar :: Parser IRExpr pVar :: Parser IRExpr
pVar = label "variable" $ lexeme $ Var <$> pIdentifier pVar = label "variable" $ lexeme $ Var <$> pIdentifier
@ -127,12 +127,11 @@ pNumSort :: Parser IRExpr
pNumSort = lexeme $ label "sort" $ eat "*" >> Level <$> L.decimal pNumSort = lexeme $ label "sort" $ eat "*" >> Level <$> L.decimal
pSort :: Parser IRExpr pSort :: Parser IRExpr
pSort = try pNumSort <|> pStar pSort = lexeme $ try pNumSort <|> pStar
pAxiom :: Parser IRDef pAxiom :: Parser IRDef
pAxiom = lexeme $ label "axiom" $ do pAxiom = lexeme $ label "axiom" $ do
skipSpace eat "axiom"
eat "def"
ident <- pIdentifier ident <- pIdentifier
params <- pManyParams params <- pManyParams
ascription <- fmap (flip (foldr (uncurry Pi)) params) pAscription ascription <- fmap (flip (foldr (uncurry Pi)) params) pAscription
@ -141,7 +140,6 @@ pAxiom = lexeme $ label "axiom" $ do
pDef :: Parser IRDef pDef :: Parser IRDef
pDef = lexeme $ label "definition" $ do pDef = lexeme $ label "definition" $ do
skipSpace
eat "def" eat "def"
ident <- pIdentifier ident <- pIdentifier
params <- pManyParams params <- pManyParams
@ -152,13 +150,10 @@ pDef = lexeme $ label "definition" $ do
pure $ Def ident ascription $ foldr (uncurry Abs) body params pure $ Def ident ascription $ foldr (uncurry Abs) body params
pIRDef :: Parser IRDef pIRDef :: Parser IRDef
pIRDef = pDef <|> pAxiom pIRDef = pAxiom <|> pDef
pTerm :: Parser IRExpr pTerm :: Parser IRExpr
pTerm = pTerm = lexeme $ label "term" $ choice [pSort, pVar, between (char '(') (char ')') pIRExpr]
lexeme $
label "term" $
choice [between (char '(') (char ')') pIRExpr, pSort, pVar]
pAppTerm :: Parser IRExpr pAppTerm :: Parser IRExpr
pAppTerm = lexeme $ choice [pLAbs, pPAbs, pLet, pApp] pAppTerm = lexeme $ choice [pLAbs, pPAbs, pLet, pApp]
@ -170,7 +165,7 @@ pAscription :: Parser IRExpr
pAscription = lexeme $ try $ eat ":" >> label "type" pIRExpr pAscription = lexeme $ try $ eat ":" >> label "type" pIRExpr
pIRProgram :: Parser IRProgram pIRProgram :: Parser IRProgram
pIRProgram = many pIRDef pIRProgram = skipSpace >> some pIRDef
parserWrapper :: Parser a -> String -> Text -> Either String a parserWrapper :: Parser a -> String -> Text -> Either String a
parserWrapper p filename input = first errorBundlePretty $ runParser p filename input parserWrapper p filename input = first errorBundlePretty $ runParser p filename input