1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
|
{
module Lexer (lex_tok) where
import ParserM (ParserM (..), mkT, mkTv, Token(..), start_code,
set_start_code,
inc_brace_depth, dec_brace_depth,
show_pos, position,
AlexInput, alexGetByte)
import qualified ParserM as ParserM (input)
}
words :-
<0> $white+ ;
<0> "--" [^\n]* \n ;
"{" { \i -> do {
set_start_code in_braces;
inc_brace_depth;
mkT TOpenBrace i
}
}
"}" { \i -> do {
dec_brace_depth;
mkT TCloseBrace i
}
}
<0> "->" { mkT TArrow }
<0> "=>" { mkT TDArrow }
<0> "=" { mkT TEquals }
<0> "," { mkT TComma }
<0> "(" { mkT TOpenParen }
<0> ")" { mkT TCloseParen }
<0> "(#" { mkT TOpenParenHash }
<0> "#)" { mkT THashCloseParen }
<0> "[" { mkT TOpenBracket }
<0> "]" { mkT TCloseBracket }
<0> "<" { mkT TOpenAngle }
<0> ">" { mkT TCloseAngle }
<0> "section" { mkT TSection }
<0> "primop" { mkT TPrimop }
<0> "pseudoop" { mkT TPseudoop }
<0> "primtype" { mkT TPrimtype }
<0> "with" { mkT TWith }
<0> "defaults" { mkT TDefaults }
<0> "True" { mkT TTrue }
<0> "False" { mkT TFalse }
<0> "Dyadic" { mkT TDyadic }
<0> "Monadic" { mkT TMonadic }
<0> "Compare" { mkT TCompare }
<0> "GenPrimOp" { mkT TGenPrimOp }
<0> "fixity" { mkT TFixity }
<0> "infix" { mkT TInfixN }
<0> "infixl" { mkT TInfixL }
<0> "infixr" { mkT TInfixR }
<0> "Nothing" { mkT TNothing }
<0> "vector" { mkT TVector }
<0> "thats_all_folks" { mkT TThatsAllFolks }
<0> "SCALAR" { mkT TSCALAR }
<0> "VECTOR" { mkT TVECTOR }
<0> "VECTUPLE" { mkT TVECTUPLE }
<0> [a-z][a-zA-Z0-9\#_]* { mkTv TLowerName }
<0> [A-Z][a-zA-Z0-9\#_]* { mkTv TUpperName }
<0> \-? [0-9][0-9]* { mkTv (TInteger . read) }
<0> \" [^\"]* \" { mkTv (TString . tail . init) }
<in_braces> [^\{\}]+ { mkTv TNoBraces }
<in_braces> \n { mkTv TNoBraces }
{
get_tok :: ParserM Token
get_tok = ParserM $ \i st ->
case alexScan i (start_code st) of
AlexEOF -> Right (i, st, TEOF)
AlexError _ -> Left ("Lexical error at " ++ show_pos (position i))
AlexSkip i' _ -> case get_tok of
ParserM f -> f i' st
AlexToken i' l a -> case a $ take l $ ParserM.input i of
ParserM f -> f i' st
lex_tok :: (Token -> ParserM a) -> ParserM a
lex_tok cont = get_tok >>= cont
}
|
