X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fgenprimopcode%2FMain.hs;h=0e7c815f44d16b9e0b6b47a7f321bdea5827dc32;hb=84bd33df44c6f52c5517405dd1bb968a7ccdd154;hp=f957dbf1a728cb562b5352bc47cd3116734e028d;hpb=01eb02c3392ff9acb5e4207f2633776ad6b8780d;p=ghc-hetmet.git diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs index f957dbf..0e7c815 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" @@ -66,11 +62,6 @@ main = getArgs >>= \args -> "strictness" "primOpStrictness" p_o_specs) - "--usage" - -> putStr (gen_switch_from_attribs - "usage" - "primOpUsg" p_o_specs) - "--primop-primop-info" -> putStr (gen_primop_info p_o_specs) @@ -101,7 +92,6 @@ known_args "--needs-wrapper", "--can-fail", "--strictness", - "--usage", "--primop-primop-info", "--primop-tag", "--primop-list", @@ -263,7 +253,6 @@ gen_latex_doc (Info defaults entries) ++ mk_needs_wrapper o ++ "}{" ++ mk_can_fail o ++ "}{" ++ latex_encode (mk_strictness o) ++ "}{" - ++ latex_encode (mk_usage o) ++ "}" mk_has_side_effects o = mk_bool_opt o "has_side_effects" "Has side effects." "Has no side effects." @@ -285,12 +274,6 @@ gen_latex_doc (Info defaults entries) Just _ -> error "Boolean value for strictness" Nothing -> "" - mk_usage o = - case lookup_attrib "usage" o of - Just (OptionString _ s) -> s -- for now - Just _ -> error "Boolean value for usage" - Nothing -> "" - zencode xs = case maybe_tuple xs of Just n -> n -- Tuples go to Z2T etc @@ -550,358 +533,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 -- -------------------------------------------------------------------