X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=utils%2Fgenprimopcode%2FMain.hs;h=d228045ad945442e90dad1135f83654f4f7d66c7;hp=16f2d4445553853773415770c5a842d028bdeb56;hb=b84b5969798530dbf5be9b8bb795b77e5dfbf042;hpb=604539cd8f4577198535d30d61e3c9e4f20e2745 diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs index 16f2d44..d228045 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 @@ -17,6 +14,7 @@ import List import System ( getArgs ) import Maybe ( catMaybes ) +main :: IO () main = getArgs >>= \args -> if length args /= 1 || head args `notElem` known_args then error ("usage: genprimopcode command < primops.txt > ...\n" @@ -25,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) ( + Right p_o_specs@(Info _ entries) + -> seq (sanityTop p_o_specs) ( case head args of "--data-decl" @@ -65,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) @@ -85,11 +77,16 @@ main = getArgs >>= \args -> "--make-haskell-source" -> putStr (gen_hs_source p_o_specs) + "--make-ext-core-source" + -> putStr (gen_ext_core_source entries) + "--make-latex-doc" -> putStr (gen_latex_doc p_o_specs) - ) + _ -> error "Should not happen, known_args out of sync?" + ) +known_args :: [String] known_args = [ "--data-decl", "--has-side-effects", @@ -98,12 +95,12 @@ known_args "--needs-wrapper", "--can-fail", "--strictness", - "--usage", "--primop-primop-info", "--primop-tag", "--primop-list", "--make-haskell-wrappers", "--make-haskell-source", + "--make-ext-core-source", "--make-latex-doc" ] @@ -111,10 +108,11 @@ known_args -- Code generators ----------------------------------------------- ------------------------------------------------------------------ +gen_hs_source :: Info -> String gen_hs_source (Info defaults entries) = "-----------------------------------------------------------------------------\n" ++ "-- |\n" - ++ "-- Module : GHC.Arr\n" + ++ "-- Module : GHC.Prim\n" ++ "-- \n" ++ "-- Maintainer : cvs-ghc@haskell.org\n" ++ "-- Stability : internal\n" @@ -136,8 +134,9 @@ gen_hs_source (Info defaults entries) = hdr (PrimOpSpec { name = n }) = wrapOp n ++ "," hdr (PseudoOpSpec { name = n }) = wrapOp n ++ "," hdr (PrimTypeSpec { ty = TyApp n _ }) = wrapTy n ++ "," + hdr (PrimTypeSpec {}) = error "Illegal type spec" - ent s@(Section {}) = "" + ent (Section {}) = "" ent o@(PrimOpSpec {}) = spec o ent o@(PrimTypeSpec {}) = spec o ent o@(PseudoOpSpec {}) = spec o @@ -150,6 +149,7 @@ gen_hs_source (Info defaults entries) = PrimOpSpec { name = n, ty = t } -> wrapOp n ++ " :: " ++ pty t PseudoOpSpec { name = n, ty = t } -> wrapOp n ++ " :: " ++ pty t PrimTypeSpec { ty = t } -> "data " ++ pty t + Section { } -> "" comm = case (desc o) of [] -> "" @@ -175,7 +175,7 @@ gen_hs_source (Info defaults entries) = '{':'\\':'i':'t':cs -> markup "/" "/" cs c : cs -> c : unlatex cs [] -> [] - markup s t cs = s ++ mk (dropWhile isSpace cs) + markup s t xs = s ++ mk (dropWhile isSpace xs) where mk "" = t mk ('\n':cs) = ' ' : mk cs mk ('}':cs) = t ++ unlatex cs @@ -183,27 +183,165 @@ gen_hs_source (Info defaults entries) = escape = concatMap (\c -> if c `elem` special then '\\':c:[] else c:[]) where special = "/'`\"@<" +-- Generates the type environment that the stand-alone External Core tools use. +gen_ext_core_source :: [Entry] -> String +gen_ext_core_source entries = + "-----------------------------------------------------------------------\n" + ++ "-- This module is automatically generated by the GHC utility\n" + ++ "-- \"genprimopcode\". Do not edit!\n" + ++ "-----------------------------------------------------------------------\n" + ++ "module Language.Core.PrimEnv(primTcs, primVals, intLitTypes, ratLitTypes," + ++ "\n charLitTypes, stringLitTypes) where\nimport Language.Core.Core" + ++ "\nimport Language.Core.Encoding\n\n" + ++ "primTcs :: [(Tcon, Kind)]\n" + ++ "primTcs = [\n" + ++ printList tcEnt entries + ++ " ]\n" + ++ "primVals :: [(Var, Ty)]\n" + ++ "primVals = [\n" + ++ printList valEnt entries + ++ "]\n" + ++ "intLitTypes :: [Ty]\n" + ++ "intLitTypes = [\n" + ++ printList tyEnt (intLitTys entries) + ++ "]\n" + ++ "ratLitTypes :: [Ty]\n" + ++ "ratLitTypes = [\n" + ++ printList tyEnt (ratLitTys entries) + ++ "]\n" + ++ "charLitTypes :: [Ty]\n" + ++ "charLitTypes = [\n" + ++ printList tyEnt (charLitTys entries) + ++ "]\n" + ++ "stringLitTypes :: [Ty]\n" + ++ "stringLitTypes = [\n" + ++ printList tyEnt (stringLitTys entries) + ++ "]\n\n" + + where printList f = concat . intersperse ",\n" . filter (not . null) . map f + tcEnt (PrimTypeSpec {ty=t}) = + case t of + TyApp tc args -> parens tc (tcKind tc args) + _ -> error ("tcEnt: type in PrimTypeSpec is not a type" + ++ " constructor: " ++ show t) + tcEnt _ = "" + -- hack alert! + -- The primops.txt.pp format doesn't have enough information in it to + -- print out some of the information that ext-core needs (like kinds, + -- and later on in this code, module names) so we special-case. An + -- alternative would be to refer to things indirectly and hard-wire + -- certain things (e.g., the kind of the Any constructor, here) into + -- ext-core's Prims module again. + tcKind "Any" _ = "Klifted" + tcKind tc [] | last tc == '#' = "Kunlifted" + tcKind tc [] | otherwise = "Klifted" + -- assumes that all type arguments are lifted (are they?) + tcKind tc (v:as) = "(Karrow Klifted " ++ tcKind tc as + ++ ")" + valEnt (PseudoOpSpec {name=n, ty=t}) = valEntry n t + valEnt (PrimOpSpec {name=n, ty=t}) = valEntry n t + valEnt _ = "" + valEntry name ty = parens name (mkForallTy (freeTvars ty) (pty ty)) + where pty (TyF t1 t2) = mkFunTy (pty t1) (pty t2) + pty (TyApp tc ts) = mkTconApp (mkTcon tc) (map pty ts) + pty (TyUTup ts) = mkUtupleTy (map pty ts) + pty (TyVar tv) = paren $ "Tvar \"" ++ tv ++ "\"" + + mkFunTy s1 s2 = "Tapp " ++ (paren ("Tapp (Tcon tcArrow)" + ++ " " ++ paren s1)) + ++ " " ++ paren s2 + mkTconApp tc args = foldl tapp tc args + mkTcon tc = paren $ "Tcon " ++ paren (qualify True tc) + mkUtupleTy args = foldl tapp (tcUTuple (length args)) args + mkForallTy [] t = t + mkForallTy vs t = foldr + (\ v s -> "Tforall " ++ + (paren (quot v ++ ", " ++ vKind v)) ++ " " + ++ paren s) t vs + + -- hack alert! + vKind "o" = "Kopen" + vKind _ = "Klifted" + + freeTvars (TyF t1 t2) = freeTvars t1 `union` freeTvars t2 + freeTvars (TyApp _ tys) = freeTvarss tys + freeTvars (TyVar v) = [v] + freeTvars (TyUTup tys) = freeTvarss tys + freeTvarss = nub . concatMap freeTvars + + tapp s nextArg = paren $ "Tapp " ++ s ++ " " ++ paren nextArg + tcUTuple n = paren $ "Tcon " ++ paren (qualify False $ "Z" + ++ show n ++ "H") + + tyEnt (PrimTypeSpec {ty=(TyApp tc args)}) = " " ++ paren ("Tcon " ++ + (paren (qualify True tc))) + tyEnt _ = "" + + -- more hacks. might be better to do this on the ext-core side, + -- as per earlier comment + qualify _ tc | tc == "ByteArr#" = qualify True "ByteArray#" + qualify _ tc | tc == "MutArr#" = qualify True "MutableArray#" + qualify _ tc | tc == "MutByteArr#" = + qualify True "MutableByteArray#" + qualify _ tc | tc == "Bool" = "Just boolMname" ++ ", " + ++ ze True tc + qualify _ tc | tc == "()" = "Just baseMname" ++ ", " + ++ ze True tc + qualify enc tc = "Just primMname" ++ ", " ++ (ze enc tc) + ze enc tc = (if enc then "zEncodeString " else "") + ++ "\"" ++ tc ++ "\"" + + intLitTys = prefixes ["Int", "Word", "Addr", "Char"] + ratLitTys = prefixes ["Float", "Double"] + charLitTys = prefixes ["Char"] + stringLitTys = prefixes ["Addr"] + prefixes ps = filter (\ t -> + case t of + (PrimTypeSpec {ty=(TyApp tc args)}) -> + any (\ p -> p `isPrefixOf` tc) ps + _ -> False) + + parens n ty = " (zEncodeString \"" ++ n ++ "\", " ++ ty ++ ")" + paren s = "(" ++ s ++ ")" + quot s = "\"" ++ s ++ "\"" + +gen_latex_doc :: Info -> String gen_latex_doc (Info defaults entries) = "\\primopdefaults{" ++ mk_options defaults ++ "}\n" ++ (concat (map mk_entry entries)) - where mk_entry (PrimOpSpec {cons=cons,name=name,ty=ty,cat=cat,desc=desc,opts=opts}) = + where mk_entry (PrimOpSpec {cons=constr,name=n,ty=t,cat=c,desc=d,opts=o}) = "\\primopdesc{" - ++ latex_encode cons ++ "}{" - ++ latex_encode name ++ "}{" - ++ latex_encode (zencode name) ++ "}{" - ++ latex_encode (show cat) ++ "}{" - ++ latex_encode (mk_source_ty ty) ++ "}{" - ++ latex_encode (mk_core_ty ty) ++ "}{" - ++ desc ++ "}{" - ++ mk_options opts + ++ latex_encode constr ++ "}{" + ++ latex_encode n ++ "}{" + ++ latex_encode (zencode n) ++ "}{" + ++ latex_encode (show c) ++ "}{" + ++ latex_encode (mk_source_ty t) ++ "}{" + ++ latex_encode (mk_core_ty t) ++ "}{" + ++ d ++ "}{" + ++ mk_options o ++ "}\n" - mk_entry (Section {title=title,desc=desc}) = + mk_entry (Section {title=ti,desc=d}) = "\\primopsection{" - ++ latex_encode title ++ "}{" - ++ desc ++ "}\n" - mk_source_ty t = pty t + ++ latex_encode ti ++ "}{" + ++ d ++ "}\n" + mk_entry (PrimTypeSpec {ty=t,desc=d,opts=o}) = + "\\primtypespec{" + ++ latex_encode (mk_source_ty t) ++ "}{" + ++ latex_encode (mk_core_ty t) ++ "}{" + ++ d ++ "}{" + ++ mk_options o + ++ "}\n" + mk_entry (PseudoOpSpec {name=n,ty=t,desc=d,opts=o}) = + "\\pseudoopspec{" + ++ latex_encode (zencode n) ++ "}{" + ++ latex_encode (mk_source_ty t) ++ "}{" + ++ latex_encode (mk_core_ty t) ++ "}{" + ++ d ++ "}{" + ++ mk_options o + ++ "}\n" + mk_source_ty typ = pty typ where pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2 pty t = pbty t pbty (TyApp tc ts) = tc ++ (concat (map (' ':) (map paty ts))) @@ -212,7 +350,7 @@ gen_latex_doc (Info defaults entries) paty (TyVar tv) = tv paty t = "(" ++ pty t ++ ")" - mk_core_ty t = foralls ++ (pty t) + mk_core_ty typ = foralls ++ (pty typ) where pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2 pty t = pbty t pbty (TyApp tc ts) = (zencode tc) ++ (concat (map (' ':) (map paty ts))) @@ -224,62 +362,58 @@ gen_latex_doc (Info defaults entries) utuplenm 1 = "(# #)" utuplenm n = "(#" ++ (replicate (n-1) ',') ++ "#)" foralls = if tvars == [] then "" else "%forall " ++ (tbinds tvars) - tvars = tvars_of t + tvars = tvars_of typ tbinds [] = ". " tbinds ("o":tbs) = "(o::?) " ++ (tbinds tbs) tbinds (tv:tbs) = tv ++ " " ++ (tbinds tbs) tvars_of (TyF t1 t2) = tvars_of t1 `union` tvars_of t2 - tvars_of (TyApp tc ts) = foldl union [] (map tvars_of ts) + tvars_of (TyApp _ ts) = foldl union [] (map tvars_of ts) tvars_of (TyUTup ts) = foldr union [] (map tvars_of ts) tvars_of (TyVar tv) = [tv] - mk_options opts = + mk_options o = "\\primoptions{" - ++ mk_has_side_effects opts ++ "}{" - ++ mk_out_of_line opts ++ "}{" - ++ mk_commutable opts ++ "}{" - ++ mk_needs_wrapper opts ++ "}{" - ++ mk_can_fail opts ++ "}{" - ++ latex_encode (mk_strictness opts) ++ "}{" - ++ latex_encode (mk_usage opts) + ++ mk_has_side_effects o ++ "}{" + ++ mk_out_of_line o ++ "}{" + ++ mk_commutable o ++ "}{" + ++ mk_needs_wrapper o ++ "}{" + ++ mk_can_fail o ++ "}{" + ++ latex_encode (mk_strictness o) ++ "}{" ++ "}" - mk_has_side_effects opts = mk_bool_opt opts "has_side_effects" "Has side effects." "Has no side effects." - mk_out_of_line opts = mk_bool_opt opts "out_of_line" "Implemented out of line." "Implemented in line." - mk_commutable opts = mk_bool_opt opts "commutable" "Commutable." "Not commutable." - mk_needs_wrapper opts = mk_bool_opt opts "needs_wrapper" "Needs wrapper." "Needs no wrapper." - mk_can_fail opts = mk_bool_opt opts "can_fail" "Can fail." "Cannot fail." + mk_has_side_effects o = mk_bool_opt o "has_side_effects" "Has side effects." "Has no side effects." + mk_out_of_line o = mk_bool_opt o "out_of_line" "Implemented out of line." "Implemented in line." + mk_commutable o = mk_bool_opt o "commutable" "Commutable." "Not commutable." + mk_needs_wrapper o = mk_bool_opt o "needs_wrapper" "Needs wrapper." "Needs no wrapper." + mk_can_fail o = mk_bool_opt o "can_fail" "Can fail." "Cannot fail." - mk_bool_opt opts opt_name if_true if_false = - case lookup_attrib opt_name opts of + mk_bool_opt o opt_name if_true if_false = + case lookup_attrib opt_name o of Just (OptionTrue _) -> if_true Just (OptionFalse _) -> if_false + Just (OptionString _ _) -> error "String value for boolean option" Nothing -> "" - mk_strictness opts = - case lookup_attrib "strictness" opts of - Just (OptionString _ s) -> s -- for now - Nothing -> "" - - mk_usage opts = - case lookup_attrib "usage" opts of + mk_strictness o = + case lookup_attrib "strictness" o of Just (OptionString _ s) -> s -- for now + Just _ -> error "Boolean value for strictness" Nothing -> "" - zencode cs = - case maybe_tuple cs of + zencode xs = + case maybe_tuple xs of Just n -> n -- Tuples go to Z2T etc - Nothing -> concat (map encode_ch cs) + Nothing -> concat (map encode_ch xs) where maybe_tuple "(# #)" = Just("Z1H") maybe_tuple ('(' : '#' : cs) = case count_commas (0::Int) cs of - (n, '#' : ')' : cs) -> Just ('Z' : shows (n+1) "H") - other -> Nothing + (n, '#' : ')' : _) -> Just ('Z' : shows (n+1) "H") + _ -> Nothing maybe_tuple "()" = Just("Z0T") maybe_tuple ('(' : cs) = case count_commas (0::Int) cs of - (n, ')' : cs) -> Just ('Z' : shows (n+1) "T") - other -> Nothing - maybe_tuple other = Nothing + (n, ')' : _) -> Just ('Z' : shows (n+1) "T") + _ -> Nothing + maybe_tuple _ = Nothing count_commas :: Int -> String -> (Int, String) count_commas n (',' : cs) = count_commas (n+1) cs @@ -329,7 +463,8 @@ gen_latex_doc (Info defaults entries) latex_encode ('\\':cs) = "$\\backslash$" ++ (latex_encode cs) latex_encode (c:cs) = c:(latex_encode cs) -gen_wrappers (Info defaults entries) +gen_wrappers :: Info -> String +gen_wrappers (Info _ entries) = "{-# OPTIONS -fno-implicit-prelude #-}\n" -- Dependencies on Prelude must be explicit in libraries/base, but we -- don't need the Prelude here so we add -fno-implicit-prelude. @@ -355,25 +490,29 @@ gen_wrappers (Info defaults entries) "parAtAbs#", "parAtRel#", "parAtForNow#" ] - -gen_primop_list (Info defaults entries) +gen_primop_list :: Info -> String +gen_primop_list (Info _ entries) = unlines ( [ " [" ++ cons first ] ++ - map (\pi -> " , " ++ cons pi) rest + map (\p -> " , " ++ cons p) rest ++ [ " ]" ] ) where (first:rest) = filter is_primop entries -gen_primop_tag (Info defaults entries) - = unlines (max_def : zipWith f primop_entries [1..]) +gen_primop_tag :: Info -> String +gen_primop_tag (Info _ entries) + = unlines (max_def_type : max_def : + tagOf_type : zipWith f primop_entries [1 :: Int ..]) where - primop_entries = filter is_primop entries - f i n = "tagOf_PrimOp " ++ cons i - ++ " = _ILIT(" ++ show n ++ ") :: FastInt" - max_def = "maxPrimOpTag = " ++ show (length primop_entries) ++ " :: Int" - -gen_data_decl (Info defaults entries) + primop_entries = filter is_primop entries + tagOf_type = "tagOf_PrimOp :: PrimOp -> FastInt" + f i n = "tagOf_PrimOp " ++ cons i ++ " = _ILIT(" ++ show n ++ ")" + max_def_type = "maxPrimOpTag :: Int" + max_def = "maxPrimOpTag = " ++ show (length primop_entries) + +gen_data_decl :: Info -> String +gen_data_decl (Info _ entries) = let conss = map cons (filter is_primop entries) in "data PrimOp\n = " ++ head conss ++ "\n" ++ unlines (map (" | "++) (tail conss)) @@ -381,7 +520,7 @@ gen_data_decl (Info defaults entries) gen_switch_from_attribs :: String -> String -> Info -> String gen_switch_from_attribs attrib_name fn_name (Info defaults entries) = let defv = lookup_attrib attrib_name defaults - alts = catMaybes (map mkAlt (filter is_primop entries)) + alternatives = catMaybes (map mkAlt (filter is_primop entries)) getAltRhs (OptionFalse _) = "False" getAltRhs (OptionTrue _) = "True" @@ -396,36 +535,42 @@ gen_switch_from_attribs attrib_name fn_name (Info defaults entries) case defv of Nothing -> error ("gen_switch_from: " ++ attrib_name) Just xx - -> unlines alts - ++ fn_name ++ " other = " ++ getAltRhs xx ++ "\n" + -> unlines alternatives + ++ fn_name ++ " _ = " ++ getAltRhs xx ++ "\n" ------------------------------------------------------------------ -- Create PrimOpInfo text from PrimOpSpecs ----------------------- ------------------------------------------------------------------ - -gen_primop_info (Info defaults entries) +gen_primop_info :: Info -> String +gen_primop_info (Info _ entries) = unlines (map mkPOItext (filter is_primop entries)) +mkPOItext :: Entry -> String mkPOItext i = mkPOI_LHS_text i ++ mkPOI_RHS_text i +mkPOI_LHS_text :: Entry -> String mkPOI_LHS_text i = "primOpInfo " ++ cons i ++ " = " +mkPOI_RHS_text :: Entry -> String mkPOI_RHS_text i = case cat i of Compare -> case ty i of - TyF t1 (TyF t2 td) + TyF t1 (TyF _ _) -> "mkCompare " ++ sl_name i ++ ppType t1 + _ -> error "Type error in comparison op" Monadic -> case ty i of - TyF t1 td + TyF t1 _ -> "mkMonadic " ++ sl_name i ++ ppType t1 + _ -> error "Type error in monadic op" Dyadic -> case ty i of - TyF t1 (TyF t2 td) + TyF t1 (TyF _ _) -> "mkDyadic " ++ sl_name i ++ ppType t1 + _ -> error "Type error in dyadic op" GenPrimOp -> let (argTys, resTy) = flatTys (ty i) tvs = nub (tvsIn (ty i)) @@ -434,16 +579,19 @@ mkPOI_RHS_text i ++ listify (map ppTyVar tvs) ++ " " ++ listify (map ppType argTys) ++ " " ++ "(" ++ ppType resTy ++ ")" - -sl_name i = "FSLIT(\"" ++ name i ++ "\") " +sl_name :: Entry -> String +sl_name i = "(fsLit \"" ++ name i ++ "\") " + +ppTyVar :: String -> String ppTyVar "a" = "alphaTyVar" ppTyVar "b" = "betaTyVar" ppTyVar "c" = "gammaTyVar" ppTyVar "s" = "deltaTyVar" ppTyVar "o" = "openAlphaTyVar" +ppTyVar _ = error "Unknown type var" - +ppType :: Ty -> String ppType (TyApp "Bool" []) = "boolTy" ppType (TyApp "Int#" []) = "intPrimTy" @@ -463,7 +611,6 @@ ppType (TyApp "ForeignObj#" []) = "foreignObjPrimTy" ppType (TyApp "BCO#" []) = "bcoPrimTy" ppType (TyApp "()" []) = "unitTy" -- unitTy is TysWiredIn's name for () - ppType (TyVar "a") = "alphaTy" ppType (TyVar "b") = "betaTy" ppType (TyVar "c") = "gammaTy" @@ -501,329 +648,16 @@ ppType other listify :: [String] -> String listify ss = "[" ++ concat (intersperse ", " ss) ++ "]" +flatTys :: Ty -> ([Ty],Ty) flatTys (TyF t1 t2) = case flatTys t2 of (ts,t) -> (t1:ts,t) flatTys other = ([],other) +tvsIn :: Ty -> [TyVar] tvsIn (TyF t1 t2) = tvsIn t1 ++ tvsIn t2 -tvsIn (TyApp tc tys) = concatMap tvsIn tys +tvsIn (TyApp _ tys) = concatMap tvsIn tys tvsIn (TyVar tv) = [tv] 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 (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 () x = x -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 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 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 td)) - | t1 == t2 && t2 == t2 = True -sane_ty GenPrimOp any_old_thing - = True -sane_ty _ _ - = False - -get_attrib_name (OptionFalse nm) = nm -get_attrib_name (OptionTrue nm) = nm -get_attrib_name (OptionString nm _) = nm - -lookup_attrib nm [] = Nothing -lookup_attrib nm (a:as) - = if get_attrib_name a == nm then Just a else lookup_attrib nm as - ------------------------------------------------------------------- --- The parser ---------------------------------------------------- ------------------------------------------------------------------- - -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 eq ff -> OptionFalse nm) pName (lit "=") (lit "False"), - then3 (\nm eq tt -> OptionTrue nm) pName (lit "=") (lit "True"), - then3 (\nm eq 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 = optdef [] (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 = optdef "" 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 - (opt (then2 sel22 (lit "->") pType)) - --- Atomic types -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 - = then3 (\ _ ts _ -> TyUTup ts) - (lit "(#") - (then2 (:) pType (many (then2 sel22 (lit ",") pType))) - (lit "#)") - --- Primitive types -ppT = alts [apply TyVar pTyvar, - apply (\tc -> TyApp tc []) pTycon - ] - -pTyvar = sat (`notElem` keywords) pName -pTycon = alts [pConstructor, lexeme (string "()")] -pName = lexeme (then2 (:) lower (many isIdChar)) -pConstructor = lexeme (then2 (:) upper (many isIdChar)) - -isIdChar = satisfy (`elem` idChars) -idChars = ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9'] ++ "#_" - -sat pred p - = do x <- try p - if pred x - then return x - else pzero - ------------------------------------------------------------------- --- Helpful additions to Daan's parser stuff ---------------------- ------------------------------------------------------------------- - -alts [p1] = try p1 -alts (p1:p2:ps) = (try p1) <|> alts (p2:ps) - -then2 f p1 p2 - = do x1 <- p1 ; x2 <- p2 ; return (f x1 x2) -then3 f p1 p2 p3 - = do x1 <- p1 ; x2 <- p2 ; x3 <- p3 ; return (f x1 x2 x3) -then4 f p1 p2 p3 p4 - = do x1 <- p1 ; x2 <- p2 ; x3 <- p3 ; x4 <- p4 ; return (f x1 x2 x3 x4) -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 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 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) -opt p - = (do x <- p; return (Just x)) <|> return Nothing -optdef d p - = (do x <- p; return x) <|> return d - -sel12 a b = a -sel22 a b = b -sel23 a b c = 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 -- ------------------------------------------------------------------- - - -