0 | module Text.WebIDL.Codegen.Rules

  2 | import Data.List

  3 | import Data.List1

  4 | import Data.List.Elem

  5 | import Data.SortedSet

  6 | import Text.WebIDL.Codegen.Util

 12 | parents : Domain -> List Identifier

 13 | parents d =

 14 |   mapMaybe inherits d.interfaces ++ mapMaybe inherits d.dictionaries

 16 | kinds : List Domain -> SortedMap Identifier Kind

 17 | kinds ds =

 18 |   let ps = SortedSet.fromList $ ds >>= parents

 19 |    in SortedMap.fromList

 20 |         $  (ds >>= pairs name KEnum . enums)

 21 |         ++ (ds >>= pairs name KMixin . mixins)

 22 |         ++ (ds >>= pairs name (iface ps) . interfaces)

 23 |         ++ (ds >>= pairs name KDictionary . dictionaries)

 24 |         ++ (ds >>= pairs name KCallback . callbackInterfaces)

 25 |         ++ (ds >>= pairs name KCallback . callbacks)

 26 |         ++ (ds >>= pairs name KAlias . typedefs)

 27 |   where

 28 |     -- list of identifiers with their kinds

 29 |     pairs :

 30 |          (a -> Identifier)

 31 |       -> (Identifier -> Kind)

 32 |       -> List a

 33 |       -> List (Identifier,Kind)

 34 |     pairs name knd = map $ \v => (name v, knd $ name v)

 36 |     iface : SortedSet Identifier -> Identifier -> Kind

 37 |     iface ps i = KInterface (contains i ps) i

 41 | env : Nat -> List Domain -> Env

 42 | env k ds =

 43 |   let ks := kinds ds

 44 |    in MkEnv k ks jsTypes (aliases ks $ ds >>= typedefs)

 46 |   where

 47 |     -- calculates the mapping from type aliases to the

 48 |     -- types they represent

 49 |     aliases :

 50 |          SortedMap Identifier Kind

 51 |       -> List Typedef

 52 |       -> SortedMap Identifier (IdlTypeF ExtAttributeList Kind)

 53 |     aliases ks = SortedMap.fromList . map mkPair

 54 |       where

 55 |         kind : Identifier -> Kind

 56 |         kind i = fromMaybe (KOther i) $ lookup i ks

 58 |         mkPair : Typedef -> (Identifier,IdlTypeF ExtAttributeList Kind)

 59 |         mkPair (MkTypedef _ _ t n) = (n, map kind t)

 61 |     dictToType : Dictionary -> (Identifier,JSType)

 62 |     dictToType (MkDictionary _ n i _) = (n, MkJSType i Nil)

 64 |     interfaceToType : Interface -> (Identifier,JSType)

 65 |     interfaceToType (MkInterface _ n i _) = (n, MkJSType i Nil)

 67 |     mixin :

 68 |          SortedMap Identifier JSType

 69 |       -> Includes

 70 |       -> SortedMap Identifier JSType

 71 |     mixin ts (MkIncludes _ n incl) =

 72 |       case lookup n ts of

 73 |         Nothing => ts

 74 |         Just js => let js2 := {mixins $= (incl ::)} js in insert n js2 ts

 76 |     jsTypes : SortedMap Identifier JSType

 77 |     jsTypes =

 78 |       let types :=

 79 |             (ds >>= map dictToType . dictionaries) ++

 80 |             (ds >>= map interfaceToType . interfaces)

 82 |           includes := ds >>= includeStatements

 84 |           initialMap := SortedMap.fromList types

 86 |        in foldl mixin initialMap includes

 92 | buff : BufferRelatedType -> SimpleType

 93 | buff Uint8Array        = Unchangeable "UInt8Array"

 94 | buff Uint16Array       = Unchangeable "UInt8Array"

 95 | buff Uint32Array       = Unchangeable "UInt8Array"

 96 | buff Uint8ClampedArray = Unchangeable "UInt8ClampedArray"

 97 | buff x                 = Unchangeable $ show x

