Support JSString in ChoiceString when compiling with ghcjs

libs/hs/blaze-react-core/blaze-react-core.cabal

@@ -40,20 +40,38 @@ library
       Blaze.React.Svg.Attributes
 
 
-  build-depends:
-      aeson
-    , base
-    , bytestring
-    , either
-    , hashable
-    , lens
-    , mtl
-    , profunctors
-    , QuickCheck
-    , text
-    , transformers
-    , time
-    , unordered-containers
-    , vector
-    , void
-
+  if impl(ghcjs)
+    build-depends:
+        ghcjs-base
+      , aeson
+      , base
+      , bytestring
+      , either
+      , hashable
+      , lens
+      , mtl
+      , profunctors
+      , QuickCheck
+      , text
+      , transformers
+      , time
+      , unordered-containers
+      , vector
+      , void
+  else
+    build-depends:
+        aeson
+      , base
+      , bytestring
+      , either
+      , hashable
+      , lens
+      , mtl
+      , profunctors
+      , QuickCheck
+      , text
+      , transformers
+      , time
+      , unordered-containers
+      , vector
+      , void

libs/hs/blaze-react-core/src/Blaze/React/Markup.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, CPP #-}
 -- | Generic abstractions for markup languages like Html and SVG.
 module Blaze.React.Markup
     (
@@ -37,6 +37,10 @@ import Data.Word (Word32, Word64)
 import Data.Text (Text)
 import qualified Data.Text.Lazy as LT
 
+#ifdef ghcjs_HOST_OS
+import Data.JSString (JSString)
+#endif
+
 
 -- | Class allowing us to use a single function for Markup values
 --
@@ -57,6 +61,12 @@ instance ToMarkup String where
     toMarkup = string
     {-# INLINE toMarkup #-}
 
+#ifdef ghcjs_HOST_OS
+instance ToMarkup JSString where
+    toMarkup = jsString
+    {-# INLINE toMarkup #-}
+#endif
+
 instance ToMarkup Int where
     toMarkup = string . show
     {-# INLINE toMarkup #-}
@@ -124,6 +134,12 @@ instance ToValue String where
     toValue = stringValue
     {-# INLINE toValue #-}
 
+#ifdef ghcjs_HOST_OS
+instance ToValue JSString where
+    toValue = jsStringValue
+    {-# INLINE toValue #-}
+#endif
+
 instance ToValue Int where
     toValue = stringValue . show
     {-# INLINE toValue #-}

libs/hs/blaze-react-core/src/Blaze/React/Markup/Internal.hs

@@ -3,7 +3,7 @@
              FlexibleInstances, ExistentialQuantification,
              DeriveDataTypeable, MultiParamTypeClasses, DeriveFunctor,
              DeriveFoldable, DeriveTraversable,
-             FunctionalDependencies #-}
+             FunctionalDependencies, CPP #-}
 -- | Internal types for representing markup-like languages.
 --
 -- While this module is exported, usage of it is not recommended, unless you
@@ -32,6 +32,9 @@ module Blaze.React.Markup.Internal
     , text
     , lazyText
     , string
+#ifdef ghcjs_HOST_OS
+    , jsString
+#endif
 
       -- * Converting values to tags.
     , textTag
@@ -41,6 +44,9 @@ module Blaze.React.Markup.Internal
     , textValue
     , lazyTextValue
     , stringValue
+#ifdef ghcjs_HOST_OS
+    , jsStringValue
+#endif
 
       -- * Setting attributes
     , Attributable
@@ -72,6 +78,12 @@ import qualified Data.Vector                  as V
 
 import           GHC.Exts                     (IsString (..))
 
+#ifdef ghcjs_HOST_OS
+import           Data.JSString                (JSString)
+import qualified Data.JSString                as JSString
+import qualified Data.JSString.Text           as JSString
+#endif
+
 import           Prelude                      hiding (null)
 
 
@@ -81,14 +93,25 @@ data StaticString = StaticString
     { getString         :: String -> String  -- ^ Appending haskell string
     , getUtf8ByteString :: B.ByteString      -- ^ UTF-8 encoded bytestring
     , getText           :: Text              -- ^ Text value
+#ifdef ghcjs_HOST_OS
+    , getJSString       :: JSString
+#endif
     }
 
 -- 'StaticString's should only be converted from string literals, as far as I
 -- can see.
 --
 instance IsString StaticString where
-    fromString s = let t = T.pack s
-                   in StaticString (s ++) (T.encodeUtf8 t) t
+    fromString s =
+      let t = T.pack s in
+      StaticString
+        { getString = (s ++)
+        , getUtf8ByteString = T.encodeUtf8 t
+        , getText = t
+#ifdef ghcjs_HOST_OS
+        , getJSString = JSString.pack s
+#endif
+        }
 
 -- | A string denoting input from different string representations.
 --
@@ -99,6 +122,10 @@ data ChoiceString
     | String String
     -- | A Text value
     | Text Text
+#ifdef ghcjs_HOST_OS
+    -- | A Javascript string
+    | JSString JSString
+#endif
     -- | Concatenation
     | AppendChoiceString ChoiceString ChoiceString
     -- | Empty string
@@ -276,11 +303,27 @@ string :: String    -- ^ String to insert.
 string = Content . String
 {-# INLINE string #-}
 
+#ifdef ghcjs_HOST_OS
+-- | Create an HTML snippet from a 'String'.
+--
+jsString :: JSString  -- ^ JSString to insert.
+         -> Markup ev -- ^ Resulting HTML fragment.
+jsString = Content . JSString
+{-# INLINE jsString #-}
+#endif
+
 -- | Create a 'Tag' from some 'Text'.
 --
 textTag :: Text  -- ^ Text to create a tag from
         -> Tag   -- ^ Resulting tag
-textTag t = Tag $ StaticString (T.unpack t ++) (T.encodeUtf8 t) t
+textTag t = Tag $ StaticString
+  { getString = (T.unpack t ++)
+  , getUtf8ByteString = T.encodeUtf8 t
+  , getText = t
+#ifdef ghcjs_HOST_OS
+  , getJSString = JSString.textToJSString t
+#endif
+  }
 
 -- | Create a 'Tag' from a 'String'.
 --
@@ -308,6 +351,14 @@ stringValue :: String -> AttributeValue
 stringValue = AttributeValue . String
 {-# INLINE stringValue #-}
 
+#ifdef ghcjs_HOST_OS
+-- | Create an attribute value from a 'JSString'.
+--
+jsStringValue :: JSString -> AttributeValue
+jsStringValue = AttributeValue . JSString
+{-# INLINE jsStringValue #-}
+#endif
+
 -- | Used for applying attributes. You should not define your own instances of
 -- this class.
 class Attributable h ev | h -> ev where
@@ -386,6 +437,9 @@ null markup = case markup of
         Static ss                -> emptyStaticString ss
         String s                 -> List.null s
         Text t                   -> T.null t
+#ifdef ghcjs_HOST_OS
+        JSString s               -> JSString.null s
+#endif
         AppendChoiceString c1 c2 -> emptyChoiceString c1 && emptyChoiceString c2
         EmptyChoiceString        -> True
 
@@ -404,6 +458,9 @@ choiceStringToString =
         Static ss                -> getString ss k
         String s                 -> s ++ k
         Text t                   -> T.unpack t ++ k
+#ifdef ghcjs_HOST_OS
+        JSString s               -> JSString.unpack s
+#endif
         AppendChoiceString c1 c2 -> go (go k c2) c1
         EmptyChoiceString        -> k
 

libs/hs/blaze-react-core/src/Blaze/React/Markup/Renderer/String.hs

@@ -2,7 +2,7 @@
 -- | A renderer that produces a native Haskell 'String', mostly meant for
 -- debugging purposes.
 --
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings, CPP #-}
 module Blaze.React.Markup.Renderer.String
     ( -- fromChoiceString
     -- , renderMarkup
@@ -16,6 +16,10 @@ import qualified Data.HashMap.Strict     as HMS
 import           Data.Monoid
 import qualified Data.Text               as T
 
+#ifdef ghcjs_HOST_OS
+import qualified Data.JSString           as JSString
+#endif
+
 
 -- | Escape predefined XML entities in a string
 --
@@ -39,6 +43,9 @@ fromChoiceString :: ChoiceString  -- ^ String to render
 fromChoiceString (Static s)     = getString s
 fromChoiceString (String s)     = escapeMarkupEntities s
 fromChoiceString (Text s)       = escapeMarkupEntities $ T.unpack s
+#ifdef ghcjs_HOST_OS
+fromChoiceString (JSString s)   = escapeMarkupEntities $ JSString.unpack s
+#endif
 fromChoiceString (AppendChoiceString x y) =
     fromChoiceString x . fromChoiceString y
 fromChoiceString EmptyChoiceString = id

libs/hs/blaze-react-spa/src/Blaze/React/Html5/Renderer/ReactJS.hs

@@ -78,35 +78,26 @@ foreign import javascript unsafe
 -- Rendering
 ------------------------------------------------------------------------------
 
-
--- TODO (SM): find a better representation for the rendering of Strings.
--- Probably a DList T.Text with a following concat.
-
 -- | Render a 'ChoiceString'.
 --
-fromChoiceString :: ChoiceString  -- ^ String to render
-                 -> String        -- ^ String to append
-                 -> String        -- ^ Resulting string
-fromChoiceString (Static s)     = getString s
-fromChoiceString (String s)     = (s ++)
-fromChoiceString (Text s)       = (T.unpack s ++)
--- fromChoiceString (ByteString s) = (SBC.unpack s ++)
--- fromChoiceString (PreEscaped x) =
---     -- FiXME (SM): here we actually need to unescape!
---     case x of
---       String s -> (s ++)
---       Text   s -> (\k -> T.foldr (:) k s)
---       s        -> fromChoiceString s
--- fromChoiceString (External x) = case x of
---     -- Check that the sequence "</" is *not* in the external data.
---     String s     -> if "</" `isInfixOf` s then id else (s ++)
---     Text   s     -> if "</" `T.isInfixOf` s then id else (\k -> T.foldr (:) k s)
---     ByteString s -> if "</" `S.isInfixOf` s then id else (SBC.unpack s ++)
---     s            -> fromChoiceString s
-fromChoiceString (AppendChoiceString x y) =
-    fromChoiceString x . fromChoiceString y
-fromChoiceString EmptyChoiceString = id
-
+choiceStringToJs :: ChoiceString -> JSString
+choiceStringToJs cs = case cs of
+  Static s -> getJSString s
+  String s -> JSString.pack s
+  Text s -> JSString.textToJSString s
+  JSString s -> s
+  AppendChoiceString x y -> appendChoiceString x y
+  EmptyChoiceString -> ""
+
+type DList a = [a] -> [a]
+
+appendChoiceString :: ChoiceString -> ChoiceString -> JSString
+appendChoiceString x y = JSString.concat ((go x . go y) [])
+  where
+    go :: ChoiceString -> DList JSString
+    go (AppendChoiceString a b) = go a . go b
+    go EmptyChoiceString = id
+    go s = (choiceStringToJs s :)
 
 -- | Render some 'Markup' to a virtual dom.
 --
@@ -165,8 +156,6 @@ render handleAct0 markup = do
             go handleAct setProps children h1
             go handleAct setProps children h2
       where
-        choiceStringToJs cs = JSString.pack (fromChoiceString cs "")
-
         -- setProperty :: JSString -> JSRef a -> MarkupM (EventHandler act') b -> IO ()
         setProperty key value content =
             go handleAct setProps' children content