Replace genprimopcode's parsec parser with an alex+happy parser

[ghc-hetmet.git] / utils / genprimopcode / Lexer.x

diff --git a/utils/genprimopcode/Lexer.x b/utils/genprimopcode/Lexer.x
new file mode 100644 (file)
index 0000000..19b0f66
--- /dev/null
+++ b/utils/genprimopcode/Lexer.x
@@ -0,0 +1,68 @@
+
+{
+module Lexer (lex_tok) where
+
+import Control.Monad.State (StateT, get)
+import ParserM (ParserM (..), mkT, mkTv, Token(..), St, start_code,
+                StartCode, Action, set_start_code,
+                inc_brace_depth, dec_brace_depth,
+                show_pos, position, input,
+                AlexInput, alexGetChar, alexInputPrevChar)
+}
+
+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 TEquals }
+    <0>         ","                 { mkT TComma }
+    <0>         "("                 { mkT TOpenParen }
+    <0>         ")"                 { mkT TCloseParen }
+    <0>         "(#"                { mkT TOpenParenHash }
+    <0>         "#)"                { mkT THashCloseParen }
+    <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>         "thats_all_folks"   { mkT TThatsAllFolks }
+    <0>         [a-z][a-zA-Z0-9\#_]* { mkTv TLowerName }
+    <0>         [A-Z][a-zA-Z0-9\#_]* { mkTv TUpperName }
+    <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 $ input i of
+                               ParserM f -> f i' st
+
+lex_tok :: (Token -> ParserM a) -> ParserM a
+lex_tok cont = get_tok >>= cont
+}
+