101 | prim : PrimitiveType -> SimpleType

102 | prim Boolean             = Boolean

103 | prim (Unsigned Short)    = Primitive "Bits16"

104 | prim (Unsigned Long)     = Primitive "Bits32"

105 | prim (Unsigned LongLong) = Primitive "JSBits64"

106 | prim (Signed Short)      = Primitive "Int16"

107 | prim (Signed Long)       = Primitive "Int32"

108 | prim (Signed LongLong)   = Primitive "JSInt64"

109 | prim (Unrestricted x)    = Primitive "Double"

110 | prim (Restricted x)      = Primitive "Double"

111 | prim Undefined           = Undef

112 | prim Byte                = Primitive "Int8"

113 | prim Octet               = Primitive "Bits8"

114 | prim BigInt              = Primitive "Integer"

116 | string : StringType -> SimpleType

117 | string ByteString = Unchangeable "ByteString"

118 | string DOMString  = Primitive "String"

119 | string USVString  = Primitive "String"

121 | strTpe : StringType -> String

122 | strTpe ByteString = "ByteString"

123 | strTpe DOMString = "String"

124 | strTpe USVString = "String"

126 | parameters (e : Env)

127 |            (dom : Domain)

129 |   -- Lookup the kind of an identifier from the environment

130 |   kind : Identifier -> Kind

131 |   kind i = fromMaybe (KOther i) $ lookup i e.kinds

133 |   mutual

134 |     -- the most interesting part when unaliasing a type:

135 |     -- here the aliases may be wrapped in an `I` data

136 |     -- constructor, in which case we try to convert it

137 |     -- to a distinguishable type. If that's not possible,

138 |     -- we return the corresponding type wrapped in a `Left`.

139 |     -- Otherwise we keep the distinguishable type

140 |     -- (but keep unaliasing inner types, if any)

141 |     uaD : DistinguishableF ExtAttributeList Kind -> Codegen CGType

142 |     uaD i@(I $ KAlias x) =

143 |       case lookup x e.aliases of

144 |         Nothing            => Left [UnresolvedAlias dom x]

145 |         Just x             => unalias x

146 |     uaD (I k)                 = Right $ fromKind k

147 |     uaD (Sequence x y)        = simple . Array <$> unalias y

148 |     uaD (FrozenArray x y)     = simple . Array <$> unalias y

149 |     uaD (ObservableArray x y) = simple . Array <$> unalias y

150 |     uaD (Record x _ z)        = simple . Record (strTpe x) <$> unalias z

151 |     uaD (P p)                 = Right . simple $ prim p

152 |     uaD (S s)                 = Right . simple $ string s

153 |     uaD (B b)                 = Right . simple $ buff b

154 |     uaD Object                = Right . simple . Interface True $

155 |                                 MkIdent "Object"

156 |     uaD Symbol                = Right $ unchangeable "Symbol"

158 |     uaU :

159 |          UnionTypeF ExtAttributeList Kind

160 |       -> Codegen (Nullable $ List1 SimpleType)

161 |     uaU (UT f s r) =

162 |       do (hf ::: tf) <- uaM f

163 |          rest        <- map join (traverse uaM (s ::: r))

165 |          let nullables = hf ::: (tf ++ forget rest)

166 |              simples   = map nullVal nullables

168 |          if any isNullable nullables

169 |             -- the result is nullable

170 |             then pure $ MaybeNull simples

171 |             -- the result is non-nullable

172 |             else pure $ NotNull simples

175 |     -- in case of a wrapped distinguishable type,

176 |     -- we unalias it using `uaD` but keep the unaliased

177 |     -- version only, if it is again distinguishable.

178 |     uaM :  UnionMemberTypeF ExtAttributeList Kind

179 |         -> Codegen (List1 $ Nullable SimpleType)

