From 22e2f33fd59698858dfef1a74bacef627ceb97e9 Mon Sep 17 00:00:00 2001 From: David Waern Date: Wed, 28 Oct 2015 11:54:40 +0100 Subject: [PATCH] Support JSString in ChoiceString when compiling with ghcjs --- .../blaze-react-core/blaze-react-core.cabal | 52 ++++++++++----- .../src/Blaze/React/Markup.hs | 18 ++++- .../src/Blaze/React/Markup/Internal.hs | 65 +++++++++++++++++-- .../src/Blaze/React/Markup/Renderer/String.hs | 9 ++- .../src/Blaze/React/Html5/Renderer/ReactJS.hs | 47 +++++--------- 5 files changed, 139 insertions(+), 52 deletions(-) diff --git a/libs/hs/blaze-react-core/blaze-react-core.cabal b/libs/hs/blaze-react-core/blaze-react-core.cabal index 214b6a6..b4ab614 100644 --- a/libs/hs/blaze-react-core/blaze-react-core.cabal +++ b/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 diff --git a/libs/hs/blaze-react-core/src/Blaze/React/Markup.hs b/libs/hs/blaze-react-core/src/Blaze/React/Markup.hs index 2a7a255..d34fb28 100644 --- a/libs/hs/blaze-react-core/src/Blaze/React/Markup.hs +++ b/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 #-} diff --git a/libs/hs/blaze-react-core/src/Blaze/React/Markup/Internal.hs b/libs/hs/blaze-react-core/src/Blaze/React/Markup/Internal.hs index dfd7ffc..799374e 100644 --- a/libs/hs/blaze-react-core/src/Blaze/React/Markup/Internal.hs +++ b/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 diff --git a/libs/hs/blaze-react-core/src/Blaze/React/Markup/Renderer/String.hs b/libs/hs/blaze-react-core/src/Blaze/React/Markup/Renderer/String.hs index 27d0a93..fb6e7be 100644 --- a/libs/hs/blaze-react-core/src/Blaze/React/Markup/Renderer/String.hs +++ b/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 diff --git a/libs/hs/blaze-react-spa/src/Blaze/React/Html5/Renderer/ReactJS.hs b/libs/hs/blaze-react-spa/src/Blaze/React/Html5/Renderer/ReactJS.hs index cd16d41..37c9234 100644 --- a/libs/hs/blaze-react-spa/src/Blaze/React/Html5/Renderer/ReactJS.hs +++ b/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 " if " if " T.foldr (:) k s) --- ByteString s -> if " 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