0 | module Text.WebIDL.Codegen.Definitions
  1 |
  2 | import Data.List
  3 | import Data.List.Elem
  4 | import Data.SOP
  5 | import Data.String
  6 | import Text.WebIDL.Codegen.Args
  7 | import Text.WebIDL.Codegen.Enum
  8 | import Text.WebIDL.Codegen.Members
  9 | import Text.WebIDL.Codegen.Rules
 10 | import Text.WebIDL.Codegen.Types
 11 | import public Text.WebIDL.Codegen.Util
 12 |
 13 | %default total
 14 |
 15 | --------------------------------------------------------------------------------
 16 | --          Imports
 17 | --------------------------------------------------------------------------------
 18 |
 19 | defImports : CGDomain -> String
 20 | defImports d = """
 21 |   import JS
 22 |   import Web.Internal.\{d.name}Prim
 23 |   import Web.Internal.Types
 24 |   """
 25 |
 26 | typeImports : String
 27 | typeImports = "import JS"
 28 |
 29 | --------------------------------------------------------------------------------
 30 | --          Data Declarations
 31 | --------------------------------------------------------------------------------
 32 |
 33 | extern : CGDomain -> String
 34 | extern d =
 35 |   fastUnlines
 36 |     [ section "Interfaces" $ exts ext name d.ifaces
 37 |     , section "Dictionaries" $ exts extNoCast name d.dicts
 38 |     , section "Mixins" $ exts extNoCast name d.mixins
 39 |     , section "Callbacks" $ exts extNoCast name d.callbacks
 40 |     ]
 41 |
 42 |   where
 43 |     extNoCast : String -> String
 44 |     extNoCast s = """
 45 |       export data \{s} : Type where [external]
 46 |
 47 |       export
 48 |       ToFFI \{s} \{s} where toFFI = id
 49 |
 50 |       export
 51 |       FromFFI \{s} \{s} where fromFFI = Just
 52 |       """
 53 |
 54 |     ext : String -> String
 55 |     ext s = extNoCast s ++ "\n\n" ++ """
 56 |       export
 57 |       SafeCast \{s} where
 58 |         safeCast = unsafeCastOnPrototypeName "\{s}"
 59 |       """
 60 |
 61 |     exts :
 62 |          (f : String -> String)
 63 |       -> (a -> Identifier)
 64 |       -> List a
 65 |       -> List String
 66 |     exts f g = map (("\n" ++) . f) . sort . map (value . g)
 67 |
 68 | --------------------------------------------------------------------------------
 69 | --          CallbackInterfaces
 70 | --------------------------------------------------------------------------------
 71 |
 72 | cbacks : (CGCallback -> List String) -> CGDomain -> String
 73 | cbacks f = section "Callbacks" . map ns . sortBy (comparing name) . callbacks
 74 |   where ns : CGCallback -> String
 75 |         ns i = namespaced i.name (f i)
 76 |
 77 | callbacks : CGDomain -> String
 78 | callbacks = cbacks go
 79 |   where go : CGCallback -> List String
 80 |         go cb = callback cb :: constants cb.constants
 81 |
 82 | primCallbacks : CGDomain -> String
 83 | primCallbacks = cbacks (pure . primCallback)
 84 |
 85 | --------------------------------------------------------------------------------
 86 | --          JSType
 87 | --------------------------------------------------------------------------------
 88 |
 89 | jsTypes : List CGDomain -> String
 90 | jsTypes ds =
 91 |   let ifs  := sortBy (comparing name) (ds >>= ifaces)
 92 |       dics := sortBy (comparing name) (ds >>= dicts)
 93 |    in section "Inheritance" $
 94 |         map (\i => jsType i.name i.super) ifs ++
 95 |         map (\d => jsType d.name d.super) dics
 96 |
 97 | --------------------------------------------------------------------------------
 98 | --          Interfaces
 99 | --------------------------------------------------------------------------------