180 |     uaM (MkUnionMember a t) =

181 |       do t2 <- uaD t

182 |          case t2 of

183 |            Any       => Left [AnyInUnion dom]

184 |            Promise x => Left [PromiseInUnion dom]

185 |            Simple x  => Right $ singleton x

186 |            (Union $ MaybeNull xs) => Right $ map MaybeNull xs

187 |            (Union $ NotNull xs)   => Right $ map NotNull xs

189 |     unalias : IdlTypeF ExtAttributeList Kind -> Codegen CGType

190 |     unalias Any               = Right Any

191 |     unalias (D $ NotNull d)   = uaD d

192 |     unalias (U $ NotNull d)   = Union <$> uaU d

193 |     unalias (U $ MaybeNull d) = Union . nullable <$> uaU d

194 |     unalias (Promise x)       = Promise <$> unalias x

195 |     unalias t@(D $ MaybeNull d) =

196 |       do res <- uaD d

197 |          case res of

198 |            Any       => Left [NullableAny dom]

199 |            Simple x  => pure . Simple $ nullable x

200 |            Union x   => pure . Union $ nullable x

201 |            Promise x => Left [NullablePromise dom]

203 |   -- calculate the aliased type from a type coming

204 |   -- from the WebIDL parser

205 |   -- the unaliased version of the type is only kept (in a `Just`)

206 |   -- if it differs from the original type.

207 |   tpe : IdlType -> Codegen CGType

208 |   tpe t = let cgt = map kind t

209 |            in unalias cgt

211 |   -- convert an IDL type coming from the parser to

212 |   -- a return type in the code generator

213 |   rtpe : IdlType -> Codegen ReturnType

214 |   rtpe (D $ NotNull $ P Undefined)        = Right Undefined

215 |   rtpe (D $ NotNull $ I $ MkIdent "void") = Right Undefined

216 |   rtpe t = Def <$> tpe t

218 |   constTpe : ConstType -> Codegen CGConstType

219 |   constTpe (CI i) =

220 |     case uaD (I $ kind i) of

221 |       Left x                                 => Left x

222 |       Right (Simple $ NotNull $ Primitive s) => Right $ MkConstType s

223 |       Right _                                => Left [InvalidConstType dom]

225 |   constTpe (CP p) =

226 |     case prim p of

227 |       Primitive s => Right $ MkConstType s

228 |       _           => Left [InvalidConstType dom]

230 |   const : Const -> Codegen CGConst

231 |   const (MkConst t n v) = map (\t2 => MkConst t2 n v) (constTpe t)

237 |   -- create an optional argument named "value" from

238 |   -- a type coming from the parser

239 |   optArg : IdlType -> Default -> Codegen CGArg

240 |   optArg t d = [| Optional (pure $ MkArgName "value") (tpe t) (pure d) |]

242 |   -- create an argument named "value" from

243 |   -- a type coming from the parser

244 |   valArg : IdlType -> Codegen CGArg

245 |   valArg t = Mandatory (MkArgName "value") <$> tpe t

247 |   -- convert an argument coming from the parser

248 |   -- to one to be used in the code generator

249 |   arg : Arg -> Codegen CGArg

250 |   arg (MkArg _ t n) = Mandatory n <$> tpe t

252 |   -- convert an argument coming from the parser

253 |   -- to a vararg to be used in the code generator

254 |   vararg : Arg -> Codegen CGArg

255 |   vararg (MkArg _ t n) = VarArg n <$> tpe t

257 |   -- convert an argument coming from the parser

258 |   -- to an optional arg to be used in the code generator

259 |   opt : OptArg -> Codegen CGArg

260 |   opt (MkOptArg _ _ t n d) = [| Optional (pure n) (tpe t) (pure d) |]

262 |   -- convert an argument list coming from the parser

263 |   -- to a list of codegen args

264 |   toArgs : ArgumentList -> Codegen Args

