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 ... }
45 -- categorises primops
47 = Dyadic | Monadic | Compare | GenPrimOp
55 | TyUTup [Ty] -- unboxed tuples; just a TyCon really,
56 -- but convenient like this
63 ------------------------------------------------------------------
64 -- Sanity checking -----------------------------------------------
65 ------------------------------------------------------------------
67 {- Do some simple sanity checks:
68 * all the default field names are unique
69 * for each PrimOpSpec, all override field names are unique
70 * for each PrimOpSpec, all overriden field names
71 have a corresponding default value
72 * that primop types correspond in certain ways to the
73 Category: eg if Comparison, the type must be of the form
75 Dies with "error" if there's a problem, else returns ().
77 myseqAll :: [()] -> a -> a
78 myseqAll (():ys) x = myseqAll ys x
81 sanityTop :: Info -> ()
82 sanityTop (Info defs entries)
83 = let opt_names = map get_attrib_name defs
84 primops = filter is_primop entries
86 if length opt_names /= length (nub opt_names)
87 then error ("non-unique default attribute names: " ++ show opt_names ++ "\n")
88 else myseqAll (map (sanityPrimOp opt_names) primops) ()
90 sanityPrimOp :: [String] -> Entry -> ()
91 sanityPrimOp def_names p
92 = let p_names = map get_attrib_name (opts p)
94 = length p_names == length (nub p_names)
95 && all (`elem` def_names) p_names
96 ty_ok = sane_ty (cat p) (ty p)
99 then error ("attribute names are non-unique or have no default in\n" ++
100 "info for primop " ++ cons p ++ "\n")
103 then error ("type of primop " ++ cons p ++ " doesn't make sense w.r.t" ++
104 " category " ++ show (cat p) ++ "\n")
107 sane_ty :: Category -> Ty -> Bool
108 sane_ty Compare (TyF t1 (TyF t2 td))
109 | t1 == t2 && td == TyApp "Bool" [] = True
110 sane_ty Monadic (TyF t1 td)
112 sane_ty Dyadic (TyF t1 (TyF t2 td))
113 | t1 == td && t2 == td = True
119 get_attrib_name :: Option -> String
120 get_attrib_name (OptionFalse nm) = nm
121 get_attrib_name (OptionTrue nm) = nm
122 get_attrib_name (OptionString nm _) = nm
124 lookup_attrib :: String -> [Option] -> Maybe Option
125 lookup_attrib _ [] = Nothing
126 lookup_attrib nm (a:as)
127 = if get_attrib_name a == nm then Just a else lookup_attrib nm as