132 lines
3.1 KiB
Idris
132 lines
3.1 KiB
Idris
module Quox.Lexer
|
||
|
||
import Quox.Error
|
||
|
||
import Data.String
|
||
import public Text.Lexer
|
||
|
||
%default total
|
||
|
||
|
||
public export
|
||
record Error where
|
||
constructor Err
|
||
line, col : Int
|
||
char : Char
|
||
|
||
public export
|
||
data Punc
|
||
= LParen | RParen
|
||
| LSquare | RSquare
|
||
| LBrace | RBrace
|
||
| Comma
|
||
| Colon | DblColon
|
||
| Arrow | DblArrow
|
||
| Times | Triangle
|
||
| Wild
|
||
|
||
puncRepr : Punc -> Nat
|
||
puncRepr = \case
|
||
LParen => 0; RParen => 1; LSquare => 2; RSquare => 3
|
||
LBrace => 4; RBrace => 5; Comma => 5
|
||
Colon => 6; DblColon => 7; Arrow => 8; DblArrow => 9
|
||
Times => 10; Triangle => 11
|
||
Wild => 12
|
||
|
||
export Eq Punc where (==) = (==) `on` puncRepr
|
||
export Ord Punc where compare = compare `on` puncRepr
|
||
|
||
export
|
||
Show Punc where
|
||
show = \case
|
||
LParen => "'('"; RParen => "')'"; LSquare => "'['"; RSquare => "']'"
|
||
LBrace => "'{'"; RBrace => "'}'"; Comma => "','"
|
||
Colon => "':'"; DblColon => "'∷'"; Arrow => "'→'"; DblArrow => "'⇒'"
|
||
Times => "'×'"; Triangle => "'⊲'"
|
||
Wild => "'_'"
|
||
|
||
|
||
|
||
public export
|
||
data Kind
|
||
= P Punc
|
||
| Name | Symbol
|
||
|
||
kindRepr : Kind -> (Nat, Nat)
|
||
kindRepr (P p) = (0, puncRepr p)
|
||
kindRepr Name = (1, 0)
|
||
kindRepr Symbol = (2, 0)
|
||
|
||
export Eq Kind where (==) = (==) `on` kindRepr
|
||
export Ord Kind where compare = compare `on` kindRepr
|
||
|
||
export
|
||
Show Kind where
|
||
show (P p) = show p
|
||
show Name = "Name"
|
||
show Symbol = "Symbol"
|
||
|
||
|
||
export
|
||
TokenKind Kind where
|
||
TokType (P _) = ()
|
||
TokType Name = String
|
||
TokType Symbol = String
|
||
|
||
tokValue (P _) _ = ()
|
||
tokValue Name x = x
|
||
tokValue Symbol x = assert_total strTail x
|
||
|
||
|
||
Token' = Token (Maybe Kind)
|
||
Token = Token Kind
|
||
|
||
TokenMap' = TokenMap Token'
|
||
TokenMap = TokenMap Token
|
||
|
||
nameStart = pred $ \c => isAlpha c || c == '_'
|
||
nameCont = pred $ \c => isAlphaNum c || c == '_' || c == '\''
|
||
|
||
name = nameStart <+> many nameCont <+> reject nameCont
|
||
|
||
wild = exact "_" <+> reject nameCont
|
||
|
||
%hide Text.Lexer.symbol
|
||
symbol = exact "'" <+> name
|
||
|
||
|
||
tokens = toTokenMap [
|
||
(lineComment (exact "--"), Nothing),
|
||
(blockComment (exact "{-") (exact "-}"), Nothing),
|
||
(spaces, Nothing),
|
||
|
||
(exact "(", Just $ P LParen), (exact ")", Just $ P RParen),
|
||
(exact "[", Just $ P LSquare), (exact "]", Just $ P RSquare),
|
||
(exact "{", Just $ P LBrace), (exact "}", Just $ P RBrace),
|
||
(exact ",", Just $ P Comma),
|
||
(exact "::" <|> exact "∷", Just $ P DblColon),
|
||
(exact ":", Just $ P Colon),
|
||
|
||
(exact "->" <|> exact "→", Just $ P Arrow),
|
||
(exact "=>" <|> exact "⇒", Just $ P DblArrow),
|
||
(exact "**" <|> exact "×", Just $ P Times),
|
||
(exact "<<" <|> exact "⊲", Just $ P Triangle),
|
||
(wild, Just $ P Wild),
|
||
|
||
(name, Just Name), (symbol, Just Symbol)
|
||
]
|
||
|
||
sequenceT : Token (Maybe Kind) -> Maybe (Token Kind)
|
||
sequenceT tok =
|
||
case tok.kind of
|
||
Just k => Just $ {kind := k} tok
|
||
Nothing => Nothing
|
||
|
||
export
|
||
lex : MonadThrow Error m => String -> m (List (WithBounds Token))
|
||
lex str =
|
||
let (res, (line, col, str)) = lex tokens str in
|
||
case asList str of
|
||
[] => pure $ mapMaybe (traverse sequenceT) res
|
||
c :: _ => throw $ Err {line, col, char = c}
|