0 | module Web.Async.Widget

  2 | import Data.Linear.Unique

  3 | import Data.List1

  4 | import Data.String

  5 | import HTTP.API.Decode

  6 | import Text.CSS.Declaration

  7 | import Text.CSS.Property

  8 | import Text.HTML

  9 | import Text.HTML.DomID

 10 | import Text.HTML.Select

 11 | import Web.Async.I18n

 12 | import Web.Async.Util

 13 | import Web.Async.View

 14 | import Web.Internal.Types

 16 | import public Web.Async.I18n

 17 | import public Web.Async.Widget.Types

 19 | %default total

 20 | %hide Data.Linear.(.)

 21 | %hide Text.HTML.Node.a

 22 | %hide Types.SelectionMode.Select

 29 | export %inline

 30 | disabledEdit : {0 a : _} -> Has JSErr es => Ref t -> EditRes a -> JS es ()

 31 | disabledEdit r = disabled r . not . isValid

 33 | endStream : DOMLocal => JSStream () -> JSStream t -> JSStream t

 34 | endStream end es =

 35 |   finally logEnded $ haltOn (P.observe' logAbort end) es

 43 | endOnRemove : DOMLocal => Widget t -> JS es (Widget t)

 44 | endOnRemove (W ns es) = Prelude.do

 45 |   E end <- event ()

 46 |   pure $ W (map adj ns) (endStream end es)

 47 |   where

 48 |     adj : Sink () => HTMLNode -> HTMLNode

 49 |     adj (El  t as ns) = El  t (onRemove () :: as) ns

 50 |     adj (EEl t as)    = EEl t (onRemove () :: as)

 51 |     adj n             = n

 58 | voidRef : Ref t -> Ref Void

 59 | voidRef (Id id)  = Elem id

 60 | voidRef (Elem s) = Elem s

 61 | voidRef Body     = Body

 62 | voidRef Document = Document

 63 | voidRef Window   = Window

 68 | attributesWithID :

 69 |      {auto lio : LIO io}

 70 |   -> {s   : _}

 71 |   -> (0 t : HTMLTag s)

 72 |   -> List (Attribute t)

 73 |   -> io (Ref t, List (Attribute t))

 74 | attributesWithID t attrs =

 75 |   case attrID attrs of

 76 |     Nothing => map (\i => (tagRef t i, ref i :: attrs)) uniqueID

 77 |     Just x  => pure (x, attrs)

 85 | nodeWithID : LIO io => HTMLNode -> io (Maybe (Ref Void, HTMLNode))

 86 | nodeWithID (El t x y) =

 87 |   (\(i,a) => Just (voidRef i,El t a y)) <$> attributesWithID t x

 88 | nodeWithID (EEl t x)  =

 89 |   (\(i,a) => Just (voidRef i,EEl t a)) <$> attributesWithID t x

 90 | nodeWithID (Raw _)    = pure Nothing

 91 | nodeWithID (Text _)   = pure Nothing

 92 | nodeWithID Empty      = pure Nothing

 97 | validateRes : DOMLocal => Ref t -> (0 p : ValidityTag t) => EditRes s -> Act ()

 98 | validateRes r v = validityMessage r (editRes v) >> attr r (validity v)

100 | parameters {auto loc : DOMLocal}

101 |            (tpe      : InputType)

102 |            (attrs    : List (Attribute Tag.Input))

104 |   textInP : String -> JS es (Ref Tag.Input, Widget String)

105 |   textInP v = do

106 |     E es   <- eventFrom v

107 |     (i,as) <- attributesWithID Tag.Input attrs

108 |     let es' := observe logInput es

109 |     pure (i, W [input $ [value v, type tpe, onInput Prelude.id] ++ as] es')

111 |   ||| An input element that emits `String` events.

112 |   export

113 |   textIn : String -> JS es (Widget String)

114 |   textIn v = snd <$> textInP v

116 |   ||| A validated input element that emits events of type

120 |   export

121 |   valIn : String -> (String -> EditRes e) -> JS es (Widget $ EditRes e)

122 |   valIn v f = do

123 |     (r, W n evs) <- textInP v

124 |     pure $ W n (observe (validateRes r) (mapOutput f evs))

127 | read : DOMLocal => Decode t => String -> EditRes t

128 | read s =

129 |   case Decode.decode (fromString s) of

130 |     Left x  => case s of

131 |       "" => Missing

132 |       s  => Invalid "\{x}"

133 |     Right x => Valid x

135 | fakeBody : String -> String

136 | fakeBody s =

137 |   case [<] <>< forget (String.split ('\\' ==) s) of

138 |     _ :< p => p

139 |     _      => ""

141 | toFile : InputInfo -> Maybe FileEv

142 | toFile (MkInputInfo p [f] _) = Just (FE f (fakeBody p))

143 | toFile _                     = Nothing

146 | onFileIn : Sink e => (f : FileEv -> e) -> Attribute Tag.Input

147 | onFileIn f = Event (Input $ map f . toFile)

149 | Interpolation FileEv where interpolate = name

152 | fileIn : DOMLocal => Attributes Tag.Input -> JS es (Widget $ EditRes FileEv)

153 | fileIn as = do

154 |   E es   <- eventFrom Missing

155 |   pure $

156 |     W [input $ [type File, onFileIn Valid] ++ as]

157 |       (observe (logRes fileStr) es)

163 | listInit : Maybe t -> (v -> t) -> List v -> Maybe t

164 | listInit (Just x) f xs     = Just x

165 | listInit Nothing  f (x::_) = Just (f x)

166 | listInit _        _ _      = Nothing

168 | entriesInit : List (SelectEntry t) -> Maybe t

169 | entriesInit []                = Nothing

170 | entriesInit (Title _   :: xs) = entriesInit xs

171 | entriesInit (Entry v _ :: xs) = Just v

173 | selToRes : Maybe (SelectEv t) -> EditRes t

174 | selToRes = maybe Missing (Valid . value)

176 | initEv : Nat -> (t -> Bool) -> List (SelectEntry t) -> Maybe (SelectEv t)

177 | initEv n f []                = Nothing

178 | initEv n f (Title _   :: xs) = initEv n f xs

179 | initEv n f (Entry v s :: xs) =

180 |   case f v of

181 |     False => initEv (S n) f xs

182 |     True  => Just (SE n s v)

184 | parameters {auto lc : DOMLocal}

185 |            {auto eq : Eq t}

187 |   ||| A select element displaying the values of type `v`

192 |   export

193 |   selEntries :

194 |        List (SelectEntry t)

195 |     -> List (Attribute Select)

196 |     -> Maybe t

197 |     -> JS es (Widget (EditRes t))

198 |   selEntries vs as m = do

199 |     let ini := m <|> entriesInit vs

200 |     E ws @{s} <- eventFrom (initEv 0 ((ini ==) . Just) vs)

201 |     let ms := cmap Just s

202 |     let ws' := observe logSelect ws |> P.mapOutput selToRes

203 |     pure $ W [selectEntries vs ((ini ==) . Just) id as] ws'

205 |   ||| A select element displaying the values of type `v`

210 |   export

211 |   sel :

212 |        (v -> t)

213 |     -> (v -> String)

214 |     -> List v

215 |     -> List (Attribute Select)

216 |     -> Maybe t

217 |     -> JS es (Widget (EditRes t))

218 |   sel f g = selEntries . map (\v => Entry (f v) (g v))

220 | export %inline

221 | txtEdit :

222 |      {auto loc : DOMLocal}

223 |   -> (parse : String -> EditRes t)

224 |   -> (tpe   : InputType)

225 |   -> (ini   : Maybe t -> String)

226 |   -> (attrs : List (Attribute Tag.Input))

227 |   -> Editor t

228 | txtEdit parse tpe ini as = E $ \m => valIn tpe as (ini m) parse

230 | export %inline

231 | selEdit :

232 |      {auto loc : DOMLocal}

233 |   -> {auto ip : Interpolation t}

234 |   -> {auto eq : Eq t}

235 |   -> (values  : List t)

236 |   -> (attrs   : List (Attribute Select))

237 |   -> Editor t

238 | selEdit vs = E . sel id interpolate vs

244 | 0 StopRef : Type

245 | StopRef = IORef (Maybe $ Event JS [JSErr] ())

248 | stopref : Act StopRef

249 | stopref = newref Nothing

252 | stopStream : DOMLocal => StopRef -> Act (Event JS [JSErr] ())

253 | stopStream ref = Prelude.do

254 |   m <- readref ref

255 |   for_ m $ \(E {}) => sink () >> logSwitchStopped

256 |   ev  <- event ()

257 |   writeref ref (Just ev)

258 |   pure ev

260 | hiddenDiv : DomID -> HTMLNode

261 | hiddenDiv i = div [style [display None], ref i] []

264 | bindEd : DOMLocal => (a -> Editor b) -> (Maybe b -> Maybe a) -> Editor a -> Editor b

265 | bindEd f fromB (E w) =

266 |   E $ \mb => Prelude.do

267 |     i       <- uniqueID

268 |     j       <- uniqueID

269 |     ref     <- stopref

270 |     W na as <- w (fromB mb)

271 |     pure $ W (na ++ [hiddenDiv i, hiddenDiv j]) $

272 |       switchMap id $

273 |            P.mapMaybe toMaybe as

274 |         |> P.zipWithIndex

275 |         |> P.evalMap (adj i j ref mb)

277 |   where

278 |     adj :

279 |          (i,j : DomID)

280 |       -> StopRef

281 |       -> Maybe b

282 |       -> (a,Nat)

283 |       -> Act (JSStream (EditRes b))

284 |     adj i j ref mb (va,n)  = Prelude.do

285 |       logSwitch

286 |       E es <- stopStream ref

287 |       W nb xs  <- widget (f va) (if n == 0 then mb else Nothing)

288 |       replaceBetween (elemRef i) (elemRef j) nb

289 |       logReplaced

290 |       pure (endStream es xs)