0 | module Text.WebIDL.Codegen.Members
  1 |
  2 | import Data.List
  3 | import Text.WebIDL.Codegen.Args
  4 | import Text.WebIDL.Codegen.Rules
  5 | import Text.WebIDL.Codegen.Types
  6 | import Text.WebIDL.Codegen.Util
  7 | import Text.WebIDL.Types
  8 |
  9 | %default total
 10 |
 11 | --------------------------------------------------------------------------------
 12 | --          Subtyping
 13 | --------------------------------------------------------------------------------
 14 |
 15 | export
 16 | jsType : Identifier -> Supertypes -> String
 17 | jsType n (MkSupertypes parents ms) =
 18 |   let mixins = sortedNubOn id ms
 19 |
 20 |    in render80 $
 21 |         vsep
 22 |           [ empty
 23 |           , line "public export"
 24 |           , line "JSType \{n} where"
 25 |           , indent 2 $ prettyCon Open "parents =" [list (map (line . value) parents)]
 26 |           , empty
 27 |           , indent 2 $ prettyCon Open "mixins =" [list (map (line . value) mixins)]
 28 |           ]
 29 |
 30 | --------------------------------------------------------------------------------
 31 | --          Constants
 32 | --------------------------------------------------------------------------------
 33 |
 34 | export
 35 | constants : List CGConst -> List String
 36 | constants = map (render80 . const) . sortBy (comparing name)
 37 |
 38 |   where
 39 |     const : {opts : _} -> CGConst -> Doc opts
 40 |     const (MkConst t n v) =
 41 |       indent 2 $
 42 |         vsep
 43 |           [ empty
 44 |           , line "public export"
 45 |           , line "\{n} :" <++> constTpe t
 46 |           , line "\{n} =" <++> prettyConst v
 47 |           ]
 48 |
 49 | --------------------------------------------------------------------------------
 50 | --          Callback Conversion
 51 | --------------------------------------------------------------------------------
 52 |
 53 | export
 54 | primCallback : CGCallback -> String
 55 | primCallback (MkCallback n _ t as) =
 56 |   callbackFFI n (primMarshallCallback n) (callbackFFI $ length as) as t
 57 |
 58 | export
 59 | callback : CGCallback -> String
 60 | callback (MkCallback n _ t as) =
 61 |   callbackAPI n (marshallCallback n) (primMarshallCallback n) as t
 62 |
 63 | --------------------------------------------------------------------------------
 64 | --          Attribute
 65 | --------------------------------------------------------------------------------
 66 |
 67 | attrImpl:
 68 |      {opts : _}
 69 |   -> (msg : Doc opts)
 70 |   -> (set : Doc opts)
 71 |   -> (get : Doc opts)
 72 |   -> (app : Doc opts)
 73 |   -> (arg : CGArg)
 74 |   -> (Doc opts, Doc opts)
 75 | attrImpl msg s g a (Mandatory _ (Simple $ MaybeNull x)) =
 76 |   ( line "Attribute False Maybe" <++> ret App (Simple $ NotNull x)
 77 |   , prettyCon Open "fromNullablePrim" [msg,s,g,a]
 78 |   )
 79 |
 80 | attrImpl msg s g a (Mandatory _ (Union $ MaybeNull x)) =
 81 |   ( line "Attribute False Maybe" <++> ret App (Union $ NotNull x)
 82 |   , prettyCon Open "fromNullablePrim" [msg,s,g,a]
 83 |   )
 84 |
 85 | attrImpl msg s g a (Mandatory _ t) =
 86 |   ( line "Attribute True Prelude.id" <++> ret App t
 87 |   , prettyCon Open "fromPrim" [msg,s,g,a]
 88 |   )
 89 |
 90 | attrImpl msg s g a (VarArg _ t) =
 91 |   ( line "Attribute True Prelude.id" <++> prettyCon App "VarArg" [ffi App t]
 92 |   , prettyCon Open "fromPrim" [msg,s,g,a]
 93 |   )
 94 |
 95 | attrImpl msg s g a (Optional _ t d) =
 96 |    case deflt (safeCast t) App t d of
 97 |      Nothing  =>
 98 |        ( line "Attribute False Optional" <++> ret App t
 99 |        , prettyCon Open "fromUndefOrPrimNoDefault" [msg,s,g,a]
100 |        )
101 |      Just x =>
102 |        ( line "Attribute True Optional" <++> ret App t
103 |        , prettyCon Open "fromUndefOrPrim" [msg,s,g,x,a]
104 |        )
105 |
106 | attrRW :
107 |      Nat
108 |   -> AttributeName
109 |   -> Kind
110 |   -> CGArg
111 |   -> ReturnType
112 |   -> String
113 | attrRW k n o t rt =
114 |   let implName := attrGetter k n
115 |       primGet  := line "\{primAttrGetter k n}"
116 |       primSet  := line "\{primAttrSetter k n}"
117 |       msg      := namespacedIdent o (fromString $ "get" ++ n.value)
118 |       po       := kindToString o
119 |       up       := if isParent o then "(v :> \{po})" else "v"
120 |
121 |       (tpe,impl) := attrImpl (line msg) primGet primSet (line up) t
122 |       funTpe :=
123 |         if isParent o
124 |            then
125 |              typeDecl
126 |                implName
127 |                tpe
128 |                [ line "{auto 0 _ : JSType t}"
129 |                , line "{auto 0 _ : Elem \{po} (Types t)}"
130 |                , line "t"
131 |                ]
132 |            else typeDecl implName tpe [line "\{po}"]
133 |
134 |    in render80 . indent 2 $
135 |         vsep
136 |           [ empty
137 |           , line "export"
138 |           , funTpe
139 |           , line "\{implName} v =" <++> impl
140 |           ]
141 |
142 | --------------------------------------------------------------------------------
143 | --          Functions
144 | --------------------------------------------------------------------------------
145 |
146 | obj : Kind -> CGArg
147 | obj k = Mandatory (MkArgName "obj") (fromKind k)
148 |
149 | function : (Nat,CGFunction) -> String
150 | function (k,Getter o i t) = fun o (getter k) (primGetter k) [obj o, i] t
151 |
152 | function (k,Setter o i v) =
153 |   fun o (setter k) (primSetter k) [obj o, i, v] Undefined
154 |
155 | function (k,Regular n o as t) = fun o (op k n) (primOp k n) (obj o :: as) t
156 |
157 | function (k,Static n o as t) = fun o (op k n) (primOp k n) as t
158 |
159 | function (k,Attribute n o t rt) = attrRW k n o t rt
160 |
161 | function (k,AttributeGet n o t) =
162 |   fun o (attrGetter k n) (primAttrGetter k n) [obj o] t
163 |
164 | function (k,StaticAttributeSet n o t) =
165 |   fun o (attrSetter k n) (primAttrSetter k n) [t] Undefined
166 |
167 | function (k,StaticAttributeGet n o t) =
168 |   fun o (attrGetter k n) (primAttrGetter k n) [] t
169 |
170 | function (k,DictConstructor o as) =
171 |   fun o (constr k) (primConstr k) as (fromKind o)
172 |
173 | function (k,Constructor o as) =
174 |   fun o (constr k) (primConstr k) as (fromKind o)
175 |
176 | hasVarArg : Args -> Bool
177 | hasVarArg (VarArg _ _ :: []) = True
178 | hasVarArg []                 = False
179 | hasVarArg (_ :: xs)          = hasVarArg xs
180 |
181 | prim : (Nat,CGFunction) -> String
182 | prim (k,Getter o i t) = funFFI (primGetter k) getterFFI [obj o, i] t
183 | prim (k,Setter o i v) = funFFI (primSetter k) setterFFI [obj o, i, v] Undefined
184 | prim (k,Regular n o args t) =
185 |   let as = obj o :: args
186 |    in if hasVarArg args
187 |          then funFFI (primOp k n) (funFFIVarArg n $ length args) as t
188 |          else funFFI (primOp k n) (funFFI n $ length args) as t
189 |
190 | prim (k,Static n o as t) =
191 |   if hasVarArg as
192 |      then funFFI (primOp k n) (staticFunFFIVarArg o n $ length as) as t
193 |      else funFFI (primOp k n) (staticFunFFI o n $ length as) as t
194 |
195 | prim (k,Attribute n o t rt) =
196 |   fastUnlines
197 |     [ funFFI (primAttrGetter k n) (attrGetFFI n) [obj o] rt
198 |     , ""
199 |     , funFFI (primAttrSetter k n) (attrSetFFI n) [obj o, t] Undefined
200 |     ]
201 |
202 | prim (k,AttributeGet n o t) =
203 |   funFFI (primAttrGetter k n) (attrGetFFI n) [obj o] t
204 |
205 | prim (k,StaticAttributeSet n o t) =
206 |   funFFI (primAttrSetter k n) (staticAttrSetFFI o n) [t] Undefined
207 |
208 | prim (k,StaticAttributeGet n o t) =
209 |   funFFI (primAttrGetter k n) (staticAttrGetFFI o n) [] t
210 |
211 | prim (k,DictConstructor o as) =
212 |   funFFI (primConstr k) (dictConFFI $ map argName as) as (fromKind o)
213 |
214 | prim (k,Constructor o as)  =
215 |   if hasVarArg as
216 |      then funFFI (primConstr k) (conFFIVarArg o $ length as) as (fromKind o)
217 |      else funFFI (primConstr k) (conFFI o $ length as) as (fromKind o)
218 |
219 | -- Tags functions with an index if several function of the
220 | -- same priority (same kind of function and same name) exist,
221 | -- as these would lead to overloading issues.
222 | tagFunctions : List CGFunction -> List (Nat,CGFunction)
223 | tagFunctions = go 0
224 |
225 |   where
226 |     go : Nat -> List CGFunction -> List (Nat,CGFunction)
227 |     go _ []        = []
228 |     go k (x :: []) = [(k,x)]
229 |     go k (x :: t@(y :: ys)) =
230 |       if priority x == priority y
231 |          then (k,x) :: go (S k) t
232 |          else (k,x) :: go 0 t
233 |
234 | export
235 | functions : List CGFunction -> List String
236 | functions = map function . tagFunctions . sortBy (comparing priority)
237 |
238 | export
239 | primFunctions : List CGFunction -> List String
240 | primFunctions = map prim . tagFunctions . sortBy (comparing priority)
241 |