Provide a utility to check API Annotations
[ghc.git] / utils / genprimopcode / Syntax.hs
1 module Syntax where
2
3 import Data.List
4
5 ------------------------------------------------------------------
6 -- Abstract syntax -----------------------------------------------
7 ------------------------------------------------------------------
8
9 -- info for all primops; the totality of the info in primops.txt(.pp)
10 data Info
11 = Info [Option] [Entry] -- defaults, primops
12 deriving Show
13
14 -- info for one primop
15 data Entry
16 = PrimOpSpec { cons :: String, -- PrimOp name
17 name :: String, -- name in prog text
18 ty :: Ty, -- type
19 cat :: Category, -- category
20 desc :: String, -- description
21 opts :: [Option] } -- default overrides
22 | PrimVecOpSpec { cons :: String, -- PrimOp name
23 name :: String, -- name in prog text
24 prefix :: String, -- prefix for generated names
25 veclen :: Int, -- vector length
26 elemrep :: String, -- vector ElemRep
27 ty :: Ty, -- type
28 cat :: Category, -- category
29 desc :: String, -- description
30 opts :: [Option] } -- default overrides
31 | PseudoOpSpec { name :: String, -- name in prog text
32 ty :: Ty, -- type
33 desc :: String, -- description
34 opts :: [Option] } -- default overrides
35 | PrimTypeSpec { ty :: Ty, -- name in prog text
36 desc :: String, -- description
37 opts :: [Option] } -- default overrides
38 | PrimVecTypeSpec { ty :: Ty, -- name in prog text
39 prefix :: String, -- prefix for generated names
40 veclen :: Int, -- vector length
41 elemrep :: String, -- vector ElemRep
42 desc :: String, -- description
43 opts :: [Option] } -- default overrides
44 | Section { title :: String, -- section title
45 desc :: String } -- description
46 deriving Show
47
48 is_primop :: Entry -> Bool
49 is_primop (PrimOpSpec _ _ _ _ _ _) = True
50 is_primop _ = False
51
52 is_primtype :: Entry -> Bool
53 is_primtype (PrimTypeSpec {}) = True
54 is_primtype _ = False
55
56 -- a binding of property to value
57 data Option
58 = OptionFalse String -- name = False
59 | OptionTrue String -- name = True
60 | OptionString String String -- name = { ... unparsed stuff ... }
61 | OptionInteger String Int -- name = <int>
62 | OptionVector [(String,String,Int)] -- name = [(,...),...]
63 | OptionFixity (Maybe Fixity) -- fixity = infix{,l,r} <int> | Nothing
64 deriving Show
65
66 -- categorises primops
67 data Category
68 = Dyadic | Monadic | Compare | GenPrimOp
69 deriving Show
70
71 -- types
72 data Ty
73 = TyF Ty Ty
74 | TyC Ty Ty -- We only allow one constraint, keeps the grammar simpler
75 | TyApp TyCon [Ty]
76 | TyVar TyVar
77 | TyUTup [Ty] -- unboxed tuples; just a TyCon really,
78 -- but convenient like this
79 deriving (Eq,Show)
80
81 type TyVar = String
82
83 data TyCon = TyCon String
84 | SCALAR
85 | VECTOR
86 | VECTUPLE
87 | VecTyCon String String
88 deriving (Eq, Ord)
89
90 instance Show TyCon where
91 show (TyCon tc) = tc
92 show SCALAR = "SCALAR"
93 show VECTOR = "VECTOR"
94 show VECTUPLE = "VECTUPLE"
95 show (VecTyCon tc _) = tc
96
97 -- Follow definitions of Fixity and FixityDirection in GHC
98
99 data Fixity = Fixity Int FixityDirection
100 deriving (Eq, Show)
101
102 data FixityDirection = InfixN | InfixL | InfixR
103 deriving (Eq, Show)
104
105 ------------------------------------------------------------------
106 -- Sanity checking -----------------------------------------------
107 ------------------------------------------------------------------
108
109 {- Do some simple sanity checks:
110 * all the default field names are unique
111 * for each PrimOpSpec, all override field names are unique
112 * for each PrimOpSpec, all overriden field names
113 have a corresponding default value
114 * that primop types correspond in certain ways to the
115 Category: eg if Comparison, the type must be of the form
116 T -> T -> Bool.
117 Dies with "error" if there's a problem, else returns ().
118 -}
119 myseqAll :: [()] -> a -> a
120 myseqAll (():ys) x = myseqAll ys x
121 myseqAll [] x = x
122
123 sanityTop :: Info -> ()
124 sanityTop (Info defs entries)
125 = let opt_names = map get_attrib_name defs
126 primops = filter is_primop entries
127 in
128 if length opt_names /= length (nub opt_names)
129 then error ("non-unique default attribute names: " ++ show opt_names ++ "\n")
130 else myseqAll (map (sanityPrimOp opt_names) primops) ()
131
132 sanityPrimOp :: [String] -> Entry -> ()
133 sanityPrimOp def_names p
134 = let p_names = map get_attrib_name (opts p)
135 p_names_ok
136 = length p_names == length (nub p_names)
137 && all (`elem` def_names) p_names
138 ty_ok = sane_ty (cat p) (ty p)
139 in
140 if not p_names_ok
141 then error ("attribute names are non-unique or have no default in\n" ++
142 "info for primop " ++ cons p ++ "\n")
143 else
144 if not ty_ok
145 then error ("type of primop " ++ cons p ++ " doesn't make sense w.r.t" ++
146 " category " ++ show (cat p) ++ "\n")
147 else ()
148
149 sane_ty :: Category -> Ty -> Bool
150 sane_ty Compare (TyF t1 (TyF t2 td))
151 | t1 == t2 && td == TyApp (TyCon "Int#") [] = True
152 sane_ty Monadic (TyF t1 td)
153 | t1 == td = True
154 sane_ty Dyadic (TyF t1 (TyF t2 td))
155 | t1 == td && t2 == td = True
156 sane_ty GenPrimOp _
157 = True
158 sane_ty _ _
159 = False
160
161 get_attrib_name :: Option -> String
162 get_attrib_name (OptionFalse nm) = nm
163 get_attrib_name (OptionTrue nm) = nm
164 get_attrib_name (OptionString nm _) = nm
165 get_attrib_name (OptionInteger nm _) = nm
166 get_attrib_name (OptionVector _) = "vector"
167 get_attrib_name (OptionFixity _) = "fixity"
168
169 lookup_attrib :: String -> [Option] -> Maybe Option
170 lookup_attrib _ [] = Nothing
171 lookup_attrib nm (a:as)
172 = if get_attrib_name a == nm then Just a else lookup_attrib nm as
173
174 is_vector :: Entry -> Bool
175 is_vector i = case lookup_attrib "vector" (opts i) of
176 Nothing -> False
177 _ -> True