Fix the type sanity test in genprimopcode's Syntax.hs
[ghc.git] / utils / genprimopcode / Syntax.hs
1
2 module Syntax where
3
4 import Data.List
5
6 ------------------------------------------------------------------
7 -- Abstract syntax -----------------------------------------------
8 ------------------------------------------------------------------
9
10 -- info for all primops; the totality of the info in primops.txt(.pp)
11 data Info
12 = Info [Option] [Entry] -- defaults, primops
13 deriving Show
14
15 -- info for one primop
16 data Entry
17 = PrimOpSpec { cons :: String, -- PrimOp name
18 name :: String, -- name in prog text
19 ty :: Ty, -- type
20 cat :: Category, -- category
21 desc :: String, -- description
22 opts :: [Option] } -- default overrides
23 | PseudoOpSpec { name :: String, -- name in prog text
24 ty :: Ty, -- type
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
32 deriving Show
33
34 is_primop :: Entry -> Bool
35 is_primop (PrimOpSpec _ _ _ _ _ _) = True
36 is_primop _ = False
37
38 -- a binding of property to value
39 data Option
40 = OptionFalse String -- name = False
41 | OptionTrue String -- name = True
42 | OptionString String String -- name = { ... unparsed stuff ... }
43 deriving Show
44
45 -- categorises primops
46 data Category
47 = Dyadic | Monadic | Compare | GenPrimOp
48 deriving Show
49
50 -- types
51 data Ty
52 = TyF Ty Ty
53 | TyApp TyCon [Ty]
54 | TyVar TyVar
55 | TyUTup [Ty] -- unboxed tuples; just a TyCon really,
56 -- but convenient like this
57 deriving (Eq,Show)
58
59 type TyVar = String
60 type TyCon = String
61
62
63 ------------------------------------------------------------------
64 -- Sanity checking -----------------------------------------------
65 ------------------------------------------------------------------
66
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
74 T -> T -> Bool.
75 Dies with "error" if there's a problem, else returns ().
76 -}
77 myseqAll :: [()] -> a -> a
78 myseqAll (():ys) x = myseqAll ys x
79 myseqAll [] x = x
80
81 sanityTop :: Info -> ()
82 sanityTop (Info defs entries)
83 = let opt_names = map get_attrib_name defs
84 primops = filter is_primop entries
85 in
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) ()
89
90 sanityPrimOp :: [String] -> Entry -> ()
91 sanityPrimOp def_names p
92 = let p_names = map get_attrib_name (opts p)
93 p_names_ok
94 = length p_names == length (nub p_names)
95 && all (`elem` def_names) p_names
96 ty_ok = sane_ty (cat p) (ty p)
97 in
98 if not p_names_ok
99 then error ("attribute names are non-unique or have no default in\n" ++
100 "info for primop " ++ cons p ++ "\n")
101 else
102 if not ty_ok
103 then error ("type of primop " ++ cons p ++ " doesn't make sense w.r.t" ++
104 " category " ++ show (cat p) ++ "\n")
105 else ()
106
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)
111 | t1 == td = True
112 sane_ty Dyadic (TyF t1 (TyF t2 td))
113 | t1 == td && t2 == td = True
114 sane_ty GenPrimOp _
115 = True
116 sane_ty _ _
117 = False
118
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
123
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
128