From 03ffa2bfa6c31dc6bcdcacecc2bdb3bbabd800a9 Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Tue, 10 Apr 2007 22:00:15 +0000 Subject: [PATCH] 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. --- utils/Makefile | 8 +- utils/genprimopcode/Lexer.x | 68 ++++++++ utils/genprimopcode/Main.hs | 367 +--------------------------------------- utils/genprimopcode/Makefile | 16 +- utils/genprimopcode/Parser.y | 155 +++++++++++++++++ utils/genprimopcode/ParserM.hs | 147 ++++++++++++++++ utils/genprimopcode/Syntax.hs | 128 ++++++++++++++ 7 files changed, 510 insertions(+), 379 deletions(-) create mode 100644 utils/genprimopcode/Lexer.x create mode 100644 utils/genprimopcode/Parser.y create mode 100644 utils/genprimopcode/ParserM.hs create mode 100644 utils/genprimopcode/Syntax.hs diff --git a/utils/Makefile b/utils/Makefile index b4a7ba1..b5a14af 100644 --- a/utils/Makefile +++ b/utils/Makefile @@ -22,7 +22,6 @@ ifneq "$(TARGETPLATFORM)" "i386-unknown-mingw32" SUBDIRS += lndir endif - # Utils that we don't build by default: # nofib-analyse @@ -43,3 +42,10 @@ endif # a Haskell compiler and if you want it. include $(TOP)/mk/target.mk + +# genprimopcode is needed to boot in ghc/compiler... +ifneq "$(BootingFromHc)" "YES" +boot :: + $(MAKE) -C genprimopcode +endif + diff --git a/utils/genprimopcode/Lexer.x b/utils/genprimopcode/Lexer.x new file mode 100644 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) } + [^\{\}]+ { mkTv TNoBraces } + \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 f957dbf..fa4973a 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 681480a..20c409a 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 0000000..a949765 --- /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 0000000..d70947b --- /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 0000000..64e7875 --- /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 + -- 1.7.10.4