6 ------------------------------------------------------------------
7 -- Abstract syntax -----------------------------------------------
8 ------------------------------------------------------------------
10 -- info for all primops; the totality of the info in primops.txt(.pp)
12 = Info [Option] [Entry] -- defaults, primops
15 -- info for one primop
17 = PrimOpSpec { cons :: String, -- PrimOp name
18 name :: String, -- name in prog text
20 cat :: Category, -- category
21 desc :: String, -- description
22 opts :: [Option] } -- default overrides
23 | PseudoOpSpec { name :: String, -- name in prog text
25 desc :: String, -- description
26 opts :: [Option] } -- default overrides
27 | PrimTypeSpec { ty :: Ty, -- name in prog text
28 desc :: String, -- description
29 opts :: [Option] } -- default overrides
30 | Section { title :: String, -- section title
31 desc :: String } -- description
34 is_primop :: Entry -> Bool
35 is_primop (PrimOpSpec _ _ _ _ _ _) = True
38 -- a binding of property to value
40 = OptionFalse String -- name = False
41 | OptionTrue String -- name = True
42 | OptionString String String -- name = { ... unparsed stuff ... }
43 | OptionInteger String Int -- name = <int>
46 -- categorises primops
48 = Dyadic | Monadic | Compare | GenPrimOp
56 | TyUTup [Ty] -- unboxed tuples; just a TyCon really,
57 -- but convenient like this
64 ------------------------------------------------------------------
65 -- Sanity checking -----------------------------------------------
66 ------------------------------------------------------------------
68 {- Do some simple sanity checks:
69 * all the default field names are unique
70 * for each PrimOpSpec, all override field names are unique
71 * for each PrimOpSpec, all overriden field names
72 have a corresponding default value
73 * that primop types correspond in certain ways to the
74 Category: eg if Comparison, the type must be of the form
76 Dies with "error" if there's a problem, else returns ().
78 myseqAll :: [()] -> a -> a
79 myseqAll (():ys) x = myseqAll ys x
82 sanityTop :: Info -> ()
83 sanityTop (Info defs entries)
84 = let opt_names = map get_attrib_name defs
85 primops = filter is_primop entries
87 if length opt_names /= length (nub opt_names)
88 then error ("non-unique default attribute names: " ++ show opt_names ++ "\n")
89 else myseqAll (map (sanityPrimOp opt_names) primops) ()
91 sanityPrimOp :: [String] -> Entry -> ()
92 sanityPrimOp def_names p
93 = let p_names = map get_attrib_name (opts p)
95 = length p_names == length (nub p_names)
96 && all (`elem` def_names) p_names
97 ty_ok = sane_ty (cat p) (ty p)
100 then error ("attribute names are non-unique or have no default in\n" ++
101 "info for primop " ++ cons p ++ "\n")
104 then error ("type of primop " ++ cons p ++ " doesn't make sense w.r.t" ++
105 " category " ++ show (cat p) ++ "\n")
108 sane_ty :: Category -> Ty -> Bool
109 sane_ty Compare (TyF t1 (TyF t2 td))
110 | t1 == t2 && td == TyApp "Bool" [] = True
111 sane_ty Monadic (TyF t1 td)
113 sane_ty Dyadic (TyF t1 (TyF t2 td))
114 | t1 == td && t2 == td = True
120 get_attrib_name :: Option -> String
121 get_attrib_name (OptionFalse nm) = nm
122 get_attrib_name (OptionTrue nm) = nm
123 get_attrib_name (OptionString nm _) = nm
124 get_attrib_name (OptionInteger nm _) = nm
126 lookup_attrib :: String -> [Option] -> Maybe Option
127 lookup_attrib _ [] = Nothing
128 lookup_attrib nm (a:as)
129 = if get_attrib_name a == nm then Just a else lookup_attrib nm as