1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
|
module Syntax where
import Data.List
------------------------------------------------------------------
-- Abstract syntax -----------------------------------------------
------------------------------------------------------------------
-- info for all primops; the totality of the info in primops.txt(.pp)
data Info
= Info [Option] [Entry] -- defaults, primops
deriving Show
-- info for one primop
data Entry
= PrimOpSpec { cons :: String, -- PrimOp name
name :: String, -- name in prog text
ty :: Ty, -- type
cat :: Category, -- category
desc :: String, -- description
opts :: [Option] } -- default overrides
| PseudoOpSpec { name :: String, -- name in prog text
ty :: Ty, -- type
desc :: String, -- description
opts :: [Option] } -- default overrides
| PrimTypeSpec { ty :: Ty, -- name in prog text
desc :: String, -- description
opts :: [Option] } -- default overrides
| Section { title :: String, -- section title
desc :: String } -- description
deriving Show
is_primop :: Entry -> Bool
is_primop (PrimOpSpec _ _ _ _ _ _) = True
is_primop _ = False
-- a binding of property to value
data Option
= OptionFalse String -- name = False
| OptionTrue String -- name = True
| OptionString String String -- name = { ... unparsed stuff ... }
deriving Show
-- categorises primops
data Category
= Dyadic | Monadic | Compare | GenPrimOp
deriving Show
-- types
data Ty
= TyF Ty Ty
| TyApp TyCon [Ty]
| TyVar TyVar
| TyUTup [Ty] -- unboxed tuples; just a TyCon really,
-- but convenient like this
deriving (Eq,Show)
type TyVar = String
type TyCon = String
------------------------------------------------------------------
-- Sanity checking -----------------------------------------------
------------------------------------------------------------------
{- Do some simple sanity checks:
* all the default field names are unique
* for each PrimOpSpec, all override field names are unique
* for each PrimOpSpec, all overriden field names
have a corresponding default value
* that primop types correspond in certain ways to the
Category: eg if Comparison, the type must be of the form
T -> T -> Bool.
Dies with "error" if there's a problem, else returns ().
-}
myseqAll :: [()] -> a -> a
myseqAll (():ys) x = myseqAll ys x
myseqAll [] x = x
sanityTop :: Info -> ()
sanityTop (Info defs entries)
= let opt_names = map get_attrib_name defs
primops = filter is_primop entries
in
if length opt_names /= length (nub opt_names)
then error ("non-unique default attribute names: " ++ show opt_names ++ "\n")
else myseqAll (map (sanityPrimOp opt_names) primops) ()
sanityPrimOp :: [String] -> Entry -> ()
sanityPrimOp def_names p
= let p_names = map get_attrib_name (opts p)
p_names_ok
= length p_names == length (nub p_names)
&& all (`elem` def_names) p_names
ty_ok = sane_ty (cat p) (ty p)
in
if not p_names_ok
then error ("attribute names are non-unique or have no default in\n" ++
"info for primop " ++ cons p ++ "\n")
else
if not ty_ok
then error ("type of primop " ++ cons p ++ " doesn't make sense w.r.t" ++
" category " ++ show (cat p) ++ "\n")
else ()
sane_ty :: Category -> Ty -> Bool
sane_ty Compare (TyF t1 (TyF t2 td))
| t1 == t2 && td == TyApp "Bool" [] = True
sane_ty Monadic (TyF t1 td)
| t1 == td = True
sane_ty Dyadic (TyF t1 (TyF t2 _))
| t1 == t2 && t2 == t2 = True
sane_ty GenPrimOp _
= True
sane_ty _ _
= False
get_attrib_name :: Option -> String
get_attrib_name (OptionFalse nm) = nm
get_attrib_name (OptionTrue nm) = nm
get_attrib_name (OptionString nm _) = nm
lookup_attrib :: String -> [Option] -> Maybe Option
lookup_attrib _ [] = Nothing
lookup_attrib nm (a:as)
= if get_attrib_name a == nm then Just a else lookup_attrib nm as
|
