0 | module Text.WebIDL.Codegen.Util

  2 | import Data.List

  3 | import Data.Nat

  4 | import Data.Stream

  5 | import public Data.String

  6 | import public Data.Vect

  7 | import public Text.PrettyPrint.Bernardy

  8 | import public Text.WebIDL.Codegen.Types

  9 | import public Text.WebIDL.Types

 11 | %default total

 14 | mapFirstChar : (Char -> Char) -> String -> String

 15 | mapFirstChar f x = case unpack x of

 16 |   []     => ""

 17 |   h :: t => pack (f h :: t)

 24 | sortedNubOn : Ord b => (a -> b) -> List a -> List a

 25 | sortedNubOn f = nub . sortBy (comparing f)

 27 |   where

 28 |     nub : List a -> List a

 29 |     nub (x :: t@(y :: ys)) = if f x == f y then nub t else x :: nub t

 30 |     nub xs                 = xs

 37 | moduleName : String -> String

 38 | moduleName "uievents" = "UIEvents"

 39 | moduleName s          = mapFirstChar toUpper s

 46 | unquote : String -> List Char

 47 | unquote = run . unpack

 49 |   where

 50 |     run : List Char -> List Char

 51 |     run []                   = []

 52 |     run ('\\' :: '"' :: cs)  = '"' :: run cs

 53 |     run ('"' :: cs)          = run cs

 54 |     run (c   :: cs)          = c :: run cs

 61 | toDataConstructor : String -> String

 62 | toDataConstructor s = case unquote s of

 63 |   []        => "Empty"

 64 |   ['2','d'] => "TwoD"

 65 |   c :: cs   => pack (toUpper c :: run cs)

 67 |   where

 68 |     run : List Char -> List Char

 69 |     run []             = []

 70 |     run (x :: xs@(c :: cs)) =

 71 |       if isAlphaNum x then x :: run xs else toUpper c :: run cs

 72 |     run (c :: cs)      = c :: run cs

 79 | title : String -> String

 80 | title n = """

 87 | section : String -> List String -> String

 88 | section _ Nil = ""

 89 | section t ds  = unlines ("" :: title t :: ds)

 96 | namespaced : Identifier -> List String -> String

 97 | namespaced _ [] = ""

 98 | namespaced n ds = unlines $ "" :: "namespace \{n.value}" :: ds

104 | parameters {opts : LayoutOpts}

106 |   export

107 |   functionTypeOnly : (res : Doc opts) -> (args : List $ Doc opts) -> Doc opts

108 |   functionTypeOnly res []     = parens $ "() ->" <++> res

109 |   functionTypeOnly res (h::t) =

110 |     let withArrows := map (line "->" <++>) (t ++ [res])

111 |         sl         := parens (hsep $ h :: withArrows)

112 |         ml         := vsep $ (line "(  " <+> h) :: withArrows ++ [line ")"]

113 |      in ifMultiline sl ml

115 |   export

116 |   functionType :

117 |        (name : IdrisIdent)

118 |     -> (sep  : String)

119 |     -> (res  : Doc opts)

120 |     -> (args : List $ Doc opts)

121 |     -> Doc opts

122 |   functionType nm sep res [] =

123 |     let head := line "\{nm} \{sep}"

124 |      in ifMultiline (head <++> res) (vappend head $ indent 2 res)

125 |   functionType nm sep res (h::t) =

126 |     let head       := line "\{nm} \{sep}"

127 |         withArrows := map (line "->" <++>) (t ++ [res])

128 |         sl         := hsep $ head :: h :: withArrows

129 |         ml         := vsep $ indent 3 h :: withArrows

130 |      in ifMultiline sl (vappend head $ indent 2 ml)

132 |   export

133 |   typeDecl :

134 |        (name : IdrisIdent)

135 |     -> (res : Doc opts)

136 |     -> (args : List $ Doc opts)

137 |     -> Doc opts

138 |   typeDecl n = functionType n ":"

144 | ix : Nat -> String

145 | ix Z = ""

146 | ix k = show k

149 | primSetter : Nat -> IdrisIdent

150 | primSetter k = Prim . fromString $ "set" ++ ix k

153 | setter : Nat -> IdrisIdent

154 | setter k = fromString $ "set" ++ ix k

157 | primGetter : Nat -> IdrisIdent

158 | primGetter k = Prim . fromString $ "get" ++ ix k

161 | getter : Nat -> IdrisIdent

162 | getter k = fromString $ "get" ++ ix k

165 | primAttrSetter : Nat -> AttributeName -> IdrisIdent

166 | primAttrSetter k n =

167 |   Prim $ fromString ("set" ++ mapFirstChar toUpper n.value ++ ix k)

170 | attrSetter : Nat -> AttributeName -> IdrisIdent

171 | attrSetter k n = fromString $ "set" ++ mapFirstChar toUpper n.value ++ ix k

174 | primAttrGetter : Nat -> AttributeName -> IdrisIdent

175 | primAttrGetter k n = Prim $ fromString (n.value ++ ix k)

178 | attrGetter : Nat -> AttributeName -> IdrisIdent

179 | attrGetter k n = fromString $ n.value ++ ix k

182 | primOp : Nat -> OperationName -> IdrisIdent

183 | primOp k n = Prim $ fromString (n.value ++ ix k)

186 | op : Nat -> OperationName -> IdrisIdent

187 | op k n = fromString (n.value ++ ix k)

190 | primConstr : Nat -> IdrisIdent

191 | primConstr k = Prim $ fromString ("new" ++ ix k)

194 | constr : Nat -> IdrisIdent

195 | constr k = fromString ("new" ++ ix k)

198 | marshallCallback : Identifier -> IdrisIdent

199 | marshallCallback i = fromString $ "to" ++ i.value

202 | primMarshallCallback : Identifier -> IdrisIdent

203 | primMarshallCallback i = Prim . fromString $ "to" ++ i.value

210 | argNames : Stream String

211 | argNames =

212 |   "a" :: "b" :: "c" :: "d" :: "e" :: "f" :: "g" ::

213 |   "h" :: "i" :: "j" :: "k" :: "l" :: "m" :: "n" ::

214 |   "o" :: "p" :: "q" :: "r" :: "s" :: "t" :: "u" ::

215 |   "v" :: "w" :: "y" :: "z" ::

216 |   map (\v => "x" ++ show {ty = Integer} v) [1 ..]

219 | unShadowingArgNames : IdrisIdent -> Stream String

220 | unShadowingArgNames i = go "\{i}" argNames

221 |   where

222 |     go : String -> Stream String -> Stream String

223 |     go s (h :: t) = if s == h then t else h :: go s t

225 | foreignBrowser : String -> String

226 | foreignBrowser s = "%foreign \"browser:lambda:\{s}\""

229 | attrGetFFI : AttributeName -> String

230 | attrGetFFI n = foreignBrowser "x=>x.\{n.value}"

233 | staticAttrGetFFI : Kind -> AttributeName -> String

234 | staticAttrGetFFI o n =

235 |   foreignBrowser "()=>\{kindToString o}.\{n.value}"

238 | attrSetFFI : AttributeName -> String

239 | attrSetFFI n = foreignBrowser "(x,v)=>{x.\{n.value} = v}"

242 | staticAttrSetFFI : Kind -> AttributeName -> String

243 | staticAttrSetFFI o n =

244 |   foreignBrowser "v=>{\{kindToString o}.\{n.value} = v}"

247 | funFFI : OperationName -> Nat -> String

248 | funFFI n Z = foreignBrowser "x=>x.\{n.value}()"

249 | funFFI n k =

250 |   let vs   := take k argNames

251 |       vals := fastConcat $ intersperse "," vs

252 |    in foreignBrowser "(x,\{vals})=>x.\{n.value}(\{vals})"

255 | funFFIVarArg : OperationName -> Nat -> String

256 | funFFIVarArg n k =

257 |   let vs   := take (pred k) argNames

258 |       vals := fastConcat $ intersperse "," (vs ++ ["va"])

259 |       args := fastConcat $ intersperse "," (vs ++ ["...va()"])

260 |    in foreignBrowser "(x,\{vals})=>x.\{n.value}(\{args})"

263 | staticFunFFI : Kind -> OperationName -> Nat -> String

264 | staticFunFFI o n Z = foreignBrowser "x=>x.\{n.value}()"

265 | staticFunFFI o n k =

266 |   let vs   := take k argNames

267 |       vals := fastConcat $ intersperse "," vs

268 |    in foreignBrowser "(\{vals})=>\{kindToString o}.\{n.value}(\{vals})"

271 | staticFunFFIVarArg : Kind -> OperationName -> Nat -> String

272 | staticFunFFIVarArg o n k =

273 |   let vs   := take (pred k) argNames

274 |       vals := fastConcat $ intersperse "," (vs ++ ["va"])

275 |       args := fastConcat $ intersperse "," (vs ++ ["...va()"])

276 |    in foreignBrowser "(\{vals})=>\{kindToString o}.\{n.value}(\{args})"

279 | conFFI : Kind -> Nat -> String

280 | conFFI n k =

281 |   let vs   := take k argNames

282 |       vals := fastConcat $ intersperse "," vs

283 |    in foreignBrowser "(\{vals})=> new \{kindToString n}(\{vals})"

286 | conFFIVarArg : Kind -> Nat -> String

287 | conFFIVarArg n k =

288 |   let vs   := take (pred k) argNames

289 |       vals := fastConcat $ intersperse "," (vs ++ ["va"])

290 |       args := fastConcat $ intersperse "," (vs ++ ["...va()"])

291 |    in foreignBrowser "(\{vals})=> new \{kindToString n}(\{args})"

294 | dictConFFI : List ArgumentName -> String

295 | dictConFFI ns =

296 |   let vs     := take (length ns) argNames

297 |       vals   := fastConcat $ intersperse "," vs

298 |       fields := fastConcat $ intersperse "," (zipWith app vs ns)

299 |    in foreignBrowser "(\{vals})=> ({\{fields}})"

301 |   where

302 |     app : String -> ArgumentName -> String

303 |     app v a = a.value ++ ": " ++ v

306 | getterFFI : String

307 | getterFFI = foreignBrowser "(o,x)=>o[x]"

310 | setterFFI : String

311 | setterFFI = foreignBrowser "(o,x,v)=>o[x] = v"

314 | callbackFFI : Nat -> String

315 | callbackFFI n =

316 |   let vs := fastConcat $ intersperse "," $ take n argNames

317 |    in foreignBrowser "x=>(\{vs})=>x(\{vs})()"

323 | export %inline

324 | render80 : Doc (Opts 80) -> String

325 | render80 = render _