Merge branch 'master' of darcs.haskell.org:/srv/darcs//ghc
[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 | PseudoOpSpec { name :: String, -- name in prog text
23 ty :: Ty, -- type
24 desc :: String, -- description
25 opts :: [Option] } -- default overrides
26 | PrimTypeSpec { ty :: Ty, -- name in prog text
27 desc :: String, -- description
28 opts :: [Option] } -- default overrides
29 | Section { title :: String, -- section title
30 desc :: String } -- description
31 deriving Show
32
33 is_primop :: Entry -> Bool
34 is_primop (PrimOpSpec _ _ _ _ _ _) = True
35 is_primop _ = False
36
37 -- a binding of property to value
38 data Option
39 = OptionFalse String -- name = False
40 | OptionTrue String -- name = True
41 | OptionString String String -- name = { ... unparsed stuff ... }
42 | OptionInteger String Int -- name = <int>
43 | OptionFixity (Maybe Fixity) -- fixity = infix{,l,r} <int> | Nothing
44 deriving Show
45
46 -- categorises primops
47 data Category
48 = Dyadic | Monadic | Compare | GenPrimOp
49 deriving Show
50
51 -- types
52 data Ty
53 = TyF Ty Ty
54 | TyApp TyCon [Ty]
55 | TyVar TyVar
56 | TyUTup [Ty] -- unboxed tuples; just a TyCon really,
57 -- but convenient like this
58 deriving (Eq,Show)
59
60 type TyVar = String
61 type TyCon = String
62
63 -- Follow definitions of Fixity and FixityDirection in GHC
64
65 data Fixity = Fixity Int FixityDirection
66 deriving (Eq, Show)
67
68 data FixityDirection = InfixN | InfixL | InfixR
69 deriving (Eq, Show)
70
71 ------------------------------------------------------------------
72 -- Sanity checking -----------------------------------------------
73 ------------------------------------------------------------------
74
75 {- Do some simple sanity checks:
76 * all the default field names are unique
77 * for each PrimOpSpec, all override field names are unique
78 * for each PrimOpSpec, all overriden field names
79 have a corresponding default value
80 * that primop types correspond in certain ways to the
81 Category: eg if Comparison, the type must be of the form
82 T -> T -> Bool.
83 Dies with "error" if there's a problem, else returns ().
84 -}
85 myseqAll :: [()] -> a -> a
86 myseqAll (():ys) x = myseqAll ys x
87 myseqAll [] x = x
88
89 sanityTop :: Info -> ()
90 sanityTop (Info defs entries)
91 = let opt_names = map get_attrib_name defs
92 primops = filter is_primop entries
93 in
94 if length opt_names /= length (nub opt_names)
95 then error ("non-unique default attribute names: " ++ show opt_names ++ "\n")
96 else myseqAll (map (sanityPrimOp opt_names) primops) ()
97
98 sanityPrimOp :: [String] -> Entry -> ()
99 sanityPrimOp def_names p
100 = let p_names = map get_attrib_name (opts p)
101 p_names_ok
102 = length p_names == length (nub p_names)
103 && all (`elem` def_names) p_names
104 ty_ok = sane_ty (cat p) (ty p)
105 in
106 if not p_names_ok
107 then error ("attribute names are non-unique or have no default in\n" ++
108 "info for primop " ++ cons p ++ "\n")
109 else
110 if not ty_ok
111 then error ("type of primop " ++ cons p ++ " doesn't make sense w.r.t" ++
112 " category " ++ show (cat p) ++ "\n")
113 else ()
114
115 sane_ty :: Category -> Ty -> Bool
116 sane_ty Compare (TyF t1 (TyF t2 td))
117 | t1 == t2 && td == TyApp "Bool" [] = True
118 sane_ty Monadic (TyF t1 td)
119 | t1 == td = True
120 sane_ty Dyadic (TyF t1 (TyF t2 td))
121 | t1 == td && t2 == td = True
122 sane_ty GenPrimOp _
123 = True
124 sane_ty _ _
125 = False
126
127 get_attrib_name :: Option -> String
128 get_attrib_name (OptionFalse nm) = nm
129 get_attrib_name (OptionTrue nm) = nm
130 get_attrib_name (OptionString nm _) = nm
131 get_attrib_name (OptionInteger nm _) = nm
132 get_attrib_name (OptionFixity _) = "fixity"
133
134 lookup_attrib :: String -> [Option] -> Maybe Option
135 lookup_attrib _ [] = Nothing
136 lookup_attrib nm (a:as)
137 = if get_attrib_name a == nm then Just a else lookup_attrib nm as
138