265 |   toArgs (VarArg as v)    = [| snoc (traverse arg as) (vararg v) |]

266 |   toArgs (NoVarArg as os) = [| traverse arg as ++ traverse opt os |]

272 |   objectOnly : Supertypes

273 |   objectOnly = MkSupertypes [MkIdent "Object"] []

275 |   ||| Calculates the supertypes and mixins for a given

282 |   supertypes : Identifier -> Supertypes

283 |   supertypes = run e.maxInheritance

285 |     where

286 |       run : Nat -> Identifier -> Supertypes

287 |       run 0     i = objectOnly

288 |       run (S k) i =

289 |         case lookup i e.jsTypes of

290 |           Nothing => objectOnly

292 |           (Just $ MkJSType Nothing mixins) =>

293 |             { mixins := mixins } objectOnly

295 |           (Just $ MkJSType (Just parent) mixins) =>

296 |             let MkSupertypes parents mixins2 = run k parent

297 |              in MkSupertypes (parent :: parents) (mixins ++ mixins2)

303 |   op : Identifier -> Op a -> Codegen (List CGFunction)

304 |   op n (MkOp _ _ Nothing _)   = Left [RegularOpWithoutName dom n]

305 |   op n (MkOp _ t (Just o) as) =

306 |     map pure [| Regular (pure o) (pure $ kind n) (toArgs as) (rtpe t) |]

308 |   static : Identifier -> Op a -> Codegen (List CGFunction)

309 |   static n (MkOp _ _ Nothing _)   = Left [RegularOpWithoutName dom n]

310 |   static n (MkOp _ t (Just o) a) =

311 |     map pure [| Static (pure o) (pure $ kind n) (toArgs a) (rtpe t) |]

313 |   constr : Identifier -> ArgumentList -> Codegen (List CGFunction)

314 |   constr name args = pure . Constructor (kind name) <$> toArgs args

316 |   attrRO : Identifier -> Readonly Attribute -> Codegen (List CGFunction)

317 |   attrRO o (MkRO $ MkAttribute _ t n) =

318 |     pure . AttributeGet n (kind o) <$> rtpe t

320 |   attr : Identifier -> Attribute -> Codegen (List CGFunction)

321 |   attr obj (MkAttribute _ t n) =

322 |      map pure [| Attribute (pure n) (pure $ kind obj) (valArg t) (rtpe t) |]

324 |   str : Identifier -> Stringifier -> Codegen (List CGFunction)

325 |   str o (Z v)              = attr o v

326 |   str o (S $ Z v)          = attrRO o v

327 |   str o (S $ S $ Z v)      = op o v

328 |   str o (S $ S $ S $ Z ()) =

329 |     let name = Just $ MkOpName "toString"

330 |      in op o (MkOp () domString name (NoVarArg [] []))

332 |   staticAttrRO : Identifier -> Readonly Attribute -> Codegen (List CGFunction)

333 |   staticAttrRO o (MkRO $ MkAttribute _ t n) =

334 |     pure . StaticAttributeGet n (kind o) <$> rtpe t

336 |   staticAttr : Identifier -> Attribute -> Codegen (List CGFunction)

337 |   staticAttr obj (MkAttribute _ t n) =

338 |     let ak  = kind obj

339 |      in sequence [ StaticAttributeGet n ak <$> rtpe t

340 |                  , StaticAttributeSet n ak <$> valArg t

341 |                  ]

343 |   dictCon : Kind -> List DictionaryMemberRest -> Codegen CGFunction

344 |   dictCon o = go Nil Nil

346 |     where

347 |       go : Args -> Args -> List DictionaryMemberRest -> Codegen CGFunction

348 |       go xs ys [] = pure $ DictConstructor o (reverse xs ++ reverse ys)

349 |       go xs ys (Required _ t n :: zs) =

350 |         do t2 <- tpe t

