-----------------------------------------------------------------------------
{-# LANGUAGE CPP                  #-}
{-# LANGUAGE LambdaCase           #-}
{-# LANGUAGE FlexibleInstances    #-}
-----------------------------------------------------------------------------
{-# OPTIONS_GHC -fno-warn-orphans #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Miso.String
-- Copyright   :  (C) 2016-2025 David M. Johnson
-- License     :  BSD3-style (see the file LICENSE)
-- Maintainer  :  David M. Johnson <code@dmj.io>
-- Stability   :  experimental
-- Portability :  non-portable
----------------------------------------------------------------------------
module Miso.String (
    ToMisoString (..)
  , FromMisoString (..)
  , fromMisoString
  , MisoString
  , module Data.JSString
  , module Data.Monoid
  , ms
  ) where
----------------------------------------------------------------------------
import           Control.Exception (SomeException)
#ifdef GHCJS_BOTH
import           Data.Aeson
#endif
import qualified Data.ByteString         as B
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Lazy    as BL
import           Data.Char
import           Data.JSString
import qualified Data.JSString as JS
import           Data.JSString.Text
import           Data.Monoid
import qualified Data.Text               as T
import qualified Data.Text.Encoding      as T
import qualified Data.Text.Lazy          as LT
import qualified Data.Text.Lazy.Encoding as LT
import           Language.Javascript.JSaddle (MakeArgs (..), toJSVal)
import           Prelude                 hiding (foldr)
import           Text.StringLike         (StringLike(..))
----------------------------------------------------------------------------
-- | String type swappable based on compiler
type MisoString = JS.JSString
----------------------------------------------------------------------------
instance MakeArgs JS.JSString where
  makeArgs :: JSString -> JSM [JSVal]
makeArgs JSString
arg = (JSVal -> [JSVal] -> [JSVal]
forall a. a -> [a] -> [a]
:[]) (JSVal -> [JSVal]) -> JSM JSVal -> JSM [JSVal]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSString -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal JSString
arg
----------------------------------------------------------------------------
#ifdef GHCJS_BOTH
-- | `ToJSON` for `MisoString`
instance ToJSON MisoString where
  toJSON = String . textFromJSString
----------------------------------------------------------------------------
-- | `FromJSON` for `MisoString`
instance FromJSON MisoString where
  parseJSON =
    withText "Not a valid string" $ \x ->
      pure (toMisoString x)
#endif
----------------------------------------------------------------------------
-- | Convenience class for creating `MisoString` from other string-like types
class ToMisoString str where
  toMisoString :: str -> MisoString
----------------------------------------------------------------------------
-- | Class used to parse a 'MisoString'. Like a safe 'Read' for 'MisoString'
class FromMisoString t where
  fromMisoStringEither :: MisoString -> Either String t
----------------------------------------------------------------------------
-- | Reads a 'MisoString', throws an error when decoding
-- fails. Use `fromMisoStringEither` for as a safe alternative.
fromMisoString :: FromMisoString a => MisoString -> a
fromMisoString :: forall a. FromMisoString a => JSString -> a
fromMisoString JSString
s =
  case JSString -> Either String a
forall t. FromMisoString t => JSString -> Either String t
fromMisoStringEither JSString
s of
    Left String
err -> String -> a
forall a. HasCallStack => String -> a
error String
err
    Right a
x  -> a
x
----------------------------------------------------------------------------
-- | Convenience function, shorthand for `toMisoString`
ms :: ToMisoString str => str -> MisoString
ms :: forall str. ToMisoString str => str -> JSString
ms = str -> JSString
forall str. ToMisoString str => str -> JSString
toMisoString
----------------------------------------------------------------------------
instance ToMisoString MisoString where
  toMisoString :: JSString -> JSString
toMisoString = JSString -> JSString
forall a. a -> a
id
----------------------------------------------------------------------------
instance ToMisoString SomeException where
  toMisoString :: SomeException -> JSString
toMisoString = String -> JSString
forall str. ToMisoString str => str -> JSString
toMisoString (String -> JSString)
-> (SomeException -> String) -> SomeException -> JSString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall a. Show a => a -> String
show
----------------------------------------------------------------------------
instance ToMisoString String where
  toMisoString :: String -> JSString
toMisoString = String -> JSString
JS.pack
----------------------------------------------------------------------------
instance ToMisoString T.Text where
  toMisoString :: Text -> JSString
toMisoString = Text -> JSString
textToJSString
----------------------------------------------------------------------------
instance ToMisoString LT.Text where
  toMisoString :: Text -> JSString
toMisoString = Text -> JSString
lazyTextToJSString
instance ToMisoString B.ByteString where
  toMisoString :: ByteString -> JSString
toMisoString = Text -> JSString
forall str. ToMisoString str => str -> JSString
toMisoString (Text -> JSString)
-> (ByteString -> Text) -> ByteString -> JSString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
T.decodeUtf8
----------------------------------------------------------------------------
instance ToMisoString BL.ByteString where
  toMisoString :: ByteString -> JSString
toMisoString = Text -> JSString
forall str. ToMisoString str => str -> JSString
toMisoString (Text -> JSString)
-> (ByteString -> Text) -> ByteString -> JSString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
LT.decodeUtf8
----------------------------------------------------------------------------
instance ToMisoString B.Builder where
  toMisoString :: Builder -> JSString
toMisoString = ByteString -> JSString
forall str. ToMisoString str => str -> JSString
toMisoString (ByteString -> JSString)
-> (Builder -> ByteString) -> Builder -> JSString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
B.toLazyByteString
----------------------------------------------------------------------------
instance ToMisoString Float where
  toMisoString :: Float -> JSString
toMisoString = String -> JSString
JS.pack (String -> JSString) -> (Float -> String) -> Float -> JSString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> String
forall a. Show a => a -> String
show
----------------------------------------------------------------------------
instance ToMisoString Double where
  toMisoString :: Double -> JSString
toMisoString = String -> JSString
JS.pack (String -> JSString) -> (Double -> String) -> Double -> JSString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> String
forall a. Show a => a -> String
show
----------------------------------------------------------------------------
instance ToMisoString Int where
  toMisoString :: Int -> JSString
toMisoString = String -> JSString
JS.pack (String -> JSString) -> (Int -> String) -> Int -> JSString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show
----------------------------------------------------------------------------
instance ToMisoString Word where
  toMisoString :: Word -> JSString
toMisoString = String -> JSString
JS.pack (String -> JSString) -> (Word -> String) -> Word -> JSString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> String
forall a. Show a => a -> String
show
----------------------------------------------------------------------------
instance FromMisoString MisoString where
  fromMisoStringEither :: JSString -> Either String JSString
fromMisoStringEither = JSString -> Either String JSString
forall a b. b -> Either a b
Right
----------------------------------------------------------------------------
instance FromMisoString String where
  fromMisoStringEither :: JSString -> Either String String
fromMisoStringEither = String -> Either String String
forall a b. b -> Either a b
Right (String -> Either String String)
-> (JSString -> String) -> JSString -> Either String String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSString -> String
JS.unpack
----------------------------------------------------------------------------
instance FromMisoString T.Text where
  fromMisoStringEither :: JSString -> Either String Text
fromMisoStringEither = Text -> Either String Text
forall a b. b -> Either a b
Right (Text -> Either String Text)
-> (JSString -> Text) -> JSString -> Either String Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSString -> Text
textFromJSString
----------------------------------------------------------------------------
instance FromMisoString LT.Text where
  fromMisoStringEither :: JSString -> Either String Text
fromMisoStringEither = Text -> Either String Text
forall a b. b -> Either a b
Right (Text -> Either String Text)
-> (JSString -> Text) -> JSString -> Either String Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSString -> Text
lazyTextFromJSString
----------------------------------------------------------------------------
instance FromMisoString B.ByteString where
  fromMisoStringEither :: JSString -> Either String ByteString
fromMisoStringEither = (Text -> ByteString)
-> Either String Text -> Either String ByteString
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> ByteString
T.encodeUtf8 (Either String Text -> Either String ByteString)
-> (JSString -> Either String Text)
-> JSString
-> Either String ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSString -> Either String Text
forall t. FromMisoString t => JSString -> Either String t
fromMisoStringEither
----------------------------------------------------------------------------
instance FromMisoString BL.ByteString where
  fromMisoStringEither :: JSString -> Either String ByteString
fromMisoStringEither = (Text -> ByteString)
-> Either String Text -> Either String ByteString
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> ByteString
LT.encodeUtf8 (Either String Text -> Either String ByteString)
-> (JSString -> Either String Text)
-> JSString
-> Either String ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSString -> Either String Text
forall t. FromMisoString t => JSString -> Either String t
fromMisoStringEither
----------------------------------------------------------------------------
instance FromMisoString B.Builder where
  fromMisoStringEither :: JSString -> Either String Builder
fromMisoStringEither = (ByteString -> Builder)
-> Either String ByteString -> Either String Builder
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Builder
B.byteString (Either String ByteString -> Either String Builder)
-> (JSString -> Either String ByteString)
-> JSString
-> Either String Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSString -> Either String ByteString
forall t. FromMisoString t => JSString -> Either String t
fromMisoStringEither
----------------------------------------------------------------------------
instance FromMisoString Float where
  fromMisoStringEither :: JSString -> Either String Float
fromMisoStringEither = (Double -> Float) -> Either String Double -> Either String Float
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Double -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Either String Double -> Either String Float)
-> (JSString -> Either String Double)
-> JSString
-> Either String Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSString -> Either String Double
jsStringToDoubleEither
----------------------------------------------------------------------------
instance FromMisoString Double where
  fromMisoStringEither :: JSString -> Either String Double
fromMisoStringEither = JSString -> Either String Double
jsStringToDoubleEither
----------------------------------------------------------------------------
instance FromMisoString Int where
  fromMisoStringEither :: JSString -> Either String Int
fromMisoStringEither = JSString -> Either String Int
parseInt
----------------------------------------------------------------------------
instance FromMisoString Word where
  fromMisoStringEither :: JSString -> Either String Word
fromMisoStringEither = JSString -> Either String Word
parseWord
----------------------------------------------------------------------------
jsStringToDoubleEither :: JS.JSString -> Either String Double
jsStringToDoubleEither :: JSString -> Either String Double
jsStringToDoubleEither JSString
s = let d :: Double
d = String -> Double
forall a. Read a => String -> a
read (String -> Double) -> String -> Double
forall a b. (a -> b) -> a -> b
$ JSString -> String
JS.unpack JSString
s
                           in if Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
d then String -> Either String Double
forall a b. a -> Either a b
Left String
"jsStringToDoubleEither: parse failed"
                                         else Double -> Either String Double
forall a b. b -> Either a b
Right Double
d
----------------------------------------------------------------------------
parseWord :: MisoString -> Either String Word
parseWord :: JSString -> Either String Word
parseWord JSString
s = case JSString -> Maybe (Char, JSString)
JS.uncons JSString
s of
                Maybe (Char, JSString)
Nothing     -> String -> Either String Word
forall a b. a -> Either a b
Left String
"parseWord: parse error"
                Just (Char
c,JSString
s') -> (Either String Word -> Char -> Either String Word)
-> Either String Word -> JSString -> Either String Word
forall a. (a -> Char -> a) -> a -> JSString -> a
JS.foldl' Either String Word -> Char -> Either String Word
forall {b}. Num b => Either String b -> Char -> Either String b
k (Char -> Either String Word
forall {b}. Num b => Char -> Either String b
pDigit Char
c) JSString
s'
  where
    pDigit :: Char -> Either String b
pDigit Char
c | Char -> Bool
isDigit Char
c = b -> Either String b
forall a b. b -> Either a b
Right (b -> Either String b) -> (Char -> b) -> Char -> Either String b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> b) -> (Char -> Int) -> Char -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
digitToInt (Char -> Either String b) -> Char -> Either String b
forall a b. (a -> b) -> a -> b
$ Char
c
             | Bool
otherwise = String -> Either String b
forall a b. a -> Either a b
Left String
"parseWord: parse error"
    k :: Either String b -> Char -> Either String b
k Either String b
ea Char
c = (\b
a b
x -> b
10b -> b -> b
forall a. Num a => a -> a -> a
*b
a b -> b -> b
forall a. Num a => a -> a -> a
+ b
x) (b -> b -> b) -> Either String b -> Either String (b -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either String b
ea Either String (b -> b) -> Either String b -> Either String b
forall a b.
Either String (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Char -> Either String b
forall {b}. Num b => Char -> Either String b
pDigit Char
c
----------------------------------------------------------------------------
parseInt   :: MisoString -> Either String Int
parseInt :: JSString -> Either String Int
parseInt JSString
s = case JSString -> Maybe (Char, JSString)
JS.uncons JSString
s of
               Just (Char
'-',JSString
s') -> ((-Int
1)Int -> Int -> Int
forall a. Num a => a -> a -> a
*) (Int -> Int) -> (Word -> Int) -> Word -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Int) -> Either String Word -> Either String Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSString -> Either String Word
parseWord JSString
s'
               Maybe (Char, JSString)
_             ->           Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Int) -> Either String Word -> Either String Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSString -> Either String Word
parseWord JSString
s
----------------------------------------------------------------------------
instance StringLike MisoString where
  uncons :: JSString -> Maybe (Char, JSString)
uncons = JSString -> Maybe (Char, JSString)
JS.uncons
  toString :: JSString -> String
toString = JSString -> String
JS.unpack
  fromChar :: Char -> JSString
fromChar = Char -> JSString
JS.singleton
  strConcat :: [JSString] -> JSString
strConcat = [JSString] -> JSString
JS.concat
  empty :: JSString
empty = JSString
JS.empty
  strNull :: JSString -> Bool
strNull = JSString -> Bool
JS.null
  cons :: Char -> JSString -> JSString
cons = Char -> JSString -> JSString
JS.cons
  append :: JSString -> JSString -> JSString
append = JSString -> JSString -> JSString
JS.append
  strMap :: (Char -> Char) -> JSString -> JSString
strMap = (Char -> Char) -> JSString -> JSString
JS.map
----------------------------------------------------------------------------