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

This use was the only thing keeping parsec in core-packages, and
we already have a dependency on alex+happy anyway.

6 files changed, 503 insertions, 378 deletions

diff --git a/utils/genprimopcode/Lexer.x b/utils/genprimopcode/Lexer.x
new file mode 100644
index 0000000000..19b0f667d6
--- /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
+}
+
diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs
index f957dbf1a7..fa4973a7af 100644
--- a/utils/genprimopcode/Main.hs
+++ b/utils/genprimopcode/Main.hs
@@ -5,11 +5,8 @@
 
 module Main where
 
-#if __GLASGOW_HASKELL__ >= 504
-import Text.ParserCombinators.Parsec
-#else
-import Parsec
-#endif
+import Parser
+import Syntax
 
 import Monad
 import Char
@@ -26,11 +23,10 @@ main = getArgs >>= \args ->
                   )
        else
        do s <- getContents
-          let pres = parse pTop "" s
-          case pres of
+          case parse s of
              Left err -> error ("parse error at " ++ (show err))
              Right p_o_specs
-                -> myseq (sanityTop p_o_specs) (
+                -> seq (sanityTop p_o_specs) (
                    case head args of
 
                       "--data-decl" 
@@ -550,358 +546,3 @@ tvsIn (TyUTup tys)   = concatMap tvsIn tys
 arity :: Ty -> Int
 arity = length . fst . flatTys
 
-------------------------------------------------------------------
--- Abstract syntax -----------------------------------------------
-------------------------------------------------------------------
-
--- info for all primops; the totality of the info in primops.txt(.pp)
-data Info
-   = Info [Option] [Entry]   -- defaults, primops
-     deriving Show
-
--- info for one primop
-data Entry
-    = PrimOpSpec { cons  :: String,      -- PrimOp name
-                   name  :: String,      -- name in prog text
-                   ty    :: Ty,          -- type
-                   cat   :: Category,    -- category
-		   desc  :: String,      -- description
-                   opts  :: [Option] }   -- default overrides
-    | PseudoOpSpec { name  :: String,      -- name in prog text
-                     ty    :: Ty,          -- type
-		     desc  :: String,      -- description
-                     opts  :: [Option] }   -- default overrides
-    | PrimTypeSpec { ty    :: Ty,      -- name in prog text
-		     desc  :: String,      -- description
-                     opts  :: [Option] }   -- default overrides
-    | Section { title :: String,	 -- section title
-		desc  :: String }        -- description
-    deriving Show
-
-is_primop :: Entry -> Bool
-is_primop (PrimOpSpec _ _ _ _ _ _) = True
-is_primop _ = False
-
--- a binding of property to value
-data Option
-   = OptionFalse  String          -- name = False
-   | OptionTrue   String          -- name = True
-   | OptionString String String   -- name = { ... unparsed stuff ... }
-     deriving Show
-
--- categorises primops
-data Category
-   = Dyadic | Monadic | Compare | GenPrimOp
-     deriving Show
-
--- types
-data Ty
-   = TyF    Ty Ty
-   | TyApp  TyCon [Ty]
-   | TyVar  TyVar
-   | TyUTup [Ty]   -- unboxed tuples; just a TyCon really, 
-                   -- but convenient like this
-   deriving (Eq,Show)
-
-type TyVar = String
-type TyCon = String
-
-
-------------------------------------------------------------------
--- Sanity checking -----------------------------------------------
-------------------------------------------------------------------
-
-{- Do some simple sanity checks:
-    * all the default field names are unique
-    * for each PrimOpSpec, all override field names are unique
-    * for each PrimOpSpec, all overriden field names   
-          have a corresponding default value
-    * that primop types correspond in certain ways to the 
-      Category: eg if Comparison, the type must be of the form
-         T -> T -> Bool.
-   Dies with "error" if there's a problem, else returns ().
--}
-myseq :: () -> a -> a
-myseq () x = x
-
-myseqAll :: [()] -> a -> a
-myseqAll (():ys) x = myseqAll ys x
-myseqAll []      x = x
-
-sanityTop :: Info -> ()
-sanityTop (Info defs entries)
-   = let opt_names = map get_attrib_name defs
-	 primops = filter is_primop entries
-     in  
-     if   length opt_names /= length (nub opt_names)
-     then error ("non-unique default attribute names: " ++ show opt_names ++ "\n")
-     else myseqAll (map (sanityPrimOp opt_names) primops) ()
-
-sanityPrimOp :: [String] -> Entry -> ()
-sanityPrimOp def_names p
-   = let p_names = map get_attrib_name (opts p)
-         p_names_ok
-            = length p_names == length (nub p_names)
-              && all (`elem` def_names) p_names
-         ty_ok = sane_ty (cat p) (ty p)
-     in
-         if   not p_names_ok
-         then error ("attribute names are non-unique or have no default in\n" ++
-                     "info for primop " ++ cons p ++ "\n")
-         else
-         if   not ty_ok
-         then error ("type of primop " ++ cons p ++ " doesn't make sense w.r.t" ++
-                     " category " ++ show (cat p) ++ "\n")
-         else ()
-
-sane_ty :: Category -> Ty -> Bool
-sane_ty Compare (TyF t1 (TyF t2 td)) 
-   | t1 == t2 && td == TyApp "Bool" []  = True
-sane_ty Monadic (TyF t1 td) 
-   | t1 == td  = True
-sane_ty Dyadic (TyF t1 (TyF t2 _))
-   | t1 == t2 && t2 == t2  = True
-sane_ty GenPrimOp _
-   = True
-sane_ty _ _
-   = False
-
-get_attrib_name :: Option -> String
-get_attrib_name (OptionFalse nm) = nm
-get_attrib_name (OptionTrue nm)  = nm
-get_attrib_name (OptionString nm _) = nm
-
-lookup_attrib :: String -> [Option] -> Maybe Option
-lookup_attrib _ [] = Nothing
-lookup_attrib nm (a:as) 
-    = if get_attrib_name a == nm then Just a else lookup_attrib nm as
-
-------------------------------------------------------------------
--- The parser ----------------------------------------------------
-------------------------------------------------------------------
-
-keywords :: [String]
-keywords = [ "section", "primop", "pseudoop", "primtype", "with"]
-
--- Due to lack of proper lexing facilities, a hack to zap any
--- leading comments
-pTop :: Parser Info
-pTop = then4 (\_ ds es _ -> Info ds es) 
-             pCommentAndWhitespace pDefaults (many pEntry)
-             (lit "thats_all_folks")
-
-pEntry :: Parser Entry
-pEntry 
-  = alts [pPrimOpSpec, pPrimTypeSpec, pPseudoOpSpec, pSection]
-
-pSection :: Parser Entry
-pSection = then3 (\_ n d -> Section {title = n, desc = d}) 
-		 (lit "section") stringLiteral pDesc
-
-pDefaults :: Parser [Option]
-pDefaults = then2 sel22 (lit "defaults") (many pOption)
-
-pOption :: Parser Option
-pOption 
-   = alts [
-        then3 (\nm _ _  -> OptionFalse nm)  pName (lit "=") (lit "False"),
-        then3 (\nm _ _  -> OptionTrue nm)   pName (lit "=") (lit "True"),
-        then3 (\nm _ zz -> OptionString nm zz)
-              pName (lit "=") pStuffBetweenBraces
-     ]
-
-pPrimOpSpec :: Parser Entry
-pPrimOpSpec
-   = then7 (\_ c n k t d o -> PrimOpSpec { cons = c, name = n, ty = t, 
-                                           cat = k, desc = d, opts = o } )
-           (lit "primop") pConstructor stringLiteral 
-           pCategory pType pDesc pOptions
-
-pPrimTypeSpec :: Parser Entry
-pPrimTypeSpec
-   = then4 (\_ t d o -> PrimTypeSpec { ty = t, desc = d, opts = o } )
-           (lit "primtype") pType pDesc pOptions
-
-pPseudoOpSpec :: Parser Entry
-pPseudoOpSpec
-   = then5 (\_ n t d o -> PseudoOpSpec { name = n, ty = t, desc = d,
-					     opts = o } )
-           (lit "pseudoop") stringLiteral pType pDesc pOptions
-
-pOptions :: Parser [Option]
-pOptions = pOptDef [] (then2 sel22 (lit "with") (many pOption))
-
-pCategory :: Parser Category
-pCategory 
-   = alts [
-        apply (const Dyadic)    (lit "Dyadic"),
-        apply (const Monadic)   (lit "Monadic"),
-        apply (const Compare)   (lit "Compare"),
-        apply (const GenPrimOp) (lit "GenPrimOp")
-     ]
-
-pDesc :: Parser String
-pDesc = pOptDef "" pStuffBetweenBraces
-
-pStuffBetweenBraces :: Parser String
-pStuffBetweenBraces
-    = lexeme (
-	do char '{'
-	   ass <- many pInsides
-	   char '}'
-           return (concat ass) )
-
-pInsides :: Parser String
-pInsides 
-    = (do char '{' 
-	  stuff <- many pInsides
-          char '}'
-          return ("{" ++ (concat stuff) ++ "}"))
-      <|> 
-      (do c <- satisfy (/= '}')
-          return [c])
-
--------------------
--- Parsing types --
--------------------
-
-pType :: Parser Ty
-pType = then2 (\t maybe_tt -> case maybe_tt of 
-                                 Just tt -> TyF t tt
-                                 Nothing -> t)
-              paT 
-              (pOpt (then2 sel22 (lit "->") pType))
-
--- Atomic types
-paT :: Parser Ty
-paT = alts [ then2 TyApp pTycon (many ppT),
-             pUnboxedTupleTy,
-             then3 sel23 (lit "(") pType (lit ")"),
-             ppT 
-      ]
-
--- the magic bit in the middle is:  T (,T)*  so to speak
-pUnboxedTupleTy :: Parser Ty
-pUnboxedTupleTy
-   = then3 (\ _ ts _ -> TyUTup ts)
-           (lit "(#")
-           (then2 (:) pType (many (then2 sel22 (lit ",") pType)))
-           (lit "#)")
-
--- Primitive types
-ppT :: Parser Ty
-ppT = alts [apply TyVar pTyvar,
-            apply (\tc -> TyApp tc []) pTycon
-           ]
-
-pTyvar :: Parser String
-pTyvar       = sat (`notElem` keywords) pName
-
-pTycon :: Parser String
-pTycon       = alts [pConstructor, lexeme (string "()")]
-
-pName :: Parser String
-pName        = lexeme (then2 (:) lower (many isIdChar))
-
-pConstructor :: Parser String
-pConstructor = lexeme (then2 (:) upper (many isIdChar))
-
-isIdChar :: Parser Char
-isIdChar = satisfy (`elem` idChars)
-
-idChars :: [Char]
-idChars  = ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9'] ++ "#_"
-
-sat :: (a -> Bool) -> Parser a -> Parser a
-sat predicate p
-   = do x <- try p
-        if predicate x
-         then return x
-         else pzero
-
-------------------------------------------------------------------
--- Helpful additions to Daan's parser stuff ----------------------
-------------------------------------------------------------------
-
-alts :: [Parser a] -> Parser a
-alts []         = pzero
-alts [p1]       = try p1
-alts (p1:p2:ps) = (try p1) <|> alts (p2:ps)
-
-then2 :: (a -> b -> c) -> Parser a -> Parser b -> Parser c
-then2 f p1 p2 
-   = do x1 <- p1 ; x2 <- p2 ; return (f x1 x2)
-
-then3 :: (a -> b -> c -> d) -> Parser a -> Parser b -> Parser c -> Parser d
-then3 f p1 p2 p3
-   = do x1 <- p1 ; x2 <- p2 ; x3 <- p3 ; return (f x1 x2 x3)
-
-then4 :: (a -> b -> c -> d -> e) -> Parser a -> Parser b -> Parser c -> Parser d -> Parser e
-then4 f p1 p2 p3 p4
-   = do x1 <- p1 ; x2 <- p2 ; x3 <- p3 ; x4 <- p4 ; return (f x1 x2 x3 x4)
-
-then5 :: (a -> b -> c -> d -> e -> f) -> Parser a -> Parser b -> Parser c -> Parser d -> Parser e -> Parser f
-then5 f p1 p2 p3 p4 p5
-   = do x1 <- p1 ; x2 <- p2 ; x3 <- p3 ; x4 <- p4 ; x5 <- p5
-        return (f x1 x2 x3 x4 x5)
-
-then6 :: (a -> b -> c -> d -> e -> f -> g) -> Parser a -> Parser b -> Parser c -> Parser d -> Parser e -> Parser f -> Parser g
-then6 f p1 p2 p3 p4 p5 p6
-   = do x1 <- p1 ; x2 <- p2 ; x3 <- p3 ; x4 <- p4 ; x5 <- p5 ; x6 <- p6
-        return (f x1 x2 x3 x4 x5 x6)
-
-then7 :: (a -> b -> c -> d -> e -> f -> g -> h) -> Parser a -> Parser b -> Parser c -> Parser d -> Parser e -> Parser f -> Parser g -> Parser h
-then7 f p1 p2 p3 p4 p5 p6 p7
-   = do x1 <- p1 ; x2 <- p2 ; x3 <- p3 ; x4 <- p4 ; x5 <- p5 ; x6 <- p6 ; x7 <- p7
-        return (f x1 x2 x3 x4 x5 x6 x7)
-
-pOpt :: Parser a -> Parser (Maybe a)
-pOpt p
-   = (do x <- p; return (Just x)) <|> return Nothing
-
-pOptDef :: a -> Parser a -> Parser a
-pOptDef d p
-   = (do x <- p; return x) <|> return d
-
-sel12 :: a -> b -> a
-sel12 a _ = a
-
-sel22 :: a -> b -> b
-sel22 _ b = b
-
-sel23 :: a -> b -> c -> b
-sel23 _ b _ = b
-
-apply :: (a -> b) -> Parser a -> Parser b
-apply f p = liftM f p
-
--- Hacks for zapping whitespace and comments, unfortunately needed
--- because Daan won't let us have a lexer before the parser :-(
-lexeme  :: Parser p -> Parser p
-lexeme p = then2 sel12 p pCommentAndWhitespace
-
-lit :: String -> Parser ()
-lit s = apply (const ()) (lexeme (string s))
-
-pCommentAndWhitespace :: Parser ()
-pCommentAndWhitespace
-   = apply (const ()) (many (alts [pLineComment, 
-                                   apply (const ()) (satisfy isSpace)]))
-     <|>
-     return ()
-
-pLineComment :: Parser ()
-pLineComment
-   = try (then3 (\_ _ _ -> ()) (string "--") (many (satisfy (/= '\n'))) (char '\n'))
-
-stringLiteral :: Parser String
-stringLiteral   = lexeme (
-                      do { between (char '"')                   
-                                   (char '"' <?> "end of string")
-                                   (many (noneOf "\"")) 
-                         }
-                      <?> "literal string")
-
-------------------------------------------------------------------
--- end                                                          --
-------------------------------------------------------------------
diff --git a/utils/genprimopcode/Makefile b/utils/genprimopcode/Makefile
index 681480a8be..20c409a422 100644
--- a/utils/genprimopcode/Makefile
+++ b/utils/genprimopcode/Makefile
@@ -3,19 +3,5 @@ include $(TOP)/mk/boilerplate.mk
 
 HS_PROG = genprimopcode
 
-SRC_HC_OPTS += -Wall
-
-ifeq "$(ghc_ge_504)" "NO"
-SRC_HC_OPTS += -package text
-endif
-
-ifeq "$(ghc_ge_602)" "YES"
-SRC_HC_OPTS += -package parsec
-endif
-
-# genprimopcode is needed to boot in ghc/compiler...
-ifneq "$(BootingFromHc)" "YES"
-boot :: all
-endif
-
 include $(TOP)/mk/target.mk
+
diff --git a/utils/genprimopcode/Parser.y b/utils/genprimopcode/Parser.y
new file mode 100644
index 0000000000..a949765526
--- /dev/null
+++ b/utils/genprimopcode/Parser.y
@@ -0,0 +1,155 @@
+
+{
+module Parser (parse) where
+
+import Lexer (lex_tok)
+import ParserM (Token(..), ParserM, run_parser, get_pos, show_pos,
+                happyError)
+import Syntax
+}
+
+%name      parsex
+%tokentype { Token }
+%monad     { ParserM }
+%lexer     { lex_tok } { TEOF }
+
+%token
+    '->'            { TArrow }
+    '='             { TEquals }
+    ','             { TComma }
+    '('             { TOpenParen }
+    ')'             { TCloseParen }
+    '(#'            { TOpenParenHash }
+    '#)'            { THashCloseParen }
+    '{'             { TOpenBrace }
+    '}'             { TCloseBrace }
+    section         { TSection }
+    primop          { TPrimop }
+    pseudoop        { TPseudoop }
+    primtype        { TPrimtype }
+    with            { TWith }
+    defaults        { TDefaults }
+    true            { TTrue }
+    false           { TFalse }
+    dyadic          { TDyadic }
+    monadic         { TMonadic }
+    compare         { TCompare }
+    genprimop       { TGenPrimOp }
+    thats_all_folks { TThatsAllFolks }
+    lowerName       { TLowerName $$ }
+    upperName       { TUpperName $$ }
+    string          { TString $$ }
+    noBraces        { TNoBraces $$ }
+
+%%
+
+info :: { Info }
+info : pDefaults pEntries thats_all_folks { Info $1 $2 }
+
+pDefaults :: { [Option] }
+pDefaults : defaults pOptions { $2 }
+
+pOptions :: { [Option] }
+pOptions : pOption pOptions { $1 : $2 }
+         | {- empty -}      { [] }
+
+pOption :: { Option }
+pOption : lowerName '=' false               { OptionFalse  $1 }
+        | lowerName '=' true                { OptionTrue   $1 }
+        | lowerName '=' pStuffBetweenBraces { OptionString $1 $3 }
+
+pEntries :: { [Entry] }
+pEntries : pEntry pEntries { $1 : $2 }
+         | {- empty -}   { [] }
+
+pEntry :: { Entry }
+pEntry : pPrimOpSpec   { $1 }
+       | pPrimTypeSpec { $1 }
+       | pPseudoOpSpec { $1 }
+       | pSection      { $1 }
+
+pPrimOpSpec :: { Entry }
+pPrimOpSpec : primop upperName string pCategory pType
+              pDesc pWithOptions
+              { PrimOpSpec {
+                    cons = $2,
+                    name = $3,
+                    cat = $4,
+                    ty = $5,
+                    desc = $6,
+                    opts = $7
+                }
+              }
+
+pPrimTypeSpec :: { Entry }
+pPrimTypeSpec : primtype pType pDesc pWithOptions
+                { PrimTypeSpec { ty = $2, desc = $3, opts = $4 } }
+
+pPseudoOpSpec :: { Entry }
+pPseudoOpSpec : pseudoop string pType pDesc pWithOptions
+                { PseudoOpSpec { name = $2, ty = $3, desc = $4, opts = $5 } }
+
+pSection :: { Entry }
+pSection : section string pDesc { Section { title = $2, desc = $3 } }
+
+pWithOptions :: { [Option] }
+pWithOptions : with pOptions { $2 }
+             | {- empty -}   { [] }
+
+pCategory :: { Category }
+pCategory : dyadic { Dyadic }
+          | monadic { Monadic }
+          | compare { Compare }
+          | genprimop { GenPrimOp }
+
+pDesc :: { String }
+pDesc : pStuffBetweenBraces { $1 }
+      | {- empty -}         { "" }
+
+pStuffBetweenBraces :: { String }
+pStuffBetweenBraces : '{' pInsides '}' { $2 }
+
+pInsides :: { String }
+pInsides : pInside pInsides { $1 ++ $2 }
+         | {- empty -}      { "" }
+
+pInside :: { String }
+pInside : '{' pInsides '}' { "{" ++ $2 ++ "}" }
+        | noBraces         { $1 }
+
+pType :: { Ty }
+pType : paT '->' pType { TyF $1 $3 }
+      | paT            { $1 }
+
+-- Atomic types
+paT :: { Ty }
+paT : pTycon ppTs     { TyApp $1 $2 }
+    | pUnboxedTupleTy { $1 }
+    | '(' pType ')'   { $2 }
+    | lowerName       { TyVar $1 }
+
+pUnboxedTupleTy :: { Ty }
+pUnboxedTupleTy : '(#' pCommaTypes '#)' { TyUTup $2 }
+
+pCommaTypes :: { [Ty] }
+pCommaTypes : pType ',' pCommaTypes { $1 : $3 }
+            | pType                 { [$1] }
+
+ppTs :: { [Ty] }
+ppTs : ppT ppTs    { $1 : $2 }
+     | {- empty -} { [] }
+
+-- Primitive types
+ppT :: { Ty }
+ppT : lowerName { TyVar $1 }
+    | pTycon    { TyApp $1 [] }
+
+pTycon :: { String }
+pTycon : upperName { $1 }
+       | '(' ')'   { "()" }
+
+{
+parse :: String -> Either String Info
+parse = run_parser parsex
+}
+
diff --git a/utils/genprimopcode/ParserM.hs b/utils/genprimopcode/ParserM.hs
new file mode 100644
index 0000000000..d70947bb8e
--- /dev/null
+++ b/utils/genprimopcode/ParserM.hs
@@ -0,0 +1,147 @@
+
+module ParserM (
+    -- Parser Monad
+    ParserM(..), AlexInput, run_parser,
+    -- Parser state
+    St,
+    StartCode, start_code, set_start_code,
+    inc_brace_depth, dec_brace_depth,
+    -- Tokens
+    Token(..),
+    -- Actions
+    Action, andBegin, mkT, mkTv,
+    -- Positions
+    get_pos, show_pos,
+    -- Input
+    alexGetChar, alexInputPrevChar, input, position,
+    -- Other
+    happyError
+ ) where
+
+import Syntax
+
+-- Parser Monad
+newtype ParserM a = ParserM (AlexInput -> St -> Either String (AlexInput, St, a))
+
+instance Monad ParserM where
+    ParserM m >>= k = ParserM $ \i s -> case m i s of
+                                            Right (i', s', x) ->
+                                                case k x of
+                                                    ParserM y -> y i' s'
+                                            Left err ->
+                                                Left err
+    return a = ParserM $ \i s -> Right (i, s, a)
+    fail err = ParserM $ \_ _ -> Left err
+
+run_parser :: ParserM a -> (String -> Either String a)
+run_parser (ParserM f)
+ = \s -> case f (AlexInput init_pos s) init_state of
+             Left es -> Left es
+             Right (_, _, x) -> Right x
+
+-- Parser state
+
+data St = St {
+              start_code :: !StartCode,
+              brace_depth :: !Int
+          }
+    deriving Show
+type StartCode = Int
+
+init_state :: St
+init_state = St {
+                 start_code = 0,
+                 brace_depth = 0
+             }
+
+-- Tokens
+
+data Token = TEOF
+           | TArrow
+           | TEquals
+           | TComma
+           | TOpenParen
+           | TCloseParen
+           | TOpenParenHash
+           | THashCloseParen
+           | TOpenBrace
+           | TCloseBrace
+           | TSection
+           | TPrimop
+           | TPseudoop
+           | TPrimtype
+           | TWith
+           | TDefaults
+           | TTrue
+           | TFalse
+           | TDyadic
+           | TMonadic
+           | TCompare
+           | TGenPrimOp
+           | TThatsAllFolks
+           | TLowerName String
+           | TUpperName String
+           | TString String
+           | TNoBraces String
+    deriving Show
+
+-- Actions
+
+type Action = String -> ParserM Token
+
+set_start_code :: StartCode -> ParserM ()
+set_start_code sc = ParserM $ \i st -> Right (i, st { start_code = sc }, ())
+
+inc_brace_depth :: ParserM ()
+inc_brace_depth = ParserM $ \i st ->
+                  Right (i, st { brace_depth = brace_depth st + 1 }, ())
+
+dec_brace_depth :: ParserM ()
+dec_brace_depth = ParserM $ \i st ->
+                  let bd = brace_depth st - 1
+                      sc = if bd == 0 then 0 else 1
+                  in Right (i, st { brace_depth = bd, start_code = sc }, ())
+
+andBegin :: Action -> StartCode -> Action
+(act `andBegin` sc) x = do set_start_code sc
+                           act x
+
+mkT :: Token -> Action
+mkT t = mkTv (const t)
+
+mkTv :: (String -> Token) -> Action
+mkTv f str = ParserM (\i st -> Right (i, st, f str))
+
+-- Positions
+
+data Pos = Pos !Int{- Line -} !Int{- Column -}
+
+get_pos :: ParserM Pos
+get_pos = ParserM $ \i@(AlexInput p _) st -> Right (i, st, p)
+
+alexMove :: Pos -> Char -> Pos
+alexMove (Pos l _) '\n' = Pos (l+1) 1
+alexMove (Pos l c) '\t' = Pos l ((c+8) `div` 8 * 8)
+alexMove (Pos l c) _    = Pos l (c+1)
+
+init_pos :: Pos
+init_pos = Pos 1 1
+
+show_pos :: Pos -> String
+show_pos (Pos l c) = "line " ++ show l ++ ", column " ++ show c
+
+-- Input
+
+data AlexInput = AlexInput {position :: !Pos, input :: String}
+
+alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
+alexGetChar (AlexInput p (x:xs)) = Just (x, AlexInput (alexMove p x) xs)
+alexGetChar (AlexInput _ []) = Nothing
+
+alexInputPrevChar :: AlexInput -> Char
+alexInputPrevChar _ = error "Lexer doesn't implement alexInputPrevChar"
+
+happyError :: ParserM a
+happyError = do p <- get_pos
+                fail $ "Parse error at " ++ show_pos p
+
diff --git a/utils/genprimopcode/Syntax.hs b/utils/genprimopcode/Syntax.hs
new file mode 100644
index 0000000000..64e7875a40
--- /dev/null
+++ b/utils/genprimopcode/Syntax.hs
@@ -0,0 +1,128 @@
+
+module Syntax where
+
+import Data.List
+
+------------------------------------------------------------------
+-- Abstract syntax -----------------------------------------------
+------------------------------------------------------------------
+
+-- info for all primops; the totality of the info in primops.txt(.pp)
+data Info
+   = Info [Option] [Entry]   -- defaults, primops
+     deriving Show
+
+-- info for one primop
+data Entry
+    = PrimOpSpec { cons  :: String,      -- PrimOp name
+                   name  :: String,      -- name in prog text
+                   ty    :: Ty,          -- type
+                   cat   :: Category,    -- category
+		   desc  :: String,      -- description
+                   opts  :: [Option] }   -- default overrides
+    | PseudoOpSpec { name  :: String,      -- name in prog text
+                     ty    :: Ty,          -- type
+		     desc  :: String,      -- description
+                     opts  :: [Option] }   -- default overrides
+    | PrimTypeSpec { ty    :: Ty,      -- name in prog text
+		     desc  :: String,      -- description
+                     opts  :: [Option] }   -- default overrides
+    | Section { title :: String,	 -- section title
+		desc  :: String }        -- description
+    deriving Show
+
+is_primop :: Entry -> Bool
+is_primop (PrimOpSpec _ _ _ _ _ _) = True
+is_primop _ = False
+
+-- a binding of property to value
+data Option
+   = OptionFalse  String          -- name = False
+   | OptionTrue   String          -- name = True
+   | OptionString String String   -- name = { ... unparsed stuff ... }
+     deriving Show
+
+-- categorises primops
+data Category
+   = Dyadic | Monadic | Compare | GenPrimOp
+     deriving Show
+
+-- types
+data Ty
+   = TyF    Ty Ty
+   | TyApp  TyCon [Ty]
+   | TyVar  TyVar
+   | TyUTup [Ty]   -- unboxed tuples; just a TyCon really, 
+                   -- but convenient like this
+   deriving (Eq,Show)
+
+type TyVar = String
+type TyCon = String
+
+
+------------------------------------------------------------------
+-- Sanity checking -----------------------------------------------
+------------------------------------------------------------------
+
+{- Do some simple sanity checks:
+    * all the default field names are unique
+    * for each PrimOpSpec, all override field names are unique
+    * for each PrimOpSpec, all overriden field names   
+          have a corresponding default value
+    * that primop types correspond in certain ways to the 
+      Category: eg if Comparison, the type must be of the form
+         T -> T -> Bool.
+   Dies with "error" if there's a problem, else returns ().
+-}
+myseqAll :: [()] -> a -> a
+myseqAll (():ys) x = myseqAll ys x
+myseqAll []      x = x
+
+sanityTop :: Info -> ()
+sanityTop (Info defs entries)
+   = let opt_names = map get_attrib_name defs
+	 primops = filter is_primop entries
+     in  
+     if   length opt_names /= length (nub opt_names)
+     then error ("non-unique default attribute names: " ++ show opt_names ++ "\n")
+     else myseqAll (map (sanityPrimOp opt_names) primops) ()
+
+sanityPrimOp :: [String] -> Entry -> ()
+sanityPrimOp def_names p
+   = let p_names = map get_attrib_name (opts p)
+         p_names_ok
+            = length p_names == length (nub p_names)
+              && all (`elem` def_names) p_names
+         ty_ok = sane_ty (cat p) (ty p)
+     in
+         if   not p_names_ok
+         then error ("attribute names are non-unique or have no default in\n" ++
+                     "info for primop " ++ cons p ++ "\n")
+         else
+         if   not ty_ok
+         then error ("type of primop " ++ cons p ++ " doesn't make sense w.r.t" ++
+                     " category " ++ show (cat p) ++ "\n")
+         else ()
+
+sane_ty :: Category -> Ty -> Bool
+sane_ty Compare (TyF t1 (TyF t2 td)) 
+   | t1 == t2 && td == TyApp "Bool" []  = True
+sane_ty Monadic (TyF t1 td) 
+   | t1 == td  = True
+sane_ty Dyadic (TyF t1 (TyF t2 _))
+   | t1 == t2 && t2 == t2  = True
+sane_ty GenPrimOp _
+   = True
+sane_ty _ _
+   = False
+
+get_attrib_name :: Option -> String
+get_attrib_name (OptionFalse nm) = nm
+get_attrib_name (OptionTrue nm)  = nm
+get_attrib_name (OptionString nm _) = nm
+
+lookup_attrib :: String -> [Option] -> Maybe Option
+lookup_attrib _ [] = Nothing
+lookup_attrib nm (a:as) 
+    = if get_attrib_name a == nm then Just a else lookup_attrib nm as
+