351 |            go (Mandatory (MkArgName n.value) t2 :: xs) ys zs

352 |       go xs ys (Optional t n d :: zs) =

353 |         do t2 <- tpe t

354 |            go xs (Optional (MkArgName n.value) t2 d :: ys) zs

356 |   dictFuns : Dictionary -> Codegen (List CGFunction)

357 |   dictFuns d =

358 |     [| dictCon (kind d.name) (map snd d.members) ::

359 |        (map join (traverse (fromMember . snd) d.members))

360 |     |]

362 |     where

363 |       fromMember : DictionaryMemberRest -> Codegen (List CGFunction)

364 |       fromMember (Required _ t n) =

365 |         let an := Right $ MkAttributeName n.value

366 |          in map pure [| Attribute an (pure $ kind d.name)

367 |                                   (valArg t) (rtpe t) |]

369 |       fromMember (Optional t n def) =

370 |         let an  := Right $ MkAttributeName n.value

371 |             cgt := map (`UndefOr` Just def) (tpe t)

372 |             ak  := Right $ kind d.name

373 |          in map pure [| Attribute an ak (optArg t def) cgt |]

375 |   mixinFuns : Mixin -> Codegen (List CGFunction)

376 |   mixinFuns m = concat <$> traverse (fromMember . snd) m.members

378 |     where

379 |       fromMember : MixinMember -> Codegen (List CGFunction)

380 |       fromMember (MConst _)   = Right Nil

381 |       fromMember (MOp o)      = op m.name o

382 |       fromMember (MStr s)     = str m.name s

383 |       fromMember (MAttrRO ro) = attrRO m.name ro

384 |       fromMember (MAttr at)   = attr m.name at

386 |   ifaceFuns : Interface -> Codegen (List CGFunction)

387 |   ifaceFuns i = concat <$> traverse (fromMember . snd) i.members

389 |     where

390 |       getter : IdlType -> ArgumentList -> Codegen (List CGFunction)

391 |       getter t (NoVarArg [a] Nil) = do

392 |         ag <- arg a

393 |         rt <- rtpe t

394 |         if isIndex (argType ag)

395 |            then Right [Getter (kind i.name) ag rt]

396 |            else Left [InvalidGetter dom i.name]

398 |       getter _ _ = Left [InvalidGetter dom i.name]

400 |       setter : IdlType -> ArgumentList -> Codegen (List CGFunction)

401 |       setter t (NoVarArg [a,r] Nil) = do

402 |         ag <- arg a

403 |         rt <- rtpe t

404 |         rg <- arg r

405 |         if isIndex (argType ag) && isUndefined rt

406 |            then Right [Setter (kind i.name) ag rg]

407 |            else Left [InvalidSetter dom i.name]

409 |       setter _ _ = Left [InvalidSetter dom i.name]

411 |       -- getters and setters without a name are treated as indexed

412 |       -- versions (special syntax in the FFI), all others are treated

413 |       -- as regular operations

414 |       fromOp : Operation -> Codegen (List CGFunction)

415 |       fromOp (MkOp (Just Getter)  t Nothing as) = getter t as

416 |       fromOp (MkOp (Just Setter)  t Nothing as) = setter t as

417 |       fromOp (MkOp (Just Deleter) _ _       _ ) = Right Nil

418 |       fromOp x                                  = op i.name x

420 |       fromPart : PartialInterfaceMember -> Codegen (List CGFunction)

421 |       fromPart (IOp x)                 = fromOp x

422 |       fromPart (IStr x)                = str i.name x

423 |       fromPart (IStatic $ Z x)         = staticAttr i.name x

424 |       fromPart (IStatic $ S $ Z x)     = staticAttrRO i.name x

425 |       fromPart (IStatic $ S $ S $ Z x) = static i.name x

426 |       fromPart (IAttr x)               = attr i.name x

427 |       fromPart (IAttrRO x)             = attrRO i.name x

