quox/lib/Quox/Parser.idr

132 lines
3.2 KiB
Idris
Raw Normal View History

2022-05-06 15:58:32 -04:00
module Quox.Parser
import Quox.Syntax
import Quox.Token
import Quox.Lexer
2022-05-07 23:41:55 -04:00
import Data.Maybe
2022-05-06 15:58:32 -04:00
import Data.SnocVect
import Data.SnocList
import Text.Parser
%default total
public export
Vars : Nat -> Type
Vars n = SnocVect n String
public export
Grammar : Bool -> Type -> Type
Grammar = Core.Grammar () Token
%hide Core.Grammar
public export
data Error
= Lex (Lexer.Error)
| Parse (List1 (ParsingError Token))
| Leftover (List BToken)
%hide Lexer.Error
public export
parseAll : {c : Bool} -> Grammar c a -> List BToken -> Either Error a
parseAll grm input =
case parse grm input of
Right (x, []) => Right x
Right (x, rest) => Left $ Leftover rest
Left errs => Left $ Parse errs
public export
lexParseAll : {c : Bool} -> Grammar c a -> String -> Either Error a
lexParseAll grm = lex' >=> parseAll grm
where lex' : String -> Either Error (List BToken)
lex' = bimap Lex id . lex
punc : Punc -> Grammar True ()
punc p = terminal (show p) $ \case
P p' => if p == p' then Just () else Nothing
_ => Nothing
between : Punc -> Punc -> Grammar True a -> Grammar True a
between opener closer inner = punc opener *> inner <* punc closer
parens, squares, braces : Grammar True a -> Grammar True a
parens = between LParen RParen
squares = between LSquare RSquare
braces = between LBrace RBrace
export
number : Grammar True Nat
number = terminal "number" $ \case
N Zero => Just 0
N One => Just 1
N (Other k) => Just k
_ => Nothing
zero, one, omega : Grammar True ()
zero = terminal "0" $ \case N Zero => Just (); _ => Nothing
one = terminal "1" $ \case N One => Just (); _ => Nothing
omega = terminal "ω" $ \case K Omega => Just (); _ => Nothing
export
quantity : Grammar True Qty
quantity = Zero <$ zero <|> One <$ one <|> Any <$ omega
find1 : Eq a => SnocVect k a -> a -> Maybe (Var k)
find1 [<] y = Nothing
find1 (sx :< x) y = if x == y then Just VZ else VS <$> find1 sx y
find : Vars k -> Name -> Maybe (Var k)
find vs (MakeName [<] (UN y)) = find1 vs y
find _ _ = Nothing
export
2022-05-07 23:41:55 -04:00
bound : (what : String) -> Vars k -> Grammar True (Var k)
bound what vs = terminal "bound \{what} variable" $
\case Name x => find1 vs x; _ => Nothing
2022-05-06 15:58:32 -04:00
export
sname : Grammar True String
sname = terminal "simple name" $ \case Name x => pure x; _ => Nothing
export
qname : Grammar True Name
qname = do
parts <- sepBy1 (punc Dot) sname
pure $ MakeName {mods = cast $ init parts, base = UN $ last parts}
export
2022-05-07 23:41:55 -04:00
nameWith : (bound : Vars k) -> (avoid : Vars n) ->
Grammar True (Either (Var k) Name)
nameWith bound avoid = do
2022-05-06 15:58:32 -04:00
y <- qname
2022-05-07 23:41:55 -04:00
when (isJust $ find avoid y) $
fail "wrong type of bound variable: \{show y}"
pure $ maybe (Right y) Left $ find bound y
2022-05-06 15:58:32 -04:00
export
dimension : Vars d -> Grammar True (Dim d)
dimension vs =
K Zero <$ zero
<|> K One <$ one
2022-05-07 23:41:55 -04:00
<|> B <$> bound "dimension" vs
mutual
export
term : (dvars : Vars d) -> (tvars : Vars n) -> Grammar True (Term d n)
term dvars tvars =
E <$> squares (elim dvars tvars)
export
elim : (dvars : Vars d) -> (tvars : Vars n) -> Grammar True (Elim d n)
elim dvars tvars =
either B F <$> nameWith {bound = tvars, avoid = dvars}