100 |
101 | ifaces' : (CGIface -> List String) -> CGDomain -> String
102 | ifaces' f = section "Interfaces" . map ns . sortBy (comparing name) . ifaces
103 |
104 |   where
105 |     ns : CGIface -> String
106 |     ns i = namespaced i.name (f i)
107 |
108 | ifaces : CGDomain -> String
109 | ifaces = ifaces' $ \(MkIface n s cs fs) => constants cs ++ functions fs
110 |
111 | primIfaces : CGDomain -> String
112 | primIfaces = ifaces' (primFunctions . functions)
113 |
114 | --------------------------------------------------------------------------------
115 | --          Dictionaries
116 | --------------------------------------------------------------------------------
117 |
118 | dicts' : (CGDict -> List String) -> CGDomain -> String
119 | dicts' f = section "Dictionaries" . map ns . sortBy (comparing name) . dicts
120 |
121 |   where
122 |     ns : CGDict -> String
123 |     ns d = namespaced d.name (f d)
124 |
125 | dicts : CGDomain -> String
126 | dicts = dicts' $ \(MkDict n s fs) => functions fs
127 |
128 | primDicts : CGDomain -> String
129 | primDicts = dicts' (primFunctions . functions)
130 |
131 | --------------------------------------------------------------------------------
132 | --          Mixins
133 | --------------------------------------------------------------------------------
134 |
135 | mixins' : (CGMixin -> List String) -> CGDomain -> String
136 | mixins' f = section "Mixins" . map ns . sortBy (comparing name) . mixins
137 |
138 |   where
139 |     ns : CGMixin -> String
140 |     ns m = namespaced m.name (f m)
141 |
142 | mixins : CGDomain -> String
143 | mixins = mixins' $ \(MkMixin n cs fs) => constants cs ++ functions fs
144 |
145 | primMixins : CGDomain -> String
146 | primMixins = mixins' (primFunctions . functions)
147 |
148 | --------------------------------------------------------------------------------
149 | --          Typedefs
150 | --------------------------------------------------------------------------------
151 |
152 | export
153 | typedefs : List CGDomain -> String
154 | typedefs ds =
155 |   """
156 |   module Web.Internal.Types
157 |
158 |   import JS
159 |   import public Web.Internal.AnimationTypes as Types
160 |   import public Web.Internal.ClipboardTypes as Types
161 |   import public Web.Internal.CssTypes as Types
162 |   import public Web.Internal.CssomviewTypes as Types
163 |   import public Web.Internal.DomTypes as Types
164 |   import public Web.Internal.FetchTypes as Types
165 |   import public Web.Internal.FileTypes as Types
166 |   import public Web.Internal.GeometryTypes as Types
167 |   import public Web.Internal.HtmlTypes as Types
168 |   import public Web.Internal.IndexedDBTypes as Types
169 |   import public Web.Internal.MediasourceTypes as Types
170 |   import public Web.Internal.MediastreamTypes as Types
171 |   import public Web.Internal.PermissionsTypes as Types
172 |   import public Web.Internal.ServiceworkerTypes as Types
173 |   import public Web.Internal.StreamsTypes as Types
174 |   import public Web.Internal.SvgTypes as Types
175 |   import public Web.Internal.UIEventsTypes as Types
176 |   import public Web.Internal.UrlTypes as Types
177 |   import public Web.Internal.VisibilityTypes as Types
178 |   import public Web.Internal.WebglTypes as Types
179 |   import public Web.Internal.WebidlTypes as Types
180 |   import public Web.Internal.XhrTypes as Types
181 |
182 |   %default total
183 |   """ ++ "\n\n" ++ jsTypes ds
184 |
185 | --------------------------------------------------------------------------------
186 | --          Codegen
187 | --------------------------------------------------------------------------------
188 | --
189 | export
190 | types : CGDomain -> String
191 | types d =
192 |   """
193 |   module Web.Internal.\{d.name}Types
194 |
195 |   \{typeImports}
196 |
197 |   %default total
198 |
199 |   \{enums d.enums}
200 |   \{extern d}
201 |   """
202 |
203 | export
204 | primitives : CGDomain -> String
205 | primitives d =
206 |   """
207 |   module Web.Internal.\{d.name}Prim
208 |
209 |   import JS
210 |   import Web.Internal.Types
211 |
212 |   %default total
213 |
214 |   \{primIfaces d}
215 |   \{primMixins d}
216 |   \{primDicts d}
217 |   \{primCallbacks d}
218 |   """
219 |
220 | export
221 | definitions : CGDomain -> String
222 | definitions d =
223 |   """
224 |   module Web.Raw.\{d.name}
225 |
226 |   \{defImports d}
227 |
228 |   %default total
229 |
230 |   \{Definitions.ifaces d}
231 |   \{Definitions.mixins d}
232 |   \{Definitions.dicts d}
233 |   \{Definitions.callbacks d}
234 |   """
235 |