Skip to content

Commit 15e24ef

Browse files
newhoggynewhoggy
committed
Convert to use Text rather than String
1 parent 5455df5 commit 15e24ef

File tree

13 files changed

+119
-86
lines changed

13 files changed

+119
-86
lines changed

‎app/App/Commands/Count.hs‎

Lines changed: 3 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -31,7 +31,6 @@ import Options.Applicative hiding (columns)
3131
import qualified App.Commands.Types as Z
3232
import qualified App.Naive as NAIVE
3333
import qualified App.XPath.Parser as XPP
34-
import qualified Data.Text as T
3534
import qualified System.Exit as IO
3635
import qualified System.IO as IO
3736

@@ -47,7 +46,7 @@ newtype Catalog = Catalog
4746
{ plants :: [Plant]
4847
} deriving (Eq, Show, Generic)
4948

50-
tags :: Value -> String -> [Value]
49+
tags :: Value -> Text -> [Value]
5150
tags xml@(XmlElement n _ _) elemName = if n == elemName
5251
then [xml]
5352
else []
@@ -59,9 +58,9 @@ kids _ = []
5958

6059
countAtPath :: [Text] -> Value -> DecodeResult Int
6160
countAtPath [] _ = return 0
62-
countAtPath [t] xml = return (length (tags xml (T.unpack t)))
61+
countAtPath [t] xml = return (length (tags xml t))
6362
countAtPath (t:ts) xml = do
64-
counts <- forM (tags xml (T.unpack t) >>= kids) $ countAtPath ts
63+
counts <- forM (tags xml t >>= kids) $ countAtPath ts
6564
return (sum counts)
6665

6766
runCount :: Z.CountOptions -> IO ()

‎app/App/Commands/Demo.hs‎

Lines changed: 5 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -13,6 +13,7 @@ module App.Commands.Demo
1313
import Data.Foldable
1414
import Data.Maybe
1515
import Data.Semigroup ((<>))
16+
import Data.Text (Text)
1617
import HaskellWorks.Data.TreeCursor
1718
import HaskellWorks.Data.Xml.Decode
1819
import HaskellWorks.Data.Xml.DecodeResult
@@ -29,10 +30,10 @@ import qualified App.Commands.Types as Z
2930
class ParseText a where
3031
parseText :: Value -> DecodeResult a
3132

32-
instance ParseText String where
33+
instance ParseText Text where
3334
parseText (XmlText text) = DecodeOk text
3435
parseText (XmlCData text) = DecodeOk text
35-
parseText (XmlElement _ _ cs) = DecodeOk $ concat $ concat $ toList . parseText <$> cs
36+
parseText (XmlElement _ _ cs) = DecodeOk $ mconcat $ mconcat $ toList . parseText <$> cs
3637
parseText _ = DecodeOk ""
3738

