\"+a.content+\"\"},!u.document)return u.addEventListener&&(M.disableWorkerMessageHandler||u.addEventListener(\"message\",function(e){var n=JSON.parse(e.data),t=n.language,r=n.code,a=n.immediateClose;u.postMessage(M.highlight(r,M.languages[t],t)),a&&u.close()},!1)),M;var t=M.util.currentScript();function r(){M.manual||M.highlightAll()}if(t&&(M.filename=t.src,t.hasAttribute(\"data-manual\")&&(M.manual=!0)),!M.manual){var a=document.readyState;\"loading\"===a||\"interactive\"===a&&t&&t.defer?document.addEventListener(\"DOMContentLoaded\",r):window.requestAnimationFrame?window.requestAnimationFrame(r):window.setTimeout(r,16)}return M}(_self);\"undefined\"!=typeof module&&module.exports&&(module.exports=Prism),\"undefined\"!=typeof global&&(global.Prism=Prism);\
- \Prism.languages.markup={comment:{pattern://,greedy:!0},prolog:{pattern:/<\\?[\\s\\S]+?\\?>/,greedy:!0},doctype:{pattern:/\"'[\\]]|\"[^\"]*\"|'[^']*')+(?:\\[(?:[^<\"'\\]]|\"[^\"]*\"|'[^']*'|<(?!!--)|)*\\]\\s*)?>/i,greedy:!0,inside:{\"internal-subset\":{pattern:/(^[^\\[]*\\[)[\\s\\S]+(?=\\]>$)/,lookbehind:!0,greedy:!0,inside:null},string:{pattern:/\"[^\"]*\"|'[^']*'/,greedy:!0},punctuation:/^$|[[\\]]/,\"doctype-tag\":/^DOCTYPE/i,name:/[^\\s<>'\"]+/}},cdata:{pattern://i,greedy:!0},tag:{pattern:/<\\/?(?!\\d)[^\\s>\\/=$<%]+(?:\\s(?:\\s*[^\\s>\\/=]+(?:\\s*=\\s*(?:\"[^\"]*\"|'[^']*'|[^\\s'\">=]+(?=[\\s>]))|(?=[\\s/>])))+)?\\s*\\/?>/,greedy:!0,inside:{tag:{pattern:/^<\\/?[^\\s>\\/]+/,inside:{punctuation:/^<\\/?/,namespace:/^[^\\s>\\/:]+:/}},\"special-attr\":[],\"attr-value\":{pattern:/=\\s*(?:\"[^\"]*\"|'[^']*'|[^\\s'\">=]+)/,inside:{punctuation:[{pattern:/^=/,alias:\"attr-equals\"},/\"|'/]}},punctuation:/\\/?>/,\"attr-name\":{pattern:/[^\\s>\\/]+/,inside:{namespace:/^[^\\s>\\/:]+:/}}}},entity:[{pattern:/&[\\da-z]{1,8};/i,alias:\"named-entity\"},/&#x?[\\da-f]{1,8};/i]},Prism.languages.markup.tag.inside[\"attr-value\"].inside.entity=Prism.languages.markup.entity,Prism.languages.markup.doctype.inside[\"internal-subset\"].inside=Prism.languages.markup,Prism.hooks.add(\"wrap\",function(a){\"entity\"===a.type&&(a.attributes.title=a.content.replace(/&/,\"&\"))}),Object.defineProperty(Prism.languages.markup.tag,\"addInlined\",{value:function(a,e){var s={};s[\"language-\"+e]={pattern:/(^$)/i,lookbehind:!0,inside:Prism.languages[e]},s.cdata=/^$/i;var t={\"included-cdata\":{pattern://i,inside:s}};t[\"language-\"+e]={pattern:/[\\s\\S]+/,inside:Prism.languages[e]};var n={};n[a]={pattern:RegExp(\"(<__[^>]*>)(?:))*\\\\]\\\\]>|(?!)\".replace(/__/g,function(){return a}),\"i\"),lookbehind:!0,greedy:!0,inside:t},Prism.languages.insertBefore(\"markup\",\"cdata\",n)}}),Object.defineProperty(Prism.languages.markup.tag,\"addAttribute\",{value:function(a,e){Prism.languages.markup.tag.inside[\"special-attr\"].push({pattern:RegExp(\"(^|[\\\"'\\\\s])(?:\"+a+\")\\\\s*=\\\\s*(?:\\\"[^\\\"]*\\\"|'[^']*'|[^\\\\s'\\\">=]+(?=[\\\\s>]))\",\"i\"),lookbehind:!0,inside:{\"attr-name\":/^[^\\s=]+/,\"attr-value\":{pattern:/=[\\s\\S]+/,inside:{value:{pattern:/(^=\\s*([\"']|(?![\"'])))\\S[\\s\\S]*(?=\\2$)/,lookbehind:!0,alias:[e,\"language-\"+e],inside:Prism.languages[e]},punctuation:[{pattern:/^=/,alias:\"attr-equals\"},/\"|'/]}}}})}}),Prism.languages.html=Prism.languages.markup,Prism.languages.mathml=Prism.languages.markup,Prism.languages.svg=Prism.languages.markup,Prism.languages.xml=Prism.languages.extend(\"markup\",{}),Prism.languages.ssml=Prism.languages.xml,Prism.languages.atom=Prism.languages.xml,Prism.languages.rss=Prism.languages.xml;\
- \!function(s){var e=/(?:\"(?:\\\\(?:\\r\\n|[\\s\\S])|[^\"\\\\\\r\\n])*\"|'(?:\\\\(?:\\r\\n|[\\s\\S])|[^'\\\\\\r\\n])*')/;s.languages.css={comment:/\\/\\*[\\s\\S]*?\\*\\//,atrule:{pattern:/@[\\w-](?:[^;{\\s]|\\s+(?![\\s{]))*(?:;|(?=\\s*\\{))/,inside:{rule:/^@[\\w-]+/,\"selector-function-argument\":{pattern:/(\\bselector\\s*\\(\\s*(?![\\s)]))(?:[^()\\s]|\\s+(?![\\s)])|\\((?:[^()]|\\([^()]*\\))*\\))+(?=\\s*\\))/,lookbehind:!0,alias:\"selector\"},keyword:{pattern:/(^|[^\\w-])(?:and|not|only|or)(?![\\w-])/,lookbehind:!0}}},url:{pattern:RegExp(\"\\\\burl\\\\((?:\"+e.source+\"|(?:[^\\\\\\\\\\r\\n()\\\"']|\\\\\\\\[^])*)\\\\)\",\"i\"),greedy:!0,inside:{function:/^url/i,punctuation:/^\\(|\\)$/,string:{pattern:RegExp(\"^\"+e.source+\"$\"),alias:\"url\"}}},selector:{pattern:RegExp(\"(^|[{}\\\\s])[^{}\\\\s](?:[^{};\\\"'\\\\s]|\\\\s+(?![\\\\s{])|\"+e.source+\")*(?=\\\\s*\\\\{)\"),lookbehind:!0},string:{pattern:e,greedy:!0},property:{pattern:/(^|[^-\\w\\xA0-\\uFFFF])(?!\\s)[-_a-z\\xA0-\\uFFFF](?:(?!\\s)[-\\w\\xA0-\\uFFFF])*(?=\\s*:)/i,lookbehind:!0},important:/!important\\b/i,function:{pattern:/(^|[^-a-z0-9])[-a-z0-9]+(?=\\()/i,lookbehind:!0},punctuation:/[(){};:,]/},s.languages.css.atrule.inside.rest=s.languages.css;var t=s.languages.markup;t&&(t.tag.addInlined(\"style\",\"css\"),t.tag.addAttribute(\"style\",\"css\"))}(Prism);\
- \Prism.languages.haskell={comment:{pattern:/(^|[^-!#$%*+=?&@|~.:<>^\\\\\\/])(?:--(?:(?=.)[^-!#$%*+=?&@|~.:<>^\\\\\\/].*|$)|\\{-[\\s\\S]*?-\\})/m,lookbehind:!0},char:{pattern:/'(?:[^\\\\']|\\\\(?:[abfnrtv\\\\\"'&]|\\^[A-Z@[\\]^_]|ACK|BEL|BS|CAN|CR|DC1|DC2|DC3|DC4|DEL|DLE|EM|ENQ|EOT|ESC|ETB|ETX|FF|FS|GS|HT|LF|NAK|NUL|RS|SI|SO|SOH|SP|STX|SUB|SYN|US|VT|\\d+|o[0-7]+|x[0-9a-fA-F]+))'/,alias:\"string\"},string:{pattern:/\"(?:[^\\\\\"]|\\\\(?:\\S|\\s+\\\\))*\"/,greedy:!0},keyword:/\\b(?:case|class|data|deriving|do|else|if|in|infixl|infixr|instance|let|module|newtype|of|primitive|then|type|where)\\b/,\"import-statement\":{pattern:/(^[\\t ]*)import\\s+(?:qualified\\s+)?(?:[A-Z][\\w']*)(?:\\.[A-Z][\\w']*)*(?:\\s+as\\s+(?:[A-Z][\\w']*)(?:\\.[A-Z][\\w']*)*)?(?:\\s+hiding\\b)?/m,lookbehind:!0,inside:{keyword:/\\b(?:as|hiding|import|qualified)\\b/,punctuation:/\\./}},builtin:/\\b(?:abs|acos|acosh|all|and|any|appendFile|approxRational|asTypeOf|asin|asinh|atan|atan2|atanh|basicIORun|break|catch|ceiling|chr|compare|concat|concatMap|const|cos|cosh|curry|cycle|decodeFloat|denominator|digitToInt|div|divMod|drop|dropWhile|either|elem|encodeFloat|enumFrom|enumFromThen|enumFromThenTo|enumFromTo|error|even|exp|exponent|fail|filter|flip|floatDigits|floatRadix|floatRange|floor|fmap|foldl|foldl1|foldr|foldr1|fromDouble|fromEnum|fromInt|fromInteger|fromIntegral|fromRational|fst|gcd|getChar|getContents|getLine|group|head|id|inRange|index|init|intToDigit|interact|ioError|isAlpha|isAlphaNum|isAscii|isControl|isDenormalized|isDigit|isHexDigit|isIEEE|isInfinite|isLower|isNaN|isNegativeZero|isOctDigit|isPrint|isSpace|isUpper|iterate|last|lcm|length|lex|lexDigits|lexLitChar|lines|log|logBase|lookup|map|mapM|mapM_|max|maxBound|maximum|maybe|min|minBound|minimum|mod|negate|not|notElem|null|numerator|odd|or|ord|otherwise|pack|pi|pred|primExitWith|print|product|properFraction|putChar|putStr|putStrLn|quot|quotRem|range|rangeSize|read|readDec|readFile|readFloat|readHex|readIO|readInt|readList|readLitChar|readLn|readOct|readParen|readSigned|reads|readsPrec|realToFrac|recip|rem|repeat|replicate|return|reverse|round|scaleFloat|scanl|scanl1|scanr|scanr1|seq|sequence|sequence_|show|showChar|showInt|showList|showLitChar|showParen|showSigned|showString|shows|showsPrec|significand|signum|sin|sinh|snd|sort|span|splitAt|sqrt|subtract|succ|sum|tail|take|takeWhile|tan|tanh|threadToIOResult|toEnum|toInt|toInteger|toLower|toRational|toUpper|truncate|uncurry|undefined|unlines|until|unwords|unzip|unzip3|userError|words|writeFile|zip|zip3|zipWith|zipWith3)\\b/,number:/\\b(?:\\d+(?:\\.\\d+)?(?:e[+-]?\\d+)?|0o[0-7]+|0x[0-9a-f]+)\\b/i,operator:[{pattern:/`(?:[A-Z][\\w']*\\.)*[_a-z][\\w']*`/,greedy:!0},{pattern:/(\\s)\\.(?=\\s)/,lookbehind:!0},/[-!#$%*+=?&@|~:<>^\\\\\\/][-!#$%*+=?&@|~.:<>^\\\\\\/]*|\\.[-!#$%*+=?&@|~.:<>^\\\\\\/]+/],hvariable:{pattern:/\\b(?:[A-Z][\\w']*\\.)*[_a-z][\\w']*/,inside:{punctuation:/\\./}},constant:{pattern:/\\b(?:[A-Z][\\w']*\\.)*[A-Z][\\w']*/,inside:{punctuation:/\\./}},punctuation:/[{}[\\];(),.:]/},Prism.languages.hs=Prism.languages.haskell;\
- \"
-
-prismCss :: JSString
-prismCss = "\
- \/* PrismJS 1.25.0\
- \https://prismjs.com/download.html#themes=prism&languages=haskell */\
- \code[class*=language-],pre[class*=language-]{color:#000;background:0 0;text-shadow:0 1px #fff;font-family:Consolas,Monaco,'Andale Mono','Ubuntu Mono',monospace;font-size:1em;text-align:left;white-space:pre;word-spacing:normal;word-break:normal;word-wrap:normal;line-height:1.5;-moz-tab-size:4;-o-tab-size:4;tab-size:4;-webkit-hyphens:none;-moz-hyphens:none;-ms-hyphens:none;hyphens:none}code[class*=language-] ::-moz-selection,code[class*=language-]::-moz-selection,pre[class*=language-] ::-moz-selection,pre[class*=language-]::-moz-selection{text-shadow:none;background:#b3d4fc}code[class*=language-] ::selection,code[class*=language-]::selection,pre[class*=language-] ::selection,pre[class*=language-]::selection{text-shadow:none;background:#b3d4fc}@media print{code[class*=language-],pre[class*=language-]{text-shadow:none}}pre[class*=language-]{padding:1em;margin:.5em 0;overflow:auto}:not(pre)>code[class*=language-],pre[class*=language-]{background:#f5f2f0}:not(pre)>code[class*=language-]{padding:.1em;border-radius:.3em;white-space:normal}.token.cdata,.token.comment,.token.doctype,.token.prolog{color:#708090}.token.punctuation{color:#999}.token.namespace{opacity:.7}.token.boolean,.token.constant,.token.deleted,.token.number,.token.property,.token.symbol,.token.tag{color:#905}.token.attr-name,.token.builtin,.token.char,.token.inserted,.token.selector,.token.string{color:#690}.language-css .token.string,.style .token.string,.token.entity,.token.operator,.token.url{color:#9a6e3a;background:hsla(0,0%,100%,.5)}.token.atrule,.token.attr-value,.token.keyword{color:#07a}.token.class-name,.token.function{color:#dd4a68}.token.important,.token.regex,.token.variable{color:#e90}.token.bold,.token.important{font-weight:700}.token.italic{font-style:italic}.token.entity{cursor:help}\
- \"
diff --git a/examples/simple-routing/Pages.hs b/examples/simple-routing/Pages.hs
deleted file mode 100644
index b4f9af3..0000000
--- a/examples/simple-routing/Pages.hs
+++ /dev/null
@@ -1,205 +0,0 @@
-module Pages where
-
-import Control.Monad.IO.Class
-import Control.Monad.Reader
-import Data.Foldable
-import Data.List qualified as List
-import Data.Maybe
-import Data.Ord
-import HtmlT
-import JavaScript.Compat.Marshal
-import JavaScript.Compat.String (JSString)
-import JavaScript.Compat.String qualified as JSS
-
-import "this" Assets
-import "this" Router
-import "this" Utils
-
-homePage :: Html ()
-homePage = unsafeHtml $ "\
- \How routing works \
- \Inside the \
- \Router \
- \module there is a definition of type Route:
\
- \" <> highlightHaskell "\
- \data Route\n\
- \ = HomeR -- matches root route\n\
- \ | CountriesMapR CountriesMapQ -- example: #map?selected=ru\n\
- \ | CountriesListR CountriesListQ -- example: #list?page=3"
- <> " \
- \Here Route defines the list of webpages in the site. \
- \Constructor parameters (like CountriesMapQ) indicate \
- \that this page takes some information from the URL string encoded in GET \
- \parameters or URL segments. By convention route contructors have suffix \
- \-R and constructor parameters has suffix -Q
\
- \Another importants definitions are these two functions:\
- \
" <> highlightHaskell "\
- \parseRoute :: UrlParts -> Maybe Route\n\
- \parseRoute = \\case\n\
- \ Url [] [] -> Just HomeR\n\
- \ Url [\"map\"] q\n\
- \ | selected <- List.lookup \"selected\" q\n\
- \ -> Just $ CountriesMapR CountriesMapQ{selected}\n\
- \ Url [\"list\"] q\n\
- \ | search <- List.lookup \"search\" q\n\
- \ , page <- parsePage $ List.lookup \"page\" q\n\
- \ , sort_dir <- parseSortDir $ List.lookup \"sort_dir\" q\n\
- \ , sort_by <- parseSortBy $ List.lookup \"sort_by\" q\n\
- \ -> Just $ CountriesListR CountriesListQ{search, page, sort_dir, sort_by}"
- <> " " <> highlightHaskell "\
- \printRoute :: Route -> UrlParts\n\
- \printRoute = \\case\n\
- \ HomeR -> Url [] []\n\
- \ CountriesMapR q -> Url [\"map\"] $ catMaybes\n\
- \ [ (\"selected\",) <$> q.selected ]\n\
- \ CountriesListR q -> Url [\"list\"] $ catMaybes\n\
- \ [ (\"search\",) <$> mfilter (/=\"\") q.search\n\
- \ , (\"page\",) <$> printPage q.page\n\
- \ , (\"sort_dir\",) <$> printSortDir q.sort_dir\n\
- \ , (\"sort_by\",) <$> printSortBy q.sort_by\n\
- \ ]"
- <> " \
- \With help of haskell guarded pattern-match syntax it's easy to convert a \
- \URL in form of UrlParts to a structured datatype like \
- \Route and other way around. The type Route and \
- \these two functions conclude the portable part of the routing mechanism. \
- \They can and should be shared with backend code to construct correct URLs \
- \and implement backend part of HTML5-style routing.\
- \Last thing we need to run the site is this auxiliary function \
- \mkUrlHashRef \
- \that creates a DynRef JSString — dynamic value containing current \
- \hash-string from the browser. When parsed to Dynamic Route \
- \and then mapped with (<&>) operator to \
- \Dynamic (Html ()) the dyn function can be used to \
- \attach the contents of dynamic pages to the application.\
- \
" <> highlightHaskell "\
- \dyn $ routeDyn <&> \\case\n\
- \ HomeR -> homePage\n\
- \ CountriesMapR q -> countriesMapPage q\n\
- \ CountriesListR q -> countriesListPage q"
- <> " "
-
-countriesListPage :: CountriesListQ -> Html ()
-countriesListPage q = div_ [class_ "CountriesList"] do
- searchQueryRef <- newRef q
- form_ do
- onOptions "submit" (ListenerOpts True True True) \_event -> do
- newRoute <- toUrl . CountriesListR . (\s -> s{page = 1}) <$> readRef searchQueryRef
- pushUrl newRoute
- div_ [style_ "display:flex;"] do
- input_
- [ type_ "text" , placeholder_ "Search countries by title", autofocus_ True
- ] do
- dynValue $ fromMaybe "" . (.search) <$> fromRef searchQueryRef
- on "input" $ decodeEvent valueDecoder $
- modifyRef searchQueryRef . (\v s -> s{search = v}) . Just
- button_ [type_ "submit"] "Search"
- table_ do
- thead_ $ tr_ do
- th_ ""
- thSort SortByTitle "Country Name"
- thSort SortByRegion "Region"
- thSort SortBySubregion "Subregion"
- thSort SortByPopulation "Population"
- tbody_ do
- for_ pageResults \(n, country) -> tr_ do
- td_ do text (JSS.pack (show @Int n))
- td_ do
- a_ [href_ (mkMapLink country.code)] do
- for_ country.flag_icon
- (img_ . (>> style_ "display:inline; margin-right: 6px"). src_)
- text country.title
- td_ do text country.region
- td_ do text country.subregion
- td_ do text (JSS.pack (show country.population))
- center_ do
- for_ (paginate total q.page itemsPerPage) \case
- Nothing ->
- button_ [disabled_ True] "..."
- Just p -> a_
- [ href_ (toUrl (CountriesListR q {page = p}))] $
- button_ [disabled_ (q.page == p)] $ text $ JSS.pack $ show p
- dl_ do
- dt_ "Country"
- dd_ $ unsafeHtml "The word country comes from \
- \Old French contrée , which derives from \
- \Vulgar Latin (terra ) contrata (\"(land) lying \
- \opposite\"; \"(land) spread before\"), derived from contra \
- \(\"against, opposite\"). It most likely entered the English language \
- \after the Franco-Norman invasion \
- \ during the 11th century."
- where
- thSort sortBy title = th_ [style_ "cursor: pointer"] do
- text title
- case (q.sort_by, q.sort_dir) of
- (sortVal, Asc) | sortVal == sortBy -> text "▲"
- (sortVal, Desc) | sortVal == sortBy -> text "▼"
- otherwise -> text ""
- on_ "click" do pushUrl $ toUrl . CountriesListR . toggleSortBy sortBy $ q
-
- toggleSortBy sortBy q
- | q.sort_by == sortBy = q {sort_dir = flipDir q.sort_dir}
- | otherwise = q {sort_by = sortBy, sort_dir = Asc}
- where
- flipDir = \case Asc -> Desc; Desc -> Asc
-
- offset = pred q.page * itemsPerPage
- total = Prelude.length countryResults
- pageResults = Prelude.zip [offset + 1..]
- . Prelude.take itemsPerPage
- . Prelude.drop offset
- $ countryResults
- countryResults = List.sortOn countrySortDir
- . Prelude.filter countryFilter
- $ countries
- countryFilter country = case q.search of
- Just needle ->
- JSS.isInfixOf (JSS.toLower needle) (JSS.toLower country.title)
- Nothing -> True
- countrySortBy = case q.sort_by of
- SortByTitle -> Left . (.title)
- SortByRegion -> Right . Left . (.region)
- SortBySubregion -> Right . Right . Left . (.subregion)
- SortByPopulation -> Right . Right . Right . (.population)
- countrySortDir = case q.sort_dir of
- Asc -> Left . countrySortBy
- Desc -> Right . Down . countrySortBy
- itemsPerPage = 40
- mkMapLink = toUrl . CountriesMapR . CountriesMapQ . Just . JSS.toLower
-
-countriesMapPage :: CountriesMapQ -> Html ()
-countriesMapPage q =
- div_ [class_ "CountriesMap"] $
- figure_ $ center_ do
- unsafeHtml countriesMap
- figcaption_ "political map of the planet Earth"
- centerEl <- asks html_current_element
- liftIO $ js_selectCountry centerEl $ maybeToNullable $
- fmap JSS.toJSValPure q.selected
- on "click" \event -> do
- mcode <- fmap JSS.fromJSValPure . nullableToMaybe <$>
- liftIO (js_svgClickGetCountryCode event)
- mapM_ (pushUrl . toUrl . CountriesMapR . CountriesMapQ . Just) mcode
-
-paginate
- :: Int -- ^ Total number of items
- -> Int -- ^ Current page
- -> Int -- ^ Items per page
- -> [Maybe Int] -- ^ List of page links, Nothing stands for ellipsis
-paginate totalItems curPage limit
- | totalPages <= maxLinks =
- fmap Just [1..totalPages]
- | curPage <= 7 =
- fmap Just [1..8] <> [Nothing, Just totalPages]
- | curPage >= totalPages - 6 =
- [Just 1, Nothing] <> fmap Just [(totalPages - 8)..totalPages]
- | otherwise =
- [Just 1, Nothing] <> fmap Just [(curPage - 2)..(curPage + 3)]
- <> [Nothing, Just totalPages]
- where
- (pageQuot, pageRem) = totalItems `divMod` limit
- totalPages = if pageRem == 0 then pageQuot else pageQuot + 1
- maxLinks = 10
diff --git a/examples/simple-routing/Router.hs b/examples/simple-routing/Router.hs
deleted file mode 100644
index 386e25a..0000000
--- a/examples/simple-routing/Router.hs
+++ /dev/null
@@ -1,147 +0,0 @@
-module Router where
-
-import Control.Monad
-import Data.Bifunctor
-import Data.List qualified as List
-import Data.Maybe
-import Data.Function
-import GHC.Generics
-import Text.Read
-import JavaScript.Compat.String (JSString(..))
-import JavaScript.Compat.String qualified as JSS
-
-data UrlParts = Url
- { partsPath :: [JSString] -- ^ Path segments
- , partsQuery :: [(JSString, JSString)] -- ^ GET parameters
- } deriving (Eq, Show, Generic)
-
-data Route
- = HomeR
- | CountriesMapR CountriesMapQ
- | CountriesListR CountriesListQ
- deriving (Eq, Show, Generic)
-
-data CountriesListQ = CountriesListQ
- { search :: Maybe JSString
- , page :: Int
- , sort_by :: CountrySortBy
- , sort_dir :: SortDir
- } deriving (Eq, Show, Generic)
-
-data CountriesMapQ = CountriesMapQ
- { selected :: Maybe JSString
- } deriving (Eq, Show, Generic)
-
-data SortDir = Asc | Desc
- deriving (Eq, Show, Generic)
-
-data CountrySortBy
- = SortByTitle
- | SortByPopulation
- | SortByRegion
- | SortBySubregion
- deriving (Eq, Show, Generic)
-
-parseRoute :: UrlParts -> Maybe Route
-parseRoute = \case
- Url [] [] -> Just HomeR
- Url ["map"] q
- | selected <- List.lookup "selected" q
- -> Just $ CountriesMapR CountriesMapQ{selected}
- Url ["list"] q
- | search <- List.lookup "search" q
- , page <- parsePage $ List.lookup "page" q
- , sort_dir <- parseSortDir $ List.lookup "sort_dir" q
- , sort_by <- parseSortBy $ List.lookup "sort_by" q
- -> Just $ CountriesListR CountriesListQ{search, page, sort_dir, sort_by}
- _ -> Nothing
- where
- parsePage = fromMaybe defaultCountriesListQ.page
- . (parseIntQuery =<<)
- parseSortDir = \case
- Just "asc" -> Asc
- Just "desc" -> Desc
- _ -> defaultCountriesListQ.sort_dir
- parseSortBy = \case
- Just "title" -> SortByTitle
- Just "population" -> SortByPopulation
- Just "region" -> SortByRegion
- Just "subregion" -> SortBySubregion
- _ -> defaultCountriesListQ.sort_by
- parseIntQuery = readMaybe . JSS.unpack
-
-printRoute :: Route -> UrlParts
-printRoute = \case
- HomeR -> Url [] []
- CountriesMapR q -> Url ["map"] $ catMaybes
- [ ("selected",) <$> q.selected ]
- CountriesListR q -> Url ["list"] $ catMaybes
- [ ("search",) <$> mfilter (/="") q.search
- , ("page",) <$> printPage q.page
- , ("sort_dir",) <$> printSortDir q.sort_dir
- , ("sort_by",) <$> printSortBy q.sort_by
- ]
- where
- printPage = fmap toIntQuery .
- mfilter (/=defaultCountriesListQ.page) . Just
- printSortDir = fmap (\case
- Asc -> "asc"
- Desc -> "desc") .
- mfilter (/=defaultCountriesListQ.sort_dir) . Just
- printSortBy = fmap (\case
- SortByTitle -> "title"
- SortByPopulation -> "population"
- SortByRegion -> "region"
- SortBySubregion -> "subregion") .
- mfilter (/=defaultCountriesListQ.sort_by) . Just
- toIntQuery = JSS.pack . show
-
-defaultCountriesListQ :: CountriesListQ
-defaultCountriesListQ = CountriesListQ
- { search = Nothing
- , page = 1
- , sort_by = SortByPopulation
- , sort_dir = Desc
- }
-
-defaultCountriesMapQ :: CountriesMapQ
-defaultCountriesMapQ = CountriesMapQ
- { selected = Nothing
- }
-
-toUrl :: Route -> JSString
-toUrl = ("#"<>) . partsToText . printRoute
-
-fromUrl :: JSString -> Maybe Route
-fromUrl url = url
- & JSS.stripPrefix "#"
- & fromMaybe url
- & textToParts
- & parseRoute
-
-partsToText :: UrlParts -> JSString
-partsToText (Url s q) = JSS.intercalate "?" (segments : query)
- where
- segments =
- JSS.intercalate "/" $ fmap JSS.encodeURIComponent s
- query = q
- & fmap (bimap JSS.encodeURIComponent JSS.encodeURIComponent)
- & fmap (\(k, v) -> k <> "=" <> v)
- & List.filter (not . JSS.null)
- & JSS.intercalate "&"
- & List.filter (not . JSS.null) . (:[])
-
-textToParts :: JSString -> UrlParts
-textToParts t = Url segments query
- where
- (segmentsStr, queryStr) = breakOn1 "?" t
- segments = segmentsStr
- & JSS.splitOn "/"
- & List.filter (not . JSS.null)
- & fmap JSS.decodeURIComponent
- query = queryStr
- & JSS.splitOn "&"
- & List.filter (not . JSS.null)
- & fmap (breakOn1 "=" . JSS.decodeURIComponent)
- breakOn1 s t =
- let (a, b) = JSS.breakOn s t in (a, JSS.drop 1 b)
diff --git a/examples/simple-routing/Utils.hs b/examples/simple-routing/Utils.hs
deleted file mode 100644
index bbf873c..0000000
--- a/examples/simple-routing/Utils.hs
+++ /dev/null
@@ -1,94 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE ForeignFunctionInterface #-}
-{-# LANGUAGE JavaScriptFFI #-}
-module Utils where
-
-import Control.Monad.IO.Class
-import Data.Coerce
-import HtmlT
-import JavaScript.Compat.Foreign.Callback
-import JavaScript.Compat.Marshal
-import JavaScript.Compat.Prim
-import JavaScript.Compat.String (JSString)
-import JavaScript.Compat.String qualified as JSS
-import Unsafe.Coerce
-
-mkUrlHashRef :: MonadReactive m => m (DynRef JSString)
-mkUrlHashRef = do
- initial <- liftIO js_readUrlHash
- routeRef <- newRef initial
- win <- liftIO getCurrentWindow
- popStateCb <- liftIO $ asyncCallback $
- js_readUrlHash >>= dynStep . writeRef routeRef
- liftIO $ js_callMethod2 (coerce win) "addEventListener"
- (JSS.toJSValPure "popstate") (unsafeCoerce popStateCb)
- installFinalizer do
- js_callMethod2 (coerce win) "removeEventListener"
- (JSS.toJSValPure "popstate") (unsafeCoerce popStateCb)
- releaseCallback popStateCb
- return routeRef
-
-pushUrl :: MonadIO m => JSString -> m ()
-pushUrl url = liftIO $ js_pushHref url
-
-highlightHaskell :: JSString -> JSString
-highlightHaskell = js_highlightHaskell
-
-insertScript :: JSString -> IO ()
-insertScript = js_insertScript
-
-#if defined(javascript_HOST_ARCH)
-foreign import javascript unsafe
- "(function(el, code){\
- if (!code) return;\
- var svgGroup = el.querySelector('#' + code); if (!svgGroup) return;\
- var svgPaths = svgGroup instanceof SVGPathElement ? [svgGroup] : svgGroup.querySelectorAll('path');\
- for (var i = 0; i < svgPaths.length; i++) {\
- svgPaths[i].classList.add('selected');\
- }\
- svgGroup.parentElement.appendChild(svgGroup);\
- })"
- js_selectCountry :: DOMElement -> Nullable JSVal -> IO ()
-
-foreign import javascript unsafe
- "(function(event){\
- var iter = event.target;\
- for(;;){\
- if (!iter || !iter.parentNode) break;\
- /* immediate children contains the country code */\
- if (iter.parentNode instanceof SVGSVGElement) return iter.id;\
- iter = iter.parentNode;\
- }\
- return null;\
- })"
- js_svgClickGetCountryCode :: DOMEvent -> IO (Nullable JSVal)
-
-foreign import javascript unsafe
- "((s) => Prism.highlight(s, Prism.languages.haskell, 'haskell'))"
- js_highlightHaskell :: JSString -> JSString
-
-foreign import javascript unsafe
- "(function(script){\
- var scriptEl = document.createElement('script');\
- scriptEl.innerText = script;\
- document.head.appendChild(scriptEl);\
- })"
- js_insertScript :: JSString -> IO ()
-foreign import javascript unsafe
- "(function(){\
- return location.hash;\
- })"
- js_readUrlHash :: IO JSString
-foreign import javascript unsafe
- "(function(url){\
- return location = url;\
- })"
- js_pushHref :: JSString -> IO ()
-#else
-js_selectCountry :: DOMElement -> Nullable JSVal -> IO () = errorGhcjsOnly
-js_svgClickGetCountryCode :: DOMEvent -> IO (Nullable JSVal) = errorGhcjsOnly
-js_highlightHaskell :: JSString -> JSString = errorGhcjsOnly
-js_insertScript :: JSString -> IO () = errorGhcjsOnly
-js_readUrlHash :: IO JSString = errorGhcjsOnly
-js_pushHref :: JSString -> IO () = errorGhcjsOnly
-#endif
diff --git a/examples/simple-routing/prism.externs b/examples/simple-routing/prism.externs
deleted file mode 100644
index 34e97e8..0000000
--- a/examples/simple-routing/prism.externs
+++ /dev/null
@@ -1,16 +0,0 @@
-/** @const */
-var Prism = {};
-
-/** @const */
-Prism.languages = {};
-
-/** @const */
-Prism.languages.haskell = {};
-
-/**
- * @param {string} code
- * @param {!Object} language
- * @param {string} languageString
- * @return {string}
- */
-Prism.highlight = function(code, language, languageString) {};
\ No newline at end of file
diff --git a/examples/simple-routing/simple-routing.hs b/examples/simple-routing/simple-routing.hs
deleted file mode 100644
index 26a8d46..0000000
--- a/examples/simple-routing/simple-routing.hs
+++ /dev/null
@@ -1,68 +0,0 @@
-import Control.Monad
-import Control.Monad.IO.Class
-import Data.Maybe
-import Data.Functor
-import HtmlT
-import JavaScript.Compat.String (JSString(..))
-
-import "this" Pages
-import "this" Router
-import "this" Utils
-import "this" Assets
-
-main :: IO ()
-main = void $ attachToBody do
- liftIO $ insertScript prismJs
- el "style" (text awsmCss)
- el "style" (text customCss)
- el "style" (text prismCss)
- urlHashRef <- mkUrlHashRef
- let routeDyn = fromMaybe HomeR . fromUrl <$> fromRef urlHashRef
- header_ do
- h1_ "Simple in-browser routing example"
- p_ do
- "See the source on the "
- a_ [href_ "https://github.com/lagunoff/htmlt/blob/master/examples/\
- \simple-routing/"] "github"
- nav_ $ ul_ do
- let link t r = li_ $ a_ [href_ (toUrl r)] $ text t
- link "Home" HomeR
- link "List of Countries" $ CountriesListR defaultCountriesListQ
- link "Countries on the Map" $ CountriesMapR defaultCountriesMapQ
- main_ $ dyn $ routeDyn <&> \case
- HomeR -> homePage
- CountriesMapR q -> countriesMapPage q
- CountriesListR q -> countriesListPage q
- footer_ $ p_ $ a_ [href_ "https://github.com/lagunoff"] "Vladislav Lagunov"
-
-customCss :: JSString
-customCss = "\
- \body header, body main, body footer, body article {\
- \ max-width: 80rem;\
- \}\
- \pre {\
- \ border-left: solid 8px rgb(0 0 0 / 14%);\
- \ padding-left: 16px;\
- \ background: transparent;\
- \}\
- \.CountriesList table {\
- \ width: 100%;;\
- \}\
- \.CountriesList table th, .CountriesList table td {\
- \ white-space: nowrap;\
- \}\
- \.CountriesList table th:last-child, .CountriesList table td:last-child {\
- \ width: 99%;\
- \ text-align: right;\
- \}\
- \.CountriesMap svg path.selected {\
- \ fill: #bfd3ff !important;\
- \ stroke: #4175e8;\
- \ stroke-width: 1;\
- \}\
- \.CountriesMap svg path {\
- \ cursor: pointer;\
- \}\
- \.CountriesMap svg path:hover {\
- \ fill: #ccc;\
- \}"
diff --git a/examples/todomvc/TodoItem.hs b/examples/todomvc/TodoItem.hs
deleted file mode 100644
index 8f566f9..0000000
--- a/examples/todomvc/TodoItem.hs
+++ /dev/null
@@ -1,109 +0,0 @@
-module TodoItem where
-
-import Control.Monad.State
-import Data.Maybe
-import GHC.Generics (Generic)
-import HtmlT
-import JavaScript.Compat.Marshal
-import JavaScript.Compat.Prim
-import JavaScript.Compat.String (JSString)
-import JavaScript.Compat.String qualified as JSS
-
-import "this" Utils
-
-data TodoItemConfig = TodoItemConfig
- { state_ref :: DynRef TodoItemState
- , is_hidden_dyn :: Dynamic Bool
- , ask_delete_item :: Step ()
- }
-
-data TodoItemState = TodoItemState
- { title :: JSString
- , completed :: Bool
- , editing :: Maybe JSString
- } deriving stock (Show, Eq, Generic)
-
-data TodoItemAction a where
- CancelAction :: TodoItemConfig -> TodoItemAction ()
- CommitAction :: TodoItemConfig -> TodoItemAction ()
- InputAction :: TodoItemConfig -> JSString -> TodoItemAction ()
- DoubleClickAction :: TodoItemConfig -> JSVal -> TodoItemAction ()
- CheckedAction :: TodoItemConfig -> Bool -> TodoItemAction ()
- KeydownAction :: TodoItemConfig -> Int -> TodoItemAction ()
-
-eval :: TodoItemAction a -> Step a
-eval = \case
- CancelAction cfg ->
- modifyRef cfg.state_ref \s -> s{editing=Nothing}
- CommitAction cfg -> do
- state <- readRef cfg.state_ref
- case state.editing of
- Just "" ->
- cfg.ask_delete_item
- Just t ->
- modifyRef cfg.state_ref \s -> s {editing=Nothing, title = t}
- Nothing ->
- pure ()
- InputAction cfg newVal ->
- modifyRef cfg.state_ref \s -> s{editing = Just newVal}
- DoubleClickAction cfg targetEl -> do
- modifyRef cfg.state_ref \s -> s {editing = Just s.title}
- liftIO $ js_todoItemInputFocus targetEl
- CheckedAction cfg isChecked -> do
- modifyRef cfg.state_ref \s -> s{completed = isChecked}
- KeydownAction cfg key -> case key of
- 13 {- Enter -} -> eval (CommitAction cfg)
- 27 {- Escape -} -> eval (CancelAction cfg)
- _ -> return ()
-
-html :: TodoItemConfig -> Html ()
-html cfg = li_ do
- let
- completedDyn = (.completed) <$> fromRef cfg.state_ref
- editingDyn = isJust . (.editing) <$> fromRef cfg.state_ref
- valueDyn = fromMaybe "" . (.editing) <$> fromRef cfg.state_ref
- toggleClass "completed" completedDyn
- toggleClass "editing" editingDyn
- toggleClass "hidden" cfg.is_hidden_dyn
- div_ [class_ "view"] do
- on "dblclick" $ decodeEvent (propDecoder "target") $
- eval . DoubleClickAction cfg
- input_ [class_ "toggle", type_ "checkbox"] do
- dynChecked $ (.completed) <$> fromRef cfg.state_ref
- on "change" $ decodeEvent checkedDecoder $
- eval . CheckedAction cfg
- label_ $ dynText $ (.title) <$> fromRef cfg.state_ref
- button_ [class_ "destroy"] do
- on_ "click" cfg.ask_delete_item
- input_ [class_ "edit", type_ "text"] do
- dynValue valueDyn
- on "input" $ decodeEvent valueDecoder $
- eval . InputAction cfg
- on "keydown" $ decodeEvent keyCodeDecoder $
- eval . KeydownAction cfg
- on_ "blur" $
- eval (CommitAction cfg)
-
-emptyTodoItemState :: TodoItemState
-emptyTodoItemState = TodoItemState "" False Nothing
-
-instance ToJSVal TodoItemState where
- toJSVal s = do
- title <- toJSVal s.title
- completed <- toJSVal s.completed
- editing <- toJSVal s.editing
- return $ js_buildObjectI3
- (JSS.toJSValPure "title") title
- (JSS.toJSValPure "completed") completed
- (JSS.toJSValPure "editing") editing
-
-instance FromJSVal TodoItemState where
- fromJSVal j = do
- mtitle <- fromJSVal =<< getProp j "title"
- mcompleted <- fromJSVal =<< getProp j "completed"
- mediting <- fromJSVal =<< getProp j "editing"
- return do
- title <- mtitle
- completed <- mcompleted
- editing <- mediting
- return TodoItemState {..}
diff --git a/examples/todomvc/TodoList.hs b/examples/todomvc/TodoList.hs
deleted file mode 100644
index a928d9b..0000000
--- a/examples/todomvc/TodoList.hs
+++ /dev/null
@@ -1,585 +0,0 @@
-module TodoList where
-
-import Control.Monad.IO.Class
-import Data.Foldable
-import Data.List qualified as List
-import Data.Maybe
-import GHC.Generics (Generic)
-import HtmlT
-import JavaScript.Compat.Marshal
-import JavaScript.Compat.String (JSString(..))
-import JavaScript.Compat.String qualified as JSS
-
-import "this" TodoItem qualified as TodoItem
-import "this" Utils
-
-data TodoListConfig = TodoListConfig
- { state_ref :: DynRef TodoListState
- }
-
-data TodoListState = TodoListState
- { title :: JSString
- , items :: [TodoItem.TodoItemState]
- , filter :: Filter
- } deriving (Show, Eq, Generic)
-
-data Filter = All | Active | Completed
- deriving (Show, Eq, Generic)
-
-newtype LocalStorageTodoItems = LocalStorageTodoItems
- { unLocalStorageTodoItems :: [TodoItem.TodoItemState]
- } deriving newtype (ToJSVal, FromJSVal)
-
-data TodoListAction a where
- InitAction :: ReactiveEnv -> DynRef JSString -> TodoListAction (DynRef TodoListState)
- ToggleAllAction :: TodoListConfig -> Bool -> TodoListAction ()
- InputAction :: TodoListConfig -> JSString -> TodoListAction ()
- CommitAction :: TodoListConfig -> TodoListAction ()
- KeydownAction :: TodoListConfig -> Int -> TodoListAction ()
- DeleteItemAction :: TodoListConfig -> Int -> TodoListAction ()
- ClearCompletedAction :: TodoListConfig -> TodoListAction ()
-
-eval :: TodoListAction a -> Step a
-eval = \case
- InitAction renv urlHashRef -> do
- let parseFilter' = fromMaybe All . parseFilter
- todos <- fromMaybe [] . fmap unLocalStorageTodoItems <$> liftIO localStorageGet
- initFilter <- parseFilter' <$> readRef urlHashRef
- todosRef <- execReactiveT renv do
- todosRef <- newRef $ TodoListState "" todos initFilter
- subscribe (updates (fromRef urlHashRef)) $
- modifyRef todosRef . (\v s -> s{filter=v}) . parseFilter'
- return todosRef
- liftIO $ onBeforeUnload do
- TodoListState{items} <- readRef todosRef
- localStorageSet $ LocalStorageTodoItems items
- return todosRef
- ToggleAllAction cfg isChecked ->
- modifyRef cfg.state_ref \s -> s
- { items =
- fmap (\i -> i {TodoItem.completed = isChecked}) s.items
- }
- InputAction cfg newVal -> do
- modifyRef cfg.state_ref \s -> s {title = newVal}
- CommitAction cfg -> do
- title <- JSS.strip . (.title) <$> readRef cfg.state_ref
- case title of
- "" -> return ()
- t -> modifyRef cfg.state_ref \s -> s
- { items = s.items <> [mkNewItem t]
- , title = ""
- }
- KeydownAction cfg key -> case key of
- 13 {- Enter -} -> eval (CommitAction cfg)
- _ -> return ()
- DeleteItemAction cfg itemIx ->
- modifyRef cfg.state_ref \s -> s {items = deleteIx itemIx s.items}
- ClearCompletedAction cfg ->
- modifyRef cfg.state_ref \s -> s
- {items = (List.filter (not . TodoItem.completed)) s.items}
- where
- deleteIx :: Int -> [a] -> [a]
- deleteIx _ [] = []
- deleteIx i (a:as)
- | i == 0 = as
- | otherwise = a : deleteIx (i-1) as
- mkNewItem t =
- TodoItem.emptyTodoItemState {TodoItem.title = t}
-
-html :: TodoListConfig -> Html ()
-html cfg = do
- el "style" $ text styles
- div_ do
- section_ [class_ "todoapp"] do
- headerWidget
- mainWidget
- footerWidget
- footerInfoWidget
- where
- headerWidget = header_ [class_ "header"] do
- h1_ (text "todos")
- input_ [class_ "new-todo", placeholder_ "What needs to be done?", autofocus_ True] do
- dynValue $ (.title) <$> fromRef cfg.state_ref
- on "input" $ decodeEvent valueDecoder $
- eval . InputAction cfg
- on "keydown" $ decodeEvent keyCodeDecoder $
- eval . KeydownAction cfg
- mainWidget = section_ [class_ "main"] do
- toggleClass "hidden" hiddenDyn
- input_ [id_ "toggle-all", class_ "toggle-all", type_ "checkbox"] do
- on "click" $ decodeEvent checkedDecoder $
- eval . ToggleAllAction cfg
- label_ do
- attr "for" "toggle-all"
- text "Mark all as completed"
- ul_ [class_ "todo-list"] do
- simpleList itemsDyn \idx todoRef ->
- TodoItem.html $ TodoItem.TodoItemConfig
- { TodoItem.state_ref = todoRef
- { dynref_modifier = todoItemModifier cfg idx todoRef.dynref_modifier
- }
- , TodoItem.is_hidden_dyn =
- isTodoItemHidden <$> fromRef cfg.state_ref <*> fromRef todoRef
- , TodoItem.ask_delete_item = eval (DeleteItemAction cfg idx)
- }
- footerWidget = footer_ [class_ "footer"] do
- toggleClass "hidden" hiddenDyn
- span_ [class_ "todo-count"] do
- strong_ $ dynText $ JSS.pack . show <$> itemsLeftDyn
- dynText $ pluralize " item left" " items left" <$> itemsLeftDyn
- ul_ [class_ "filters"] do
- for_ [All, Active, Completed] filterWidget
- button_ [class_ "clear-completed"] do
- on_ "click" $ eval (ClearCompletedAction cfg)
- text "Clear completed"
- footerInfoWidget = footer_ [class_ "info"] do
- p_ "Double-click to edit a todo"
- p_ do
- text "Created by "
- a_ [href_ "https://github.com/lagunoff"] "Vlad Lagunov"
- p_ do
- text "Part of "
- a_ [href_ "http://todomvc.com"] "TodoMVC"
- filterWidget flt = li_ do
- a_ [href_ (printFilter flt)] do
- toggleClass "selected" $ filterSelectedDyn flt
- text $ JSS.pack (show flt)
- hiddenDyn =
- Prelude.null . (.items) <$> fromRef cfg.state_ref
- itemsLeftDyn =
- countItemsLeft <$> fromRef cfg.state_ref
- filterSelectedDyn flt =
- (==flt) . (.filter) <$> fromRef cfg.state_ref
- itemsDyn =
- (.items) <$> fromRef cfg.state_ref
- countItemsLeft TodoListState{items} =
- foldl (\acc TodoItem.TodoItemState{completed} ->
- if not completed then acc + 1 else acc) 0 items
- isTodoItemHidden listState itemState =
- case (listState.filter, itemState.completed) of
- (Active, True) -> True
- (Completed, False) -> True
- _ -> False
-
--- | Synchronize changes inside TodoItem widget with the outer
--- TodoList widget.
-todoItemModifier
- :: TodoListConfig
- -> Int
- -> Modifier TodoItem.TodoItemState
- -> Modifier TodoItem.TodoItemState
-todoItemModifier cfg idx elemModifier = Modifier \upd f -> do
- -- Update the local TodoItem element widget
- ((old, new), result) <- unModifier elemModifier upd \old ->
- let (new, result) = f old in (new, ((old, new), result))
- let
- -- When False, the update event won't be propagated into the outer
- -- widget for the sake of optimization
- needsUpdate = upd && (old.completed /= new.completed)
- -- Update the outer widget
- unModifier (dynref_modifier cfg.state_ref) needsUpdate \old ->
- (old {items = overIx idx (const new) old.items}, ())
- return result
- where
- overIx :: Int -> (a -> a) -> [a] -> [a]
- overIx 0 f (x:xs) = f x : xs
- overIx n f (x:xs) = x : overIx (pred n) f xs
- overIx n _ [] = []
-
-pluralize :: JSString -> JSString -> Int -> JSString
-pluralize singular plural 0 = singular
-pluralize singular plural _ = plural
-
-parseFilter :: JSString -> Maybe Filter
-parseFilter = \case
- "#/" -> Just All
- "#/active" -> Just Active
- "#/completed" -> Just Completed
- _ -> Nothing
-
-printFilter :: Filter -> JSString
-printFilter = \case
- All -> "#/"
- Active -> "#/active"
- Completed -> "#/completed"
-
-styles :: JSString
-styles = "\
- \body {\
- \ margin: 0;\
- \ padding: 0;\
- \}\
- \\
- \button {\
- \ margin: 0;\
- \ padding: 0;\
- \ border: 0;\
- \ background: none;\
- \ font-size: 100%;\
- \ vertical-align: baseline;\
- \ font-family: inherit;\
- \ font-weight: inherit;\
- \ color: inherit;\
- \ -webkit-appearance: none;\
- \ appearance: none;\
- \ -webkit-font-smoothing: antialiased;\
- \ -moz-osx-font-smoothing: grayscale;\
- \}\
- \\
- \body {\
- \ font: 14px 'Helvetica Neue', Helvetica, Arial, sans-serif;\
- \ line-height: 1.4em;\
- \ background: #f5f5f5;\
- \ color: #4d4d4d;\
- \ min-width: 230px;\
- \ max-width: 550px;\
- \ margin: 0 auto;\
- \ -webkit-font-smoothing: antialiased;\
- \ -moz-osx-font-smoothing: grayscale;\
- \ font-weight: 300;\
- \}\
- \\
- \:focus {\
- \ outline: 0;\
- \}\
- \\
- \.hidden {\
- \ display: none;\
- \}\
- \\
- \.todoapp {\
- \ background: #fff;\
- \ margin: 130px 0 40px 0;\
- \ position: relative;\
- \ box-shadow: 0 2px 4px 0 rgba(0, 0, 0, 0.2),\
- \ 0 25px 50px 0 rgba(0, 0, 0, 0.1);\
- \}\
- \\
- \.todoapp input::-webkit-input-placeholder {\
- \ font-style: italic;\
- \ font-weight: 300;\
- \ color: #e6e6e6;\
- \}\
- \\
- \.todoapp input::-moz-placeholder {\
- \ font-style: italic;\
- \ font-weight: 300;\
- \ color: #e6e6e6;\
- \}\
- \\
- \.todoapp input::input-placeholder {\
- \ font-style: italic;\
- \ font-weight: 300;\
- \ color: #e6e6e6;\
- \}\
- \\
- \.todoapp h1 {\
- \ position: absolute;\
- \ top: -155px;\
- \ width: 100%;\
- \ font-size: 100px;\
- \ font-weight: 100;\
- \ text-align: center;\
- \ color: rgba(175, 47, 47, 0.15);\
- \ -webkit-text-rendering: optimizeLegibility;\
- \ -moz-text-rendering: optimizeLegibility;\
- \ text-rendering: optimizeLegibility;\
- \}\
- \\
- \.new-todo,\
- \.edit {\
- \ position: relative;\
- \ margin: 0;\
- \ width: 100%;\
- \ font-size: 24px;\
- \ font-family: inherit;\
- \ font-weight: inherit;\
- \ line-height: 1.4em;\
- \ border: 0;\
- \ color: inherit;\
- \ padding: 6px;\
- \ border: 1px solid #999;\
- \ box-shadow: inset 0 -1px 5px 0 rgba(0, 0, 0, 0.2);\
- \ box-sizing: border-box;\
- \ -webkit-font-smoothing: antialiased;\
- \ -moz-osx-font-smoothing: grayscale;\
- \}\
- \\
- \.new-todo {\
- \ padding: 16px 16px 16px 60px;\
- \ border: none;\
- \ background: rgba(0, 0, 0, 0.003);\
- \ box-shadow: inset 0 -2px 1px rgba(0,0,0,0.03);\
- \}\
- \\
- \.main {\
- \ position: relative;\
- \ z-index: 2;\
- \ border-top: 1px solid #e6e6e6;\
- \}\
- \\
- \.toggle-all {\
- \ width: 1px;\
- \ height: 1px;\
- \ border: none; /* Mobile Safari */\
- \ opacity: 0;\
- \ position: absolute;\
- \ right: 100%;\
- \ bottom: 100%;\
- \}\
- \\
- \.toggle-all + label {\
- \ width: 60px;\
- \ height: 34px;\
- \ font-size: 0;\
- \ position: absolute;\
- \ top: -52px;\
- \ left: -13px;\
- \ -webkit-transform: rotate(90deg);\
- \ transform: rotate(90deg);\
- \}\
- \\
- \.toggle-all + label:before {\
- \ content: '❯';\
- \ font-size: 22px;\
- \ color: #e6e6e6;\
- \ padding: 10px 27px 10px 27px;\
- \}\
- \\
- \.toggle-all:checked + label:before {\
- \ color: #737373;\
- \}\
- \\
- \.todo-list {\
- \ margin: 0;\
- \ padding: 0;\
- \ list-style: none;\
- \}\
- \\
- \.todo-list li {\
- \ position: relative;\
- \ font-size: 24px;\
- \ border-bottom: 1px solid #ededed;\
- \}\
- \\
- \.todo-list li:last-child {\
- \ border-bottom: none;\
- \}\
- \\
- \.todo-list li.editing {\
- \ border-bottom: none;\
- \ padding: 0;\
- \}\
- \\
- \.todo-list li.editing .edit {\
- \ display: block;\
- \ width: calc(100% - 43px);\
- \ padding: 12px 16px;\
- \ margin: 0 0 0 43px;\
- \}\
- \\
- \.todo-list li.editing .view {\
- \ display: none;\
- \}\
- \\
- \.todo-list li .toggle {\
- \ text-align: center;\
- \ width: 40px;\
- \ /* auto, since non-WebKit browsers doesn't support input styling */\
- \ height: auto;\
- \ position: absolute;\
- \ top: 0;\
- \ bottom: 0;\
- \ margin: auto 0;\
- \ border: none; /* Mobile Safari */\
- \ -webkit-appearance: none;\
- \ appearance: none;\
- \}\
- \\
- \.todo-list li .toggle {\
- \ opacity: 0;\
- \}\
- \\
- \.todo-list li .toggle + label {\
- \ /*\
- \ Firefox requires `#` to be escaped - https://bugzilla.mozilla.org/show_bug.cgi?id=922433\
- \ IE and Edge requires *everything* to be escaped to render, so we do that instead of just the `#` - https://developer.microsoft.com/en-us/microsoft-edge/platform/issues/7157459/\
- \ */\
- \ background-image: url('data:image/svg+xml;utf8,%3Csvg%20xmlns%3D%22http%3A//www.w3.org/2000/svg%22%20width%3D%2240%22%20height%3D%2240%22%20viewBox%3D%22-10%20-18%20100%20135%22%3E%3Ccircle%20cx%3D%2250%22%20cy%3D%2250%22%20r%3D%2250%22%20fill%3D%22none%22%20stroke%3D%22%23ededed%22%20stroke-width%3D%223%22/%3E%3C/svg%3E');\
- \ background-repeat: no-repeat;\
- \ background-position: center left;\
- \}\
- \\
- \.todo-list li .toggle:checked + label {\
- \ background-image: url('data:image/svg+xml;utf8,%3Csvg%20xmlns%3D%22http%3A//www.w3.org/2000/svg%22%20width%3D%2240%22%20height%3D%2240%22%20viewBox%3D%22-10%20-18%20100%20135%22%3E%3Ccircle%20cx%3D%2250%22%20cy%3D%2250%22%20r%3D%2250%22%20fill%3D%22none%22%20stroke%3D%22%23bddad5%22%20stroke-width%3D%223%22/%3E%3Cpath%20fill%3D%22%235dc2af%22%20d%3D%22M72%2025L42%2071%2027%2056l-4%204%2020%2020%2034-52z%22/%3E%3C/svg%3E');\
- \}\
- \\
- \.todo-list li label {\
- \ word-break: break-all;\
- \ padding: 15px 15px 15px 60px;\
- \ display: block;\
- \ line-height: 1.2;\
- \ transition: color 0.4s;\
- \}\
- \\
- \.todo-list li.completed label {\
- \ color: #d9d9d9;\
- \ text-decoration: line-through;\
- \}\
- \\
- \.todo-list li .destroy {\
- \ display: none;\
- \ position: absolute;\
- \ top: 0;\
- \ right: 10px;\
- \ bottom: 0;\
- \ width: 40px;\
- \ height: 40px;\
- \ margin: auto 0;\
- \ font-size: 30px;\
- \ color: #cc9a9a;\
- \ margin-bottom: 11px;\
- \ transition: color 0.2s ease-out;\
- \}\
- \\
- \.todo-list li .destroy:hover {\
- \ color: #af5b5e;\
- \}\
- \\
- \.todo-list li .destroy:after {\
- \ content: '×';\
- \}\
- \\
- \.todo-list li:hover .destroy {\
- \ display: block;\
- \}\
- \\
- \.todo-list li .edit {\
- \ display: none;\
- \}\
- \\
- \.todo-list li.editing:last-child {\
- \ margin-bottom: -1px;\
- \}\
- \\
- \.footer {\
- \ color: #777;\
- \ padding: 10px 15px;\
- \ height: 20px;\
- \ text-align: center;\
- \ border-top: 1px solid #e6e6e6;\
- \}\
- \\
- \.footer:before {\
- \ content: '';\
- \ position: absolute;\
- \ right: 0;\
- \ bottom: 0;\
- \ left: 0;\
- \ height: 50px;\
- \ overflow: hidden;\
- \ box-shadow: 0 1px 1px rgba(0, 0, 0, 0.2),\
- \ 0 8px 0 -3px #f6f6f6,\
- \ 0 9px 1px -3px rgba(0, 0, 0, 0.2),\
- \ 0 16px 0 -6px #f6f6f6,\
- \ 0 17px 2px -6px rgba(0, 0, 0, 0.2);\
- \}\
- \\
- \.todo-count {\
- \ float: left;\
- \ text-align: left;\
- \}\
- \\
- \.todo-count strong {\
- \ font-weight: 300;\
- \}\
- \\
- \.filters {\
- \ margin: 0;\
- \ padding: 0;\
- \ list-style: none;\
- \ position: absolute;\
- \ right: 0;\
- \ left: 0;\
- \}\
- \\
- \.filters li {\
- \ display: inline;\
- \}\
- \\
- \.filters li a {\
- \ color: inherit;\
- \ margin: 3px;\
- \ padding: 3px 7px;\
- \ text-decoration: none;\
- \ border: 1px solid transparent;\
- \ border-radius: 3px;\
- \}\
- \\
- \.filters li a:hover {\
- \ border-color: rgba(175, 47, 47, 0.1);\
- \}\
- \\
- \.filters li a.selected {\
- \ border-color: rgba(175, 47, 47, 0.2);\
- \}\
- \\
- \.clear-completed,\
- \html .clear-completed:active {\
- \ float: right;\
- \ position: relative;\
- \ line-height: 20px;\
- \ text-decoration: none;\
- \ cursor: pointer;\
- \}\
- \\
- \.clear-completed:hover {\
- \ text-decoration: underline;\
- \}\
- \\
- \.info {\
- \ margin: 65px auto 0;\
- \ color: #bfbfbf;\
- \ font-size: 10px;\
- \ text-shadow: 0 1px 0 rgba(255, 255, 255, 0.5);\
- \ text-align: center;\
- \}\
- \\
- \.info p {\
- \ line-height: 1;\
- \}\
- \\
- \.info a {\
- \ color: inherit;\
- \ text-decoration: none;\
- \ font-weight: 400;\
- \}\
- \\
- \.info a:hover {\
- \ text-decoration: underline;\
- \}\
- \\
- \/*\
- \ Hack to remove background from Mobile Safari.\
- \ Can't use it globally since it destroys checkboxes in Firefox\
- \*/\
- \@media screen and (-webkit-min-device-pixel-ratio:0) {\
- \ .toggle-all,\
- \ .todo-list li .toggle {\
- \ background: none;\
- \ }\
- \\
- \ .todo-list li .toggle {\
- \ height: 40px;\
- \ }\
- \}\
- \\
- \@media (max-width: 430px) {\
- \ .footer {\
- \ height: 50px;\
- \ }\
- \\
- \ .filters {\
- \ bottom: 10px;\
- \ }\
- \}"
diff --git a/examples/todomvc/Utils.hs b/examples/todomvc/Utils.hs
deleted file mode 100644
index ba9e0b5..0000000
--- a/examples/todomvc/Utils.hs
+++ /dev/null
@@ -1,83 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE ForeignFunctionInterface #-}
-{-# LANGUAGE JavaScriptFFI #-}
-module Utils where
-
-import Control.Monad
-import Control.Monad.Reader
-import Data.Coerce
-import Data.Typeable
-import HtmlT
-import JavaScript.Compat.Foreign.Callback
-import JavaScript.Compat.Marshal
-import JavaScript.Compat.Prim
-import JavaScript.Compat.String (JSString(..))
-import JavaScript.Compat.String qualified as JSS
-import Unsafe.Coerce
-
-mkUrlHashRef :: MonadReactive m => m (DynRef JSString)
-mkUrlHashRef = do
- initial <- liftIO js_readUrlHash
- routeRef <- newRef initial
- win <- getCurrentWindow
- popStateCb <- liftIO $ asyncCallback $
- js_readUrlHash >>= dynStep . writeRef routeRef
- liftIO $ js_setProp (coerce win) "onpopstate" (unsafeCoerce popStateCb)
- return routeRef
-
-localStorageSet :: forall a m. (MonadIO m, ToJSVal a, Typeable a) => a -> m ()
-localStorageSet val =
- liftIO (toJSVal val >>= js_setItem key)
- where
- key = JSS.pack . show $ typeRepFingerprint $ typeRep (Proxy @a)
-
-localStorageGet :: forall a m. (MonadIO m, FromJSVal a, Typeable a) => m (Maybe a)
-localStorageGet = liftIO do
- mval <- nullableToMaybe <$> (js_getItem key)
- join <$> forM mval fromJSVal
- where
- key = JSS.pack . show . typeRepFingerprint $ typeRep (Proxy @a)
-
-#if defined(javascript_HOST_ARCH)
-foreign import javascript unsafe
- "(($1) => { setTimeout(function() {\
- var inputEl = $1.parentNode.parentNode.querySelector('input.edit');\
- inputEl.focus();\
- }, 0); })"
- js_todoItemInputFocus :: JSVal -> IO ()
-
-foreign import javascript unsafe
- "(function(key, val){\
- localStorage.setItem(key, JSON.stringify(val));\
- })"
- js_setItem :: JSString -> JSVal -> IO ()
-
-foreign import javascript unsafe
- "(function(key){\
- var itemText = localStorage.getItem(key);\
- return itemText ? JSON.parse(itemText) : null;\
- })"
- js_getItem :: JSString -> IO (Nullable JSVal)
-foreign import javascript unsafe
- "(function(){\
- return location.hash;\
- })"
- js_readUrlHash :: IO JSString
-
--- Need this because GHC.JS.Prim.Internal.Build buildObjectI3 is
--- broken. The FFI declarations were not migrated from GHCJS style
--- properly, they throw ReferenceError: $1 is not defined
-foreign import javascript unsafe
- "(function(k1, v1, k2, v2, k3, v3){\
- var res = {};\
- res[k1] = v1; res[k2] = v2; res[k3] = v3;\
- return res;\
- })"
- js_buildObjectI3 :: JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> JSVal
-#else
-js_todoItemInputFocus :: JSVal -> IO () = errorGhcjsOnly
-js_setItem :: JSString -> JSVal -> IO () = errorGhcjsOnly
-js_getItem :: JSString -> IO (Nullable JSVal) = errorGhcjsOnly
-js_readUrlHash :: IO JSString = errorGhcjsOnly
-js_buildObjectI3 :: JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> JSVal = errorGhcjsOnly
-#endif
diff --git a/examples/todomvc/todomvc.hs b/examples/todomvc/todomvc.hs
deleted file mode 100644
index a8c800e..0000000
--- a/examples/todomvc/todomvc.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-import Control.Monad
-import Control.Monad.Reader
-import HtmlT
-
-import "this" TodoList qualified as TodoList
-import "this" Utils
-
-main :: IO ()
-main = void $ attachToBody do
- renv <- asks (.html_reactive_env)
- urlHashRef <- mkUrlHashRef
- todosRef <- dynStep $ TodoList.eval (TodoList.InitAction renv urlHashRef)
- TodoList.html $ TodoList.TodoListConfig todosRef
diff --git a/ghc-wasm-meta b/ghc-wasm-meta
new file mode 160000
index 0000000..426e46a
--- /dev/null
+++ b/ghc-wasm-meta
@@ -0,0 +1 @@
+Subproject commit 426e46a5a8ffda63a5dde02e0bf9eb60f9cca089
diff --git a/htmlt.cabal b/htmlt.cabal
index 545cc7c..7eafc05 100644
--- a/htmlt.cabal
+++ b/htmlt.cabal
@@ -29,7 +29,7 @@ common htmlt-common
-Wall -Wno-missing-signatures -Wno-name-shadowing -Wno-unused-matches
-Wno-unused-do-bind
if flag(production)
- ghc-options: -O2
+ ghc-options: -O3
default-extensions:
AllowAmbiguousTypes
BangPatterns
@@ -78,91 +78,127 @@ common htmlt-common
library
import: htmlt-common
- hs-source-dirs: src
+ hs-source-dirs: src ./examples/charts
exposed-modules:
- HtmlT
- HtmlT.Base
- HtmlT.DOM
- HtmlT.Element
- HtmlT.Event
- HtmlT.Internal
- HtmlT.Main
- HtmlT.Property
- HtmlT.Types
- JavaScript.Compat.Foreign.Callback
- JavaScript.Compat.Marshal
- JavaScript.Compat.Prim
- JavaScript.Compat.String
+ -- HtmlT
+ -- HtmlT.Base
+ -- HtmlT.DOM
+ -- HtmlT.Element
+ -- HtmlT.Event
+ -- HtmlT.Internal
+ -- HtmlT.Main
+ -- HtmlT.Property
+ -- HtmlT.Types
+ Clickable
+ Clickable.Core
+ Clickable.DOM
+ Clickable.Element
+ Clickable.Property
+ Clickable.Main
+ Clickable.Types
+ Clickable.Internal
+ Clickable.FFI
+ Wasm.Compat.Prim
+ Wasm.Compat.Marshal
other-modules: Paths_htmlt
build-depends:
base,
+ binary,
+ bytestring,
containers,
exceptions,
mtl,
text,
transformers,
- if !arch(javascript)
- build-depends:
- ghc-prim,
- other-modules:
- JavaScript.Compat.String.Native
- else
- other-modules:
- JavaScript.Compat.String.JavaScript
+ ghc-experimental,
+ ghc-prim,
+ -- generic-lens,
-executable htmlt-counter
- import: htmlt-common
- main-is: counter.hs
- hs-source-dirs: ./examples/counter
- build-depends:
- base,
- htmlt,
- transformers,
- if !flag(examples)
- buildable: False
+-- executable htmlt-counter
+-- import: htmlt-common
+-- main-is: counter.hs
+-- hs-source-dirs: ./examples/counter
+-- ghc-options:
+-- -no-hs-main -optl-mexec-model=reactor
+-- -optl-Wl,--export=hs_init,--export=wasm_main
+-- build-depends:
+-- base,
+-- htmlt,
+-- text,
+-- mtl,
+-- transformers,
+-- if !flag(examples)
+-- buildable: False
+
+-- executable htmlt-todomvc
+-- import: htmlt-common
+-- main-is: todomvc.hs
+-- hs-source-dirs: ./examples/todomvc
+-- ghc-options:
+-- -no-hs-main -optl-mexec-model=reactor
+-- -optl-Wl,--export=hs_init,--export=wasm_main
+-- other-modules:
+-- TodoItem
+-- TodoList
+-- Utils
+-- build-depends:
+-- base,
+-- htmlt,
+-- text,
+-- mtl,
+-- if !flag(examples)
+-- buildable: False
-executable htmlt-todomvc
+executable htmlt-charts
import: htmlt-common
- main-is: todomvc.hs
- hs-source-dirs: ./examples/todomvc
- other-modules:
- TodoItem
- TodoList
- Utils
+ main-is: charts.hs
+ hs-source-dirs: ./examples/charts
+ ghc-options:
+ -no-hs-main -optl-mexec-model=reactor
+ -optl-Wl,--export=hs_init,--export=wasm_main
build-depends:
base,
htmlt,
+ text,
mtl,
- if !flag(examples)
- buildable: False
-
-executable htmlt-simple-routing
- import: htmlt-common
- main-is: simple-routing.hs
- hs-source-dirs: ./examples/simple-routing
other-modules:
- Assets
- Router
- Pages
- Utils
- build-depends:
- base,
- bytestring,
- mtl,
- htmlt,
+ App
+ Charts
+ PairSelector
if !flag(examples)
buildable: False
-executable htmlt-benchmarks
- import: htmlt-common
- main-is: benchmarks.hs
- hs-source-dirs: ./benchmarks/
- build-depends:
- base,
- htmlt,
- text,
- gauge,
- -- Fails to build with javascript-backend
- buildable: False
+-- executable htmlt-simple-routing
+-- import: htmlt-common
+-- main-is: simple-routing.hs
+-- hs-source-dirs: ./examples/simple-routing
+-- ghc-options:
+-- -no-hs-main -optl-mexec-model=reactor
+-- -optl-Wl,--export=hs_init,--export=wasm_main
+-- other-modules:
+-- Assets
+-- Router
+-- Pages
+-- Utils
+-- build-depends:
+-- base,
+-- bytestring,
+-- mtl,
+-- htmlt,
+-- text,
+-- if !flag(examples)
+-- buildable: False
+
+-- executable htmlt-benchmarks
+-- import: htmlt-common
+-- main-is: benchmarks.hs
+-- hs-source-dirs: ./benchmarks/
+-- build-depends:
+-- base,
+-- htmlt,
+-- text,
+-- gauge,
+-- -- Fails to build with javascript-backend
+-- buildable: False
diff --git a/jsbits/index.js b/jsbits/index.js
new file mode 100644
index 0000000..02d3edf
--- /dev/null
+++ b/jsbits/index.js
@@ -0,0 +1,23 @@
+import { WASI, File, OpenFile } from '@bjorn3/browser_wasi_shim';
+import * as jsffi from './jsffi';
+
+let __exports = {};
+
+window.startReactor = async function (wasmUri, opt) {
+ const wasi = new WASI([], [], [
+ new OpenFile(new File([])), // stdin
+ new OpenFile(new File([])), // stdout
+ new OpenFile(new File([])), // stderr
+ ]);
+
+ const wasm = await WebAssembly.compileStreaming(fetch(wasmUri));
+ const inst = await WebAssembly.instantiate(wasm, {
+ wasi_snapshot_preview1: wasi.wasiImport,
+ ghc_wasm_jsffi: jsffi.default(__exports)
+ });
+
+ Object.assign(__exports, inst.exports);
+ await wasi.initialize(inst);
+ await inst.exports.hs_init();
+ await inst.exports.wasm_main();
+};
diff --git a/jsbits/jsffi.js b/jsbits/jsffi.js
new file mode 100644
index 0000000..9c3c9f2
--- /dev/null
+++ b/jsbits/jsffi.js
@@ -0,0 +1,124 @@
+// This file implements the JavaScript runtime logic for Haskell
+// modules that use JSFFI. It is not an ESM module, but the template
+// of one; the post-linker script will copy all contents into a new
+// ESM module.
+
+// Manage a mapping from unique 32-bit ids to actual JavaScript
+// values.
+class JSValManager {
+ #lastk = 0;
+ #kv = new Map();
+
+ constructor() {}
+
+ // Maybe just bump this.#lastk? For 64-bit ids that's sufficient,
+ // but better safe than sorry in the 32-bit case.
+ #allocKey() {
+ let k = this.#lastk;
+ while (true) {
+ if (!this.#kv.has(k)) {
+ this.#lastk = k;
+ return k;
+ }
+ k = (k + 1) | 0;
+ }
+ }
+
+ newJSVal(v) {
+ const k = this.#allocKey();
+ this.#kv.set(k, v);
+ return k;
+ }
+
+ // A separate has() call to ensure we can store undefined as a value
+ // too. Also, unconditionally check this since the check is cheap
+ // anyway, if the check fails then there's a use-after-free to be
+ // fixed.
+ getJSVal(k) {
+ if (!this.#kv.has(k)) {
+ throw new WebAssembly.RuntimeError(`getJSVal(${k})`);
+ }
+ return this.#kv.get(k);
+ }
+
+ // Check for double free as well.
+ freeJSVal(k) {
+ if (!this.#kv.delete(k)) {
+ throw new WebAssembly.RuntimeError(`freeJSVal(${k})`);
+ }
+ }
+}
+
+// A simple & fast setImmediate() implementation for browsers. It's
+// not a drop-in replacement for node.js setImmediate() because:
+// 1. There's no clearImmediate(), and setImmediate() doesn't return
+// anything
+// 2. There's no guarantee that callbacks scheduled by setImmediate()
+// are executed in the same order (in fact it's the opposite lol),
+// but you are never supposed to rely on this assumption anyway
+class SetImmediate {
+ #fs = [];
+ #mc = new MessageChannel();
+
+ constructor() {
+ this.#mc.port1.addEventListener("message", () => {
+ this.#fs.pop()();
+ });
+ this.#mc.port1.start();
+ }
+
+ setImmediate(cb, ...args) {
+ this.#fs.push(() => cb(...args));
+ this.#mc.port2.postMessage(undefined);
+ }
+}
+
+// The actual setImmediate() to be used. This is a ESM module top
+// level binding and doesn't pollute the globalThis namespace.
+let setImmediate;
+if (globalThis.setImmediate) {
+ // node.js, bun
+ setImmediate = globalThis.setImmediate;
+} else {
+ /* try {
+ * // deno
+ * setImmediate = (await import("node:timers")).setImmediate;
+ * } catch { */
+ // browsers
+ const sm = new SetImmediate();
+ setImmediate = (cb, ...args) => sm.setImmediate(cb, ...args);
+ /* } */
+}
+
+export default (__exports) => {
+const __ghc_wasm_jsffi_jsval_manager = new JSValManager();
+const __ghc_wasm_jsffi_finalization_registry = new FinalizationRegistry(sp => __exports.rts_freeStablePtr(sp));
+return {
+newJSVal: (v) => __ghc_wasm_jsffi_jsval_manager.newJSVal(v),
+getJSVal: (k) => __ghc_wasm_jsffi_jsval_manager.getJSVal(k),
+freeJSVal: (k) => __ghc_wasm_jsffi_jsval_manager.freeJSVal(k),
+scheduleWork: () => setImmediate(__exports.rts_schedulerLoop),
+ZC0ZChtmltzm0zi1zi0zi0zminplaceZCClickableziFFIZC: ($1) => ($1()),
+ZC1ZChtmltzm0zi1zi0zi0zminplaceZCClickableziFFIZC: ($1,$2,$3,$4) => {var j = new TextDecoder('utf8').decode(new Uint8Array(__exports.memory.buffer, $2, $3)); if ($1 instanceof Comment) { return eval(j)($1.parentNode, $4); } else { return eval(j)($1, $4); }},
+ZC3ZChtmltzm0zi1zi0zi0zminplaceZCClickableziFFIZC: ($1) => {function isOpenBracket(node) {return node instanceof Comment && node.textContent == 'ContentBoundary {{'} function isCloseBracket(node) {return node instanceof Comment && node.textContent == '}}'} var iter = $1; var nestedCounter = 0; for (;;){ if (!iter.previousSibling || (nestedCounter == 0 && isOpenBracket(iter.previousSibling)) ) break; if (isCloseBracket(iter.previousSibling)) nestedCounter++; else if (isOpenBracket(iter.previousSibling)) nestedCounter--; iter.previousSibling.parentNode.removeChild(iter.previousSibling); }},
+ZC4ZChtmltzm0zi1zi0zi0zminplaceZCClickableziFFIZC: ($1) => {var c1 = document.createComment('ContentBoundary {{'); var c2 = document.createComment('}}'); if ($1 instanceof Comment) { $1.parentNode.insertBefore(c1, $1); $1.parentNode.insertBefore(c2, $1); } else { $1.appendChild(c1); $1.appendChild(c2); } return c2;},
+ZC5ZChtmltzm0zi1zi0zi0zminplaceZCClickableziFFIZC: ($1,$2) => {console.log(new TextDecoder('utf8').decode(new Uint8Array(__exports.memory.buffer, $1, $2)));},
+ZC7ZChtmltzm0zi1zi0zi0zminplaceZCClickableziFFIZC: ($1) => ((a1) => __exports.ghczuwasmzujsffiZC6ZChtmltzm0zi1zi0zi0zminplaceZCClickableziFFIZC($1,a1)),
+ZC10ZChtmltzm0zi1zi0zi0zminplaceZCClickableziFFIZC: () => (document.body),
+ZC13ZChtmltzm0zi1zi0zi0zminplaceZCClickableziFFIZC: ($1,$2,$3,$4,$5) => {var k = new TextDecoder('utf8').decode(new Uint8Array(__exports.memory.buffer, $2, $3)); var v = new TextDecoder('utf8').decode(new Uint8Array(__exports.memory.buffer, $4, $5)); if ($1 instanceof Comment) { $1.parentNode[k] = v; } else { $1[k] = v; }},
+ZC14ZChtmltzm0zi1zi0zi0zminplaceZCClickableziFFIZC: ($1,$2,$3) => {$1.nodeValue = new TextDecoder('utf8').decode(new Uint8Array(__exports.memory.buffer, $2, $3));},
+ZC15ZChtmltzm0zi1zi0zi0zminplaceZCClickableziFFIZC: ($1,$2,$3) => {var t = new TextDecoder('utf8').decode(new Uint8Array(__exports.memory.buffer, $2, $3)); var n = document.createElement(t); if ($1 instanceof Comment) { $1.parentNode.insertBefore(n, $1); } else { $1.appendChild(n); } return n;},
+ZC16ZChtmltzm0zi1zi0zi0zminplaceZCClickableziFFIZC: ($1,$2,$3) => {var c = new TextDecoder('utf8').decode(new Uint8Array(__exports.memory.buffer, $2, $3)); var n = document.createTextNode(c); if ($1 instanceof Comment) { $1.parentNode.insertBefore(n, $1); } else { $1.appendChild(n); } return n;},
+ZC0ZCghczminternalZCGHCziInternalziWasmziPrimziExportsZC: ($1,$2) => ($1.reject(new WebAssembly.RuntimeError($2))),
+ZC19ZCghczminternalZCGHCziInternalziWasmziPrimziExportsZC: ($1) => ($1.resolve()),
+ZC20ZCghczminternalZCGHCziInternalziWasmziPrimziExportsZC: () => {let res, rej; const p = new Promise((resolve, reject) => { res = resolve; rej = reject; }); p.resolve = res; p.reject = rej; return p;},
+ZC21ZCghczminternalZCGHCziInternalziWasmziPrimziExportsZC: ($1,$2) => (__ghc_wasm_jsffi_finalization_registry.register($1, $2, $1)),
+ZC0ZCghczminternalZCGHCziInternalziWasmziPrimziTypesZC: ($1) => (`${$1.stack ? $1.stack : $1}`),
+ZC1ZCghczminternalZCGHCziInternalziWasmziPrimziTypesZC: ($1,$2) => ((new TextDecoder('utf-8', {fatal: true})).decode(new Uint8Array(__exports.memory.buffer, $1, $2))),
+ZC2ZCghczminternalZCGHCziInternalziWasmziPrimziTypesZC: ($1,$2,$3) => ((new TextEncoder()).encodeInto($1, new Uint8Array(__exports.memory.buffer, $2, $3)).written),
+ZC3ZCghczminternalZCGHCziInternalziWasmziPrimziTypesZC: ($1) => ($1.length),
+ZC4ZCghczminternalZCGHCziInternalziWasmziPrimziTypesZC: ($1) => {if (!__ghc_wasm_jsffi_finalization_registry.unregister($1)) { throw new WebAssembly.RuntimeError('js_callback_unregister'); }},
+ZC0ZCghczminternalZCGHCziInternalziWasmziPrimziConcziInternalZC: async ($1) => (new Promise(res => setTimeout(res, $1 / 1000))),
+ZC18ZCghczminternalZCGHCziInternalziWasmziPrimziImportsZC: ($1,$2) => ($1.then(() => __exports.rts_promiseResolveUnit($2), err => __exports.rts_promiseReject($2, err))),
+};
+};
diff --git a/shell.nix b/shell.nix
index 8b5272f..82fb296 100644
--- a/shell.nix
+++ b/shell.nix
@@ -1 +1 @@
-(import ./default.nix {}).shell.javascript
+(import ./default.nix {}).shell
diff --git a/src/Clickable.hs b/src/Clickable.hs
new file mode 100644
index 0000000..06325d1
--- /dev/null
+++ b/src/Clickable.hs
@@ -0,0 +1,10 @@
+module Clickable (module Exports) where
+
+import Clickable.DOM as Exports
+import Clickable.Core as Exports
+import Clickable.Element as Exports
+import Clickable.Main as Exports
+import Clickable.Property as Exports
+import Clickable.Types as Exports
+import Wasm.Compat.Marshal as Exports
+import Wasm.Compat.Prim as Exports
diff --git a/src/Clickable/Core.hs b/src/Clickable/Core.hs
new file mode 100644
index 0000000..a4c0257
--- /dev/null
+++ b/src/Clickable/Core.hs
@@ -0,0 +1,184 @@
+module Clickable.Core where
+
+import Control.Monad
+import Control.Monad.Reader
+import Control.Monad.State
+import Data.IORef
+import Data.Map qualified as Map
+import Data.Text (Text)
+
+import Clickable.FFI
+import Clickable.Internal (reactive, reactive_)
+import Clickable.Internal qualified as Internal
+import Clickable.Types
+import Wasm.Compat.Prim
+
+
+launchHtmlM :: JSVal -> InternalEnv -> HtmlM a -> IO a
+launchHtmlM root env =
+ flip runReaderT env . unClickM . trampoline . flip runReaderT root . unHtmlM
+
+launchClickM :: InternalEnv -> ClickM a -> IO a
+launchClickM env = flip runReaderT env . unClickM . trampoline
+
+liftClickM :: ClickM a -> HtmlM a
+liftClickM = HtmlM . lift
+
+---------------------------------------
+-- OPERATIONS OVER DYNAMIC VARIABLES --
+---------------------------------------
+
+mapVar :: DynVar a -> (a -> b) -> DynVal b
+mapVar var = MapVal (FromVar var)
+
+newVar :: a -> ClickM (DynVar a)
+newVar a = do
+ ref <- liftIO $ newIORef a
+ state \s -> (DynVar (SourceId s.next_id) ref, s {next_id = s.next_id + 1})
+
+readVal :: DynVal a -> ClickM a
+readVal (ConstVal a) = pure a
+readVal (FromVar (DynVar _ ref)) = liftIO $ readIORef ref
+readVal (MapVal val f) = fmap f $ readVal val
+readVal (SplatVal f a) = liftA2 ($) (readVal f) (readVal a)
+
+readVar :: DynVar a -> ClickM a
+readVar (DynVar _ ref) = liftIO $ readIORef ref
+
+atomicModifyVar :: DynVar s -> (s -> (s, a)) -> ClickM a
+atomicModifyVar var@(DynVar varId ref) f = do
+ (newVal, a) <- liftIO $ atomicModifyIORef' ref g
+ modify $ Internal.unsafeTrigger varId newVal
+ return a
+ where
+ g old = let (new, a) = f old in (new, (new, a))
+
+modifyVar :: DynVar s -> (s -> s) -> ClickM ()
+modifyVar var f = atomicModifyVar var ((,()) . f)
+
+writeVar :: DynVar s -> s -> ClickM ()
+writeVar var s = modifyVar var $ const s
+
+subscribe :: DynVal a -> (a -> ClickM ()) -> ClickM ()
+subscribe val k = reactive_ $ Internal.subscribe val k
+
+-------------------------
+-- RESOURCE MANAGEMENT --
+-------------------------
+
+newScope :: ClickM ResourceScope
+newScope = reactive Internal.newScope
+
+freeScope :: Bool -> ResourceScope -> ClickM ()
+freeScope unlink s = f where
+ f = reactive (const (Internal.freeScope unlink s)) >>= g
+ g [] = return ()
+ g ((_, ScopeFinalizer s'):xs) = freeScope True s' >> g xs
+ g ((_, CustomFinalizer x):xs) = x >> g xs
+
+installFinalizer :: ClickM () -> ClickM ()
+installFinalizer k = reactive_ $ Internal.installFinalizer k
+
+-- | Loop until transaction_queue is empty.
+--
+-- This makes possible to implement @Applicative DynVal@ without
+-- redundantly firing callback for the final result. TODO: Is this
+-- even worth-while to have? What if just let multiple DOM changes
+-- when it depends on multiple sources?
+trampoline :: ClickM a -> ClickM a
+trampoline act = loop0 act where
+ loop0 :: ClickM a -> ClickM a
+ loop0 before = do
+ r <- before
+ mcont <- popQueue
+ forM_ mcont loop1
+ return r
+ loop1 :: ClickM () -> ClickM ()
+ loop1 before = do
+ before
+ mcont <- popQueue
+ forM_ mcont loop1
+ popQueue :: ClickM (Maybe (ClickM ()))
+ popQueue = state \s ->
+ case Map.minViewWithKey s.transaction_queue of
+ Nothing -> (Nothing, s)
+ Just ((_, r), newQueue) -> (Just r, s {transaction_queue = newQueue})
+
+------------------
+-- BUILDING DOM --
+------------------
+
+el :: Text -> HtmlM a -> HtmlM a
+el t ch = do
+ r <- ask
+ el <- liftIO $ insertElement r t
+ local (const el) ch
+
+property :: Text -> Text -> HtmlM ()
+property k v = do
+ root <- ask
+ liftIO $ setProperty root k v
+
+boolProperty :: Text -> Bool -> HtmlM ()
+boolProperty k v = do
+ root <- ask
+ liftIO $ setBoolProperty root k v
+
+attribute :: Text -> Text -> HtmlM ()
+attribute k v = do
+ root <- ask
+ liftIO $ setAttribute root k v
+
+text :: Text -> HtmlM ()
+text t = do
+ r <- ask
+ void $ liftIO $ insertText r t
+
+dynText :: DynVal Text -> HtmlM ()
+dynText val = do
+ r <- ask
+ t <- liftClickM $ readVal val
+ textNode <- liftIO $ insertText r t
+ liftClickM $ subscribe val $ \new ->
+ liftIO $ updateTextContent textNode new
+
+dynProp :: Text -> DynVal Text -> HtmlM ()
+dynProp k val = do
+ root <- ask
+ v <- liftClickM $ readVal val
+ liftIO $ setProperty root k v
+ liftClickM $ subscribe val $ \new ->
+ liftIO $ setProperty root k new
+
+dynBoolProp :: Text -> DynVal Bool -> HtmlM ()
+dynBoolProp k val = do
+ root <- ask
+ v <- liftClickM $ readVal val
+ liftIO $ setBoolProperty root k v
+ liftClickM $ subscribe val $ \new ->
+ liftIO $ setBoolProperty root k new
+
+blank :: Applicative m => m ()
+blank = pure ()
+
+---------------------
+-- DYNAMIC CONTENT --
+---------------------
+
+dyn :: DynVal (HtmlM ()) -> HtmlM ()
+dyn val = do
+ root <- ask
+ scope <- liftClickM newScope
+ closeBracket <- liftIO $ js_insertBrackets root
+ initialVal <- liftClickM $ readVal val
+ let
+ update html = do
+ liftIO $ js_clearBrackets closeBracket
+ html
+ exec = local (\s -> s {scope}) .
+ flip runReaderT closeBracket . unHtmlM
+ liftClickM $ exec $ update initialVal
+ liftClickM $ subscribe val \newVal -> do
+ freeScope False scope
+ exec $ update newVal
+ return ()
diff --git a/src/Clickable/DOM.hs b/src/Clickable/DOM.hs
new file mode 100644
index 0000000..57201fa
--- /dev/null
+++ b/src/Clickable/DOM.hs
@@ -0,0 +1,240 @@
+module Clickable.DOM where
+
+import Control.Monad.Reader
+import Data.Text (Text)
+import Data.Kind
+import GHC.Generics
+
+import Clickable.FFI qualified as FFI
+import Clickable.Core
+import Clickable.Types
+import Wasm.Compat.Prim
+import Wasm.Compat.Marshal
+
+
+data EventListenerOptions = EventListenerOptions
+ { prevent_default :: Bool
+ , stop_propagation :: Bool
+ } deriving stock (Generic, Show, Eq)
+
+defaultEventListenerOptions :: EventListenerOptions
+defaultEventListenerOptions = EventListenerOptions
+ { prevent_default = False
+ , stop_propagation = False
+ }
+
+addEventListener :: ConnectResourceArgs callback -> callback -> HtmlM ()
+addEventListener args k = do
+ rootElement <- ask
+ liftClickM $ connectResource rootElement args k
+
+data ConnectResourceArgs callback = ConnectResourceArgs
+ { js_wrapper :: UnsafeJavaScript
+ , mk_callback :: callback -> JSVal -> ClickM ()
+ }
+
+connectResource :: JSVal -> ConnectResourceArgs callback -> callback -> ClickM ()
+connectResource target args k = do
+ e :: InternalEnv <- ask
+ let hsCallback' = (`runReaderT` e) . unClickM . trampoline . args.mk_callback k
+ hsCallback'' <- liftIO $ FFI.js_dynExport hsCallback'
+ cancel <- liftIO $ FFI.aquireResource target args.js_wrapper.unUnsafeJavaScript hsCallback''
+ installFinalizer do
+ liftIO $ FFI.apply0 cancel
+ liftIO $ freeJSVal hsCallback''
+
+on :: forall eventName. IsEventName eventName => EventListenerCb eventName -> HtmlM ()
+on k = addEventListener (addEventListenerArgs @eventName) k
+
+class IsEventName eventName where
+ type EventListenerCb eventName :: Type
+ addEventListenerArgs :: ConnectResourceArgs (EventListenerCb eventName)
+
+instance IsEventName "click" where
+ type EventListenerCb "click" = ClickM ()
+ addEventListenerArgs = pointerConnectArgs "click"
+
+instance IsEventName "mousedown" where
+ type EventListenerCb "mousedown" = ClickM ()
+ addEventListenerArgs = pointerConnectArgs "mousedown"
+
+instance IsEventName "mouseup" where
+ type EventListenerCb "mouseup" = ClickM ()
+ addEventListenerArgs = pointerConnectArgs "mouseup"
+
+instance IsEventName "dblclick" where
+ type EventListenerCb "dblclick" = ClickM ()
+ addEventListenerArgs = pointerConnectArgs "dblclick"
+
+instance IsEventName "submit" where
+ type EventListenerCb "submit" = ClickM ()
+ addEventListenerArgs = submitConnectArgs
+
+instance IsEventName "input" where
+ type EventListenerCb "input" = Text -> ClickM ()
+ addEventListenerArgs = inputConnectArgs "input"
+
+instance IsEventName "keydown" where
+ type EventListenerCb "keydown" = Int -> ClickM ()
+ addEventListenerArgs = keyboardConnectArgs "keydown"
+
+instance IsEventName "keyup" where
+ type EventListenerCb "keyup" = Int -> ClickM ()
+ addEventListenerArgs = keyboardConnectArgs "keyup"
+
+instance IsEventName "focus" where
+ type EventListenerCb "focus" = ClickM ()
+ addEventListenerArgs = pointerConnectArgs "focus"
+
+instance IsEventName "blur" where
+ type EventListenerCb "blur" = ClickM ()
+ addEventListenerArgs = pointerConnectArgs "blur"
+
+instance IsEventName "input/blur" where
+ type EventListenerCb "input/blur" = Text -> ClickM ()
+ addEventListenerArgs = inputConnectArgs "blur"
+
+instance IsEventName "input/focus" where
+ type EventListenerCb "input/focus" = Text -> ClickM ()
+ addEventListenerArgs = inputConnectArgs "focus"
+
+instance IsEventName "checkbox/change" where
+ type EventListenerCb "checkbox/change" = Bool -> ClickM ()
+ addEventListenerArgs = checkboxChangeConnectArgs
+
+instance IsEventName "select/change" where
+ type EventListenerCb "select/change" = Text -> ClickM ()
+ addEventListenerArgs = selectChangeConnectArgs
+
+-- https://developer.mozilla.org/en-US/docs/Web/API/Element/click_event
+pointerConnectArgs :: Text -> ConnectResourceArgs (ClickM ())
+pointerConnectArgs eventName = ConnectResourceArgs
+ { js_wrapper = normalEventWrapper eventName defaultEventListenerOptions
+ , mk_callback = \k _ -> k
+ }
+
+-- https://developer.mozilla.org/en-US/docs/Web/API/HTMLFormElement/submit_event
+submitConnectArgs :: ConnectResourceArgs (ClickM ())
+submitConnectArgs = ConnectResourceArgs
+ { js_wrapper = normalEventWrapper "submit" EventListenerOptions
+ { prevent_default = True
+ , stop_propagation = True
+ }
+ , mk_callback = \k _ -> k
+ }
+
+-- https://developer.mozilla.org/en-US/docs/Web/API/HTMLElement/input_event
+inputConnectArgs :: Text -> ConnectResourceArgs (Text -> ClickM ())
+inputConnectArgs eventName = ConnectResourceArgs
+ { js_wrapper =
+ "(function(target, haskellCb){\n\
+ \ function listener(target){\n\
+ \ haskellCb(event.target.value);\n\
+ \ }\n\
+ \ window.addEventListener('" <> UnsafeJavaScript eventName <> "', listener);\n\
+ \ return () => window.removeEventListener('" <> UnsafeJavaScript eventName <> "', listener);\n\
+ \})"
+ , mk_callback = \k event -> liftIO (fromJSVal event) >>= mapM_ k
+ }
+
+-- https://developer.mozilla.org/en-US/docs/Web/API/Element/keydown_event
+-- https://developer.mozilla.org/en-US/docs/Web/API/Element/keyup_event
+keyboardConnectArgs :: Text -> ConnectResourceArgs (Int -> ClickM ())
+keyboardConnectArgs eventName = ConnectResourceArgs
+ { js_wrapper =
+ "(function(target, haskellCb){\n\
+ \ function listener(target){\n\
+ \ haskellCb(event.target.value);\n\
+ \ }\n\
+ \ window.addEventListener('" <> UnsafeJavaScript eventName <> "', listener);\n\
+ \ return () => window.removeEventListener('" <> UnsafeJavaScript eventName <> "', listener);\n\
+ \})"
+ , mk_callback = \k event -> liftIO (fromJSVal event) >>= mapM_ k
+ }
+
+-- https://developer.mozilla.org/en-US/docs/Web/API/Element/focus_event
+-- https://developer.mozilla.org/en-US/docs/Web/API/Element/blur_event
+-- https://developer.mozilla.org/en-US/docs/Web/API/Element/focusin_event
+-- https://developer.mozilla.org/en-US/docs/Web/API/Element/focusout_event
+focusConnectArgs :: Text -> ConnectResourceArgs (ClickM ())
+focusConnectArgs eventName = ConnectResourceArgs
+ { js_wrapper = normalEventWrapper eventName defaultEventListenerOptions
+ , mk_callback = \k _ -> k
+ }
+
+-- https://developer.mozilla.org/en-US/docs/Web/API/HTMLElement/change_event
+checkboxChangeConnectArgs :: ConnectResourceArgs (Bool -> ClickM ())
+checkboxChangeConnectArgs = ConnectResourceArgs
+ { js_wrapper =
+ "(function(target, haskellCb){\n\
+ \ function listener(target){\n\
+ \ haskellCb(event.target.checked);\n\
+ \ }\n\
+ \ window.addEventListener('change', listener);\n\
+ \ return () => window.removeEventListener('change', listener);\n\
+ \})"
+ , mk_callback = \k event -> liftIO (fromJSVal event) >>= mapM_ k
+ }
+
+-- https://developer.mozilla.org/en-US/docs/Web/API/HTMLElement/change_event
+selectChangeConnectArgs :: ConnectResourceArgs (Text -> ClickM ())
+selectChangeConnectArgs = ConnectResourceArgs
+ { js_wrapper =
+ "(function(target, haskellCb){\n\
+ \ function listener(target){\n\
+ \ haskellCb(event.target.value);\n\
+ \ }\n\
+ \ window.addEventListener('change', listener);\n\
+ \ return () => window.removeEventListener('change', listener);\n\
+ \})"
+ , mk_callback = \k event -> liftIO (fromJSVal event) >>= mapM_ k
+ }
+
+normalEventWrapper :: Text -> EventListenerOptions -> UnsafeJavaScript
+normalEventWrapper eventName opt =
+ "(function(target, haskellCb){\n\
+ \ function listener(event){\n\
+ \ " <> preventDefaultStmt <> "\n\
+ \ " <> stopPropagationStmt <> "\n\
+ \ haskellCb(event);\n\
+ \ }\n\
+ \ target.addEventListener('" <> UnsafeJavaScript eventName <> "', listener);\n\
+ \ return () => target.removeEventListener('" <> UnsafeJavaScript eventName <> "', listener);\n\
+ \})"
+ where
+ preventDefaultStmt = if opt.prevent_default then "event.preventDefault();" else ""
+ stopPropagationStmt = if opt.stop_propagation then "event.stopPropagation();" else ""
+
+data Location = Location
+ { protocol :: Text
+ -- ^ A string containing the protocol scheme of the URL, including
+ -- the final ':'
+ , hostname :: Text
+ -- ^ A string containing the domain of the URL.
+ , port :: Text
+ -- ^ A string containing the port number of the URL.
+ , pathname :: Text
+ -- ^ A string containing an initial '/' followed by the path of the
+ -- URL, not including the query string or fragment.
+ , search :: Text
+ -- ^ A string containing a '?' followed by the parameters or
+ -- "querystring" of the URL
+ , hash :: Text
+ -- ^ A string containing a '#' followed by the fragment identifier
+ -- of the URL.
+ } deriving stock (Show, Eq, Generic)
+ deriving anyclass (FromJSVal, ToJSVal)
+
+-- https://developer.mozilla.org/en-US/docs/Web/API/Window/popstate_event
+popstateConnectArgs :: ConnectResourceArgs (Location -> ClickM ())
+popstateConnectArgs = ConnectResourceArgs
+ { js_wrapper =
+ "(function(target, haskellCb){\n\
+ \ function listener(){\n\
+ \ haskellCb(location);\n\
+ \ }\n\
+ \ target.addEventListener('popstate', listener);\n\
+ \ return () => target.removeEventListener('popstate', listener);\n\
+ \})"
+ , mk_callback = \k event -> liftIO (fromJSVal event) >>= mapM_ k
+ }
diff --git a/src/HtmlT/Element.hs b/src/Clickable/Element.hs
similarity index 97%
rename from src/HtmlT/Element.hs
rename to src/Clickable/Element.hs
index c570c39..de84a7d 100644
--- a/src/HtmlT/Element.hs
+++ b/src/Clickable/Element.hs
@@ -1,11 +1,11 @@
{-|
Shortcuts for most common HTML5 elements
-}
-module HtmlT.Element where
+module Clickable.Element where
-import HtmlT.Base
-import HtmlT.Types
-import JavaScript.Compat.String (JSString(..))
+import Clickable.Core
+import Clickable.Types
+import Data.Text
-- | This typeclass allows for tag constructors to have variable
-- length arguments. Each tag constructor like 'div_' defined below
@@ -18,18 +18,18 @@ import JavaScript.Compat.String (JSString(..))
-- https://github.com/chrisdone/lucid/blob/fb3b0e7c189c2acd8d88838d4a13923f24542ee8/src/Lucid/Base.hs#L272
class Term arg result | result -> arg where
term
- :: JSString -- ^ Name.
+ :: Text -- ^ Name.
-> arg -- ^ Some argument.
-> result -- ^ Result: either an element or an attribute.
-- | Given attributes, expect more child input.
-instance f ~ Html a => Term [Html ()] (f -> Html a) where
+instance f ~ HtmlM a => Term [HtmlM ()] (f -> HtmlM a) where
term name attrs = el name . (sequence_ attrs *>)
{-# INLINE term #-}
-- | Given children immediately, just use that and expect no
-- attributes.
-instance Term (Html a) (Html a) where
+instance Term (HtmlM a) (HtmlM a) where
term = el
{-# INLINE term #-}
@@ -357,7 +357,7 @@ sup_ :: Term arg result => arg -> result
sup_ = term "sup"
{-# INLINE sup_ #-}
-br_ :: Html ()
+br_ :: HtmlM ()
br_ = el "br" blank
{-# INLINE br_ #-}
diff --git a/src/Clickable/FFI.hs b/src/Clickable/FFI.hs
new file mode 100644
index 0000000..37a15ba
--- /dev/null
+++ b/src/Clickable/FFI.hs
@@ -0,0 +1,250 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE MagicHash #-}
+
+#if defined(wasm32_HOST_ARCH)
+{-# LANGUAGE JavaScriptFFI #-}
+#endif
+module Clickable.FFI where
+
+import Control.Monad.IO.Class
+import Wasm.Compat.Prim
+import GHC.Ptr
+import Data.Word
+import GHC.Prim
+import Data.Text.Internal
+import Data.Array.Byte
+
+
+newtype DomBuilder = DomBuilder {unDomBuilder :: JSVal}
+
+insertText :: JSVal -> Text -> IO JSVal
+insertText root (Text (ByteArray arr) off len) = do
+ let addr = byteArrayContents# arr
+ js_insertText root (Ptr addr `plusPtr` off) len
+
+insertElement :: JSVal -> Text -> IO JSVal
+insertElement root (Text (ByteArray arr) off len) = do
+ let addr = byteArrayContents# arr
+ js_insertElement root (Ptr addr `plusPtr` off) len
+
+updateTextContent :: JSVal -> Text -> IO ()
+updateTextContent root (Text (ByteArray arr) off len) = do
+ let addr = byteArrayContents# arr
+ js_updateTextContent root (Ptr addr `plusPtr` off) len
+
+setProperty :: JSVal -> Text -> Text -> IO ()
+setProperty root (Text (ByteArray arr0) off0 len0) (Text (ByteArray arr1) off1 len1) = do
+ let addr0 = byteArrayContents# arr0
+ let addr1 = byteArrayContents# arr1
+ js_setProperty root (Ptr addr0 `plusPtr` off0) len0 (Ptr addr1 `plusPtr` off1) len1
+
+setBoolProperty :: JSVal -> Text -> Bool -> IO ()
+setBoolProperty root (Text (ByteArray arr0) off0 len0) val = do
+ let addr0 = byteArrayContents# arr0
+ js_setBoolProperty root (Ptr addr0 `plusPtr` off0) len0 (if val then 1 else 0)
+
+setAttribute :: JSVal -> Text -> Text -> IO ()
+setAttribute root (Text (ByteArray arr0) off0 len0) (Text (ByteArray arr1) off1 len1) = do
+ let addr0 = byteArrayContents# arr0
+ let addr1 = byteArrayContents# arr1
+ js_setAttribute root (Ptr addr0 `plusPtr` off0) len0 (Ptr addr1 `plusPtr` off1) len1
+
+addEventListener :: JSVal -> Text -> JSVal -> IO ()
+addEventListener root (Text (ByteArray arr) off len) lisnr = do
+ let addr = byteArrayContents# arr
+ js_addEventListener root (Ptr addr `plusPtr` off) len lisnr
+
+removeEventListener :: JSVal -> Text -> JSVal -> IO ()
+removeEventListener root (Text (ByteArray arr) off len) lisnr = do
+ let addr = byteArrayContents# arr
+ js_removeEventListener root (Ptr addr `plusPtr` off) len lisnr
+
+consoleLog :: MonadIO m => Text -> m ()
+consoleLog (Text (ByteArray arr) off len) = liftIO do
+ let addr = byteArrayContents# arr
+ js_consoleLog (Ptr addr `plusPtr` off) len
+
+aquireResource :: JSVal -> Text -> JSVal -> IO JSVal
+aquireResource root (Text (ByteArray arr) off len) lisnr = do
+ let addr = byteArrayContents# arr
+ js_aquireResource root (Ptr addr `plusPtr` off) len lisnr
+
+apply0 :: JSVal -> IO ()
+apply0 = js_apply0
+
+#if !defined(wasm32_HOST_ARCH)
+js_insertText :: JSVal -> Ptr Word8 -> Int -> IO JSVal
+js_insertText = undefined
+
+js_insertElement :: JSVal -> Ptr Word8 -> Int -> IO JSVal
+js_insertElement = undefined
+
+js_updateTextContent :: JSVal -> Ptr Word8 -> Int -> IO ()
+js_updateTextContent = undefined
+
+js_setProperty :: JSVal -> Ptr Word8 -> Int -> Ptr Word8 -> Int -> IO ()
+js_setProperty = undefined
+
+js_setBoolProperty :: JSVal -> Ptr Word8 -> Int -> Int -> IO ()
+js_setBoolProperty = undefined
+
+js_setAttribute :: JSVal -> Ptr Word8 -> Int -> Ptr Word8 -> Int -> IO ()
+js_setAttribute = undefined
+
+js_addEventListener :: JSVal -> Ptr Word8 -> Int -> JSVal -> IO ()
+js_addEventListener = undefined
+
+js_removeEventListener :: JSVal -> Ptr Word8 -> Int -> JSVal -> IO ()
+js_removeEventListener = undefined
+
+js_dynExport :: (JSVal -> IO ()) -> IO JSVal
+js_dynExport = undefined
+
+documentBody :: IO JSVal
+documentBody = undefined
+
+js_consoleLog :: Ptr Word8 -> Int -> IO ()
+js_consoleLog = undefined
+
+js_insertBrackets :: JSVal -> IO JSVal
+js_insertBrackets = undefined
+
+js_clearBrackets :: JSVal -> IO ()
+js_clearBrackets = undefined
+
+js_removeBrackets :: JSVal -> IO ()
+js_removeBrackets = undefined
+
+js_aquireResource :: JSVal -> Ptr Word8 -> Int -> JSVal -> IO JSVal
+js_aquireResource = undefined
+
+js_apply0 :: JSVal -> IO ()
+js_apply0 = undefined
+
+#else
+foreign import javascript unsafe
+ "var c = new TextDecoder('utf8').decode(new Uint8Array(__exports.memory.buffer, $2, $3));\
+ var n = document.createTextNode(c);\
+ if ($1 instanceof Comment) {\
+ $1.parentNode.insertBefore(n, $1);\
+ } else {\
+ $1.appendChild(n);\
+ }\
+ return n;"
+ js_insertText :: JSVal -> Ptr Word8 -> Int -> IO JSVal
+foreign import javascript unsafe
+ "var t = new TextDecoder('utf8').decode(new Uint8Array(__exports.memory.buffer, $2, $3));\
+ var n = document.createElement(t);\
+ if ($1 instanceof Comment) {\
+ $1.parentNode.insertBefore(n, $1);\
+ } else {\
+ $1.appendChild(n);\
+ }\
+ return n;"
+ js_insertElement :: JSVal -> Ptr Word8 -> Int -> IO JSVal
+foreign import javascript unsafe
+ "$1.nodeValue = new TextDecoder('utf8').decode(new Uint8Array(__exports.memory.buffer, $2, $3));"
+ js_updateTextContent :: JSVal -> Ptr Word8 -> Int -> IO ()
+foreign import javascript unsafe
+ "var k = new TextDecoder('utf8').decode(new Uint8Array(__exports.memory.buffer, $2, $3));\
+ var v = new TextDecoder('utf8').decode(new Uint8Array(__exports.memory.buffer, $4, $5));\
+ if ($1 instanceof Comment) {\
+ $1.parentNode[k] = v;\
+ } else {\
+ $1[k] = v;\
+ }"
+ js_setProperty :: JSVal -> Ptr Word8 -> Int -> Ptr Word8 -> Int -> IO ()
+foreign import javascript unsafe
+ "var k = new TextDecoder('utf8').decode(new Uint8Array(__exports.memory.buffer, $2, $3));\
+ if ($1 instanceof Comment) {\
+ $1.parentNode[k] = $4 == 0 ? false : true;\
+ } else {\
+ $1[k] = $4 == 0 ? false : true;\
+ }"
+ js_setBoolProperty :: JSVal -> Ptr Word8 -> Int -> Int -> IO ()
+foreign import javascript unsafe
+ "var k = new TextDecoder('utf8').decode(new Uint8Array(__exports.memory.buffer, $2, $3));\
+ var v = new TextDecoder('utf8').decode(new Uint8Array(__exports.memory.buffer, $4, $5));\
+ if ($1 instanceof Comment) {\
+ $1.parentNode.setAttribute(k, v);\
+ } else {\
+ $1.setAttribute(k, v);\
+ }"
+ js_setAttribute :: JSVal -> Ptr Word8 -> Int -> Ptr Word8 -> Int -> IO ()
+foreign import javascript unsafe "document.body" documentBody :: IO JSVal
+foreign import javascript unsafe
+ "var e = new TextDecoder('utf8').decode(new Uint8Array(__exports.memory.buffer, $2, $3));\
+ if ($1 instanceof Comment) {\
+ $1.parentNode.addEventListener(e, $4);\
+ } else {\
+ $1.addEventListener(e, $4);\
+ }"
+ js_addEventListener :: JSVal -> Ptr Word8 -> Int -> JSVal -> IO ()
+foreign import javascript unsafe
+ "var e = new TextDecoder('utf8').decode(new Uint8Array(__exports.memory.buffer, $2, $3));\
+ if ($1 instanceof Comment) {\
+ $1.parentNode.addEventListener(e, $4);\
+ } else {\
+ $1.removeEventListener(e, $4);\
+ }"
+ js_removeEventListener :: JSVal -> Ptr Word8 -> Int -> JSVal -> IO ()
+foreign import javascript "wrapper" js_dynExport :: (JSVal -> IO ()) -> IO JSVal
+foreign import javascript unsafe
+ "console.log(new TextDecoder('utf8').decode(new Uint8Array(__exports.memory.buffer, $1, $2)));"
+ js_consoleLog :: Ptr Word8 -> Int -> IO ()
+foreign import javascript unsafe
+ "var c1 = document.createComment('ContentBoundary {{');\
+ var c2 = document.createComment('}}');\
+ if ($1 instanceof Comment) {\
+ $1.parentNode.insertBefore(c1, $1);\
+ $1.parentNode.insertBefore(c2, $1);\
+ } else {\
+ $1.appendChild(c1);\
+ $1.appendChild(c2);\
+ }\
+ return c2;"
+ js_insertBrackets :: JSVal -> IO JSVal
+foreign import javascript unsafe
+ "function isOpenBracket(node) {return node instanceof Comment && node.textContent == 'ContentBoundary {{'}\
+ function isCloseBracket(node) {return node instanceof Comment && node.textContent == '}}'}\
+ var iter = $1;\
+ var nestedCounter = 0;\
+ for (;;){\
+ if (!iter.previousSibling ||\
+ (nestedCounter == 0 && isOpenBracket(iter.previousSibling))\
+ ) break;\
+ if (isCloseBracket(iter.previousSibling)) nestedCounter++;\
+ else if (isOpenBracket(iter.previousSibling)) nestedCounter--;\
+ iter.previousSibling.parentNode.removeChild(iter.previousSibling);\
+ }"
+ js_clearBrackets :: JSVal -> IO ()
+foreign import javascript unsafe
+ "function isOpenBracket(node) {return node instanceof Comment && node.textContent == 'ContentBoundary {{'}\
+ function isCloseBracket(node) {return node instanceof Comment && node.textContent == '}}'}\
+ var iter = $1;\
+ var nestedCounter = 0;\
+ for (;;){\
+ if (!iter.previousSibling ||\
+ (nestedCounter == 0 && isOpenBracket(iter.previousSibling))\
+ ) break;\
+ if (isCloseBracket(iter.previousSibling)) nestedCounter++;\
+ else if (isOpenBracket(iter.previousSibling)) nestedCounter--;\
+ iter.previousSibling.parentNode.removeChild(iter.previousSibling);\
+ }\
+ $1.parentNode($1);\
+ if ($1 != iter) iter.parentNode.removeChild(iter);\
+ "
+ js_removeBrackets :: JSVal -> IO ()
+foreign import javascript unsafe
+ "var j = new TextDecoder('utf8').decode(new Uint8Array(__exports.memory.buffer, $2, $3));\
+ if ($1 instanceof Comment) {\
+ return eval(j)($1.parentNode, $4);\
+ } else {\
+ return eval(j)($1, $4);\
+ }"
+ js_aquireResource :: JSVal -> Ptr Word8 -> Int -> JSVal -> IO JSVal
+foreign import javascript unsafe
+ "$1()" js_apply0 :: JSVal -> IO ()
+#endif
diff --git a/src/Clickable/Internal.hs b/src/Clickable/Internal.hs
new file mode 100644
index 0000000..37f463f
--- /dev/null
+++ b/src/Clickable/Internal.hs
@@ -0,0 +1,96 @@
+module Clickable.Internal where
+
+import Clickable.Types
+import Control.Monad.Reader
+import Control.Monad.State
+import Data.IORef
+import Data.List qualified as List
+import Data.Map qualified as Map
+import Unsafe.Coerce
+
+
+emptyInternalState :: InternalState
+emptyInternalState = InternalState [] [] Map.empty 0
+
+newInternalEnv :: IO InternalEnv
+newInternalEnv = do
+ let scope = ResourceScope emptyInternalState.next_id
+ internal_state_ref <- newIORef emptyInternalState
+ {next_id = emptyInternalState.next_id + 1}
+ return InternalEnv {internal_state_ref, scope}
+
+unsafeTrigger :: SourceId -> a -> InternalState -> InternalState
+unsafeTrigger varId vals = go0 where
+ go0 = defer varId $ gets (.subscriptions) >>= go1
+ go1 [] = return ()
+ go1 ((_, sVar, cb) : xs)
+ | sVar == varId = cb (unsafeCoerce vals) >> go1 xs
+ | otherwise = go1 xs
+
+newScope :: ResourceScope -> InternalState -> (InternalState, ResourceScope)
+newScope p s =
+ let
+ scopeId = ResourceScope s.next_id
+ finalizers = (p, ScopeFinalizer scopeId) : s.finalizers
+ next_id = s.next_id + 1
+ in
+ (s {finalizers, next_id}, scopeId)
+
+freeScope ::
+ Bool ->
+ ResourceScope ->
+ InternalState -> (InternalState, [(ResourceScope, FinalizerVal)])
+freeScope unlink rscope s =
+ let
+ chkSub (s, _, _) = s /= rscope
+ chkFin True (s1, ScopeFinalizer s2) = s1 /= rscope && s2 /= rscope
+ chkFin True (s, _) = s /= rscope
+ chkFin False (s, _) = s /= rscope
+ (finalizers, scopeFns) = List.partition (chkFin unlink) s.finalizers
+ subscriptions = List.filter chkSub s.subscriptions
+ in
+ (s {subscriptions, finalizers}, scopeFns)
+
+installFinalizer :: ClickM () -> ResourceScope -> InternalState -> InternalState
+installFinalizer k scope s = s
+ {finalizers = (scope, CustomFinalizer k) : s.finalizers}
+
+subscribe ::
+ DynVal a ->
+ (a -> ClickM ()) ->
+ ResourceScope ->
+ InternalState -> InternalState
+subscribe (ConstVal _) _ _ s = s
+subscribe (FromVar (DynVar varId _)) fn scope s = s {subscriptions}
+ where
+ subscriptions = newSub : s.subscriptions
+ newSub = (scope, varId, fn . unsafeCoerce)
+subscribe (MapVal v f) fn scope s = subscribe v (fn . f) scope s
+subscribe (SplatVal fv av) fn scope s =
+ subscribe av g scope $ subscribe fv f scope $ attachCb s
+ where
+ f fv' = do
+ av' <- readVal av
+ modify $ unsafeTrigger varid $ fv' av'
+ g av' = do
+ fv' <- readVal fv
+ modify $ unsafeTrigger varid $ fv' av'
+ attachCb s = s
+ { subscriptions = (scope, varid, fn . unsafeCoerce) : s.subscriptions
+ , next_id = s.next_id + 1
+ }
+ varid = SourceId s.next_id
+ readVal :: DynVal a -> ClickM a
+ readVal (ConstVal a) = pure a
+ readVal (FromVar (DynVar _ ref)) = liftIO $ readIORef ref
+ readVal (MapVal val f) = fmap f $ readVal val
+ readVal (SplatVal f a) = liftA2 ($) (readVal f) (readVal a)
+
+defer :: SourceId -> ClickM () -> InternalState -> InternalState
+defer k act s = s { transaction_queue = Map.insert k act s.transaction_queue }
+
+reactive :: (ResourceScope -> InternalState -> (InternalState, a)) -> ClickM a
+reactive f = ClickM $ ReaderT $ \e -> atomicModifyIORef' e.internal_state_ref $ f e.scope
+
+reactive_ :: (ResourceScope -> InternalState -> InternalState) -> ClickM ()
+reactive_ f = reactive \scope s -> (f scope s, ())
diff --git a/src/Clickable/Main.hs b/src/Clickable/Main.hs
new file mode 100644
index 0000000..4fc2816
--- /dev/null
+++ b/src/Clickable/Main.hs
@@ -0,0 +1,37 @@
+module Clickable.Main where
+
+import GHC.Generics
+import Clickable.FFI
+import Clickable.Core
+import Clickable.Types
+import Clickable.Internal (newInternalEnv)
+import Wasm.Compat.Prim
+
+data AttachOptions = AttachOptions
+ { internal_env :: InternalEnv
+ , dom_builder :: JSVal
+ } deriving Generic
+
+-- | Needed to manually finalize and detach the application
+data RunningApp = RunningApp
+ { internal_env :: InternalEnv
+ , dom_bracket :: JSVal
+ } deriving Generic
+
+attachWithOptions :: AttachOptions -> HtmlM a -> IO (a, RunningApp)
+attachWithOptions opt app = do
+ domBracket <- js_insertBrackets opt.dom_builder
+ result <- launchHtmlM domBracket opt.internal_env app
+ let runApp = RunningApp opt.internal_env domBracket
+ return (result, runApp)
+
+attach :: HtmlM a -> IO (a, RunningApp)
+attach html = do
+ body <- documentBody
+ internalEnv <- newInternalEnv
+ attachWithOptions (AttachOptions internalEnv body) html
+
+detach :: RunningApp -> IO ()
+detach app = do
+ launchClickM app.internal_env $ freeScope True app.internal_env.scope
+ js_removeBrackets app.dom_bracket
diff --git a/src/Clickable/Property.hs b/src/Clickable/Property.hs
new file mode 100644
index 0000000..1e20ccf
--- /dev/null
+++ b/src/Clickable/Property.hs
@@ -0,0 +1,366 @@
+{-|
+Shortcuts for common HTML5 attributes and properties
+-}
+module Clickable.Property where
+
+import Clickable.Core
+import Clickable.Types
+import Data.Text
+
+
+-- TODO: Real-world usage has demonstrated that 'dynStyles' not
+-- sufficiently composable. For instance, if 'dynStyles' is used to
+-- set the CSS color for an element, essentially no other CSS property
+-- can be applied to this element, as they will be overwritten by
+-- 'dynStyles'.
+dynStyles :: DynVal Text -> HtmlM ()
+dynStyles = dynProp "style"
+{-# INLINE dynStyles #-}
+
+dynValue :: DynVal Text -> HtmlM ()
+dynValue = dynProp "value"
+{-# INLINE dynValue #-}
+
+dynClass :: DynVal Text -> HtmlM ()
+dynClass = dynProp "className"
+{-# INLINE dynClass #-}
+
+dynChecked :: DynVal Bool -> HtmlM ()
+dynChecked = dynBoolProp "checked"
+{-# INLINE dynChecked #-}
+
+dynDisabled :: DynVal Bool -> HtmlM ()
+dynDisabled = dynBoolProp "disabled"
+{-# INLINE dynDisabled #-}
+
+title_ :: Text -> HtmlM ()
+title_ = property "title"
+{-# INLINE title_ #-}
+
+selected_ :: Bool -> HtmlM ()
+selected_ = boolProperty "selected"
+{-# INLINE selected_ #-}
+
+hidden_ :: Bool -> HtmlM ()
+hidden_ = boolProperty "hidden"
+{-# INLINE hidden_ #-}
+
+value_ :: Text -> HtmlM ()
+value_ = property "value"
+{-# INLINE value_ #-}
+
+defaultValue_ :: Text -> HtmlM ()
+defaultValue_ = property "defaultValue"
+{-# INLINE defaultValue_ #-}
+
+accept_ :: Text -> HtmlM ()
+accept_ = property "accept"
+{-# INLINE accept_ #-}
+
+acceptCharset_ :: Text -> HtmlM ()
+acceptCharset_ = property "acceptCharset"
+{-# INLINE acceptCharset_ #-}
+
+action_ :: Text -> HtmlM ()
+action_ = property "action"
+{-# INLINE action_ #-}
+
+autocomplete_ :: Bool -> HtmlM ()
+autocomplete_ b = property "autocomplete" (if b then "on" else "off")
+{-# INLINE autocomplete_ #-}
+
+autosave_ :: Text -> HtmlM ()
+autosave_ = property "autosave"
+{-# INLINE autosave_ #-}
+
+disabled_ :: Bool -> HtmlM ()
+disabled_ = boolProperty "disabled"
+{-# INLINE disabled_ #-}
+
+enctype_ :: Text -> HtmlM ()
+enctype_ = property "enctype"
+{-# INLINE enctype_ #-}
+
+formation_ :: Text -> HtmlM ()
+formation_ = property "formation"
+{-# INLINE formation_ #-}
+
+list_ :: Text -> HtmlM ()
+list_ = property "list"
+{-# INLINE list_ #-}
+
+maxlength_ :: Text -> HtmlM ()
+maxlength_ = property "maxlength"
+{-# INLINE maxlength_ #-}
+
+minlength_ :: Text -> HtmlM ()
+minlength_ = property "minlength"
+{-# INLINE minlength_ #-}
+
+method_ :: Text -> HtmlM ()
+method_ = property "method"
+{-# INLINE method_ #-}
+
+multiple_ :: Bool -> HtmlM ()
+multiple_ = boolProperty "multiple"
+{-# INLINE multiple_ #-}
+
+novalidate_ :: Bool -> HtmlM ()
+novalidate_ = boolProperty "noValidate"
+{-# INLINE novalidate_ #-}
+
+pattern_ :: Text -> HtmlM ()
+pattern_ = property "pattern"
+{-# INLINE pattern_ #-}
+
+readonly_ :: Bool -> HtmlM ()
+readonly_ = boolProperty "readOnly"
+{-# INLINE readonly_ #-}
+
+required_ :: Bool -> HtmlM ()
+required_ = boolProperty "required"
+{-# INLINE required_ #-}
+
+size_ :: Text -> HtmlM ()
+size_ = property "size"
+{-# INLINE size_ #-}
+
+forProp_ :: Text -> HtmlM ()
+forProp_ = property "for"
+{-# INLINE forProp_ #-}
+
+ref_ :: Text -> HtmlM ()
+ref_ = property "ref"
+{-# INLINE ref_ #-}
+
+formProp_ :: Text -> HtmlM ()
+formProp_ = property "form"
+{-# INLINE formProp_ #-}
+
+max_ :: Text -> HtmlM ()
+max_ = property "max"
+{-# INLINE max_ #-}
+
+min_ :: Text -> HtmlM ()
+min_ = property "min"
+{-# INLINE min_ #-}
+
+step_ :: Text -> HtmlM ()
+step_ = property "step"
+{-# INLINE step_ #-}
+
+cols_ :: Text -> HtmlM ()
+cols_ = property "cols"
+{-# INLINE cols_ #-}
+
+rows_ :: Text -> HtmlM ()
+rows_ = property "rows"
+{-# INLINE rows_ #-}
+
+wrap_ :: Text -> HtmlM ()
+wrap_ = property "wrap"
+{-# INLINE wrap_ #-}
+
+target_ :: Text -> HtmlM ()
+target_ = property "target"
+{-# INLINE target_ #-}
+
+download_ :: Text -> HtmlM ()
+download_ = property "download"
+{-# INLINE download_ #-}
+
+downloadAs_ :: Text -> HtmlM ()
+downloadAs_ = property "downloadAs"
+{-# INLINE downloadAs_ #-}
+
+hreflang_ :: Text -> HtmlM ()
+hreflang_ = property "hreflang"
+{-# INLINE hreflang_ #-}
+
+media_ :: Text -> HtmlM ()
+media_ = property "media"
+{-# INLINE media_ #-}
+
+ping_ :: Text -> HtmlM ()
+ping_ = property "ping"
+{-# INLINE ping_ #-}
+
+rel_ :: Text -> HtmlM ()
+rel_ = property "rel"
+{-# INLINE rel_ #-}
+
+ismap_ :: Text -> HtmlM ()
+ismap_ = property "ismap"
+{-# INLINE ismap_ #-}
+
+usemap_ :: Text -> HtmlM ()
+usemap_ = property "usemap"
+{-# INLINE usemap_ #-}
+
+shape_ :: Text -> HtmlM ()
+shape_ = property "shape"
+{-# INLINE shape_ #-}
+
+coords_ :: Text -> HtmlM ()
+coords_ = property "coords"
+{-# INLINE coords_ #-}
+
+src_ :: Text -> HtmlM ()
+src_ = property "src"
+{-# INLINE src_ #-}
+
+height_ :: Text -> HtmlM ()
+height_ = property "height"
+{-# INLINE height_ #-}
+
+width_ :: Text -> HtmlM ()
+width_ = property "width"
+{-# INLINE width_ #-}
+
+alt_ :: Text -> HtmlM ()
+alt_ = property "alt"
+{-# INLINE alt_ #-}
+
+autoplay_ :: Bool -> HtmlM ()
+autoplay_ = boolProperty "autoplay"
+{-# INLINE autoplay_ #-}
+
+controls_ :: Bool -> HtmlM ()
+controls_ = boolProperty "controls"
+{-# INLINE controls_ #-}
+
+loop_ :: Bool -> HtmlM ()
+loop_ = boolProperty "loop"
+{-# INLINE loop_ #-}
+
+preload_ :: Text -> HtmlM ()
+preload_ = property "preload"
+{-# INLINE preload_ #-}
+
+poster_ :: Text -> HtmlM ()
+poster_ = property "poster"
+{-# INLINE poster_ #-}
+
+default_ :: Bool -> HtmlM ()
+default_ = boolProperty "default"
+{-# INLINE default_ #-}
+
+kind_ :: Text -> HtmlM ()
+kind_ = property "kind"
+{-# INLINE kind_ #-}
+
+srclang_ :: Text -> HtmlM ()
+srclang_ = property "srclang"
+{-# INLINE srclang_ #-}
+
+sandbox_ :: Text -> HtmlM ()
+sandbox_ = property "sandbox"
+{-# INLINE sandbox_ #-}
+
+seamless_ :: Text -> HtmlM ()
+seamless_ = property "seamless"
+{-# INLINE seamless_ #-}
+
+srcdoc_ :: Text -> HtmlM ()
+srcdoc_ = property "srcdoc"
+{-# INLINE srcdoc_ #-}
+
+reversed_ :: Text -> HtmlM ()
+reversed_ = property "reversed"
+{-# INLINE reversed_ #-}
+
+start_ :: Text -> HtmlM ()
+start_ = property "start"
+{-# INLINE start_ #-}
+
+align_ :: Text -> HtmlM ()
+align_ = property "align"
+{-# INLINE align_ #-}
+
+colspan_ :: Text -> HtmlM ()
+colspan_ = attribute "colspan"
+{-# INLINE colspan_ #-}
+
+rowspan_ :: Text -> HtmlM ()
+rowspan_ = attribute "rowspan"
+{-# INLINE rowspan_ #-}
+
+headers_ :: Text -> HtmlM ()
+headers_ = property "headers"
+{-# INLINE headers_ #-}
+
+scope_ :: Text -> HtmlM ()
+scope_ = property "scope"
+{-# INLINE scope_ #-}
+
+async_ :: Text -> HtmlM ()
+async_ = property "async"
+{-# INLINE async_ #-}
+
+charset_ :: Text -> HtmlM ()
+charset_ = property "charset"
+{-# INLINE charset_ #-}
+
+content_ :: Text -> HtmlM ()
+content_ = property "content"
+{-# INLINE content_ #-}
+
+defer_ :: Text -> HtmlM ()
+defer_ = property "defer"
+{-# INLINE defer_ #-}
+
+httpEquiv_ :: Text -> HtmlM ()
+httpEquiv_ = property "httpEquiv"
+{-# INLINE httpEquiv_ #-}
+
+language_ :: Text -> HtmlM ()
+language_ = property "language"
+{-# INLINE language_ #-}
+
+scoped_ :: Text -> HtmlM ()
+scoped_ = property "scoped"
+{-# INLINE scoped_ #-}
+
+type_ :: Text -> HtmlM ()
+type_ = property "type"
+{-# INLINE type_ #-}
+
+name_ :: Text -> HtmlM ()
+name_ = property "name"
+{-# INLINE name_ #-}
+
+href_ :: Text -> HtmlM ()
+href_ = property "href"
+{-# INLINE href_ #-}
+
+id_ :: Text -> HtmlM ()
+id_ = property "id"
+{-# INLINE id_ #-}
+
+placeholder_ :: Text -> HtmlM ()
+placeholder_ = property "placeholder"
+{-# INLINE placeholder_ #-}
+
+checked_ :: Bool -> HtmlM ()
+checked_ = boolProperty "checked"
+{-# INLINE checked_ #-}
+
+autofocus_ :: Bool -> HtmlM ()
+autofocus_ = boolProperty "autofocus"
+{-# INLINE autofocus_ #-}
+
+class_ :: Text -> HtmlM ()
+class_ = property "className"
+{-# INLINE class_ #-}
+
+data_ :: Text -> Text -> HtmlM ()
+data_ k v = property ("data-" <> k) v
+{-# INLINE data_ #-}
+
+role_ :: Text -> HtmlM ()
+role_ = attribute "role"
+{-# INLINE role_ #-}
+
+style_ :: Text -> HtmlM ()
+style_ = property "style"
+{-# INLINE style_ #-}
diff --git a/src/Clickable/Types.hs b/src/Clickable/Types.hs
new file mode 100644
index 0000000..91897a5
--- /dev/null
+++ b/src/Clickable/Types.hs
@@ -0,0 +1,64 @@
+module Clickable.Types where
+
+import Control.Monad
+import Control.Monad.Reader
+import Control.Monad.State
+import Data.IORef
+import Data.List qualified as List
+import Data.Text (Text)
+import Data.Tuple
+import Data.Map (Map)
+import Data.Map qualified as Map
+import GHC.Generics
+import GHC.Exts hiding (build)
+import Unsafe.Coerce
+
+import Clickable.FFI
+import Wasm.Compat.Prim
+
+data DynVar a where
+ DynVar :: SourceId -> IORef a -> DynVar a
+
+data DynVal a where
+ ConstVal :: a -> DynVal a
+ FromVar :: DynVar a -> DynVal a
+ MapVal :: DynVal a -> (a -> b) -> DynVal b
+ SplatVal :: DynVal (a -> b) -> DynVal a -> DynVal b
+
+instance Functor DynVal where fmap = flip MapVal
+
+instance Applicative DynVal where pure = ConstVal; (<*>) = SplatVal
+
+fromVar :: DynVar a -> DynVal a
+fromVar = FromVar
+
+newtype ResourceScope = ResourceScope {unResourceScope :: Int}
+ deriving newtype (Eq, Ord, Show)
+
+newtype SourceId = SourceId {unSourceId :: Int}
+ deriving newtype (Eq, Ord, Show)
+
+newtype HtmlM a = HtmlM { unHtmlM :: ReaderT JSVal ClickM a }
+ deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader JSVal)
+
+newtype ClickM a = ClickM {unClickM :: ReaderT InternalEnv IO a }
+ deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader InternalEnv)
+
+instance MonadState InternalState ClickM where
+ state f = ClickM $ ReaderT $ \e -> atomicModifyIORef' e.internal_state_ref $ swap . f
+
+data InternalEnv = InternalEnv
+ { scope :: ResourceScope
+ , internal_state_ref :: IORef InternalState
+ } deriving (Generic)
+
+data InternalState = InternalState
+ { subscriptions :: [(ResourceScope, SourceId, Any -> ClickM ())]
+ , finalizers :: [(ResourceScope, FinalizerVal)]
+ , transaction_queue :: Map SourceId (ClickM ())
+ , next_id :: Int
+ } deriving (Generic)
+
+data FinalizerVal
+ = CustomFinalizer (ClickM ())
+ | ScopeFinalizer ResourceScope
diff --git a/src/HtmlT.hs b/src/HtmlT.hs
deleted file mode 100644
index ebfb2c3..0000000
--- a/src/HtmlT.hs
+++ /dev/null
@@ -1,15 +0,0 @@
-
-module HtmlT (module X) where
-
-import HtmlT.Base as X
-import HtmlT.DOM as X
-import HtmlT.Element as X
-import HtmlT.Main as X
-import HtmlT.Property as X
-import HtmlT.Types as X
-
-import HtmlT.Event as X hiding
- ( unsafeSubscribe
- , unsafeTrigger
- , Lens'
- )
diff --git a/src/HtmlT/Base.hs b/src/HtmlT/Base.hs
deleted file mode 100644
index 55ad268..0000000
--- a/src/HtmlT/Base.hs
+++ /dev/null
@@ -1,364 +0,0 @@
-{-|
-Most essential public definions
--}
-module HtmlT.Base where
-
-import Control.Monad
-import Control.Monad.Reader
-import Control.Monad.Trans.Maybe
-import Data.Foldable
-import Data.IORef
-import Data.Map qualified as Map
-
-import HtmlT.DOM
-import HtmlT.Event
-import HtmlT.Internal
-import HtmlT.Types
-import JavaScript.Compat.Marshal
-import JavaScript.Compat.Prim
-import JavaScript.Compat.String (JSString(..))
-
--- | Create a DOM element with a given tag name and attach it to
--- 'html_current_element'. Attributes, properties and children nodes can
--- be added from inside the second argument
---
--- > el "div" do
--- > prop "className" "container"
--- > el "span" $ text "Lorem Ipsum"
-el :: JSString -> Html a -> Html a
-el tag child = do
- newRootEl <- liftIO (createElement tag)
- appendHtmlT newRootEl child
-
--- | Same as 'el' but allows to specify element's namespace
--- https://developer.mozilla.org/en-US/docs/Web/API/Document/createElementNS
---
--- > elns "http://www.w3.org/2000/svg" "svg" do
--- > prop "height" "210"
--- > prop "width" "400"
--- > elns "http://www.w3.org/2000/svg" "path" do
--- > prop "d" "M150 0 L75 200 L225 200 Z"
-elns :: JSString -> JSString -> Html a -> Html a
-elns ns tag child = do
- newRootEl <- liftIO (createElementNS ns tag)
- appendHtmlT newRootEl child
-
--- | Create a TextNode and attach it to 'html_current_element'
-text :: JSString -> Html ()
-text txt = do
- textNode <- liftIO (createTextNode txt)
- insertNode textNode
-
--- | Create a TextNode with dynamic content
-dynText :: Dynamic JSString -> Html ()
-dynText d = do
- txt <- readDyn d
- textNode <- liftIO (createTextNode txt)
- void $ subscribe (updates d) \new -> void $ liftIO do
- setTextValue textNode new
- insertNode textNode
-
--- | Assign a property to 'html_current_element'. Don't confuse
--- attributes and properties
--- https://stackoverflow.com/questions/6003819/what-is-the-difference-between-properties-and-attributes-in-html
-prop :: ToJSVal v => JSString -> v -> Html ()
-prop key val = do
- rootEl <- asks html_current_element
- v <- liftIO $ toJSVal val
- liftIO $ js_setProp (unDOMElement rootEl) key v
-
--- | Assign a property with dynamic content to the root element
-dynProp
- :: (ToJSVal v, FromJSVal v)
- => JSString
- -> Dynamic v
- -> Html ()
-dynProp jsKey dyn = do
- el <- asks html_current_element
- performDyn $ liftIO . setup el <$> dyn
- where
- setup el t = toJSVal t
- >>= js_setProp (unDOMElement el) jsKey
-
--- | Assign an attribute to the root element. Don't confuse attributes
--- and properties
--- https://stackoverflow.com/questions/6003819/what-is-the-difference-between-properties-and-attributes-in-html
-attr :: JSString -> JSString -> Html ()
-attr k v = do
- el <- asks html_current_element
- liftIO $ setAttribute el k v
-
--- | Assign an attribute with dynamic content to the root element
-dynAttr :: JSString -> Dynamic JSString -> Html ()
-dynAttr k d = do
- el <- asks html_current_element
- performDyn $ liftIO . setAttribute el k <$> d
-
--- | Attach listener to the root element. First agument is the name
--- of the DOM event to listen. Second is the callback that accepts the fired
--- DOM event object
---
--- > el "button" do
--- > on "click" \_event -> do
--- > liftIO $ putStrLn "Clicked!"
--- > text "Click here"
-on :: EventName -> (DOMEvent -> Step ()) -> Html ()
-on name k = do
- el <- asks html_current_element
- onGlobalEvent defaultListenerOpts (nodeFromElement el) name k
-
--- | Same as 'on' but ignores 'DOMEvent' inside the callback
-on_ :: EventName -> Step () -> Html ()
-on_ name = on name . const
-
--- | Same as 'on' but allows to specify 'ListenerOpts'
-onOptions :: EventName -> ListenerOpts -> (DOMEvent -> Step ()) -> Html ()
-onOptions name opts k = do
- el <- asks html_current_element
- onGlobalEvent opts (nodeFromElement el) name k
-
-decodeEvent :: (JSVal -> MaybeT Step a) -> (a -> Step ()) -> DOMEvent -> Step ()
-decodeEvent dec act (DOMEvent jsevent) =
- runMaybeT (dec jsevent) >>= maybe (pure ()) act
-
--- | Attach a listener to arbitrary target, not just the current root
--- element (usually that would be @window@, @document@ or @body@
--- objects)
-onGlobalEvent
- :: MonadReactive m
- => ListenerOpts
- -- ^ Specify whether to call @event.stopPropagation()@ and
- -- @event.preventDefault()@ on the fired event
- -> DOMNode
- -- ^ Event target
- -> EventName
- -- ^ Event name
- -> (DOMEvent -> Step ())
- -- ^ Callback that accepts reference to the DOM event
- -> m ()
-onGlobalEvent opts target name f = do
- ReactiveEnv{renv_finalizers} <- askReactiveEnv
- let
- event = Event \re cb -> liftIO do
- finalizerId <- nextQueueId re
- unlisten <- addEventListener opts target name $
- dynStep . cb . f
- modifyIORef' renv_finalizers $ Map.insert
- (FinalizerQueueId finalizerId) (CustomFinalizer unlisten)
- subscribe event id
-
--- | Assign CSS classes to the current root element. Compared to @prop
--- "className"@ can be used multiple times for the same root
---
--- > el "div" do
--- > classes "container row"
--- > classes "mt-1 mb-2"
--- classes :: JSString -> Html ()
--- classes cs = do
--- rootEl <- asks html_current_element
--- for_ (T.splitOn " " cs) $ liftIO . classListAdd rootEl
-
--- | Assign a single CSS class dynamically based on the value held by
--- the given Dynamic
---
--- > showRef <- newRef False
--- > el "div" do
--- > toggleClass "show" $ fromRef showRef
--- > el "button" do
--- > on_ "click" $ modifyRef showRef not
--- > text "Toggle visibility"
-toggleClass :: JSString -> Dynamic Bool -> Html ()
-toggleClass cs dyn = do
- rootEl <- asks html_current_element
- performDyn $ liftIO . setup rootEl cs <$> dyn
- where
- setup rootEl cs = \case
- True -> classListAdd rootEl cs
- False -> classListRemove rootEl cs
-
--- | Assign a boolean attribute dynamically based on the value held by
--- the given Dynamic
---
--- > hiddenRef <- newRef True
--- > el "div" do
--- > toggleAttr "hidden" $ fromRef hiddenRef
--- > el "button" do
--- > on_ "click" $ modifyRef hiddenRef not
--- > text "Toggle visibility"
-toggleAttr :: JSString -> Dynamic Bool -> Html ()
-toggleAttr att dyn = do
- rootEl <- asks html_current_element
- performDyn $ liftIO . setup rootEl att <$> dyn
- where
- setup rootEl name = \case
- True -> setAttribute rootEl name "on"
- False -> removeAttribute rootEl name
-
--- | Assign a CSS property to the root dynamically based on the value
--- held by the given Dynamic
---
--- > colorRef <- newRef True
--- > el "button" do
--- > dynStyle "background" $ bool "initial" "red" <$> fromRef colorRef
--- > on_ "click" $ modifyRef colorRef not
--- > text "Toggle background color"
-dynStyle :: JSString -> Dynamic JSString -> Html ()
-dynStyle cssProp dyn = do
- rootEl <- asks html_current_element
- performDyn $ liftIO . setup rootEl <$> dyn
- where
- setup el t = do
- styleVal <- getProp (unDOMElement el) "style"
- cssVal <- toJSVal t
- js_setProp styleVal cssProp cssVal
-
--- | Alias for @pure ()@, useful when some Html action is expected.
-blank :: Applicative m => m ()
-blank = pure ()
-
--- | Attach a dynamic list to the root. Convenient for displaying
--- small dynamic collections (<100 elements).
---
--- > listRef <- newRef ["One", "Two", "Three"]
--- > el "ul" do
--- > simpleList listRef \_idx elemRef -> do
--- > el "li" $ dynText $ fromRef elemRef
--- > el "button" do
--- > on_ "click" $ modifyRef listRef ("New Item":)
--- > text "Append new item"
-simpleList
- :: forall a. Dynamic [a]
- -- ^ Some dynamic data from the above scope
- -> (Int -> DynRef a -> Html ())
- -- ^ Function to build children widget. Accepts the index inside the
- -- collection and dynamic data for that particular element
- -> Html ()
-simpleList listDyn h = do
- boundary <- insertBoundary
- htmlEnv <- asks \h -> h {html_content_boundary = Just boundary}
- prevValue <- liftIO $ newIORef []
- elemEnvsRef <- liftIO $ newIORef ([] :: [ElemEnv a])
- let
- setup :: Int -> [a] -> [ElemEnv a] -> Step [ElemEnv a]
- setup idx new existing = case (existing, new) of
- ([], []) -> return []
- -- New list is longer, append new elements
- ([], x:xs) -> do
- finalizers <- liftIO $ newIORef Map.empty
- elementRef <- liftIO $ execReactiveT (html_reactive_env htmlEnv) $ newRef x
- boundary <- liftIO $ execHtmlT htmlEnv insertBoundary
- let
- elementEnv = htmlEnv
- { html_reactive_env = (html_reactive_env htmlEnv)
- { renv_finalizers = finalizers }
- , html_content_boundary = Just boundary
- }
- liftIO $ execHtmlT elementEnv $ h idx elementRef
- let newElem = ElemEnv elementEnv elementRef
- fmap (newElem:) $ setup (idx + 1) xs []
- -- New list is shorter, delete the elements that no longer
- -- present in the new list
- (r:rs, []) -> do
- liftIO $ finalizeElems True (r:rs)
- return []
- -- Update child elements along the way
- (r:rs, y:ys) -> do
- writeRef (ee_dyn_ref r) y
- fmap (r:) $ setup (idx + 1) ys rs
- finalizeElems remove = traverse_ \ElemEnv{ee_html_env} -> do
- when remove $
- mapM_ removeBoundary $ html_content_boundary ee_html_env
- let re = html_reactive_env ee_html_env
- finalizers <- readIORef $ renv_finalizers re
- applyFinalizer re finalizers
- updateList new = do
- old <- liftIO $ atomicModifyIORef' prevValue (new,)
- eenvs <- liftIO $ readIORef elemEnvsRef
- newEenvs <- setup 0 new eenvs
- liftIO $ writeIORef elemEnvsRef newEenvs
- performDyn $ updateList <$> listDyn
- void $ installFinalizer $ readIORef elemEnvsRef >>= finalizeElems False
-
--- | First build a DOM with the widget that is currently held by the
--- given Dynamic, then rebuild it every time Dynamic's value
--- changes. Useful for SPA routing, tabbed components etc.
---
--- > routeRef <- newRef Home
--- > el "div" do
--- > dyn $ routeRef <&> \case
--- > Home -> homeWidget
--- > Blog -> blogWidget
--- > Resume -> resumeWidget
--- > el "button" do
--- > on_ "click" $ writeRef routeRef Blog
--- > text "Show my blog page"
-dyn :: Dynamic (Html ()) -> Html ()
-dyn d = do
- htmlEnv <- ask
- childRef <- liftIO (newIORef Nothing)
- boundary <- insertBoundary
- let
- finalizeEnv newEnv = do
- readIORef childRef >>= \case
- Just HtmlEnv{html_reactive_env} -> do
- finalizers <- atomicModifyIORef' (renv_finalizers html_reactive_env) (Map.empty,)
- applyFinalizer html_reactive_env finalizers
- Nothing -> return ()
- writeIORef childRef newEnv
- setup html = liftIO do
- finalizers <- newIORef Map.empty
- let
- newEnv = htmlEnv
- { html_reactive_env = (html_reactive_env htmlEnv)
- { renv_finalizers = finalizers }
- , html_content_boundary = Just boundary
- }
- finalizeEnv (Just newEnv)
- clearBoundary boundary
- execHtmlT newEnv html
- installFinalizer (finalizeEnv Nothing)
- performDyn $ setup <$> d
-
--- | Run an action before the current node is detached from the DOM
-installFinalizer :: MonadReactive m => IO () -> m FinalizerKey
-installFinalizer fin = do
- renv <- askReactiveEnv
- finalizerId <- liftIO $ nextQueueId renv
- let finalizerKey = FinalizerQueueId finalizerId
- liftIO $ modifyIORef renv.renv_finalizers $
- Map.insert finalizerKey $ CustomFinalizer fin
- return finalizerKey
-
--- | Attach resulting DOM to the given node instead of
--- 'html_current_element'. Might be useful for implementing modal
--- dialogs, tooltips etc. Similar to what called portals in React
--- ecosystem
-portal :: MonadIO m => DOMElement -> HtmlT m a -> HtmlT m a
-portal newRootEl html = do
- boundary <- local (\e -> e
- { html_current_element = newRootEl
- , html_content_boundary = Nothing
- }) insertBoundary
- result <- local (\e -> e
- { html_current_element = newRootEl
- , html_content_boundary = Just boundary
- }) html
- installFinalizer $ removeBoundary boundary
- return result
-
--- | Parse given text as HTML and attach the resulting tree to
--- 'html_current_element'. This way you can create not only HTML but
--- anything that @innerHTML@ property can create (e.g. SVG)
---
--- > -- Create a div with an SVG image inside that shows a black
--- > -- circle
--- > div_ [] do
--- > unsafeHtml "\
--- > \ "
-unsafeHtml :: MonadIO m => JSString -> HtmlT m ()
-unsafeHtml htmlText = do
- henv <- ask
- let anchor = fmap boundary_end henv.html_content_boundary
- liftIO $ unsafeInsertHtml henv.html_current_element anchor
- htmlText
diff --git a/src/HtmlT/DOM.hs b/src/HtmlT/DOM.hs
deleted file mode 100644
index e48af94..0000000
--- a/src/HtmlT/DOM.hs
+++ /dev/null
@@ -1,433 +0,0 @@
-{-|
-Functions and definitions to manipulate and query the DOM tree
--}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE ForeignFunctionInterface #-}
-{-# LANGUAGE JavaScriptFFI #-}
-module HtmlT.DOM where
-
-import Control.Monad
-import Control.Monad.Reader
-import Control.Monad.Trans.Maybe
-import Data.Coerce
-import GHC.Exts as Exts
-import GHC.Generics
-import Unsafe.Coerce
-
-import HtmlT.Types
-import JavaScript.Compat.Foreign.Callback
-import JavaScript.Compat.Marshal
-import JavaScript.Compat.Prim
-import JavaScript.Compat.String (JSString)
-import JavaScript.Compat.String qualified as JSS
-
-data ListenerOpts = ListenerOpts
- { lo_stop_propagation :: Bool
- -- ^ If true call @event.stopPropagation()@
- , lo_prevent_default :: Bool
- -- ^ If true call @event.preventDefault()@
- , lo_sync_callback :: Bool
- -- ^ If true create callback with @syncCallback1 ThrowWouldBlock@
- -- otherwise — @asyncCallback1@ this is relevant for example when
- -- listening to @BeforeUnloadEvent@
- -- https://developer.mozilla.org/en-US/docs/Web/API/BeforeUnloadEvent
- } deriving stock (Generic)
-
-defaultListenerOpts :: ListenerOpts
-defaultListenerOpts = ListenerOpts False False False
-
--- | Get global Window object @window@
--- https://developer.mozilla.org/en-US/docs/Web/API/Window
-getCurrentWindow :: MonadIO m => m JSVal
-getCurrentWindow = liftIO js_getCurrentWindow
-
--- | Get global Document object
--- https://developer.mozilla.org/en-US/docs/Web/API/Document
-getCurrentDocument :: MonadIO m => m JSVal
-getCurrentDocument = liftIO js_getCurrentDocument
-
--- | Get Document.body property
--- https://developer.mozilla.org/en-US/docs/Web/API/Document/body
-getCurrentBody :: MonadIO m => m DOMElement
-getCurrentBody = liftIO $ fmap DOMElement js_getCurrentBody
-
--- | DOMElement.appendChild()
--- https://developer.mozilla.org/en-US/docs/Web/API/DOMNode/appendChild
-appendChild :: DOMElement -> DOMNode -> IO ()
-appendChild = js_appendChild
-
--- | Element.setAttribute()
--- https://developer.mozilla.org/en-US/docs/Web/API/Element/setAttribute
-setAttribute :: DOMElement -> JSString -> JSString -> IO ()
-setAttribute e k v = js_setAttribute e k v
-
--- | Element.removeAttribute()
--- https://developer.mozilla.org/en-US/docs/Web/API/Element/removeAttribute
-removeAttribute :: DOMElement -> JSString -> IO ()
-removeAttribute e k = js_removeAttribute e k
-
--- | DOMNode.removeChild()
--- https://developer.mozilla.org/en-US/docs/Web/API/DOMNode/removeChild
-removeChild :: DOMElement -> DOMNode -> IO ()
-removeChild = js_removeChild
-
--- | Document.createElement()
--- https://developer.mozilla.org/en-US/docs/Web/API/Document/createElement
-createElement :: JSString -> IO DOMElement
-createElement = js_createElement
-
--- | Document.createElementNS()
--- https://developer.mozilla.org/en-US/docs/Web/API/Document/createElementNS
-createElementNS :: JSString -> JSString -> IO DOMElement
-createElementNS n t = js_createElementNS n t
-
--- | Document.createTextNode()
--- https://developer.mozilla.org/en-US/docs/Web/API/Document/createTextNode
-createTextNode :: JSString -> IO DOMNode
-createTextNode = js_createTextNode
-
--- | Document.createComment()
--- https://developer.mozilla.org/en-US/docs/Web/API/Document/createComment
-createComment :: JSString -> IO DOMNode
-createComment = js_createComment
-
--- | Element.classList.add()
--- https://developer.mozilla.org/en-US/docs/Web/API/Element/classList
-classListAdd :: DOMElement -> JSString -> IO ()
-classListAdd e c = js_classListAdd e c
-
--- | Element.classList.remove()
--- https://developer.mozilla.org/en-US/docs/Web/API/Element/classList
-classListRemove :: DOMElement -> JSString -> IO ()
-classListRemove e c = js_classListRemove e c
-
--- | Assign text to DOMNode.nodeValue
--- https://developer.mozilla.org/en-US/docs/Web/API/DOMNode/nodeValue
-setTextValue :: DOMNode -> JSString -> IO ()
-setTextValue v = js_setTextValue v
-
--- | Insert raw HTML code, similar to @parent.innerHTML = rawHtml@ but
--- does not removes siblings
-unsafeInsertHtml :: DOMElement -> Maybe DOMNode -> JSString -> IO ()
-unsafeInsertHtml parent manchor rawHtml = js_unsafeInsertHtml parent
- (maybeToNullable manchor) rawHtml
-
--- | Assuming given 'ContentBoundary' was inserted into the @parent@
--- element remove all the content inside the boundary.
-clearBoundary :: ContentBoundary -> IO ()
-clearBoundary ContentBoundary{..} =
- js_clearBoundary boundary_begin boundary_end
-
--- | Detach 'ContentBoundary' from the DOM and everything inside the
--- boundary.
-removeBoundary :: ContentBoundary -> IO ()
-removeBoundary ContentBoundary{..} = do
- js_clearBoundary boundary_begin boundary_end
- js_detachBoundary boundary_begin boundary_end
-
--- | Run a given callback on BeforeUnloadEvent
--- https://developer.mozilla.org/en-US/docs/Web/API/BeforeUnloadEvent
-onBeforeUnload :: IO () -> IO ()
-onBeforeUnload cb = do
- syncCb <- syncCallback ThrowWouldBlock cb
- js_onBeforeUnload syncCb
-
--- | EventTarget.addEventListener()
--- https://developer.mozilla.org/en-US/docs/Web/API/EventTarget/addEventListener
-addEventListener
- :: ListenerOpts
- -> DOMNode
- -> EventName
- -> (DOMEvent -> IO ())
- -> IO (IO ())
-addEventListener ListenerOpts{..} target name f = do
- hscb <- mkcallback (f . DOMEvent)
- jscb <- withopts hscb
- js_callMethod2 (coerce target) "addEventListener"
- (JSS.toJSValPure (unEventName name)) (unsafeCoerce jscb)
- return do
- js_callMethod2 (coerce target) "removeEventListener"
- (JSS.toJSValPure (unEventName name)) (unsafeCoerce jscb)
- releaseCallback hscb
- where
- mkcallback = if lo_sync_callback
- then syncCallback1 ThrowWouldBlock
- else asyncCallback1
- withopts = js_callbackWithOptions lo_stop_propagation lo_prevent_default
-
--- | Collection of deltaX, deltaY and deltaZ properties from WheelEvent
--- https://developer.mozilla.org/en-US/docs/Web/API/WheelEvent
-data MouseDelta = MouseDelta
- { md_delta_x :: Int
- , md_delta_y :: Int
- , md_delta_z :: Int
- } deriving stock (Eq, Show, Generic)
-
-mouseDeltaDecoder :: MonadIO m => JSVal -> MaybeT m MouseDelta
-mouseDeltaDecoder mouseEvent = do
- md_delta_x <- propDecoder "deltaX" mouseEvent
- md_delta_y <- propDecoder "deltaY" mouseEvent
- md_delta_z <- propDecoder "deltaZ" mouseEvent
- return MouseDelta {..}
-
--- | Pair of two values, might denote either a size or coordinates in
--- different contexts
-data Point a = Point
- { pt_x :: a
- , pt_y :: a
- } deriving stock (Eq, Show, Ord, Functor, Generic)
-
--- | Read clientX and clientY properties from MouseEvent
--- https://developer.mozilla.org/en-US/docs/Web/API/MouseEvent
-clientXYDecoder :: MonadIO m => JSVal -> MaybeT m (Point Int)
-clientXYDecoder mouseEvent = do
- pt_x <- propDecoder "clientX" mouseEvent
- pt_y <- propDecoder "clientY" mouseEvent
- return Point {..}
-
--- | Read offsetX and offsetY properties from MouseEvent
--- https://developer.mozilla.org/en-US/docs/Web/API/MouseEvent
-offsetXYDecoder :: MonadIO m => JSVal -> MaybeT m (Point Int)
-offsetXYDecoder mouseEvent = do
- pt_x <- propDecoder "offsetX" mouseEvent
- pt_y <- propDecoder "offsetY" mouseEvent
- return Point {..}
-
--- | Read pageX and pageY properties from MouseEvent
--- https://developer.mozilla.org/en-US/docs/Web/API/MouseEvent
-pageXYDecoder :: MonadIO m => JSVal -> MaybeT m (Point Int)
-pageXYDecoder mouseEvent = do
- pt_x <- propDecoder "pageX" mouseEvent
- pt_y <- propDecoder "pageY" mouseEvent
- return Point {..}
-
--- | Collection of altKey, ctrlKey, metaKey and shiftKey properties
--- from KeyboardEvent
-data KeyModifiers = KeyModifiers
- { kmod_alt_key :: Bool
- , kmod_ctrl_key :: Bool
- , kmod_meta_key :: Bool
- , kmod_shift_key :: Bool
- } deriving stock (Eq, Show, Generic)
-
--- | Read altKey, ctrlKey, metaKey and shiftKey properties from
--- KeyboardEvent
--- https://developer.mozilla.org/en-US/docs/Web/API/KeyboardEvent
-keyModifiersDecoder :: MonadIO m => JSVal -> MaybeT m KeyModifiers
-keyModifiersDecoder keyEvent = do
- kmod_alt_key <- propDecoder "altKey" keyEvent
- kmod_ctrl_key <- propDecoder "ctrlKey" keyEvent
- kmod_meta_key <- propDecoder "metaKey" keyEvent
- kmod_shift_key <- propDecoder "shiftKey" keyEvent
- return KeyModifiers {..}
-
--- | Read keyCode properties from KeyboardEvent
--- https://developer.mozilla.org/en-US/docs/Web/API/KeyboardEvent/keyCode
-keyCodeDecoder :: MonadIO m => JSVal -> MaybeT m Int
-keyCodeDecoder = propDecoder "keyCode"
-
--- | Collection of some useful information from KeyboardEvent
-data KeyboardEvent = KeyboardEvent
- { ke_modifiers :: KeyModifiers
- , ke_key :: Maybe JSString
- , ke_key_code :: Int
- , ke_repeat :: Bool
- } deriving stock (Generic)
-
--- | Read information from KeyboardEvent
-keyboardEventDecoder :: MonadIO m => JSVal -> MaybeT m KeyboardEvent
-keyboardEventDecoder keyEvent = do
- ke_modifiers <- keyModifiersDecoder keyEvent
- ke_key <- propDecoder "key" keyEvent
- ke_key_code <- propDecoder "keyCode" keyEvent
- ke_repeat <- propDecoder "repeat" keyEvent
- return KeyboardEvent {..}
-
--- | Event.target.value
--- https://developer.mozilla.org/en-US/docs/Web/API/Event/target
--- https://developer.mozilla.org/en-US/docs/Web/HTML/Element/input#attr-value
-valueDecoder :: MonadIO m => JSVal -> MaybeT m JSString
-valueDecoder =
- propDecoder "target" >=> propDecoder "value"
-
--- | Event.target.checked
--- https://developer.mozilla.org/en-US/docs/Web/API/Event/target
--- https://developer.mozilla.org/en-US/docs/Web/HTML/Element/input/checkbox#checked
-checkedDecoder :: MonadIO m => JSVal -> MaybeT m Bool
-checkedDecoder =
- propDecoder "target" >=> propDecoder "checked"
-
-propDecoder :: (MonadIO m, FromJSVal v) => String -> JSVal -> MaybeT m v
-propDecoder k obj = do
- -- TODO: Make sure it is true that if this guard succeeds,
- -- Object.getProp will never throw an exception!
- guard $ not (isUndefined obj) && not (isNull obj)
- MaybeT $ liftIO $ fromJSVal =<<
- getProp obj k
-
-errorGhcjsOnly :: a
-errorGhcjsOnly = error "Only GHCJS is supported"
-
-#if !defined(javascript_HOST_ARCH)
-js_onBeforeUnload :: Callback a -> IO ()
-js_onBeforeUnload = errorGhcjsOnly
-
-js_appendChild :: DOMElement -> DOMNode -> IO () = errorGhcjsOnly
-js_insertBefore :: DOMElement -> DOMNode -> DOMNode -> IO () = errorGhcjsOnly
-js_clearBoundary :: DOMNode -> DOMNode -> IO () = errorGhcjsOnly
-js_detachBoundary :: DOMNode -> DOMNode -> IO () = errorGhcjsOnly
-js_setAttribute :: DOMElement -> JSString -> JSString -> IO () = errorGhcjsOnly
-js_removeAttribute :: DOMElement -> JSString -> IO () = errorGhcjsOnly
-js_removeChild :: DOMElement -> DOMNode -> IO () = errorGhcjsOnly
-js_replaceChild :: DOMElement -> DOMNode -> DOMNode -> IO () = errorGhcjsOnly
-js_createElement :: JSString -> IO DOMElement = errorGhcjsOnly
-js_createElementNS :: JSString -> JSString -> IO DOMElement = errorGhcjsOnly
-js_createTextNode :: JSString -> IO DOMNode = errorGhcjsOnly
-js_createComment :: JSString -> IO DOMNode = errorGhcjsOnly
-js_classListAdd :: DOMElement -> JSString -> IO () = errorGhcjsOnly
-js_classListRemove :: DOMElement -> JSString -> IO () = errorGhcjsOnly
-js_setTextValue :: DOMNode -> JSString -> IO () = errorGhcjsOnly
-js_getCurrentWindow :: IO JSVal = errorGhcjsOnly
-js_getCurrentDocument :: IO JSVal = errorGhcjsOnly
-js_getCurrentBody :: IO JSVal = errorGhcjsOnly
-js_unsafeInsertHtml :: DOMElement -> Nullable DOMNode -> JSString -> IO () = errorGhcjsOnly
-js_call0 :: JSVal -> IO JSVal = errorGhcjsOnly
-js_call1 :: JSVal -> JSVal -> IO JSVal = errorGhcjsOnly
-js_call2 :: JSVal -> JSVal -> JSVal -> IO JSVal = errorGhcjsOnly
-js_callMethod0 :: JSVal -> JSString -> IO JSVal = errorGhcjsOnly
-js_callMethod1 :: JSVal -> JSString -> JSVal -> IO JSVal = errorGhcjsOnly
-js_callMethod2 :: JSVal -> JSString -> JSVal -> JSVal -> IO JSVal = errorGhcjsOnly
-js_waitDocumentLoad :: IO () = errorGhcjsOnly
-js_callbackWithOptions :: Bool -> Bool -> Callback (JSVal -> IO ()) -> IO (Callback (JSVal -> IO ())) = errorGhcjsOnly
-js_setProp :: JSVal -> JSString -> JSVal -> IO () = errorGhcjsOnly
-#else
-foreign import javascript unsafe
- "(($1, $2) => $1.appendChild($2))"
- js_appendChild :: DOMElement -> DOMNode -> IO ()
-foreign import javascript unsafe
- "(($1, $2, $3) => $1.insertBefore($2, $3))"
- js_insertBefore :: DOMElement -> DOMNode -> DOMNode -> IO ()
-foreign import javascript unsafe
- "(($1, $2, $3) => $1.setAttribute($2, $3))"
- js_setAttribute :: DOMElement -> JSString -> JSString -> IO ()
-foreign import javascript unsafe
- "(($1, $2) => $1.removeAttribute($2))"
- js_removeAttribute :: DOMElement -> JSString -> IO ()
-foreign import javascript unsafe
- "(($1, $2) => $1.removeChild($2))"
- js_removeChild :: DOMElement -> DOMNode -> IO ()
-foreign import javascript unsafe
- "(($1, $2, $3) => $1.replaceChild($2, $3))"
- js_replaceChild :: DOMElement -> DOMNode -> DOMNode -> IO ()
-foreign import javascript unsafe
- "(($1) => document.createElement($1))"
- js_createElement :: JSString -> IO DOMElement
-foreign import javascript unsafe
- "(($1, $2) => document.createElementNS($1, $2))"
- js_createElementNS :: JSString -> JSString -> IO DOMElement
-foreign import javascript unsafe
- "(($1) => document.createTextNode($1))"
- js_createTextNode :: JSString -> IO DOMNode
-foreign import javascript unsafe
- "(($1) => document.createComment($1))"
- js_createComment :: JSString -> IO DOMNode
-foreign import javascript unsafe
- "(($1, $2) => $1.classList.add($2))"
- js_classListAdd :: DOMElement -> JSString -> IO ()
-foreign import javascript unsafe
- "(($1, $2) => $1.classList.remove($2))"
- js_classListRemove :: DOMElement -> JSString -> IO ()
-foreign import javascript unsafe
- "(($1, $2) => { $1.nodeValue = $2; })"
- js_setTextValue :: DOMNode -> JSString -> IO ()
-foreign import javascript unsafe
- "(($1) => window.addEventListener('beforeunload', $1))"
- js_onBeforeUnload :: Callback a -> IO ()
-foreign import javascript unsafe
- "(function(){ return window; })"
- js_getCurrentWindow :: IO JSVal
-foreign import javascript unsafe
- "(function(){ return window.document; })"
- js_getCurrentDocument :: IO JSVal
-foreign import javascript unsafe
- "(function(){ return window.document.body; })"
- js_getCurrentBody :: IO JSVal
-foreign import javascript unsafe
- "(function (begin, end) {\
- for (;;){\
- if (!end.previousSibling\
- || !end.previousSibling.parentNode\
- || end.previousSibling === begin\
- ) break;\
- end.previousSibling.parentNode.removeChild(end.previousSibling);\
- }\
- })"
- js_clearBoundary :: DOMNode -> DOMNode -> IO ()
-foreign import javascript unsafe
- "(function (begin, end) {\
- if (begin.parentNode) begin.parentNode.removeChild(begin);\
- if (end.parentNode) end.parentNode.removeChild(end);\
- })"
- js_detachBoundary :: DOMNode -> DOMNode -> IO ()
-foreign import javascript unsafe "(($1) => $1())"
- js_call0 :: JSVal -> IO JSVal
-foreign import javascript unsafe "(($1, $2) => $1($2))"
- js_call1 :: JSVal -> JSVal -> IO JSVal
-foreign import javascript unsafe "(($1, $2, $3) => $1($2, $3))"
- js_call2 :: JSVal -> JSVal -> JSVal -> IO JSVal
-foreign import javascript unsafe "(($1, $2) => $1[$2]())"
- js_callMethod0 :: JSVal -> JSString -> IO JSVal
-foreign import javascript unsafe "(($1, $2, $3) => $1[$2]($3))"
- js_callMethod1 :: JSVal -> JSString -> JSVal -> IO JSVal
-foreign import javascript unsafe "(($1, $2, $3, $4) => $1[$2]($3, $4))"
- js_callMethod2 :: JSVal -> JSString -> JSVal -> JSVal -> IO JSVal
-foreign import javascript unsafe
- "(function(el, anchor, htmlString){\
- var div = document.createElement('div');\
- div.innerHTML = htmlString;\
- var tempChilds = [];\
- for (var i = 0; i < div.childNodes.length; i++) {\
- tempChilds.push(div.childNodes[i]);\
- }\
- for (var j = 0; j < tempChilds.length; j++) {\
- div.removeChild(tempChilds[j]);\
- if (anchor) {\
- el.insertBefore(tempChilds[j], anchor);\
- } else{\
- el.appendChild(tempChilds[j]);\
- }\
- }\
- })"
- js_unsafeInsertHtml :: DOMElement -> Nullable DOMNode -> JSString -> IO ()
-foreign import javascript unsafe
- "(($1, $2, $3) => function(e) {\
- if ($1) e.stopPropagation();\
- if ($2) e.preventDefault();\
- return $3(e);\
- })"
- js_callbackWithOptions :: Bool -> Bool -> Callback (JSVal -> IO ()) -> IO (Callback (JSVal -> IO ()))
-foreign import javascript interruptible
- "if (document.readyState == 'loading') {\
- addEventListener('DOMContentLoaded', $c);\
- } else {\
- $c();\
- }"
- js_waitDocumentLoad :: IO ()
-foreign import javascript unsafe
- "(($1, $2, $3) => { $1[$2] = $3; })"
- js_setProp :: JSVal -> JSString -> JSVal -> IO ()
-foreign import javascript unsafe "(() => null)"
- js_null :: JSVal
-#endif
-
-instance (a ~ (), MonadIO m) => IsString (HtmlT m a) where
- fromString s = do
- HtmlEnv{html_current_element, html_content_boundary} <- ask
- let jsstr = toJSString s
- textNode <- liftIO $ createTextNode (JSS.fromJSValPure jsstr)
- case html_content_boundary of
- Just ContentBoundary{boundary_end} -> liftIO $
- js_insertBefore html_current_element textNode boundary_end
- Nothing -> liftIO $ appendChild html_current_element textNode
- {-# INLINE fromString #-}
diff --git a/src/HtmlT/Event.hs b/src/HtmlT/Event.hs
deleted file mode 100644
index 2d70fc9..0000000
--- a/src/HtmlT/Event.hs
+++ /dev/null
@@ -1,466 +0,0 @@
-{-|
-
-This module offers clear and straightforward implementation of FRP
-concepts such as Events and Dynamics, inspired by
-Reflex. Additionally, it introduces DynRefs, which are represented by
-a Dynamic along with a function to modify the value inside the
-Dynamic. DynRef has similar inferface to IORef with functions like
-readRef, writeRef, modifyRef etc.
--}
-module HtmlT.Event where
-
-import Control.Applicative
-import Control.Monad
-import Control.Monad.Catch
-import Control.Monad.Fix
-import Control.Monad.Reader
-import Control.Monad.State
-import Data.Foldable
-import Data.IORef
-import Data.Map (Map)
-import Data.Map qualified as Map
-import Data.Maybe
-import Data.Set (Set)
-import Data.Set qualified as Set
-import Data.Tuple
-import GHC.Exts
-import GHC.Fingerprint
-import GHC.Generics
-import Unsafe.Coerce
-
--- | Represents a stream of event occurrences of type @a@. Its actual
--- representation is simply a function that subscribes to the event
-newtype Event a = Event
- { unEvent :: ReactiveEnv -> Callback a -> IO ()
- }
-
--- | Contains a value that is subject to change over time. Provides
--- operations for reading the current value ('readDyn') and
--- subscribing to its future changes ('updates').
-data Dynamic a = Dynamic
- { dynamic_read :: IO a
- -- ^ Read current value. Use public alias 'readDyn' instead
- , dynamic_updates :: Event a
- -- ^ Event that fires when the value changes. Use public alias
- -- 'updates' instead
- } deriving stock Generic
-
--- | A mutable variable that allows for subscription to new values. It
--- shares a similar API to 'IORef' (see 'readRef', 'writeRef',
--- 'modifyRef')
-data DynRef a = DynRef
- { dynref_dynamic :: Dynamic a
- -- ^ Holds the current value and an event that notifies about value
- -- modifications
- , dynref_modifier :: Modifier a
- -- ^ Funtion to update the value
- } deriving stock Generic
-
--- | Function that updates the value inside the 'DynRef'
-newtype Modifier a = Modifier
- { unModifier :: forall r. Bool -> (a -> (a, r)) -> Step r
- -- ^ 'Bool' argument controls whether the modification should
- -- trigger an update event. It's possible to update the 'DynRef'
- -- without notifying the subscribers for optimization purposes, in
- -- cases when you know that all changes already been reflected in
- -- the DOM
- }
-
--- | State inside 'Step'
-newtype TransactState = TransactState
- { unTransactState :: Map QueueId (Step ())
- } deriving newtype (Semigroup, Monoid)
-
--- | Evaluation of effects triggered by an event firing
-newtype Step a = Step { unStep :: StateT TransactState IO a }
- deriving newtype
- ( Functor, Applicative, Monad, MonadIO, MonadState TransactState, MonadFix
- , MonadCatch, MonadThrow, MonadMask
- )
-
--- | Represents the environment necessary for "reactive" operations,
--- such as creating a new 'Event', subscribing to an event etc
-data ReactiveEnv = ReactiveEnv
- { renv_subscriptions :: IORef (Map QueueId [(QueueId, Callback Any)])
- -- ^ Keeps track of subscriptions
- , renv_finalizers :: IORef (Map FinalizerKey FinalizerValue)
- -- ^ Keeps track of finalizers. These finalizers will be activated
- -- shortly before the current part of the application is terminated.
- , renv_id_generator :: IORef QueueId
- -- ^ Maintains the next value to be used for generating 'QueueId'
- } deriving Generic
-
--- | Minimal implementation for 'HasReactiveEnv'
-newtype ReactiveT m a = ReactiveT
- { unReactiveT :: ReaderT ReactiveEnv m a
- } deriving newtype
- ( Functor, Applicative, Monad, MonadIO, MonadFix, MonadCatch, MonadThrow
- , MonadMask
- )
-
--- | Identifies a computation inside 'TransactState'. The integer
--- value within 'QueueId' dictates the execution order in a reactive
--- transaction (with higher values executing later). It is also
--- utilized to prioritize events derived from other events, ensuring
--- they are processed after the source events. This is basically the
--- mechanism that prevents double-firing of Dynamics constructed
--- using, for instance, the Applicative instance.
-newtype QueueId = QueueId {unQueueId :: Int}
- deriving newtype (Eq, Show, Ord, Num, Enum, Bounded)
-
-data FinalizerKey
- = FinalizerEventId QueueId
- | FinalizerQueueId QueueId
- | FinalizerFingerprintId Fingerprint
- deriving (Eq, Ord, Generic)
-
-data FinalizerValue
- = SubscriptionSet (Set QueueId)
- | CustomFinalizer (IO ())
- deriving Generic
-
-class HasReactiveEnv m where askReactiveEnv :: m ReactiveEnv
-
-type MonadReactive m = (HasReactiveEnv m, MonadIO m)
-
-type Lens' s a = forall f. Functor f => (a -> f a) -> s -> f s
-
-type Callback a = a -> Step ()
-
-type Trigger a = a -> Step ()
-
--- | Create new empty 'ReactiveEnv'
-newReactiveEnv :: MonadIO m => m ReactiveEnv
-newReactiveEnv = liftIO do
- renv_finalizers <- newIORef Map.empty
- renv_subscriptions <- newIORef Map.empty
- renv_id_generator <- newIORef $ QueueId 0
- return ReactiveEnv {..}
-
--- | Create new event and a function to supply values to that event
---
--- > (event, push) <- newEvent @String
--- > push "New Value" -- event fires with given value
-newEvent :: forall a m. MonadReactive m => m (Event a, Trigger a)
-newEvent = do
- renv <- askReactiveEnv
- eventId <- liftIO (nextQueueId renv)
- let event = Event $ unsafeSubscribe eventId
- return (event, unsafeTrigger eventId renv)
-
--- | Create a new 'DynRef' using given initial value
---
--- > showRef <- newRef False
--- > dynStep $ writeRef showRef True -- this triggers update event for showRef
-newRef :: forall a m. MonadReactive m => a -> m (DynRef a)
-newRef initial = do
- ref <- liftIO $ newIORef initial
- (event, push) <- newEvent
- let
- modify = Modifier \u f -> do
- (new, result) <- liftIO $ atomicModifyIORef' ref \old ->
- let (new, result) = f old in
- (new, (new, result))
- when u $ push new
- return result
- dynamic = Dynamic (readIORef ref) event
- return $ DynRef dynamic modify
-
--- | Create a Dynamic that never changes its value
-constDyn :: a -> Dynamic a
-constDyn a = Dynamic (pure a) never
-
--- | Event that will never fire
-never :: Event a
-never = Event \_ _ -> return ()
-
--- | Write new value into a 'DynRef'
---
--- > ref <- newRef "Initial value"
--- > transactionWrite ref "New value"
--- > readRef ref
--- "New value"
-writeRef :: DynRef a -> a -> Step ()
-writeRef ref a = modifyRef ref (const a)
-
--- | Read the current value held by given 'DynRef'
---
--- > ref <- newRef "Hello there!"
--- > readRef ref
--- "Hello there!"
-readRef :: MonadIO m => DynRef a -> m a
-readRef = readDyn . dynref_dynamic
-
--- | Update a 'DynRef' by applying given function to the current value
---
--- > ref <- newRef [1..3]
--- > modifyRef ref $ fmap (*2)
--- [2, 4, 6]
-modifyRef :: DynRef a -> (a -> a) -> Step ()
-modifyRef (DynRef _ (Modifier mod)) f = mod True $ (,()) . f
-
--- | Update a 'DynRef' with first field of the tuple and return back
--- the second field. The name is intended to be similar to
--- 'atomicModifyIORef' but there are no atomicity guarantees
--- whatsoever
-atomicModifyRef :: DynRef a -> (a -> (a, r)) -> Step r
-atomicModifyRef (DynRef _ (Modifier mod)) f = mod True f
-
--- | Extract a 'Dynamic' out of 'DynRef'
-fromRef :: DynRef a -> Dynamic a
-fromRef = dynref_dynamic
-
--- | Read the value held by a 'Dynamic'
-readDyn :: MonadIO m => Dynamic a -> m a
-readDyn = liftIO . dynamic_read
-
--- | Extract the updates Event from a 'Dynamic'
-updates :: Dynamic a -> Event a
-updates = dynamic_updates
-
--- | Attach a listener to the event and return an action to detach the
--- listener
-subscribe :: MonadReactive m => Event a -> Callback a -> m ()
-subscribe (Event s) k = do
- re <- askReactiveEnv
- liftIO $ s re k
-
--- | Executes an action currently held inside the 'Dynamic' and every
--- time the value changes.
-performDyn :: MonadReactive m => Dynamic (Step ()) -> m ()
-performDyn d = do
- liftIO $ dynamic_read d >>= dynStep
- subscribe (dynamic_updates d) id
-
--- | Apply a lens to the value inside 'DynRef'
-lensMap :: forall s a. Lens' s a -> DynRef s -> DynRef a
-lensMap l (DynRef sdyn (Modifier smod)) =
- DynRef adyn (Modifier amod)
- where
- adyn = Dynamic
- (fmap (getConst . l Const) $ dynamic_read sdyn)
- (fmap (getConst . l Const) $ dynamic_updates sdyn)
- amod :: forall r. Bool -> (a -> (a, r)) -> Step r
- amod u f = smod u $ swap . l (swap . f)
-
--- | Return a 'Dynamic' for which updates only fire when the value
--- actually changes according to Eq instance
-holdUniqDyn :: Eq a => Dynamic a -> Dynamic a
-holdUniqDyn = holdUniqDynBy (==)
-{-# INLINE holdUniqDyn #-}
-
--- | Same as 'holdUniqDyn' but accepts arbitrary equality test
--- function
-holdUniqDynBy :: (a -> a -> Bool) -> Dynamic a -> Dynamic a
-holdUniqDynBy equalFn Dynamic{..} = Dynamic dynamic_read
- (Event \e k -> do
- old <- liftIO dynamic_read
- oldRef <- liftIO (newIORef old)
- unEvent dynamic_updates e \new -> do
- old <- liftIO $ atomicModifyIORef' oldRef (new,)
- unless (old `equalFn` new) $ k new
- )
-
--- | Execute the gives finalizers
-applyFinalizer :: ReactiveEnv -> Map FinalizerKey FinalizerValue -> IO ()
-applyFinalizer ReactiveEnv{renv_subscriptions} finalizers = do
- forM_ (Map.toList finalizers) \(k, v) -> case (k, v) of
- (FinalizerEventId e, SubscriptionSet s) ->
- modifyIORef' renv_subscriptions $
- flip Map.alter e $ mfilter (not . Prelude.null) . Just . deleteSubs s . fromMaybe []
- (_, CustomFinalizer io) ->
- io
- (_, _) ->
- return ()
- where
- deleteSubs _ss [] = []
- deleteSubs ss ((s, c):xs)
- | Set.member s ss = xs
- | otherwise = (s, c) : deleteSubs ss xs
-
--- | Alternative version if 'fmap' where given function will only be
--- called once every time 'Dynamic a' value changes, whereas in 'fmap'
--- it would be called once for each subscription per change event. As
--- a general guideline, if the function @f! is inexpensive, choose
--- @fmap f@. Otherwise, consider using @mapDyn f@.
-mapDyn
- :: MonadReactive m
- => (a -> b)
- -> Dynamic a
- -> m (Dynamic b)
-mapDyn fun adyn = do
- initialA <- liftIO $ dynamic_read adyn
- latestA <- liftIO $ newIORef initialA
- latestB <- liftIO $ newIORef (fun initialA)
- renv <- askReactiveEnv
- eventId <- liftIO (nextQueueId renv)
- let
- updates = Event $ unsafeSubscribe eventId
- fire = defer eventId do
- newB <- liftIO $ fun <$> readIORef latestA
- liftIO $ writeIORef latestB newB
- unsafeTrigger eventId renv newB
- dynamic_updates adyn `subscribe` \newA -> do
- liftIO $ writeIORef latestA newA
- defer eventId fire
- return $ Dynamic (readIORef latestB) updates
-
--- | Works same way as 'mapDyn' but applies to two dynamics
-mapDyn2
- :: MonadReactive m
- => (a -> b -> c)
- -> Dynamic a
- -> Dynamic b
- -> m (Dynamic c)
-mapDyn2 f adyn bdyn = do
- unsafeMapDynN g [unsafeCoerce adyn, unsafeCoerce bdyn]
- where
- g [a, b] = return $ f (unsafeCoerce a) (unsafeCoerce b)
- g _ = error "mapDyn2: impossible happend!"
-
--- | I hope three arguments will be enough for most cases if more
--- needed it's easy to define this function in the application code
--- with any required arity
-mapDyn3
- :: MonadReactive m
- => (a -> b -> c -> d)
- -> Dynamic a
- -> Dynamic b
- -> Dynamic c
- -> m (Dynamic d)
-mapDyn3 f adyn bdyn cdyn = do
- unsafeMapDynN g
- [unsafeCoerce adyn, unsafeCoerce bdyn, unsafeCoerce cdyn]
- where
- g [a, b, c] = return $ f (unsafeCoerce a) (unsafeCoerce b) (unsafeCoerce c)
- g _ = error "mapDyn3: impossible happend!"
-
--- | Takes a list of Dynamics and a function to generate the
--- output. The positions of elements in the list of [Any] received by
--- the function always correspond to the positions of [Dynamic Any]
--- from which these values were generated. The Dynamic created by this
--- function will fire at most once per transaction, and only if any of
--- the input Dynamics change their values.
-unsafeMapDynN
- :: MonadReactive m
- => ([Any] -> IO a)
- -- ^ Construct the output value, from list of input values from
- -- corresponding positions of given Dynamics
- -> [Dynamic Any]
- -- ^ List of input Dynamics
- -> m (Dynamic a)
-unsafeMapDynN fun dyns = do
- renv <- askReactiveEnv
- -- TODO: Try if list of IORefs is better than IORef of list
- initialInputs <- liftIO $ mapM dynamic_read dyns
- initialOutput <- liftIO $ fun initialInputs
- latestInputsRef <- liftIO $ newIORef initialInputs
- latestOutputRef <- liftIO $ newIORef initialOutput
- eventId <- liftIO (nextQueueId renv)
- let
- fire = defer eventId do
- newOutput <- liftIO $ fun =<< readIORef latestInputsRef
- liftIO $ writeIORef latestOutputRef newOutput
- unsafeTrigger eventId renv newOutput
- updates = Event $ unsafeSubscribe eventId
- updateList _ _ [] = []
- updateList 0 a (_:xs) = a:xs
- updateList n a (x:xs) = x : updateList (pred n) a xs
- forM_ (zip [0..] dyns) \(i::Int, adyn) -> do
- dynamic_updates adyn `subscribe` \newVal -> do
- liftIO $ modifyIORef latestInputsRef $ updateList i newVal
- defer eventId fire
- return $ Dynamic (readIORef latestOutputRef) updates
-
--- | Read and increment 'renv_id_generator'
-nextQueueId :: ReactiveEnv -> IO QueueId
-nextQueueId ReactiveEnv{renv_id_generator} =
- atomicModifyIORef' renv_id_generator \eid -> (succ eid, eid)
-
--- | Defers a computation (typically an event firing) until the end of
--- the current reactive transaction. This allows for the avoidance of
--- double firing of events constructed from multiple other events.
-defer :: QueueId -> Step () -> Step ()
-defer k act =
- Step $ modify \(TransactState s) -> TransactState (Map.insert k act s)
-
--- | Run a reactive transaction.
-dynStep :: MonadIO m => Step a -> m a
-dynStep act = liftIO $ loop (TransactState Map.empty) act where
- loop :: TransactState -> Step a -> IO a
- loop rs (Step act) = do
- (r, newRs) <- runStateT act rs
- case popQueue newRs of
- (Just newAct, newerRs) -> r <$ loop newerRs newAct
- (Nothing, _newerRs) -> return r
- popQueue intact@(TransactState m) = case Map.minViewWithKey m of
- Just ((_, act), rest) -> (Just act, TransactState rest)
- Nothing -> (Nothing, intact)
-
-runReactiveT :: ReactiveT m a -> ReactiveEnv -> m a
-runReactiveT r = runReaderT (unReactiveT r)
-
-execReactiveT :: ReactiveEnv -> ReactiveT m a -> m a
-execReactiveT = flip runReactiveT
-
-unsafeSubscribe :: QueueId -> ReactiveEnv -> Callback a -> IO ()
-unsafeSubscribe eventId e@ReactiveEnv{renv_subscriptions, renv_finalizers} k = do
- subsId <- nextQueueId e
- let
- newCancel = (subsId, k . unsafeCoerce)
- f (SubscriptionSet s1) (SubscriptionSet s2) = SubscriptionSet (s1 <> s2)
- -- Unreacheable because FinalizerEventId always should map into
- -- SubscriptionSet
- f _ s = s
- modifyIORef' renv_subscriptions $
- flip Map.alter eventId $ Just . (newCancel :) . fromMaybe []
- modifyIORef' renv_finalizers $ Map.insertWith f (FinalizerEventId eventId)
- (SubscriptionSet (Set.singleton subsId))
-
-unsafeTrigger :: QueueId -> ReactiveEnv -> a -> Step ()
-unsafeTrigger eventId ReactiveEnv{..} a = defer eventId do
- subscriptions <- liftIO $ readIORef renv_subscriptions
- let callbacks = fromMaybe [] $ Map.lookup eventId subscriptions
- for_ callbacks $ ($ unsafeCoerce @_ @Any a) . snd
-
-instance Functor Event where
- fmap f (Event s) = Event \e k -> s e . (. f) $ k
-
--- | Please be aware that in cases where both events fire during the
--- same 'Step,' the one having a higher 'EventId' will win, which is
--- very hard to predict, use with caution.
-instance Semigroup a => Semigroup (Event a) where
- (<>) (Event e1) (Event e2) = Event \e k -> mdo
- e1 e (defer eventId . k)
- e2 e (defer eventId . k)
- eventId <- nextQueueId e
- return ()
-
-instance Semigroup a => Monoid (Event a) where
- mempty = never
-
-instance Functor Dynamic where
- fmap f (Dynamic s u) = Dynamic (fmap f s) (fmap f u)
-
-instance Applicative Dynamic where
- pure = constDyn
- (<*>) df da =
- let
- updatesEvent = Event \e k -> mdo
- let
- fire newF newA = defer eventId do
- f <- liftIO $ maybe (readDyn df) pure newF
- a <- liftIO $ maybe (readDyn da) pure newA
- k (f a)
- unEvent (updates df) e \f -> fire (Just f) Nothing
- unEvent (updates da) e \a -> fire Nothing (Just a)
- eventId <- nextQueueId e
- return ()
- in
- Dynamic
- { dynamic_read = liftA2 ($) (dynamic_read df) (dynamic_read da)
- , dynamic_updates = updatesEvent
- }
-
-instance Applicative m => HasReactiveEnv (ReactiveT m) where
- askReactiveEnv = ReactiveT $ ReaderT pure
diff --git a/src/HtmlT/Internal.hs b/src/HtmlT/Internal.hs
deleted file mode 100644
index 5bbde7e..0000000
--- a/src/HtmlT/Internal.hs
+++ /dev/null
@@ -1,43 +0,0 @@
-module HtmlT.Internal where
-
-import Control.Monad.Reader
-import GHC.Generics
-
-import HtmlT.Event
-import HtmlT.Types
-import HtmlT.DOM
-
--- | Auxiliary type helps to implement 'simpleList'
-data ElemEnv a = ElemEnv
- { ee_html_env :: HtmlEnv
- , ee_dyn_ref :: DynRef a
- } deriving Generic
-
--- | Insert given node to @html_current_element@ and run action with
--- inserted node as a new root
-appendHtmlT :: MonadIO m => DOMElement -> HtmlT m a -> HtmlT m a
-appendHtmlT newRootEl html = do
- result <- local (\env -> env
- { html_current_element = newRootEl
- , html_content_boundary = Nothing }) html
- result <$ insertNode (nodeFromElement newRootEl)
-
--- | Insert new node to the end of current boundary
-insertNode :: MonadIO m => DOMNode -> HtmlT m ()
-insertNode n = do
- rootEl <- asks html_current_element
- boundary <- asks html_content_boundary
- case boundary of
- Just ContentBoundary{..} -> liftIO $
- js_insertBefore rootEl n boundary_end
- Nothing -> liftIO $ appendChild rootEl n
-
--- | Insert two DOM Comment nodes intended to be used as a boundary for
--- dynamic content.
-insertBoundary :: MonadIO m => HtmlT m ContentBoundary
-insertBoundary = do
- boundary_begin <- liftIO $ createComment "ContentBoundary {{"
- boundary_end <- liftIO $ createComment "}}"
- insertNode boundary_begin
- insertNode boundary_end
- return ContentBoundary{..}
diff --git a/src/HtmlT/Main.hs b/src/HtmlT/Main.hs
deleted file mode 100644
index 2a00634..0000000
--- a/src/HtmlT/Main.hs
+++ /dev/null
@@ -1,78 +0,0 @@
--- | Start and stop browser application
-module HtmlT.Main where
-
-import Control.Monad
-import Data.IORef
-import GHC.Generics
-
-import HtmlT.DOM
-import HtmlT.Event
-import HtmlT.Types
-
-data StartOpts = StartOpts
- { startopts_reactive_env :: ReactiveEnv
- -- ^ Typically the program should only have one instance of
- -- 'ReactiveEnv', so when there are multiple running 'HtmlT'
- -- applications, use this field to share existing 'ReactiveEnv'
- -- between all of them
- , startopts_root_element :: DOMElement
- -- ^ HTMLElement where to attach the elements created by the
- -- application
- , startopts_wait_document_load :: Bool
- -- ^ If True block IO action until main document is fully loaded
- , startopts_unload_call_finalizers :: Bool
- -- ^ If True run finalizers on @beforeunload@ event. This happens
- -- just before browser tab is closed, the code in finalizers should
- -- only consist of non-blocking IO
- } deriving Generic
-
--- | Needed to manually finalize and detach the application
-data RunningApp = RunningApp
- { runapp_html_env :: HtmlEnv
- , runapp_boundary :: ContentBoundary
- } deriving Generic
-
--- | Start 'HtmlT' application applying customizations described by
--- StartOpts argument
-attachOptions :: StartOpts -> Html a -> IO (a, RunningApp)
-attachOptions StartOpts{..} render = mdo
- -- TODO: doesn't work with javascript-backend
- -- when startopts_wait_document_load
- -- js_waitDocumentLoad
- begin <- createComment "ContentBoundary {{"
- end <- createComment "}}"
- appendChild startopts_root_element begin
- appendChild startopts_root_element end
- let
- boundary = ContentBoundary begin end
- htmlEnv = HtmlEnv
- { html_current_element = startopts_root_element
- , html_content_boundary = Just boundary
- , html_reactive_env = startopts_reactive_env
- }
- runApp = RunningApp htmlEnv boundary
- result <- execHtmlT htmlEnv render
- when startopts_unload_call_finalizers $ onBeforeUnload $ do
- finalizers <- readIORef $ renv_finalizers startopts_reactive_env
- applyFinalizer startopts_reactive_env finalizers
- return (result, runApp)
-
--- | Start the application and attach it to the given HTMLElement
-attachTo :: DOMElement -> Html a -> IO (a, RunningApp)
-attachTo rootEl html = do
- renv <- newReactiveEnv
- attachOptions (StartOpts renv rootEl True True) html
-
--- | Start the application and attach it to current element
-attachToBody :: Html a -> IO (a, RunningApp)
-attachToBody html = do
- bodyEl <- getCurrentBody
- attachTo bodyEl html
-
--- | Run finalizers and detach created elements from the DOM
-detach :: RunningApp -> IO ()
-detach RunningApp{..} = do
- finalizers <- readIORef . renv_finalizers . html_reactive_env $
- runapp_html_env
- applyFinalizer (html_reactive_env runapp_html_env) finalizers
- removeBoundary runapp_boundary
diff --git a/src/HtmlT/Property.hs b/src/HtmlT/Property.hs
deleted file mode 100644
index 67860e5..0000000
--- a/src/HtmlT/Property.hs
+++ /dev/null
@@ -1,367 +0,0 @@
-{-|
-Shortcuts for common HTML5 attributes and properties
--}
-module HtmlT.Property where
-
-import HtmlT.Base
-import HtmlT.Event
-import HtmlT.Types
-import JavaScript.Compat.String (JSString(..))
-
-
--- TODO: Real-world usage has demonstrated that 'dynStyles' not
--- sufficiently composable. For instance, if 'dynStyles' is used to
--- set the CSS color for an element, essentially no other CSS property
--- can be applied to this element, as they will be overwritten by
--- 'dynStyles'.
-dynStyles :: Dynamic JSString -> Html ()
-dynStyles = dynProp "style"
-{-# INLINE dynStyles #-}
-
-dynValue :: Dynamic JSString -> Html ()
-dynValue = dynProp "value"
-{-# INLINE dynValue #-}
-
-dynClass :: Dynamic JSString -> Html ()
-dynClass = dynProp "className"
-{-# INLINE dynClass #-}
-
-dynChecked :: Dynamic Bool -> Html ()
-dynChecked = dynProp "checked"
-{-# INLINE dynChecked #-}
-
-dynDisabled :: Dynamic Bool -> Html ()
-dynDisabled = dynProp "disabled"
-{-# INLINE dynDisabled #-}
-
-title_ :: JSString -> Html ()
-title_ = prop "title"
-{-# INLINE title_ #-}
-
-selected_ :: Bool -> Html ()
-selected_ = prop "selected"
-{-# INLINE selected_ #-}
-
-hidden_ :: Bool -> Html ()
-hidden_ = prop "hidden"
-{-# INLINE hidden_ #-}
-
-value_ :: JSString -> Html ()
-value_ = prop "value"
-{-# INLINE value_ #-}
-
-defaultValue_ :: JSString -> Html ()
-defaultValue_ = prop "defaultValue"
-{-# INLINE defaultValue_ #-}
-
-accept_ :: JSString -> Html ()
-accept_ = prop "accept"
-{-# INLINE accept_ #-}
-
-acceptCharset_ :: JSString -> Html ()
-acceptCharset_ = prop "acceptCharset"
-{-# INLINE acceptCharset_ #-}
-
-action_ :: JSString -> Html ()
-action_ = prop "action"
-{-# INLINE action_ #-}
-
-autocomplete_ :: Bool -> Html ()
-autocomplete_ b = prop @JSString "autocomplete" (if b then "on" else "off")
-{-# INLINE autocomplete_ #-}
-
-autosave_ :: JSString -> Html ()
-autosave_ = prop "autosave"
-{-# INLINE autosave_ #-}
-
-disabled_ :: Bool -> Html ()
-disabled_ = prop "disabled"
-{-# INLINE disabled_ #-}
-
-enctype_ :: JSString -> Html ()
-enctype_ = prop "enctype"
-{-# INLINE enctype_ #-}
-
-formation_ :: JSString -> Html ()
-formation_ = prop "formation"
-{-# INLINE formation_ #-}
-
-list_ :: JSString -> Html ()
-list_ = prop "list"
-{-# INLINE list_ #-}
-
-maxlength_ :: JSString -> Html ()
-maxlength_ = prop "maxlength"
-{-# INLINE maxlength_ #-}
-
-minlength_ :: JSString -> Html ()
-minlength_ = prop "minlength"
-{-# INLINE minlength_ #-}
-
-method_ :: JSString -> Html ()
-method_ = prop "method"
-{-# INLINE method_ #-}
-
-multiple_ :: Bool -> Html ()
-multiple_ = prop "multiple"
-{-# INLINE multiple_ #-}
-
-novalidate_ :: Bool -> Html ()
-novalidate_ = prop "noValidate"
-{-# INLINE novalidate_ #-}
-
-pattern_ :: JSString -> Html ()
-pattern_ = prop "pattern"
-{-# INLINE pattern_ #-}
-
-readonly_ :: Bool -> Html ()
-readonly_ = prop "readOnly"
-{-# INLINE readonly_ #-}
-
-required_ :: Bool -> Html ()
-required_ = prop "required"
-{-# INLINE required_ #-}
-
-size_ :: JSString -> Html ()
-size_ = prop "size"
-{-# INLINE size_ #-}
-
-forProp_ :: JSString -> Html ()
-forProp_ = prop "for"
-{-# INLINE forProp_ #-}
-
-ref_ :: JSString -> Html ()
-ref_ = prop "ref"
-{-# INLINE ref_ #-}
-
-formProp_ :: JSString -> Html ()
-formProp_ = prop "form"
-{-# INLINE formProp_ #-}
-
-max_ :: JSString -> Html ()
-max_ = prop "max"
-{-# INLINE max_ #-}
-
-min_ :: JSString -> Html ()
-min_ = prop "min"
-{-# INLINE min_ #-}
-
-step_ :: JSString -> Html ()
-step_ = prop "step"
-{-# INLINE step_ #-}
-
-cols_ :: JSString -> Html ()
-cols_ = prop "cols"
-{-# INLINE cols_ #-}
-
-rows_ :: JSString -> Html ()
-rows_ = prop "rows"
-{-# INLINE rows_ #-}
-
-wrap_ :: JSString -> Html ()
-wrap_ = prop "wrap"
-{-# INLINE wrap_ #-}
-
-target_ :: JSString -> Html ()
-target_ = prop "target"
-{-# INLINE target_ #-}
-
-download_ :: JSString -> Html ()
-download_ = prop "download"
-{-# INLINE download_ #-}
-
-downloadAs_ :: JSString -> Html ()
-downloadAs_ = prop "downloadAs"
-{-# INLINE downloadAs_ #-}
-
-hreflang_ :: JSString -> Html ()
-hreflang_ = prop "hreflang"
-{-# INLINE hreflang_ #-}
-
-media_ :: JSString -> Html ()
-media_ = prop "media"
-{-# INLINE media_ #-}
-
-ping_ :: JSString -> Html ()
-ping_ = prop "ping"
-{-# INLINE ping_ #-}
-
-rel_ :: JSString -> Html ()
-rel_ = prop "rel"
-{-# INLINE rel_ #-}
-
-ismap_ :: JSString -> Html ()
-ismap_ = prop "ismap"
-{-# INLINE ismap_ #-}
-
-usemap_ :: JSString -> Html ()
-usemap_ = prop "usemap"
-{-# INLINE usemap_ #-}
-
-shape_ :: JSString -> Html ()
-shape_ = prop "shape"
-{-# INLINE shape_ #-}
-
-coords_ :: JSString -> Html ()
-coords_ = prop "coords"
-{-# INLINE coords_ #-}
-
-src_ :: JSString -> Html ()
-src_ = prop "src"
-{-# INLINE src_ #-}
-
-height_ :: JSString -> Html ()
-height_ = prop "height"
-{-# INLINE height_ #-}
-
-width_ :: JSString -> Html ()
-width_ = prop "width"
-{-# INLINE width_ #-}
-
-alt_ :: JSString -> Html ()
-alt_ = prop "alt"
-{-# INLINE alt_ #-}
-
-autoplay_ :: Bool -> Html ()
-autoplay_ = prop "autoplay"
-{-# INLINE autoplay_ #-}
-
-controls_ :: Bool -> Html ()
-controls_ = prop "controls"
-{-# INLINE controls_ #-}
-
-loop_ :: Bool -> Html ()
-loop_ = prop "loop"
-{-# INLINE loop_ #-}
-
-preload_ :: JSString -> Html ()
-preload_ = prop "preload"
-{-# INLINE preload_ #-}
-
-poster_ :: JSString -> Html ()
-poster_ = prop "poster"
-{-# INLINE poster_ #-}
-
-default_ :: Bool -> Html ()
-default_ = prop "default"
-{-# INLINE default_ #-}
-
-kind_ :: JSString -> Html ()
-kind_ = prop "kind"
-{-# INLINE kind_ #-}
-
-srclang_ :: JSString -> Html ()
-srclang_ = prop "srclang"
-{-# INLINE srclang_ #-}
-
-sandbox_ :: JSString -> Html ()
-sandbox_ = prop "sandbox"
-{-# INLINE sandbox_ #-}
-
-seamless_ :: JSString -> Html ()
-seamless_ = prop "seamless"
-{-# INLINE seamless_ #-}
-
-srcdoc_ :: JSString -> Html ()
-srcdoc_ = prop "srcdoc"
-{-# INLINE srcdoc_ #-}
-
-reversed_ :: JSString -> Html ()
-reversed_ = prop "reversed"
-{-# INLINE reversed_ #-}
-
-start_ :: JSString -> Html ()
-start_ = prop "start"
-{-# INLINE start_ #-}
-
-align_ :: JSString -> Html ()
-align_ = prop "align"
-{-# INLINE align_ #-}
-
-colspan_ :: JSString -> Html ()
-colspan_ = attr "colspan"
-{-# INLINE colspan_ #-}
-
-rowspan_ :: JSString -> Html ()
-rowspan_ = attr "rowspan"
-{-# INLINE rowspan_ #-}
-
-headers_ :: JSString -> Html ()
-headers_ = prop "headers"
-{-# INLINE headers_ #-}
-
-scope_ :: JSString -> Html ()
-scope_ = prop "scope"
-{-# INLINE scope_ #-}
-
-async_ :: JSString -> Html ()
-async_ = prop "async"
-{-# INLINE async_ #-}
-
-charset_ :: JSString -> Html ()
-charset_ = prop "charset"
-{-# INLINE charset_ #-}
-
-content_ :: JSString -> Html ()
-content_ = prop "content"
-{-# INLINE content_ #-}
-
-defer_ :: JSString -> Html ()
-defer_ = prop "defer"
-{-# INLINE defer_ #-}
-
-httpEquiv_ :: JSString -> Html ()
-httpEquiv_ = prop "httpEquiv"
-{-# INLINE httpEquiv_ #-}
-
-language_ :: JSString -> Html ()
-language_ = prop "language"
-{-# INLINE language_ #-}
-
-scoped_ :: JSString -> Html ()
-scoped_ = prop "scoped"
-{-# INLINE scoped_ #-}
-
-type_ :: JSString -> Html ()
-type_ = prop "type"
-{-# INLINE type_ #-}
-
-name_ :: JSString -> Html ()
-name_ = prop "name"
-{-# INLINE name_ #-}
-
-href_ :: JSString -> Html ()
-href_ = prop "href"
-{-# INLINE href_ #-}
-
-id_ :: JSString -> Html ()
-id_ = prop "id"
-{-# INLINE id_ #-}
-
-placeholder_ :: JSString -> Html ()
-placeholder_ = prop "placeholder"
-{-# INLINE placeholder_ #-}
-
-checked_ :: Bool -> Html ()
-checked_ = prop "checked"
-{-# INLINE checked_ #-}
-
-autofocus_ :: Bool -> Html ()
-autofocus_ = prop "autofocus"
-{-# INLINE autofocus_ #-}
-
-class_ :: JSString -> Html ()
-class_ = prop "className"
-{-# INLINE class_ #-}
-
-data_ :: JSString -> JSString -> Html ()
-data_ k v = prop @JSString ("data-" <> k) v
-{-# INLINE data_ #-}
-
-role_ :: JSString -> Html ()
-role_ = attr "role"
-{-# INLINE role_ #-}
-
-style_ :: JSString -> Html ()
-style_ = prop "style"
-{-# INLINE style_ #-}
diff --git a/src/HtmlT/Types.hs b/src/HtmlT/Types.hs
deleted file mode 100644
index 7fce8a2..0000000
--- a/src/HtmlT/Types.hs
+++ /dev/null
@@ -1,74 +0,0 @@
-module HtmlT.Types where
-
-import Control.Monad.Catch
-import Control.Monad.Reader
-import Data.Coerce
-import Data.String
-import GHC.Generics
-import HtmlT.Event
-import Control.Monad.Fix
-
-import JavaScript.Compat.Prim
-import JavaScript.Compat.String (JSString(..))
-
--- | HtmlT is nothing more than just a newtype over ReaderT HtmlEnv
-newtype HtmlT m a = HtmlT {unHtmlT :: ReaderT HtmlEnv m a}
- deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader HtmlEnv
- , MonadFix, MonadCatch, MonadThrow, MonadMask, MonadTrans)
-
-data HtmlEnv = HtmlEnv
- { html_current_element :: DOMElement
- -- ^ A DOMElement that will be used as a parent to insert new
- -- content, attributes, properties, listeners etc.
- , html_content_boundary :: Maybe ContentBoundary
- -- ^ Boundary defined by parent scope where new content should be
- -- attached, when Nothing whole parent element is available
- , html_reactive_env :: ReactiveEnv
- -- ^ Needed to implement 'HasReactiveEnv'
- } deriving Generic
-
--- | Most applications will only need HtmlT IO, hence this shortcut
-type Html = HtmlT IO
-
--- | A newtype over JSVal which is an instance of Node
--- https://developer.mozilla.org/en-US/docs/Web/API/Node
-newtype DOMNode = DOMNode {unDOMNode :: JSVal}
-
--- | A newtype over JSVal which is an instance of HTMLElement
--- https://developer.mozilla.org/en-US/docs/Web/API/HTMLElement
-newtype DOMElement = DOMElement {unDOMElement :: JSVal}
-
--- | A newtype over JSVal which is an instance of Event
--- https://developer.mozilla.org/en-US/docs/Web/API/Event
-newtype DOMEvent = DOMEvent {unDOMEvent :: JSVal}
-
--- | See https://developer.mozilla.org/en-US/docs/Web/Events for
--- reference, what events are supported by particular elements
-newtype EventName = EventName {unEventName :: JSString}
- deriving newtype IsString
-
--- | Two comment nodes that define a boundary and a placeholder to
--- insert additional nodes within the DOM.
-data ContentBoundary = ContentBoundary
- { boundary_begin :: DOMNode
- , boundary_end :: DOMNode
- } deriving Generic
-
--- | Each DOMElement is also a valid DOMNode
-nodeFromElement :: DOMElement -> DOMNode
-nodeFromElement = coerce
-
-runHtmlT :: HtmlT m a -> HtmlEnv -> m a
-runHtmlT h = runReaderT (unHtmlT h)
-
-execHtmlT :: HtmlEnv -> HtmlT m a -> m a
-execHtmlT = flip runHtmlT
-
-instance (Semigroup a, Applicative m) => Semigroup (HtmlT m a) where
- (<>) = liftA2 (<>)
-
-instance (Monoid a, Applicative m) => Monoid (HtmlT m a) where
- mempty = HtmlT $ ReaderT \_ -> pure mempty
-
-instance Monad m => HasReactiveEnv (HtmlT m) where
- askReactiveEnv = asks html_reactive_env
diff --git a/src/JavaScript/Compat/Foreign/Callback.hs b/src/JavaScript/Compat/Foreign/Callback.hs
deleted file mode 100644
index 950f314..0000000
--- a/src/JavaScript/Compat/Foreign/Callback.hs
+++ /dev/null
@@ -1,135 +0,0 @@
-{-# LANGUAGE CPP #-}
-#if defined(javascript_HOST_ARCH)
-module JavaScript.Compat.Foreign.Callback
- ( module GHC.JS.Foreign.Callback
- ) where
-
-import GHC.JS.Foreign.Callback
-#else
-
-module JavaScript.Compat.Foreign.Callback
- ( Callback
- , OnBlocked(..)
- , releaseCallback
- -- * asynchronous callbacks
- , asyncCallback
- , asyncCallback1
- , asyncCallback2
- , asyncCallback3
- -- * synchronous callbacks
- , syncCallback
- , syncCallback1
- , syncCallback2
- , syncCallback3
- -- * synchronous callbacks that return a value
- , syncCallback'
- , syncCallback1'
- , syncCallback2'
- , syncCallback3'
- ) where
-
-import JavaScript.Compat.Prim
-
-data OnBlocked = ContinueAsync | ThrowWouldBlock deriving (Eq)
-
-data Callback a
-
-{- |
- When you create a callback, the Haskell runtime stores a reference to
- the exported IO action or function. This means that all data referenced by the
- exported value stays in memory, even if nothing outside the Haskell runtime
- holds a reference to to callback.
- Use 'releaseCallback' to free the reference. Subsequent calls from JavaScript
- to the callback will result in an exception.
- -}
-releaseCallback :: Callback a -> IO ()
-releaseCallback = undefined
-
-{- | Make a callback (JavaScript function) that runs the supplied IO action in a synchronous
- thread when called.
- Call 'releaseCallback' when done with the callback, freeing memory referenced
- by the IO action.
- -}
-syncCallback :: OnBlocked -- ^ what to do when the thread blocks
- -> IO () -- ^ the Haskell action
- -> IO (Callback (IO ())) -- ^ the callback
-syncCallback = undefined
-
-
-{- | Make a callback (JavaScript function) that runs the supplied IO function in a synchronous
- thread when called. The callback takes one argument that it passes as a JSVal value to
- the Haskell function.
- Call 'releaseCallback' when done with the callback, freeing data referenced
- by the function.
- -}
-syncCallback1 :: OnBlocked -- ^ what to do when the thread blocks
- -> (JSVal -> IO ()) -- ^ the Haskell function
- -> IO (Callback (JSVal -> IO ())) -- ^ the callback
-syncCallback1 = undefined
-
-
-{- | Make a callback (JavaScript function) that runs the supplied IO function in a synchronous
- thread when called. The callback takes two arguments that it passes as JSVal values to
- the Haskell function.
- Call 'releaseCallback' when done with the callback, freeing data referenced
- by the function.
- -}
-syncCallback2 :: OnBlocked -- ^ what to do when the thread blocks
- -> (JSVal -> JSVal -> IO ()) -- ^ the Haskell function
- -> IO (Callback (JSVal -> JSVal -> IO ())) -- ^ the callback
-syncCallback2 = undefined
-
-{- | Make a callback (JavaScript function) that runs the supplied IO function in a synchronous
- thread when called. The callback takes three arguments that it passes as JSVal values to
- the Haskell function.
- Call 'releaseCallback' when done with the callback, freeing data referenced
- by the function.
- -}
-syncCallback3 :: OnBlocked -- ^ what to do when the thread blocks
- -> (JSVal -> JSVal -> JSVal -> IO ()) -- ^ the Haskell function
- -> IO (Callback (JSVal -> JSVal -> JSVal -> IO ())) -- ^ the callback
-syncCallback3 = undefined
-
-{- | Make a callback (JavaScript function) that runs the supplied IO action in a synchronous
- thread when called.
- Call 'releaseCallback' when done with the callback, freeing memory referenced
- by the IO action.
- -}
-syncCallback' :: IO JSVal
- -> IO (Callback (IO JSVal))
-syncCallback' = undefined
-
-syncCallback1' :: (JSVal -> IO JSVal)
- -> IO (Callback (JSVal -> IO JSVal))
-syncCallback1' = undefined
-
-syncCallback2' :: (JSVal -> JSVal -> IO JSVal)
- -> IO (Callback (JSVal -> JSVal -> IO JSVal))
-syncCallback2' = undefined
-
-syncCallback3' :: (JSVal -> JSVal -> JSVal -> IO JSVal)
- -> IO (Callback (JSVal -> JSVal -> JSVal -> IO JSVal))
-syncCallback3' = undefined
-
-{- | Make a callback (JavaScript function) that runs the supplied IO action in an asynchronous
- thread when called.
- Call 'releaseCallback' when done with the callback, freeing data referenced
- by the IO action.
- -}
-asyncCallback :: IO () -- ^ the action that the callback runs
- -> IO (Callback (IO ())) -- ^ the callback
-asyncCallback = undefined
-
-asyncCallback1 :: (JSVal -> IO ()) -- ^ the function that the callback calls
- -> IO (Callback (JSVal -> IO ())) -- ^ the calback
-asyncCallback1 = undefined
-
-asyncCallback2 :: (JSVal -> JSVal -> IO ()) -- ^ the Haskell function that the callback calls
- -> IO (Callback (JSVal -> JSVal -> IO ())) -- ^ the callback
-asyncCallback2 = undefined
-
-asyncCallback3 :: (JSVal -> JSVal -> JSVal -> IO ()) -- ^ the Haskell function that the callback calls
- -> IO (Callback (JSVal -> JSVal -> JSVal -> IO ())) -- ^ the callback
-asyncCallback3 = undefined
-
-#endif
diff --git a/src/JavaScript/Compat/Marshal.hs b/src/JavaScript/Compat/Marshal.hs
deleted file mode 100644
index a655697..0000000
--- a/src/JavaScript/Compat/Marshal.hs
+++ /dev/null
@@ -1,91 +0,0 @@
-{-|
-Implement the missing functionality, which is likely to be included in
-the standard library at some point in the future.
--}
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE ForeignFunctionInterface #-}
-{-# LANGUAGE JavaScriptFFI #-}
-module JavaScript.Compat.Marshal where
-
-import Data.Bool
-import Data.Coerce
-import Data.Maybe
-import JavaScript.Compat.Prim
-import JavaScript.Compat.String
-import Unsafe.Coerce
-
-newtype Nullable v = Nullable {unNullable :: JSVal}
-
-nullableToMaybe :: Coercible v JSVal => Nullable v -> Maybe v
-nullableToMaybe (Nullable jsval)
- | isNull jsval = Nothing
- | otherwise = Just (coerce jsval)
-
-maybeToNullable :: Coercible v JSVal => Maybe v -> Nullable v
-maybeToNullable = Nullable . maybe jsNull coerce
-
-class FromJSVal v where fromJSVal :: JSVal -> IO (Maybe v)
-
-instance FromJSVal Int where
- fromJSVal = pure . Just . fromJSInt
-
-instance FromJSVal JSVal where
- fromJSVal = pure . Just
-
-instance FromJSVal v => FromJSVal (Maybe v) where
- fromJSVal j = maybe (pure (Just Nothing)) fromJSVal $
- nullableToMaybe (Nullable j)
-
-instance FromJSVal v => FromJSVal [v] where
- fromJSVal s = fmap (Just . catMaybes) . mapM fromJSVal =<< fromJSArray s
-
-class ToJSVal v where toJSVal :: v -> IO JSVal
-
-instance ToJSVal Int where
- toJSVal = pure . toJSInt
-
-instance ToJSVal Bool where
- toJSVal = pure . bool js_false js_true
-
-instance ToJSVal JSVal where
- toJSVal = pure
-
-instance ToJSVal v => ToJSVal (Maybe v) where
- toJSVal s = pure . unNullable . maybeToNullable =<< mapM toJSVal s
-
-instance ToJSVal v => ToJSVal [v] where
- toJSVal s = toJSArray =<< mapM toJSVal s
-
-#if !defined(javascript_HOST_ARCH)
-instance FromJSVal JSString where fromJSVal = undefined
-
-instance ToJSVal JSString where toJSVal = undefined
-
-instance FromJSVal Bool where fromJSVal = undefined
-
-js_true :: JSVal = undefined
-js_false :: JSVal = undefined
-js_isString :: JSVal -> JSVal = undefined
-#else
-
-instance FromJSVal JSString where
- fromJSVal jsval = do
- let
- isString = unsafeCoerce $
- js_bool (unsafeCoerce False) (unsafeCoerce True) (js_isString jsval)
- return $ if isString then Just (JSString jsval) else Nothing
-
-instance ToJSVal JSString where
- toJSVal = pure . unJSString
-
-instance FromJSVal Bool where
- fromJSVal = pure . Just . unsafeCoerce .
- js_bool (unsafeCoerce False) (unsafeCoerce True)
-
-foreign import javascript unsafe
- "(() => true)" js_true :: JSVal
-foreign import javascript unsafe
- "(() => false)" js_false :: JSVal
-foreign import javascript unsafe
- "((s) => typeof s === 'string')" js_isString :: JSVal -> JSVal
-#endif
diff --git a/src/JavaScript/Compat/Prim.hs b/src/JavaScript/Compat/Prim.hs
deleted file mode 100644
index 88ca50c..0000000
--- a/src/JavaScript/Compat/Prim.hs
+++ /dev/null
@@ -1,177 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE MagicHash #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE JavaScriptFFI #-}
-{-# LANGUAGE GHCForeignImportPrim #-}
-{-# LANGUAGE UnliftedFFITypes #-}
-{-# LANGUAGE UnboxedTuples #-}
-
-#if defined(javascript_HOST_ARCH)
-module JavaScript.Compat.Prim
- ( module GHC.JS.Prim
- ) where
-
-import GHC.JS.Prim
-#else
-
-module JavaScript.Compat.Prim ( JSVal(..), JSVal#
- , JSException(..)
- , WouldBlockException(..)
- , toIO
- , resolve
- , resolveIO
- , mkJSException
- , fromJSString
- , toJSString
- , toJSArray
- , fromJSArray
- , fromJSInt
- , toJSInt
- , isNull
- , isUndefined
- , jsNull
- , getProp
- , getProp'
- , getProp#
- , unsafeGetProp
- , unsafeGetProp'
- , unsafeGetProp#
- , unpackJSString#
- , unpackJSStringUtf8#
- , unsafeUnpackJSString#
- , unsafeUnpackJSStringUtf8#
- , unpackJSStringUtf8##
- , unsafeUnpackJSStringUtf8##
- ) where
-
-import Data.Typeable (Typeable)
-
-import GHC.Prim
-import qualified GHC.Exception as Ex
-import qualified GHC.Exts as Exts
-
-{-
- JSVal is a boxed type that can be used as FFI
- argument or result.
--}
-
-data JSVal = JSVal Addr#
-type JSVal# = Addr#
-
-{-
- When a JavaScript exception is raised inside
- a safe or interruptible foreign call, it is converted
- to a JSException
- -}
-data JSException = JSException JSVal String
- deriving (Typeable)
-
-instance Ex.Exception JSException
-
-instance Show JSException where
- show (JSException _ xs) = "JavaScript exception: " ++ xs
-
-toIO :: Exts.Any -> IO Exts.Any
-toIO = undefined
-
-resolve :: JSVal# -> JSVal# -> Exts.Any -> IO ()
-resolve = undefined
-
-resolveIO :: JSVal# -> JSVal# -> IO Exts.Any -> IO ()
-resolveIO = undefined
-
-mkJSException :: JSVal -> IO JSException
-mkJSException = undefined
-
-{- | Low-level conversion utilities for packages that cannot
- depend on ghcjs-base
- -}
-
-{- | returns an empty string if the JSVal does not contain
- a string
- -}
-fromJSString :: JSVal -> String
-fromJSString = undefined
-
-toJSString :: String -> JSVal
-toJSString = undefined
-
-fromJSArray :: JSVal -> IO [JSVal]
-fromJSArray = undefined
-
-toJSArray :: [JSVal] -> IO JSVal
-toJSArray = undefined
-
-{- | returns zero if the JSVal does not contain a number
- -}
-fromJSInt :: JSVal -> Int
-fromJSInt = undefined
-
-toJSInt :: Int -> JSVal
-toJSInt = undefined
-
-isNull :: JSVal -> Bool
-isNull = undefined
-
-isUndefined :: JSVal -> Bool
-isUndefined = undefined
-
-jsNull :: JSVal
-jsNull = undefined
-
-getProp :: JSVal -> String -> IO JSVal
-getProp = undefined
-
--- | only safe on immutable object
-unsafeGetProp :: JSVal -> String -> JSVal
-unsafeGetProp = undefined
-
-getProp' :: JSVal -> JSVal -> IO JSVal
-getProp' = undefined
-
--- | only safe on immutable object
-unsafeGetProp' :: JSVal -> JSVal -> JSVal
-unsafeGetProp' = undefined
-
-
--- | only safe on immutable Addr#
-getProp# :: JSVal -> Addr# -> IO JSVal
-getProp# = undefined
-
--- | only safe on immutable Addr# and JSVal
-unsafeGetProp# :: JSVal -> Addr# -> JSVal
-unsafeGetProp# = undefined
-
-unpackJSString# :: Addr# -> IO JSVal
-unpackJSString# = undefined
-
-unpackJSStringUtf8# :: Addr# -> IO JSVal
-unpackJSStringUtf8# = undefined
-
-unpackJSStringUtf8## :: Addr# -> State# s -> (# State# s, JSVal# #)
-unpackJSStringUtf8## = undefined
-
--- | only safe on immutable Addr#
-unsafeUnpackJSString# :: Addr# -> JSVal
-unsafeUnpackJSString# = undefined
-
--- | only safe on immutable Addr#
-unsafeUnpackJSStringUtf8# :: Addr# -> JSVal
-unsafeUnpackJSStringUtf8# = undefined
-
-unsafeUnpackJSStringUtf8## :: Addr# -> JSVal#
-unsafeUnpackJSStringUtf8## = undefined
-
-{- | If a synchronous thread tries to do something that can only
- be done asynchronously, and the thread is set up to not
- continue asynchronously, it receives this exception.
- -}
-data WouldBlockException = WouldBlockException
- deriving (Typeable)
-
-instance Show WouldBlockException where
- show _ = "thread would block"
-
-instance Ex.Exception WouldBlockException
-#endif
diff --git a/src/JavaScript/Compat/String.hs b/src/JavaScript/Compat/String.hs
deleted file mode 100644
index 5ca61ec..0000000
--- a/src/JavaScript/Compat/String.hs
+++ /dev/null
@@ -1,16 +0,0 @@
-{-|
-Implement the missing functionality, which is likely to be included in
-the standard library at some point in the future.
--}
-{-# LANGUAGE CPP #-}
-#if defined(javascript_HOST_ARCH)
-module JavaScript.Compat.String
- ( module JavaScript.Compat.String.JavaScript
- ) where
-import JavaScript.Compat.String.JavaScript
-#else
-module JavaScript.Compat.String
- ( module JavaScript.Compat.String.Native
- ) where
-import JavaScript.Compat.String.Native
-#endif
diff --git a/src/JavaScript/Compat/String/JavaScript.hs b/src/JavaScript/Compat/String/JavaScript.hs
deleted file mode 100644
index 5d8a3b7..0000000
--- a/src/JavaScript/Compat/String/JavaScript.hs
+++ /dev/null
@@ -1,207 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE ForeignFunctionInterface #-}
-{-# LANGUAGE JavaScriptFFI #-}
-module JavaScript.Compat.String.JavaScript where
-
-import GHC.Exts as Exts
-import JavaScript.Compat.Prim
-import System.IO.Unsafe
-import Unsafe.Coerce
-
-newtype JSString = JSString {unJSString :: JSVal}
-
-toJSValPure :: JSString -> JSVal
-toJSValPure = unJSString
-
-fromJSValPure :: JSVal -> JSString
-fromJSValPure = JSString
-
-instance Show JSString where
- show = show . unpack
- {-# INLINE show #-}
-
-instance Eq JSString where
- (==) (JSString a) (JSString b) = unsafeCoerce $
- js_stringEq a b (unsafeCoerce True) (unsafeCoerce False)
- {-# INLINE (==) #-}
-
-instance Ord JSString where
- -- TODO: Could be made way faster once implemented in JavaScript
- compare a b = unpack a `compare` unpack b
-
-instance IsString JSString where
- fromString = JSString . toJSString
- {-# INLINE fromString #-}
-
-instance Semigroup JSString where
- (<>) = append
- {-# INLINE (<>) #-}
-
-instance Monoid JSString where
- mempty = empty
- {-# INLINE mempty #-}
-
-empty :: JSString
-empty = ""
-{-# NOINLINE empty #-}
-
-pack :: String -> JSString
-pack = JSString . toJSString
-{-# INLINE pack #-}
-
-unpack :: JSString -> String
-unpack = fromJSString . unJSString
-{-# INLINE unpack #-}
-
-strip :: JSString -> JSString
-strip = JSString . js_strip . unJSString
-{-# INLINE strip #-}
-
-append :: JSString -> JSString -> JSString
-append (JSString a) (JSString b) = JSString (js_append a b)
-{-# INLINE append #-}
-
-stripPrefix :: JSString -> JSString -> Maybe JSString
-stripPrefix (JSString str) (JSString prefix) =
- let
- jsVal = js_stripPrefix str prefix
- in
- if isUndefined jsVal then Nothing else Just (JSString jsVal)
-{-# INLINE stripPrefix #-}
-
-breakOn :: JSString -> JSString -> (JSString, JSString)
-breakOn (JSString sep) (JSString str) =
- let
- jsTuple = js_breakOn sep str
- in
- ( JSString (js_unsafeIndex 0 jsTuple)
- , JSString (js_unsafeIndex 1 jsTuple)
- )
-{-# INLINE breakOn #-}
-
-splitOn :: JSString -> JSString -> [JSString]
-splitOn (JSString sep) (JSString str) = fmap JSString $ unsafePerformIO $
- fromJSArray (js_splitOn sep str)
-{-# NOINLINE splitOn #-}
-
-intercalate :: JSString -> [JSString] -> JSString
-intercalate (JSString sep) list =
- let
- jsList = unsafePerformIO $ toJSArray (fmap unJSString list)
- in
- JSString $ js_intercalate sep jsList
-{-# NOINLINE intercalate #-}
-
-drop :: Int -> JSString -> JSString
-drop n (JSString str) = JSString $ js_drop n str
-{-# INLINE drop #-}
-
-take :: Int -> JSString -> JSString
-take n (JSString str) = JSString $ js_take n str
-{-# INLINE take #-}
-
-encodeURIComponent :: JSString -> JSString
-encodeURIComponent =
- JSString . js_encodeURIComponent . unJSString
-{-# INLINE encodeURIComponent #-}
-
-decodeURIComponent :: JSString -> JSString
-decodeURIComponent =
- JSString . js_decodeURIComponent . unJSString
-{-# INLINE decodeURIComponent #-}
-
-toLower :: JSString -> JSString
-toLower = JSString . js_toLower . unJSString
-{-# INLINE toLower #-}
-
-toUpper :: JSString -> JSString
-toUpper = JSString . js_toUpper . unJSString
-{-# INLINE toUpper #-}
-
-isInfixOf :: JSString -> JSString -> Bool
-isInfixOf (JSString substr) (JSString str) =
- unsafeCoerce $ js_bool (unsafeCoerce False) (unsafeCoerce True) (js_isInfixOf substr str)
-{-# INLINE isInfixOf #-}
-
-null :: JSString -> Bool
-null = (==empty)
-{-# INLINE null #-}
-
-#if !defined(javascript_HOST_ARCH)
-js_stringEq :: JSVal -> JSVal -> Exts.Any -> Exts.Any -> Exts.Any = undefined
-js_strip :: JSVal -> JSVal = undefined
-js_append :: JSVal -> JSVal -> JSVal = undefined
-js_stripPrefix :: JSVal -> JSVal -> JSVal = undefined
-js_splitOn :: JSVal-> JSVal -> JSVal = undefined
-js_breakOn :: JSVal-> JSVal -> JSVal = undefined
-js_unsafeIndex :: Int -> JSVal -> JSVal = undefined
-js_intercalate :: JSVal -> JSVal -> JSVal = undefined
-js_drop :: Int -> JSVal -> JSVal = undefined
-js_take :: Int -> JSVal -> JSVal = undefined
-js_encodeURIComponent :: JSVal -> JSVal = undefined
-js_decodeURIComponent :: JSVal -> JSVal = undefined
-js_toLower :: JSVal -> JSVal = undefined
-js_toUpper :: JSVal -> JSVal = undefined
-js_isInfixOf :: JSVal -> JSVal -> JSVal = undefined
-js_bool :: Exts.Any -> Exts.Any -> JSVal -> Exts.Any = undefined
-#else
-foreign import javascript unsafe
- "((lhs, rhs, ifeq, ifneq) => lhs == rhs ? ifeq : ifneq)"
- js_stringEq :: JSVal -> JSVal -> Exts.Any -> Exts.Any -> Exts.Any
-foreign import javascript unsafe
- "((str) => str.replace(/^\\s+|\\s+$/g, ''))"
- js_strip :: JSVal -> JSVal
-foreign import javascript unsafe
- "((a, b) => a + b)"
- js_append :: JSVal -> JSVal -> JSVal
-foreign import javascript unsafe
- "((prefix, str) => {\
- if (str.startsWith(prefix)) {\
- return str.slice(prefix.length);\
- }\
- return undefined;\
- })"
- js_stripPrefix :: JSVal -> JSVal -> JSVal
-foreign import javascript unsafe
- "((sep, str) => str.split(sep))"
- js_splitOn :: JSVal -> JSVal -> JSVal
-foreign import javascript unsafe
- "((sep, str) => {\
- var index = str.indexOf(sep);\
- if (index !== -1) {\
- return [str.slice(0, index), str.slice(index)];\
- }\
- return [str, ''];\
- })"
- js_breakOn :: JSVal -> JSVal -> JSVal
-foreign import javascript unsafe
- "((i, arr) => arr[i])"
- js_unsafeIndex :: Int -> JSVal -> JSVal
-foreign import javascript unsafe
- "((sep, list) => list.join(sep))"
- js_intercalate :: JSVal -> JSVal -> JSVal
-foreign import javascript unsafe
- "((n, str) => str.slice(n))"
- js_drop :: Int -> JSVal -> JSVal
-foreign import javascript unsafe
- "((n, str) => str.slice(0, n))"
- js_take :: Int -> JSVal -> JSVal
-foreign import javascript unsafe
- "encodeURIComponent"
- js_encodeURIComponent :: JSVal -> JSVal
-foreign import javascript unsafe
- "decodeURIComponent"
- js_decodeURIComponent :: JSVal -> JSVal
-foreign import javascript unsafe
- "((s) => s.toLowerCase())"
- js_toLower :: JSVal -> JSVal
-foreign import javascript unsafe
- "((s) => s.toUpperCase())"
- js_toUpper :: JSVal -> JSVal
-foreign import javascript unsafe
- "((substr, str) => str.includes(substr))"
- js_isInfixOf :: JSVal -> JSVal -> JSVal
-foreign import javascript unsafe
- "((iffalse, iftrue, jsbool) => jsbool ? iftrue : iffalse)"
- js_bool :: Exts.Any -> Exts.Any -> JSVal -> Exts.Any
-#endif
diff --git a/src/JavaScript/Compat/String/Native.hs b/src/JavaScript/Compat/String/Native.hs
deleted file mode 100644
index fc6583b..0000000
--- a/src/JavaScript/Compat/String/Native.hs
+++ /dev/null
@@ -1,115 +0,0 @@
-module JavaScript.Compat.String.Native where
-
-import Data.Char qualified as C
-import Data.Text (Text)
-import Data.Text qualified as T
-import GHC.Exts as Exts
-import JavaScript.Compat.Prim
-
-newtype JSString = JSString {unJSString :: Text}
- deriving newtype (Eq, Ord, Show, IsString, Semigroup, Monoid)
-
-toJSValPure :: JSString -> JSVal
-toJSValPure = undefined
-
-fromJSValPure :: JSVal -> JSString
-fromJSValPure = undefined
-
-empty :: JSString
-empty = JSString T.empty
-{-# INLINE empty #-}
-
-pack :: String -> JSString
-pack = JSString . T.pack
-{-# INLINE pack #-}
-
-unpack :: JSString -> String
-unpack = T.unpack . unJSString
-{-# INLINE unpack #-}
-
-strip :: JSString -> JSString
-strip = JSString . T.strip . unJSString
-{-# INLINE strip #-}
-
-append :: JSString -> JSString -> JSString
-append (JSString a) (JSString b) = JSString $ T.append a b
-{-# INLINE append #-}
-
-stripPrefix :: JSString -> JSString -> Maybe JSString
-stripPrefix (JSString a) (JSString b) =
- JSString <$> T.stripPrefix a b
-{-# INLINE stripPrefix #-}
-
-breakOn :: JSString -> JSString -> (JSString, JSString)
-breakOn (JSString a) (JSString b) =
- let (c, d) = T.breakOn a b in (JSString c, JSString d)
-{-# INLINE breakOn #-}
-
-splitOn :: JSString -> JSString -> [JSString]
-splitOn (JSString a) (JSString b) = fmap JSString $ T.splitOn a b
-{-# NOINLINE splitOn #-}
-
-intercalate :: JSString -> [JSString] -> JSString
-intercalate (JSString s) l = JSString $ T.intercalate s $ fmap unJSString l
-{-# INLINE intercalate #-}
-
-drop :: Int -> JSString -> JSString
-drop n (JSString s) = JSString $ T.drop n s
-{-# INLINE drop #-}
-
-take :: Int -> JSString -> JSString
-take n (JSString s) = JSString $ T.take n s
-{-# INLINE take #-}
-
-encodeURIComponent :: JSString -> JSString
-encodeURIComponent =
- JSString . T.pack . concatMap encodeChar . T.unpack . unJSString
- where
- encodeChar c
- | C.isAlphaNum c = [c]
- | c == ' ' = "+"
- | otherwise = '%' : showHex (C.ord c) ""
-
-decodeURIComponent :: JSString -> JSString
-decodeURIComponent = JSString . T.pack . decode . T.unpack . unJSString
- where
- decode [] = []
- decode ('%':x1:x2:xs)
- | C.isHexDigit x1 && C.isHexDigit x2 =
- C.chr (16 * digitToInt x1 + digitToInt x2) : decode xs
- decode ('+':xs) = ' ' : decode xs
- decode (x:xs) = x : decode xs
-
-showHex :: Int -> String -> String
-showHex n acc
- | n < 16 = intToDigit n : acc
- | otherwise = let (q,r) = n `divMod` 16 in showHex q (intToDigit r : acc)
-
-digitToInt :: Char -> Int
-digitToInt c
- | '0' <= c && c <= '9' = fromEnum c - fromEnum '0'
- | 'a' <= c && c <= 'f' = fromEnum c - fromEnum 'a' + 10
- | 'A' <= c && c <= 'F' = fromEnum c - fromEnum 'A' + 10
- | otherwise = error "digitToInt: not a digit"
-
-intToDigit :: Int -> Char
-intToDigit n
- | 0 <= n && n <= 9 = toEnum (fromEnum '0' + n)
- | 10 <= n && n <= 15 = toEnum (fromEnum 'a' + n - 10)
- | otherwise = error "intToDigit: not a digit"
-
-toLower :: JSString -> JSString
-toLower = JSString . T.toLower . unJSString
-{-# INLINE toLower #-}
-
-toUpper :: JSString -> JSString
-toUpper = JSString . T.toUpper . unJSString
-{-# INLINE toUpper #-}
-
-isInfixOf :: JSString -> JSString -> Bool
-isInfixOf (JSString a) (JSString b) = T.isInfixOf a b
-{-# INLINE isInfixOf #-}
-
-null :: JSString -> Bool
-null = T.null . unJSString
-{-# INLINE null #-}
diff --git a/src/Wasm/Compat/Marshal.hs b/src/Wasm/Compat/Marshal.hs
new file mode 100644
index 0000000..9edb9b5
--- /dev/null
+++ b/src/Wasm/Compat/Marshal.hs
@@ -0,0 +1,398 @@
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+#if defined(wasm32_HOST_ARCH)
+{-# LANGUAGE JavaScriptFFI #-}
+#endif
+module Wasm.Compat.Marshal where
+
+import Control.Monad
+import Data.Maybe
+import Data.String
+import Data.Text qualified as Text
+import Data.List qualified as List
+import Data.Coerce
+import Data.Kind
+import Wasm.Compat.Prim
+import GHC.Prim
+import GHC.Ptr
+import GHC.Int
+import GHC.Generics as G
+import GHC.IO
+import Data.Text.Internal
+import Data.Array.Byte
+import Data.Word
+
+newtype Nullable v = Nullable {unNullable :: JSVal}
+
+nullableToMaybe :: Coercible v JSVal => Nullable v -> Maybe v
+nullableToMaybe (Nullable j)
+ | js_isNull j > 0 = Nothing
+ | otherwise = Just (coerce j)
+
+maybeToNullable :: Coercible v JSVal => Maybe v -> Nullable v
+maybeToNullable = Nullable . maybe js_null coerce
+
+newtype TypeResult = TypeResult {unTypeResult :: Int}
+
+pattern TypeNull, TypeBool, TypeNumber, TypeString, TypeArray, TypeObject :: TypeResult
+pattern TypeNull = TypeResult 0
+pattern TypeBool = TypeResult 1
+pattern TypeNumber = TypeResult 2
+pattern TypeString = TypeResult 3
+pattern TypeArray = TypeResult 4
+pattern TypeObject = TypeResult 5
+--------------------------------------------------------------------------------
+
+instance IsString JSString where fromString = toJSString
+
+instance Semigroup JSString where (<>) = js_concatStr
+
+instance Monoid JSString where mempty = js_emptyStr
+
+instance Eq JSString where (==) a b = fromJSString a == fromJSString b
+
+instance Show JSString where show = show . fromJSString
+
+instance Ord JSString where compare a b = fromJSString a `compare` fromJSString b
+--------------------------------------------------------------------------------
+
+class FromJSVal a where
+ fromJSVal :: JSVal -> IO (Maybe a)
+ default fromJSVal :: (Generic a, GFromJSVal (Rep a)) => JSVal -> IO (Maybe a)
+ fromJSVal = fmap (fmap G.to) . gFromJSVal
+
+class FromJSValPure v where fromJSValPure :: JSVal -> Maybe v
+
+instance {-# OVERLAPS #-} FromJSValPure v => FromJSVal v where
+ fromJSVal = pure . fromJSValPure
+
+instance FromJSValPure Int where
+ fromJSValPure j = case js_typeOf j of
+ TypeNumber -> Just (js_unsafeInt j)
+ _ -> Nothing
+
+instance FromJSValPure v => FromJSValPure (Maybe v) where
+ fromJSValPure j
+ = maybe (Just Nothing) fromJSValPure
+ $ nullableToMaybe (Nullable j)
+
+instance FromJSVal v => FromJSVal (Maybe v) where
+ fromJSVal j = maybe (pure (Just Nothing)) fromJSVal $
+ nullableToMaybe (Nullable j)
+
+instance FromJSValPure JSVal where fromJSValPure = Just
+
+instance FromJSValPure JSString where
+ fromJSValPure j = case js_typeOf j of
+ TypeString -> Just (JSString j)
+ _ -> Nothing
+
+instance FromJSValPure Bool where
+ fromJSValPure j = case js_typeOf j of
+ TypeBool -> Just (js_unsafeBool j)
+ _ -> Nothing
+
+instance FromJSVal v => FromJSVal [v] where
+ fromJSVal s = case js_typeOf s of
+ TypeArray -> do
+ len <- js_arrayLength s
+ xs <- forM [0..(len - 1)] $ fromJSVal <=< js_arrayIndex s
+ return $ Just $ catMaybes xs
+ _ -> return Nothing
+
+instance FromJSVal Text where
+ fromJSVal j = case js_typeOf j of
+ TypeString -> fmap Just $ textFromJSString $ JSString j
+ _ -> pure Nothing
+
+instance (FromJSVal a, FromJSVal b) => FromJSVal (a, b) where
+ fromJSVal j = do
+ ma <- fromJSVal =<< js_arrayIndex j 0
+ mb <- fromJSVal =<< js_arrayIndex j 1
+ return $ liftA2 (,) ma mb
+
+instance (FromJSVal a, FromJSVal b, FromJSVal c) => FromJSVal (a, b, c) where
+ fromJSVal j = do
+ ma <- fromJSVal =<< js_arrayIndex j 0
+ mb <- fromJSVal =<< js_arrayIndex j 1
+ mc <- fromJSVal =<< js_arrayIndex j 2
+ return $ (,,) <$> ma <*> mb <*> mc
+
+--------------------------------------------------------------------------------
+class ToJSVal a where
+ toJSVal :: a -> IO JSVal
+ default toJSVal :: (Generic a, GToJSVal (Rep a)) => a -> IO JSVal
+ toJSVal = gToJSVal . G.from
+
+class ToJSValPure v where toJSValPure :: v -> JSVal
+
+instance {-# OVERLAPS #-} ToJSValPure v => ToJSVal v where
+ toJSVal = pure . toJSValPure
+
+instance ToJSValPure Int where toJSValPure = js_intJSVal
+
+instance ToJSValPure Bool where toJSValPure = js_boolJSVal
+
+instance ToJSValPure JSVal where toJSValPure j = j
+
+instance ToJSValPure JSString where toJSValPure (JSString j) = j
+
+instance ToJSVal v => ToJSVal (Maybe v) where
+ toJSVal = fmap (unNullable . maybeToNullable) . mapM toJSVal
+
+instance ToJSValPure v => ToJSValPure (Maybe v) where
+ toJSValPure = unNullable . maybeToNullable . fmap toJSValPure
+
+instance ToJSVal v => ToJSVal [v] where
+ toJSVal s = do
+ arr <- js_newEmptyArray
+ forM_ s $ toJSVal >=> js_arrayPush arr
+ return arr
+
+instance ToJSVal Text where
+ toJSVal = fmap (\(JSString j) -> j) . textToJSString
+
+instance (ToJSVal a, ToJSVal b) => ToJSVal (a, b) where
+ toJSVal (a, b) = do
+ ja <- toJSVal a
+ jb <- toJSVal b
+ toJSVal [ja, jb]
+
+instance (ToJSVal a, ToJSVal b, ToJSVal c) => ToJSVal (a, b, c) where
+ toJSVal (a, b, c) = do
+ ja <- toJSVal a
+ jb <- toJSVal b
+ jc <- toJSVal c
+ toJSVal [ja, jb, jc]
+
+--------------------------------------------------------------------------------
+
+class GFromJSVal (f :: Type -> Type) where
+ gFromJSVal :: JSVal -> IO (Maybe (f a))
+
+instance GFromJSVal f => GFromJSVal (M1 m c f) where
+ gFromJSVal = fmap (fmap M1) . gFromJSVal @f
+
+instance GFromJSObject (x :*: y) => GFromJSVal (x :*: y) where
+ gFromJSVal kvs = gFromJSObject kvs
+
+instance {-# OVERLAPPING #-} FromJSVal a => GFromJSVal (S1 s (Rec0 a)) where
+ gFromJSVal = fmap (fmap (M1 . K1)) . fromJSVal @a
+--------------------------------------------------------------------------------
+
+class GToJSVal (f :: Type -> Type) where
+ gToJSVal :: f x -> IO JSVal
+
+instance GToJSVal f => GToJSVal (M1 m c f) where
+ gToJSVal (M1 f) = gToJSVal f
+
+instance GToJSObject (x :*: y) => GToJSVal (x :*: y) where
+ gToJSVal (x :*: y) = do
+ o <- js_newObject
+ gToJSObject (x :*: y) o
+ return o
+
+instance {-# OVERLAPPING #-} (ToJSVal a) => GToJSVal (S1 s (Rec0 a)) where
+ gToJSVal (M1 (K1 a)) = toJSVal a
+--------------------------------------------------------------------------------
+
+class GToJSObject (f :: Type -> Type) where
+ gToJSObject :: f x -> JSVal -> IO ()
+
+instance (GToJSObject x, GToJSObject y) => GToJSObject (x :*: y) where
+ gToJSObject (x :*: y) o = gToJSObject x o >> gToJSObject y o
+
+instance (GToJSObject f) => GToJSObject (M1 m c f) where
+ gToJSObject (M1 a) o = gToJSObject a o
+
+instance {-# OVERLAPPING #-} (ToJSVal a, Selector s) => GToJSObject (S1 s (Rec0 a)) where
+ gToJSObject (M1 (K1 a)) o = do
+ v <- toJSVal a
+ js_assignProp o addr len v
+ where
+ key = Text.pack $ selName (undefined :: M1 S s (Rec0 a) x)
+ !(Text (ByteArray arr) off len) = key
+ addr = Ptr (byteArrayContents# arr) `plusPtr` off
+
+class GFromJSObject (f :: Type -> Type) where
+ gFromJSObject :: JSVal -> IO (Maybe (f x))
+
+instance (GFromJSObject x, GFromJSObject y) => GFromJSObject (x :*: y) where
+ gFromJSObject kvs = do
+ x <- gFromJSObject kvs
+ y <- gFromJSObject kvs
+ return $ liftA2 (:*:) x y
+
+instance (GFromJSObject f) => GFromJSObject (M1 m c f) where
+ gFromJSObject = fmap (fmap M1) . gFromJSObject
+
+instance {-# OVERLAPPING #-} (FromJSVal a, Selector s) => GFromJSObject (S1 s (Rec0 a)) where
+ gFromJSObject kvs = js_getProp kvs addr len >>= fmap (fmap (M1 . K1)) . fromJSVal
+ where
+ key = Text.pack $ selName (undefined :: M1 S s (Rec0 a) x)
+ !(Text (ByteArray arr) off len) = key
+ addr = Ptr (byteArrayContents# arr) `plusPtr` off
+--------------------------------------------------------------------------------
+
+textToJSString :: Text -> IO JSString
+textToJSString (Text (ByteArray arr) off len) = do
+ let addr = byteArrayContents# arr
+ js_decodeUtf8 (Ptr addr `plusPtr` off) len
+
+textFromJSString :: JSString -> IO Text
+textFromJSString j = IO \s0 ->
+ let (# s1, len@(I# len#) #) = unIO (js_stringLength j) s0
+ (# s2, marr #) = newByteArray# (len# *# 3#) s1
+ (# s3, tlen #) = unIO (js_encodeUtf8 j (Ptr (mutableByteArrayContents# marr)) len) s2
+ (# s4, arr #) = unsafeFreezeByteArray# marr s3
+ in (# s4, (Text (ByteArray arr) 0 tlen) #)
+
+newtype UnsafeJavaScript = UnsafeJavaScript {unUnsafeJavaScript :: Text}
+ deriving newtype (IsString, Semigroup, Monoid)
+
+evalJavaScript :: UnsafeJavaScript -> IO JSVal
+evalJavaScript rjs = do
+ let Text (ByteArray arr) off len = rjs.unUnsafeJavaScript
+ addr = byteArrayContents# arr
+ js_evalJavaScript (Ptr addr `plusPtr` off) len
+
+evalJavaScript1 :: ToJSVal arg0 => arg0 -> UnsafeJavaScript -> IO JSVal
+evalJavaScript1 arg0 rjs = do
+ a0 <- toJSVal arg0
+ let Text (ByteArray arr) off len = rjs.unUnsafeJavaScript
+ addr = byteArrayContents# arr
+ js_evalJavaScript1 a0 (Ptr addr `plusPtr` off) len
+
+evalJavaScript2 :: (ToJSVal arg0, ToJSVal arg1) => arg0 -> arg1 -> UnsafeJavaScript -> IO JSVal
+evalJavaScript2 arg0 arg1 rjs = do
+ a0 <- toJSVal arg0
+ a1 <- toJSVal arg1
+ let Text (ByteArray arr) off len = rjs.unUnsafeJavaScript
+ addr = byteArrayContents# arr
+ js_evalJavaScript2 a0 a1 (Ptr addr `plusPtr` off) len
+
+evalJavaScript3 :: (ToJSVal arg0, ToJSVal arg1, ToJSVal arg2) => arg0 -> arg1 -> arg2 -> UnsafeJavaScript -> IO JSVal
+evalJavaScript3 arg0 arg1 arg2 rjs = do
+ a0 <- toJSVal arg0
+ a1 <- toJSVal arg1
+ a2 <- toJSVal arg2
+ let Text (ByteArray arr) off len = rjs.unUnsafeJavaScript
+ addr = byteArrayContents# arr
+ js_evalJavaScript3 a0 a1 a2 (Ptr addr `plusPtr` off) len
+
+evalJavaScript4 :: (ToJSVal arg0, ToJSVal arg1, ToJSVal arg2, ToJSVal arg3) => arg0 -> arg1 -> arg2 -> arg3 -> UnsafeJavaScript -> IO JSVal
+evalJavaScript4 arg0 arg1 arg2 arg3 rjs = do
+ a0 <- toJSVal arg0
+ a1 <- toJSVal arg1
+ a2 <- toJSVal arg2
+ a3 <- toJSVal arg3
+ let Text (ByteArray arr) off len = rjs.unUnsafeJavaScript
+ addr = byteArrayContents# arr
+ js_evalJavaScript4 a0 a1 a2 a3 (Ptr addr `plusPtr` off) len
+
+#if !defined(wasm32_HOST_ARCH)
+
+js_true :: JSVal = undefined
+js_false :: JSVal = undefined
+js_null :: JSVal = undefined
+js_emptyStr :: JSString = undefined
+js_isString :: JSVal -> JSVal = undefined
+js_isNull :: JSVal -> Int = undefined
+js_typeOf :: JSVal -> TypeResult = undefined
+js_unsafeInt :: JSVal -> Int = undefined
+js_unsafeBool :: JSVal -> Bool = undefined
+js_intJSVal :: Int -> JSVal = undefined
+js_boolJSVal :: Bool -> JSVal = undefined
+js_concatStr :: JSString -> JSString -> JSString = undefined
+js_newEmptyArray :: IO JSVal = undefined
+js_arrayPush :: JSVal -> JSVal -> IO () = undefined
+js_arrayLength :: JSVal -> IO Int = undefined
+js_arrayIndex :: JSVal -> Int -> IO JSVal = undefined
+js_decodeUtf8 :: Ptr Word8 -> Int -> IO JSString = undefined
+js_encodeUtf8 :: JSString -> Ptr Word8 -> Int -> IO Int = undefined
+js_stringLength :: JSString -> IO Int = undefined
+js_evalJavaScript :: Ptr Word8 -> Int -> IO JSVal = undefined
+js_evalJavaScript1 :: JSVal -> Ptr Word8 -> Int -> IO JSVal = undefined
+js_evalJavaScript2 :: JSVal -> JSVal -> Ptr Word8 -> Int -> IO JSVal = undefined
+js_evalJavaScript3 :: JSVal -> JSVal -> JSVal -> Ptr Word8 -> Int -> IO JSVal = undefined
+js_evalJavaScript4 :: JSVal -> JSVal -> JSVal -> JSVal -> Ptr Word8 -> Int -> IO JSVal = undefined
+js_getProp :: JSVal -> Ptr Word8 -> Int -> IO JSVal = undefined
+js_assignProp :: JSVal -> Ptr Word8 -> Int -> JSVal -> IO () = undefined
+js_newObject :: IO JSVal = undefined
+
+#else
+
+foreign import javascript unsafe
+ "true" js_true :: JSVal
+foreign import javascript unsafe
+ "false" js_false :: JSVal
+foreign import javascript unsafe
+ "null" js_null :: JSVal
+foreign import javascript unsafe
+ "''" js_emptyStr :: JSString
+foreign import javascript unsafe
+ "typeof $1 === 'string'" js_isString :: JSVal -> JSVal
+foreign import javascript unsafe
+ "($1 === null || $1 === undefined)" js_isNull :: JSVal -> Int
+foreign import javascript unsafe
+ "if ($1 === undefined || $1 === null) return 0;\
+ if (typeof $1 === 'boolean') return 1;\
+ if (typeof $1 === 'number') return 2;\
+ if (typeof $1 === 'string') return 3;\
+ if (Array.isArray($1)) return 4;\
+ return 5;" js_typeOf :: JSVal -> TypeResult
+foreign import javascript unsafe
+ "$1" js_unsafeInt :: JSVal -> Int
+foreign import javascript unsafe
+ "$1" js_unsafeBool :: JSVal -> Bool
+foreign import javascript unsafe
+ "$1" js_intJSVal :: Int -> JSVal
+foreign import javascript unsafe
+ "($1 ? true : false)" js_boolJSVal :: Bool -> JSVal
+foreign import javascript unsafe
+ "$1 + $2" js_concatStr :: JSString -> JSString -> JSString
+foreign import javascript unsafe
+ "[]" js_newEmptyArray :: IO JSVal
+foreign import javascript unsafe
+ "$1.push($2)" js_arrayPush :: JSVal -> JSVal -> IO ()
+foreign import javascript unsafe
+ "$1.length" js_arrayLength :: JSVal -> IO Int
+foreign import javascript unsafe
+ "$1[$2]" js_arrayIndex :: JSVal -> Int -> IO JSVal
+foreign import javascript unsafe
+ "(new TextDecoder('utf8').decode(new Uint8Array(__exports.memory.buffer, $1, $2)))"
+ js_decodeUtf8 :: Ptr Word8 -> Int -> IO JSString
+foreign import javascript unsafe
+ "(new TextEncoder()).encodeInto($1, new Uint8Array(__exports.memory.buffer, $2, $3)).written"
+ js_encodeUtf8 :: JSString -> Ptr Word8 -> Int -> IO Int
+foreign import javascript unsafe
+ "$1.length"
+ js_stringLength :: JSString -> IO Int
+foreign import javascript unsafe
+ "eval(new TextDecoder('utf8').decode(new Uint8Array(__exports.memory.buffer, $1, $2)))"
+ js_evalJavaScript :: Ptr Word8 -> Int -> IO JSVal
+foreign import javascript unsafe
+ "eval(new TextDecoder('utf8').decode(new Uint8Array(__exports.memory.buffer, $2, $3)))($1)"
+ js_evalJavaScript1 :: JSVal -> Ptr Word8 -> Int -> IO JSVal
+foreign import javascript unsafe
+ "eval(new TextDecoder('utf8').decode(new Uint8Array(__exports.memory.buffer, $3, $4)))($1, $2)"
+ js_evalJavaScript2 :: JSVal -> JSVal -> Ptr Word8 -> Int -> IO JSVal
+foreign import javascript unsafe
+ "eval(new TextDecoder('utf8').decode(new Uint8Array(__exports.memory.buffer, $4, $5)))($1, $2, $3)"
+ js_evalJavaScript3 :: JSVal -> JSVal -> JSVal -> Ptr Word8 -> Int -> IO JSVal
+foreign import javascript unsafe
+ "eval(new TextDecoder('utf8').decode(new Uint8Array(__exports.memory.buffer, $5, $6)))($1, $2, $3, $4)"
+ js_evalJavaScript4 :: JSVal -> JSVal -> JSVal -> JSVal -> Ptr Word8 -> Int -> IO JSVal
+foreign import javascript unsafe
+ "$1[new TextDecoder('utf8').decode(new Uint8Array(__exports.memory.buffer, $2, $3))]"
+ js_getProp :: JSVal -> Ptr Word8 -> Int -> IO JSVal
+foreign import javascript unsafe
+ "$1[new TextDecoder('utf8').decode(new Uint8Array(__exports.memory.buffer, $2, $3))] = $4;"
+ js_assignProp :: JSVal -> Ptr Word8 -> Int -> JSVal -> IO ()
+foreign import javascript unsafe
+ "{}"
+ js_newObject :: IO JSVal
+#endif
diff --git a/src/Wasm/Compat/Prim.hs b/src/Wasm/Compat/Prim.hs
new file mode 100644
index 0000000..76af87c
--- /dev/null
+++ b/src/Wasm/Compat/Prim.hs
@@ -0,0 +1,76 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE GHC2021 #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE UnliftedNewtypes #-}
+
+#if defined(wasm32_HOST_ARCH)
+module Wasm.Compat.Prim (
+ module GHC.Wasm.Prim
+) where
+import GHC.Wasm.Prim
+#else
+module Wasm.Compat.Prim (
+ JSVal#(..),
+ JSVal(..),
+ freeJSVal,
+ JSString (..),
+ fromJSString,
+ toJSString,
+ JSException (..),
+ WouldBlockException (..),
+ PromisePendingException (..),
+ mkJSCallback,
+ runIO,
+ runNonIO,
+) where
+
+import Control.Exception
+import GHC.Exts
+import GHC.Stable
+
+newtype JSVal#
+ = JSVal# (Any :: UnliftedType)
+
+data JSVal
+ = forall a . JSVal JSVal# (Weak# JSVal#) (StablePtr# a)
+
+freeJSVal :: JSVal -> IO ()
+freeJSVal _ = error "freeJSVal: only implmented on Wasm Backend"
+
+newtype JSString = JSString JSVal
+
+fromJSString :: JSString -> String
+fromJSString _ = error "fromJSString: only implmented on Wasm Backend"
+
+toJSString :: String -> JSString
+toJSString _ = error "toJSString: only implmented on Wasm Backend"
+
+newtype JSException = JSException JSVal
+
+instance Show JSException where
+ showsPrec _ _ = error "showsPrec @JSException: only implmented on Wasm Backend"
+
+instance Exception JSException
+
+data WouldBlockException
+ = WouldBlockException
+ deriving (Show)
+
+instance Exception WouldBlockException
+
+data PromisePendingException
+ = PromisePendingException
+ deriving (Show)
+
+instance Exception PromisePendingException
+
+mkJSCallback :: (StablePtr a -> IO JSVal) -> a -> IO JSVal
+mkJSCallback _ _ = error "mkJSCallback: only implmented on Wasm Backend"
+
+runIO :: (JSVal -> a -> IO ()) -> IO a -> IO JSVal
+runIO _ _ = error "runIO: only implmented on Wasm Backend"
+
+runNonIO :: (JSVal -> a -> IO ()) -> a -> IO JSVal
+runNonIO _ _ = error "runNonIO: only implmented on Wasm Backend"
+#endif
diff --git a/webpack.config.js b/webpack.config.js
new file mode 100644
index 0000000..cde7f9c
--- /dev/null
+++ b/webpack.config.js
@@ -0,0 +1,13 @@
+const path = require('path');
+
+module.exports = {
+ entry: './jsbits/index.js',
+ output: {
+ path: path.resolve(__dirname, 'dist-newstyle'),
+ filename: 'index.bundle.js',
+ },
+ resolve: {
+ extensions: ['.ts', '.js'],
+ },
+ devtool: false,
+};