428 |       fromPart (IConst _)              = Right Nil

429 |       fromPart (IMap x)                = Right Nil

430 |       fromPart (ISet x)                = Right Nil

431 |       fromPart (IMapRO x)              = Right Nil

432 |       fromPart (ISetRO x)              = Right Nil

433 |       fromPart (IAttrInh x)            = Right Nil

434 |       fromPart (IIterable x y)         = Right Nil

435 |       fromPart (IAsync x y xs)         = Right Nil

437 |       fromMember : InterfaceMember -> Codegen (List CGFunction)

438 |       fromMember (Z $ MkConstructor as) = constr i.name as

439 |       fromMember (S $ Z p)              = fromPart p

440 |       fromMember (S $ S x) impossible

442 |   ifaceConsts : Interface -> Codegen (List CGConst)

443 |   ifaceConsts (MkInterface _ _ _ ms) = join <$> traverse (fromMember . snd) ms

445 |     where

446 |       fromMember : InterfaceMember -> Codegen (List CGConst)

447 |       fromMember (S $ Z $ IConst x) = map pure $ const x

448 |       fromMember _                  = Right []

450 |   mixinConsts : Mixin -> Codegen (List CGConst)

451 |   mixinConsts (MkMixin _ _ ms) = join <$> traverse (fromMember . snd) ms

452 |     where

453 |       fromMember : MixinMember -> Codegen (List CGConst)

454 |       fromMember (MConst x) = map pure $ const x

455 |       fromMember _          = Right []

457 |   callbackConsts : CallbackInterface -> Codegen (List CGConst)

458 |   callbackConsts (MkCallbackInterface _ _ ms) =

459 |     join <$> traverse (fromMember . snd) ms

461 |     where

462 |       fromMember : CallbackInterfaceMember -> Codegen (List CGConst)

463 |       fromMember v =

464 |         case extract Const v of

465 |           Nothing => Right []

466 |           Just x  => map pure $ const x

468 |   export

469 |   domain : Codegen CGDomain

470 |   domain =

471 |     [| MkDomain

472 |          (pure dom.domain)

473 |          callbacks

474 |          (traverse dict dom.dictionaries)

475 |          (pure dom.enums)

476 |          (traverse iface dom.interfaces)

477 |          (traverse mixin dom.mixins)

478 |     |]

480 |     where

481 |       dict : Dictionary -> Codegen CGDict

482 |       dict v@(MkDictionary _ n i _) =

483 |         MkDict n  (supertypes n) <$> dictFuns v

485 |       iface : Interface -> Codegen CGIface

486 |       iface v@(MkInterface _ n i _) =

487 |         [| MkIface

488 |              (pure n)

489 |              (pure $ supertypes n)

490 |              (ifaceConsts v)

491 |              (ifaceFuns v)

492 |         |]

494 |       mixin : Mixin -> Codegen CGMixin

495 |       mixin m = [| MkMixin (pure m.name) (mixinConsts m) (mixinFuns m) |]

497 |       callback : Callback -> Codegen CGCallback

498 |       callback c =

499 |         [| MkCallback

500 |              (pure c.name)

501 |              (pure Nil)

502 |              (rtpe c.type)

503 |              (toArgs c.args)

504 |         |]

506 |       callbackIface : CallbackInterface -> Codegen CGCallback

507 |       callbackIface v@(MkCallbackInterface _ n ms) =

508 |         case mapMaybe (\(_,m)   => extract RegularOperation m) ms of

509 |           [MkOp () t _ a] =>

510 |             [| MkCallback (pure n) (callbackConsts v) (rtpe t) (toArgs a) |]

511 |           xs => Left [CBInterfaceInvalidOps dom n (length xs)]

513 |       callbacks : Codegen (List CGCallback)

514 |       callbacks =

515 |         [| traverse callback dom.callbacks ++

516 |            traverse callbackIface dom.callbackInterfaces

517 |         |]