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
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
|
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE IncoherentInstances #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ConstraintKinds #-}
module Language.Fiddle.Ast where
import Data.Functor.Identity
import Data.Kind (Type)
import Data.Proxy
import Data.Text (Text)
import Data.Traversable
import Data.Typeable
import GHC.Generics
import GHC.TypeLits
type family NumberType (a :: Stage) where
NumberType Stage1 = Text
NumberType Stage2 = Integer
NumberType Stage3 = Integer
-- Stage of compilation. Parts of the AST maybe un unavailable with other stages
-- as compilation simplifies the AST.
data Stage = Stage1 | Stage2 | Stage3
deriving (Typeable)
-- Root of the parse tree. Just contains a list of declarations.
data FiddleUnit (stage :: Stage) (f :: Type -> Type) a where
FiddleUnit :: [FiddleDecl stage f a] -> a -> FiddleUnit stage f a
deriving (Generic, Annotated, Alter, Typeable)
-- Just an identifier.
data Identifier f a = Identifier !Text a
deriving (Generic, Annotated, Alter, Typeable)
-- Expression.
data Expression stage f a where
-- Just a string. Parsing the number comes in stage2.
LitNum :: NumberType stage -> a -> Expression stage f a
Var :: Identifier f a -> a -> Expression stage f a
-- Top-level declarations.
data FiddleDecl (stage :: Stage) (f :: Type -> Type) a where
{-
- An option is a key/value pair.
- option <ident> <ident>;
-}
OptionDecl ::
Identifier f a ->
Identifier f a ->
a ->
FiddleDecl stage f a
{- Package Statement. Package Name, Package body -}
PackageDecl ::
Identifier f a ->
f (PackageBody stage f a) ->
a ->
FiddleDecl stage f a
{- location <identifier> = <expr>. -}
LocationDecl ::
Identifier f a ->
Expression stage f a ->
a ->
FiddleDecl stage f a
{- bits <identifier> : <type> -}
BitsDecl ::
Identifier f a ->
BitType stage f a ->
a ->
FiddleDecl stage f a
{- objtype <identifier> : <type> -}
ObjTypeDecl ::
Identifier f a ->
f (ObjTypeBody stage f a) ->
a ->
FiddleDecl stage f a
{- object <ident> at <expr> : <type> -}
ObjectDecl ::
Identifier f a ->
Expression stage f a ->
ObjType stage f a ->
a ->
FiddleDecl stage f a
deriving (Generic, Annotated, Alter, Typeable)
data ObjTypeBody (stage :: Stage) (f :: Type -> Type) a where
ObjTypeBody :: [ObjTypeDecl stage f a] -> a -> ObjTypeBody stage f a
deriving (Generic, Annotated, Alter, Typeable)
data ObjType stage f a where
-- { <body> }
-- Anonymous types are only allowed in stage1. Stage2 should have them be
-- de-anonymized.
AnonymousObjType :: f (ObjTypeBody 'Stage1 f a) -> a -> ObjType 'Stage1 f a
-- <type>[<expr>]
ArrayObjType :: ObjType stage f a -> Expression stage f a -> a -> ObjType stage f a
-- <identifier>
ReferencedObjType :: Identifier f a -> a -> ObjType stage f a
deriving (Typeable)
type StageLessThan stage (n :: Natural) = (CmpNat (StageNumber stage) n ~ LT)
data ObjTypeDecl stage f a where
{- assert_pos(<expr>) -}
AssertPosStatement ::
(StageLessThan stage 3) =>
Expression stage f a ->
a ->
ObjTypeDecl stage f a
{- reg <ident>(<expr>) : <regtype> -}
RegisterDecl ::
Maybe (Modifier f a) ->
Maybe (Identifier f a) ->
Expression stage f a ->
Maybe (RegisterBody stage f a) ->
a ->
ObjTypeDecl stage f a
deriving (Typeable)
data Modifier f a where
ModifierKeyword :: ModifierKeyword -> a -> Modifier f a
deriving (Generic, Annotated, Alter, Typeable)
data ModifierKeyword = Rw | Ro | Wo deriving (Eq, Ord, Show, Read, Typeable)
data DeferredRegisterBody stage f a where
DeferredRegisterBody ::
[RegisterBitsDecl stage f a] ->
a ->
DeferredRegisterBody stage f a
deriving (Generic, Annotated, Alter, Typeable)
data RegisterBody stage f a where
RegisterBody :: f (DeferredRegisterBody stage f a) -> a -> RegisterBody stage f a
deriving (Generic, Annotated, Alter, Typeable)
data RegisterBitsDecl stage f a where
-- reserved(<expr>)
ReservedBits :: Expression stage f a -> a -> RegisterBitsDecl stage f a
-- <modifer> <ident> : <type>
DefinedBits ::
Maybe (Modifier f a) ->
Identifier f a ->
RegisterBitsTypeRef stage f a ->
a ->
RegisterBitsDecl stage f a
deriving (Generic, Annotated, Alter, Typeable)
data RegisterBitsTypeRef stage f a where
-- <type>[<expr>]
RegisterBitsArray ::
RegisterBitsTypeRef stage f a ->
Expression stage f a ->
a ->
RegisterBitsTypeRef stage f a
{- Reference to a type. -}
RegisterBitsReference :: Identifier f a -> a -> RegisterBitsTypeRef stage f a
{- enum(<expr>) { <body> }
Anonymous types are only allowed in stage1.
Stage2 should de-anonymize these type. -}
RegisterBitsAnonymousType ::
AnonymousBitsType Stage1 f a ->
a ->
RegisterBitsTypeRef 'Stage1 f a
{- (<expr>)
-
- The expression is just bits ... i.e. an integer.
-}
RegisterBitsJustBits ::
Expression stage f a ->
a ->
RegisterBitsTypeRef stage f a
instance Alter (Expression stage) where
alter ffn fn = \case
LitNum t a -> LitNum t <$> fn a
Var i a -> Var <$> alter ffn fn i <*> fn a
instance Annotated (Expression stage) where
annot = \case
LitNum _ a -> a
Var _ a -> a
instance Alter (ObjTypeDecl stage) where
alter ffn fn = \case
(AssertPosStatement expr a) -> AssertPosStatement <$> alter ffn fn expr <*> fn a
(RegisterDecl mMod mIdent expr mBody a) ->
RegisterDecl
<$> mapM (alter ffn fn) mMod
<*> mapM (alter ffn fn) mIdent
<*> alter ffn fn expr
<*> mapM (alter ffn fn) mBody
<*> fn a
instance Annotated (ObjTypeDecl stage) where
annot = \case
(AssertPosStatement _ a) -> a
(RegisterDecl _ _ _ _ a) -> a
instance Alter (ObjType stage) where
alter ffn fn = \case
(AnonymousObjType b a) ->
AnonymousObjType <$> (ffn =<< mapM (alter ffn fn) b) <*> fn a
(ArrayObjType t e a) ->
ArrayObjType <$> alter ffn fn t <*> alter ffn fn e <*> fn a
(ReferencedObjType i a) ->
ReferencedObjType <$> alter ffn fn i <*> fn a
instance Annotated (ObjType stage) where
annot = \case
(AnonymousObjType _ a) -> a
(ArrayObjType _ _ a) -> a
(ReferencedObjType _ a) -> a
instance Alter (RegisterBitsTypeRef stage) where
alter ffn fn = \case
(RegisterBitsArray ref exp a) ->
RegisterBitsArray <$> alter ffn fn ref <*> alter ffn fn exp <*> fn a
(RegisterBitsReference i a) ->
RegisterBitsReference <$> alter ffn fn i <*> fn a
(RegisterBitsAnonymousType t a) ->
RegisterBitsAnonymousType <$> alter ffn fn t <*> fn a
(RegisterBitsJustBits e a) ->
RegisterBitsJustBits <$> alter ffn fn e <*> fn a
instance Annotated (RegisterBitsTypeRef stage) where
annot = \case
(RegisterBitsArray _ _ a) -> a
(RegisterBitsReference _ a) -> a
(RegisterBitsAnonymousType _ a) -> a
(RegisterBitsJustBits _ a) -> a
data AnonymousBitsType stage f a where
-- enum(<expr>) { <body> }
AnonymousEnumBody ::
Expression stage f a ->
f (EnumBody stage f a) ->
a ->
AnonymousBitsType stage f a
deriving (Generic, Annotated, Alter, Typeable)
data BitType (stage :: Stage) (f :: Type -> Type) a where
-- enum(<expr>) { <body> }
EnumBitType ::
Expression stage f a ->
f (EnumBody stage f a) ->
a ->
BitType stage f a
-- (<expr>)
RawBits :: Expression stage f a -> a -> BitType stage f a
deriving (Generic, Annotated, Alter, Typeable)
data EnumBody (stage :: Stage) (f :: Type -> Type) a where
-- <decl>,
EnumBody :: [EnumConstantDecl stage f a] -> a -> EnumBody stage f a
deriving (Generic, Annotated, Alter, Typeable)
data EnumConstantDecl stage f a where
-- <ident> = <expr>
EnumConstantDecl :: Identifier f a -> Expression stage f a -> a -> EnumConstantDecl stage f a
-- reserved = <expr>
EnumConstantReserved :: Expression stage f a -> a -> EnumConstantDecl stage f a
deriving (Generic, Annotated, Alter, Typeable)
data PackageBody (stage :: Stage) (f :: Type -> Type) a where
{- The body of a package -}
PackageBody :: [FiddleDecl stage f a] -> a -> PackageBody stage f a
deriving (Generic, Annotated, Alter, Typeable)
-- instance Alter (Modifier stage) where
-- alter _ fn (ModifierKeyword m a) = ModifierKeyword m (fn a)
--
-- instance Alter (Identifier) where
-- alter _ fn (Identifier i a) = Identifier i $ fn a
--
-- instance Alter (Expression stage) where
-- alter ffn fn = \case
-- (LitNum t a) -> LitNum t $ fn a
-- (RealNum t a) -> RealNum t $ fn a
-- (Var i a) -> Var (alter ffn fn i) $ fn a
proxyOf :: t f a -> Proxy t
proxyOf _ = Proxy
class Annotated (t :: (Type -> Type) -> Type -> Type) where
annot :: t f a -> a
default annot :: (Generic (t f a), GAnnot a (Rep (t f a))) => t f a -> a
annot t = gannot (from t)
class GAnnot a r where
gannot :: r x -> a
instance GAnnot a (Rec0 a) where
gannot = unK1
instance (GAnnot a r) => GAnnot a (l :*: r) where
gannot (_ :*: r) = gannot r
instance (GAnnot a r, GAnnot a l) => GAnnot a (l :+: r) where
gannot (R1 r) = gannot r
gannot (L1 l) = gannot l
instance (GAnnot a r) => GAnnot a (M1 i c r) where
gannot (M1 a) = gannot a
class Alter (t :: (Type -> Type) -> Type -> Type) where
alter ::
forall f1 f2 a1 a2 m.
(Monad m, Traversable f1) =>
(forall z. f1 z -> m (f2 z)) ->
(a1 -> m a2) ->
t f1 a1 ->
m (t f2 a2)
default alter ::
forall f1 f2 a1 a2 m.
( Generic (t f1 a1),
Generic (t f2 a2),
Traversable f1,
GAlter t f1 f2 a1 a2 (Rep (t f1 a1)) (Rep (t f2 a2)),
Monad m
) =>
( forall z.
f1 z ->
m (f2 z)
) ->
(a1 -> m a2) ->
t f1 a1 ->
m (t f2 a2)
alter ffn fn t = to <$> galter (proxyOf t) ffn fn (from t)
instance (Alter t, Traversable f) => Functor (t f) where
fmap f t = runIdentity (alter return (return . f) t)
class GAlter t f1 f2 a1 a2 r1 r2 where
galter ::
forall proxy x m.
(Monad m, Traversable f1) =>
proxy t ->
(forall z. f1 z -> m (f2 z)) ->
(a1 -> m a2) ->
r1 x ->
m (r2 x)
{- Altering a record with type a1 will apply the mapping function and produce a
record with type a2 -}
instance GAlter t f1 f2 a1 a2 (Rec0 a1) (Rec0 a2) where
galter _ _ fn k1 = K1 <$> fn (unK1 k1)
{- Base-Case. Altering unrelated leaf types will do nothing. -}
instance GAlter t f1 f2 a1 a2 (Rec0 u1) (Rec0 u1) where
galter _ _ _ = return
{- Recursive case. Call alter on sub-structures. -}
instance (Alter u) => GAlter t f1 f2 a1 a2 (Rec0 (u f1 a1)) (Rec0 (u f2 a2)) where
galter _ ffn fn k1 =
K1 <$> alter ffn fn (unK1 k1)
{- Recursive case. Called when there are list of substructures that need to be
recused. -}
instance (Alter u, Traversable l) => GAlter t f1 f2 a1 a2 (Rec0 (l (u f1 a1))) (Rec0 (l (u f2 a2))) where
galter _ ffn fn k1 =
K1 <$> mapM (alter ffn fn) (unK1 k1)
-- instance GAlter t f1 f2 a1 a2 (Rec0 (f1 z)) (Rec0 (f2 z)) where
-- galter _ ffn _ k1 = K1 <$> ffn (unK1 k1)
{- Generic altering. Descends into the function and alters whatever is inside
the functor and then transforms the functor using the ffn function. -}
instance
(Traversable f1, Alter u) =>
GAlter t f1 f2 a1 a2 (Rec0 (f1 (u f1 a1))) (Rec0 (f2 (u f2 a2)))
where
galter proxy ffn fn k1 = do
newK <- mapM (alter ffn fn) (unK1 k1)
K1 <$> ffn newK
instance
( GAlter t f1 f2 a1 a2 l1 l2,
GAlter t f1 f2 a1 a2 r1 r2
) =>
GAlter t f1 f2 a1 a2 (l1 :*: r1) (l2 :*: r2)
where
galter proxy ffn fn (a :*: b) = do
a' <- galter proxy ffn fn a
b' <- galter proxy ffn fn b
return (a' :*: b')
instance
( GAlter t f1 f2 a1 a2 l1 l2,
GAlter t f1 f2 a1 a2 r1 r2
) =>
GAlter t f1 f2 a1 a2 (l1 :+: r1) (l2 :+: r2)
where
galter proxy ffn fn (R1 r) = R1 <$> galter proxy ffn fn r
galter proxy ffn fn (L1 l) = L1 <$> galter proxy ffn fn l
instance
(GAlter t f1 f2 a1 a2 r1 r2) =>
GAlter t f1 f2 a1 a2 (M1 i c r1) (M1 i c r2)
where
galter proxy ffn fn (M1 a) = M1 <$> galter proxy ffn fn a
type family StageNumber (s :: Stage) :: Natural where
StageNumber Stage1 = 1
StageNumber Stage2 = 2
StageNumber Stage3 = 3
{--}
squeeze :: (Alter t, Traversable f, Monad f) => t f a -> f (t Identity a)
squeeze = alter (fmap Identity) return
|