3839
-- | Convert a decode result to a maybe
@@ -44,8 +45,8 @@ decodeResultToMaybe _ = Nothing
4445
-- the data in the XML document. In fact, having a smaller model may improve
4546
-- query performance.
4647
data Plant = Plant
47-
{ common :: String
48-
, price :: String
48+
{ common :: Text
49+
, price :: Text
4950
} deriving (Eq, Show)
5051

5152
newtype Catalog = Catalog

‎hw-xml.cabal‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -81,6 +81,7 @@ library
8181
, mmap
8282
, mtl
8383
, resourcet
84+
, text
8485
, transformers
8586
, vector
8687
, word8
@@ -96,6 +97,7 @@ library
9697
HaskellWorks.Data.Xml.Internal.ByteString
9798
HaskellWorks.Data.Xml.Internal.Blank
9899
HaskellWorks.Data.Xml.Internal.List
100+
HaskellWorks.Data.Xml.Internal.Show
99101
HaskellWorks.Data.Xml.Internal.Tables
100102
HaskellWorks.Data.Xml.Internal.ToIbBp64
101103
HaskellWorks.Data.Xml.Internal.Words

‎src/HaskellWorks/Data/Xml/Decode.hs‎

Lines changed: 17 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -1,12 +1,16 @@
1+
{-# LANGUAGE OverloadedStrings #-}
2+
13
module HaskellWorks.Data.Xml.Decode where
24

35
import Control.Applicative
46
import Control.Lens
57
import Control.Monad
68
import Data.Foldable
7-
import Data.Semigroup ((<>))
9+
import Data.Semigroup ((<>))
10+
import Data.Text (Text)
811
import HaskellWorks.Data.Xml.DecodeError
912
import HaskellWorks.Data.Xml.DecodeResult
13+
import HaskellWorks.Data.Xml.Internal.Show
1014
import HaskellWorks.Data.Xml.Value
1115

1216
class Decode a where
@@ -16,39 +20,39 @@ instance Decode Value where
1620
decode = DecodeOk
1721
{-# INLINE decode #-}
1822

19-
failDecode :: String -> DecodeResult a
23+
failDecode :: Text -> DecodeResult a
2024
failDecode = DecodeFailed . DecodeError
2125

22-
(@>) :: Value -> String -> DecodeResult String
26+
(@>) :: Value -> Text -> DecodeResult Text
2327
(@>) (XmlElement _ as _) n = case find (\v -> fst v == n) as of
2428
Just (_, text) -> DecodeOk text
25-
Nothing -> failDecode $ "No such attribute " <> show n
26-
(@>) _ n = failDecode $ "Not an element whilst looking up attribute " <> show n
29+
Nothing -> failDecode $ "No such attribute " <> tshow n
30+
(@>) _ n = failDecode $ "Not an element whilst looking up attribute " <> tshow n
2731

28-
(/>) :: Value -> String -> DecodeResult Value
32+
(/>) :: Value -> Text -> DecodeResult Value
2933
(/>) (XmlElement _ _ cs) n = go cs
30-
where go [] = failDecode $ "Unable to find element " <> show n
34+
where go [] = failDecode $ "Unable to find element " <> tshow n
3135
go (r:rs) = case r of
3236
e@(XmlElement n' _ _) | n' == n -> DecodeOk e
3337
_ -> go rs
34-
(/>) _ n = failDecode $ "Expecting parent of element " <> show n
38+
(/>) _ n = failDecode $ "Expecting parent of element " <> tshow n
3539

3640
(?>) :: Value -> (Value -> DecodeResult Value) -> DecodeResult Value
3741
(?>) v f = f v <|> pure v
3842

39-
(~>) :: Value -> String -> DecodeResult Value
43+
(~>) :: Value -> Text -> DecodeResult Value
4044
(~>) e@(XmlElement n' _ _) n | n' == n = DecodeOk e
41-
(~>) _ n = failDecode $ "Expecting parent of element " <> show n
45+
(~>) _ n = failDecode $ "Expecting parent of element " <> tshow n
4246

43-
(/>>) :: Value -> String -> DecodeResult [Value]
47+
(/>>) :: Value -> Text -> DecodeResult [Value]
4448
(/>>) v n = v ^. childNodes <&> (~> n) <&> toList & join & pure
4549

4650
-- Contextful
4751

48-
(</>) :: DecodeResult Value -> String -> DecodeResult Value
52+
(</>) :: DecodeResult Value -> Text -> DecodeResult Value
4953
(</>) ma n = ma >>= (/> n)
5054

51-
(<@>) :: DecodeResult Value -> String -> DecodeResult String
55+
(<@>) :: DecodeResult Value -> Text -> DecodeResult Text
5256
(<@>) ma n = ma >>= (@> n)
5357

5458
(<?>) :: DecodeResult Value -> (Value -> DecodeResult Value) -> DecodeResult Value

‎src/HaskellWorks/Data/Xml/DecodeError.hs‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -4,6 +4,7 @@
44
module HaskellWorks.Data.Xml.DecodeError where
55

66
import Control.DeepSeq
7+
import Data.Text (Text)
78
import GHC.Generics
89

9-
newtype DecodeError = DecodeError String deriving (Eq, Show, Generic, NFData)
10+
newtype DecodeError = DecodeError Text deriving (Eq, Show, Generic, NFData)

‎src/HaskellWorks/Data/Xml/DecodeResult.hs‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,5 @@
1-
{-# LANGUAGE DeriveFunctor #-}
1+
{-# LANGUAGE DeriveFunctor #-}
2+
{-# LANGUAGE OverloadedStrings #-}
23

34
module HaskellWorks.Data.Xml.DecodeResult where
45

‎src/HaskellWorks/Data/Xml/Grammar.hs‎

Lines changed: 17 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -10,36 +10,39 @@ module HaskellWorks.Data.Xml.Grammar where
1010
import Control.Applicative
1111
import Data.Char
1212
import Data.String
13+
import Data.Text (Text)
1314
import Data.Word
14-
import HaskellWorks.Data.Parser as P
15+
import HaskellWorks.Data.Parser
1516

16-
import qualified Data.Attoparsec.Types as T
17+
import qualified Data.Attoparsec.Types as T
18+
import qualified Data.Text as T
19+
import qualified HaskellWorks.Data.Parser as P
1720

1821
data XmlElementType
1922
= XmlElementTypeDocument
20-
| XmlElementTypeElement String
23+
| XmlElementTypeElement Text
2124
| XmlElementTypeComment
2225
| XmlElementTypeCData
23-
| XmlElementTypeMeta String
26+
| XmlElementTypeMeta Text
2427

25-
parseXmlString :: (P.Parser t Word8) => T.Parser t String
28+
parseXmlString :: (P.Parser t Word8) => T.Parser t Text
2629
parseXmlString = do
2730
q <- satisfyChar (=='"') <|> satisfyChar (=='\'')
28-
many (satisfyChar (/= q))
31+
T.pack <$> many (satisfyChar (/= q))
2932

3033
parseXmlElement :: (P.Parser t Word8, IsString t) => T.Parser t XmlElementType
3134
parseXmlElement = comment <|> cdata <|> doc <|> meta <|> element
3235
where
33-
comment = const XmlElementTypeComment <$> string "!--"
34-
cdata = const XmlElementTypeCData <$> string "![CDATA["
35-
meta = XmlElementTypeMeta <$> (string "!" >> parseXmlToken)
36-
doc = const XmlElementTypeDocument <$> string "?xml"
37-
element = XmlElementTypeElement <$> parseXmlToken
36+
comment = const XmlElementTypeComment <$> string "!--"
37+
cdata = const XmlElementTypeCData <$> string "![CDATA["
38+
meta = XmlElementTypeMeta <$> (string "!" >> parseXmlToken)
39+
doc = const XmlElementTypeDocument <$> string "?xml"
40+
element = XmlElementTypeElement <$> parseXmlToken
3841

39-
parseXmlToken :: (P.Parser t Word8) => T.Parser t String
40-
parseXmlToken = many $ satisfyChar isNameChar <?> "invalid string character"
42+
parseXmlToken :: (P.Parser t Word8) => T.Parser t Text
43+
parseXmlToken = T.pack <$> many (satisfyChar isNameChar <?> "invalid string character")
4144

42-
parseXmlAttributeName :: (P.Parser t Word8) => T.Parser t String
45+
parseXmlAttributeName :: (P.Parser t Word8) => T.Parser t Text
4346
parseXmlAttributeName = parseXmlToken
4447

4548
isNameStartChar :: Char -> Bool

‎src/HaskellWorks/Data/Xml/Internal/Show.hs‎

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,10 @@
1+
module HaskellWorks.Data.Xml.Internal.Show
2+
( tshow
3+
) where
4+
5+
import Data.Text (Text)
6+
7+
import qualified Data.Text as T
8+
9+
tshow :: Show a => a -> Text
10+
tshow = T.pack . show

‎src/HaskellWorks/Data/Xml/Lens.hs‎

Lines changed: 4 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,11 +1,12 @@
11
module HaskellWorks.Data.Xml.Lens where
22

33
import Control.Lens
4+
import Data.Text (Text)
45
import HaskellWorks.Data.Xml.Value
56

6-
isTagNamed :: String -> Value -> Bool
7+
isTagNamed :: Text -> Value -> Bool
78
isTagNamed a (XmlElement b _ _) | a == b = True
8-
isTagNamed _ _ = False
9+
isTagNamed _ _ = False
910

10-
tagNamed :: (Applicative f, Choice p) => String -> Optic' p f Value Value
11+
tagNamed :: (Applicative f, Choice p) => Text -> Optic' p f Value Value
1112
tagNamed = filtered . isTagNamed

‎src/HaskellWorks/Data/Xml/RawValue.hs‎

Lines changed: 35 additions & 29 deletions
Original file line numberDiff line numberDiff line change
@@ -9,40 +9,44 @@ module HaskellWorks.Data.Xml.RawValue
99
, RawValueAt(..)
1010
) where
1111

12+
import Data.ByteString (ByteString)
1213
import Data.List
1314
import Data.Semigroup ((<>))
15+
import Data.Text (Text)
1416
import HaskellWorks.Data.Xml.Grammar
17+
import HaskellWorks.Data.Xml.Internal.Show
1518
import HaskellWorks.Data.Xml.Succinct.Index
1619
import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>))
1720

1821
import qualified Data.Attoparsec.ByteString.Char8 as ABC
1922
import qualified Data.ByteString as BS
23+
import qualified Data.Text as T
2024

2125
data RawValue
2226
= RawDocument [RawValue]
23-
| RawText String
24-
| RawElement String [RawValue]
25-
| RawCData String
26-
| RawComment String
27-
| RawMeta String [RawValue]
28-
| RawAttrName String
29-
| RawAttrValue String
27+
| RawText Text
28+
| RawElement Text [RawValue]
29+
| RawCData Text
30+
| RawComment Text
31+
| RawMeta Text [RawValue]
32+
| RawAttrName Text
33+
| RawAttrValue Text
3034
| RawAttrList [RawValue]
31-
| RawError String
35+
| RawError Text
3236
deriving (Eq, Show)
3337

3438
instance Pretty RawValue where
3539
pretty mjpv = case mjpv of
36-
RawText s -> ctext $ text s
37-
RawAttrName s -> text s
38-
RawAttrValue s -> (ctext . dquotes . text) s
40+
RawText s -> ctext $ text (T.unpack s)
41+
RawAttrName s -> text (T.unpack s)
42+
RawAttrValue s -> (ctext . dquotes . text) (T.unpack s)
3943
RawAttrList ats -> formatAttrs ats
4044
RawComment s -> text $ "<!-- " <> show s <> "-->"
41-
RawElement s xs -> formatElem s xs
45+
RawElement s xs -> formatElem (T.unpack s) xs
4246
RawDocument xs -> formatMeta "?" "xml" xs
43-
RawError s -> red $ text "[error " <> text s <> text "]"
44-
RawCData s -> cangle "<!" <> ctag (text "[CDATA[") <> text s <> cangle (text "]]>")
45-
RawMeta s xs -> formatMeta "!" s xs
47+
RawError s -> red $ text "[error " <> text (T.unpack s) <> text "]"
48+
RawCData s -> cangle "<!" <> ctag (text "[CDATA[") <> text (T.unpack s) <> cangle (text "]]>")
49+
RawMeta s xs -> formatMeta "!" (T.unpack s) xs
4650
where
4751
formatAttr at = case at of
4852
RawAttrName a -> text " " <> pretty (RawAttrName a)
@@ -69,28 +73,31 @@ class RawValueAt a where
6973

7074
instance RawValueAt XmlIndex where
7175
rawValueAt i = case i of
72-
XmlIndexCData s -> parseTextUntil "]]>" s `as` RawCData
73-
XmlIndexComment s -> parseTextUntil "-->" s `as` RawComment
74-
XmlIndexMeta s cs -> RawMeta s (rawValueAt <$> cs)
75-
XmlIndexElement s cs -> RawElement s (rawValueAt <$> cs)
76-
XmlIndexDocument cs -> RawDocument (rawValueAt <$> cs)
77-
XmlIndexAttrName cs -> parseAttrName cs `as` RawAttrName
78-
XmlIndexAttrValue cs -> parseString cs `as` RawAttrValue
76+
XmlIndexCData s -> parseTextUntil "]]>" s `as` (RawCData . T.pack)
77+
XmlIndexComment s -> parseTextUntil "-->" s `as` (RawComment . T.pack)
78+
XmlIndexMeta s cs -> RawMeta s (rawValueAt <$> cs)
79+
XmlIndexElement s cs -> RawElement s (rawValueAt <$> cs)
80+
XmlIndexDocument cs -> RawDocument (rawValueAt <$> cs)
81+
XmlIndexAttrName cs -> parseAttrName cs `as` RawAttrName
82+
XmlIndexAttrValue cs -> parseString cs `as` RawAttrValue
7983
XmlIndexAttrList cs -> RawAttrList (rawValueAt <$> cs)
80-
XmlIndexValue s -> parseTextUntil "<" s `as` RawText
84+
XmlIndexValue s -> parseTextUntil "<" s `as` (RawText . T.pack)
8185
XmlIndexError s -> RawError s
8286
--unknown -> XmlError ("Not yet supported: " <> show unknown)
8387
where
8488
parseUntil s = ABC.manyTill ABC.anyChar (ABC.string s)
8589

90+
parseTextUntil :: ByteString -> ByteString -> Either Text [Char]
8691
parseTextUntil s bs = case ABC.parse (parseUntil s) bs of
87-
ABC.Fail {} -> decodeErr ("Unable to find " <> show s <> ".") bs
88-
ABC.Partial _ -> decodeErr ("Unexpected end, expected " <> show s <> ".") bs
92+
ABC.Fail {} -> decodeErr ("Unable to find " <> tshow s <> ".") bs
93+
ABC.Partial _ -> decodeErr ("Unexpected end, expected " <> tshow s <> ".") bs
8994
ABC.Done _ r -> Right r
95+
parseString :: ByteString -> Either Text Text
9096
parseString bs = case ABC.parse parseXmlString bs of
9197
ABC.Fail {} -> decodeErr "Unable to parse string" bs
9298
ABC.Partial _ -> decodeErr "Unexpected end of string, expected" bs
9399
ABC.Done _ r -> Right r
100+
parseAttrName :: ByteString -> Either Text Text
94101
parseAttrName bs = case ABC.parse parseXmlAttributeName bs of
95102
ABC.Fail {} -> decodeErr "Unable to parse attribute name" bs
96103
ABC.Partial _ -> decodeErr "Unexpected end of attr name, expected" bs
@@ -116,9 +123,8 @@ isAttr v = case v of
116123
RawAttrList _ -> True
117124
_ -> False
118125

119-
as :: Either String a -> (a -> RawValue) -> RawValue
126+
as :: Either Text a -> (a -> RawValue) -> RawValue
120127
as = flip $ either RawError
121128

122-
decodeErr :: String -> BS.ByteString -> Either String a
123-
decodeErr reason bs =
124-
Left $ reason <>" (" <> show (BS.take 20 bs) <> "...)"
129+
decodeErr :: Text -> BS.ByteString -> Either Text a
130+
decodeErr reason bs = Left $ reason <> " (" <> tshow (BS.take 20 bs) <> "...)"

0 commit comments

Comments
 (0)