string-interpolate 0.2.0.3 → 0.2.1.0
raw patch · 15 files changed
+1609/−1063 lines, 15 filesdep +Interpolationdep +deepseqdep +interpolatedstring-perl6dep −random-shuffledep ~basedep ~neat-interpolationdep ~template-haskell
Dependencies added: Interpolation, deepseq, interpolatedstring-perl6, split
Dependencies removed: random-shuffle
Dependency ranges changed: base, neat-interpolation, template-haskell
Files
- CHANGELOG.md +12/−0
- LICENSE +1/−1
- README.md +75/−43
- bench/Bench.hs +0/−210
- bench/bench.hs +229/−0
- src/lib/Data/String/Interpolate.hs +195/−36
- src/lib/Data/String/Interpolate/Conversion.hs +14/−261
- src/lib/Data/String/Interpolate/Conversion/ByteStringSink.hs +215/−0
- src/lib/Data/String/Interpolate/Conversion/Classes.hs +59/−0
- src/lib/Data/String/Interpolate/Conversion/Encoding.hs +37/−0
- src/lib/Data/String/Interpolate/Conversion/TextSink.hs +185/−0
- src/lib/Data/String/Interpolate/Parse.hs +59/−14
- string-interpolate.cabal +46/−8
- test/Spec.hs +0/−490
- test/spec.hs +482/−0
CHANGELOG.md view
@@ -2,6 +2,18 @@ ## Unreleased +## v0.2.1.0 (2020-05-04)+++ Added benchmarks for lazy Text and lazy ByteString++ Changed default behavior for Text and ByteString to use the actual types+ themselves as intermediate objects rather than construct Builders. This+ should give significant speedups in the common case of interpolating+ smaller outputs. Old behavior can be reenabled using Cabal+ flags `-ftext-builder` and `-fbytestring-builder`++ Gated benchmarks for `Interpolation` and `interpolatedstring-perl6` behind+ a Cabal flag so that we can still be in Stackage without needing to remove+ these dependencies+ ## v0.2.0.3 (2020-04-26) + Commented out `interpolatedstring-perl6` benchmarks, since that library
LICENSE view
@@ -1,4 +1,4 @@-Copyright William Yao (c) 2019+Copyright William Yao (c) 2019-2020 All rights reserved.
README.md view
@@ -25,6 +25,11 @@ instance of `IsString`, and can interpolate anything which is an instance of `Show`. +In addition to the main quasiquoter `i`, there are two additional quasiquoters+for handling multiline strings. If you need to remove extra whitespace and+collapse into a single line, use `iii`. If you need to remove extra indentation+but keep linebreaks, use `__i`.+ ## Unicode handling **string-interpolate** handles converting to/from Unicode when converting@@ -39,14 +44,14 @@ between ByteString and real textual types so that developers don't need to constantly be aware of text encodings. -When converting a String/Text to a ByteString, string-interpolate will+When converting a String/Text to a ByteString, **string-interpolate** will automatically encode it as a sequence of UTF-8 bytes. When converting a ByteString to String/Text, string-interpolate will assume that the ByteString contains a UTF-8 string, and convert the characters accordingly. Any invalid characters in the ByteString will be converted to the Unicode replacement character � (U+FFFD). -Remember: string-interpolate is not designed for 100% correctness around text+Remember: **string-interpolate** is not designed for 100% correctness around text encodings, just for convenience in the most common case. If you absolutely need to be aware of text encodings and to handle decode failures, take a look at [text-conversions](https://hackage.haskell.org/package/text-conversions).@@ -131,11 +136,11 @@ >>> "\n a\n b\n c\n" ``` -A second quasiquoter, `iii`, is provided that handles multiline strings/whitespace+Another quasiquoter, `iii`, is provided that handles multiline strings/whitespace in a different way, by collapsing any whitespace into a single space. The intention is to use it when you want to split something across multiple lines in source for readability but want it emitted like a normal sentence.-`iii` is otherwise identical to `i`.+`iii` is otherwise identical to `i`, with the ability to interpolate arbitrary values. ```haskell λ> :{@@ -150,9 +155,27 @@ >>> "Lorum ipsum dolor sit amet." ``` -A pnemonic for remembering what `iii` does is to look at the i's as individual-lines which have been collapsed into a single line.+One last quasiquoter, `__i`, is provided that handles removing indentation+without removing line breaks, perhaps if you need to output code samples+or error messages. Again, `__i` is otherwise identical to `i`, with the ability+to interpolate arbitrary values. +```haskell+λ> :{+ | [__i|+ | id :: a -> a+ | id x = y+ | where y = x+ | |] :: String+ | :}+>>> "id :: a -> a\nid x = y\n where y = x"+```++The intended pnemonics for remembering what `iii` and `__i` do:++* `iii`: Look at the i's as individual lines which have been collapsed into a single line+* `__i`: Look at the i as being indented+ Backslashes are handled exactly the same way they are in normal Haskell strings. If you need to put a literal `#{` into your string, prefix the pound symbol with a backslash:@@ -166,16 +189,16 @@ Some other interpolation libraries available: -* [interpolate](https://hackage.haskell.org/package/interpolate)-* [formatting](https://hackage.haskell.org/package/formatting)-* Text.Printf, from base-* [neat-interpolation](https://hackage.haskell.org/package/neat-interpolation)-* [Interpolation](http://hackage.haskell.org/package/Interpolation)-* [interpolatedstring-perl6](http://hackage.haskell.org/package/interpolatedstring-perl6-1.0.1)+* [**interpolate**](https://hackage.haskell.org/package/interpolate)+* [**formatting**](https://hackage.haskell.org/package/formatting)+* **Text.Printf**, from base+* [**neat-interpolation**](https://hackage.haskell.org/package/neat-interpolation)+* [**Interpolation**](http://hackage.haskell.org/package/Interpolation)+* [**interpolatedstring-perl6**](http://hackage.haskell.org/package/interpolatedstring-perl6-1.0.1) -Of these, Text.Printf isn't exception-safe, and neat-interpolation can only-produce Text values. interpolate, formatting, Interpolation, and-interpolatedstring-perl6 provide different solutions to the problem of+Of these, **Text.Printf** isn't exception-safe, and **neat-interpolation** can only+produce strict Text values. **interpolate**, **formatting**, **Interpolation**, and+**interpolatedstring-perl6** provide different solutions to the problem of providing a general way of interpolating any value, into any kind of text. ### Features@@ -187,56 +210,65 @@ | Can interpolate arbitrary Show instances | ✅ | ✅ | ✅ | ✅ | ✅ | ❌ | | Unicode-aware | ✅ | ❌ | ⚠️ | ❌ | ❌ | ⚠️ | | Multiline strings | ✅ | ✅ | ✅ | ✅ | ✅ | ✅ |-| Indentation handling | ❌ | ❌ | ❌ | ✅ | ❌ | ✅ |+| Indentation handling | ✅ | ❌ | ❌ | ✅ | ❌ | ✅ | | Whitespace/newline chomping | ✅ | ❌ | ❌ | ❌ | ❌ | ❌ | -⚠ Since `formatting` doesn't support ByteStrings, it technically supports+⚠ Since **formatting** doesn't support ByteStrings, it technically supports Unicode. -⚠ `Interpolation` supports all five textual formats, but doesn't allow you+⚠ **Interpolation** supports all five textual formats, but doesn't allow you to mix and match; that is, you can't interpolate a String into an output string of type Text, and vice versa. -⚠ `neat-interpolation` only supports `Text`. Because of that, it technically+⚠ **neat-interpolation** only supports strict Text. Because of that, it technically supports Unicode. ### Performance Overall: **string-interpolate** is competitive with the fastest interpolation-libraries, only getting outperformed by **Interpolation** and-**interpolatedstring-perl6**, and even then mostly on ByteStrings. Since-these two libraries don't handle Unicode and **string-interpolate** converts-things to UTF-8, some slowdown is to be expected here.+libraries, only getting outperformed on ByteStrings by **Interpolation** and+**interpolatedstring-perl6**, and on large, strict Text specifically by **formatting**. We run three benchmarks: small string interpolation (<100 chars) with a single interpolation parameter; small strings with multiple interpolation parameters,-and large string (~100KB) interpolation. Each of these benchmarks is then-run against `String`, strict `Text`, and strict `ByteString`. Numbers are runtime-in relation to string-interpolate; smaller is better.+and large string (~100KB) interpolation. Each of these benchmarks is then run+against `String`, both `Text` types, and both `ByteString` types. Numbers are+runtime in relation to string-interpolate; smaller is better. -| | **string-interpolate** | **interpolate** | **formatting** | **Interpolation** | **interpolatedstring-perl6** | **neat-interpolation** |-|--------------------------|------------------------|-----------------|----------------|-------------------|------------------------------|------------------------|-| small String | 1x | 1x | 2x | 1x | 1x | N/A |-| multi interp, String | 1x | 7x | 2.3x | 0.63x | 0.63x | N/A |-| small Text | 1x | 28x | 1.5x | 2.2x | 2.2x | 3.3x |-| multi interp, Text | 1x | 22x | 1.6x | 2.9x | 2.9x | 3.0x |-| large Text | 1x | 30,000x | 1x | 80x | 80x | 102x |-| small ByteString | 1x | 15x | N/A | 0.35x | 0.35x | N/A |-| multi interp, ByteString | 1x | 10x | N/A | 0.5x | 0.5x | N/A |-| large ByteString | 1x | 100,000x | N/A | 1.6x | 1.6x | N/A |+| | **string-interpolate** | **formatting** | **Interpolation** | **interpolatedstring-perl6** | **neat-interpolation** | **interpolate** |+|-------------------------------|------------------------|----------------|-------------------|------------------------------|------------------------|-----------------|+| small String | 1x | 2.8x | 1x | 1x | | 1x |+| multi interp, String | 1x | 4.3x | 1x | 1x | | 7.9x |+| small Text | 1x | 4.3x | 1.8x | 1.9x | 5.8x | 61x |+| multi interp, Text | 1x | 3.5x | 5.3x | 5.3x | 3.3x | 29x |+| large Text | 1x | 0.6x | 11x | 11x | 22x | 10,000x |+| small lazy Text | 1x | 6.1x | 14.5x | 14.5x | | 93x |+| multi interp, lazy Text | 1x | 3.7x | 5.8x | 6x | | 34x |+| large lazy Text | 1x | 3.9x | 22,000x | 22,000x | | 3,500,000x |+| small ByteString | 1x | | 1x | 1x | | 47x |+| multi interp, ByteString | 1x | | 0.7x | 0.7x | | 17x |+| large ByteString | 1x | | 1x | 1x | | 31,000x |+| small lazy ByteString | 1x | | 1x | 1x | | 85x |+| multi interp, lazy ByteString | 1x | | 0.4x | 0.4x | | 19x |+| large lazy ByteString | 1x | | 0.8x | 0.8x | | 1,300,000x | (We don't bother running tests on large `String`s, because no one is working with data that large using `String` anyways.) In particular, notice that **Interpolation** and **interpolatedstring-perl6**-blow up on large Text; **string-interpolation** and **formatting** have+blow up on both Text types; **string-interpolate** and **formatting** have consistent performance across all benchmarks, with string-interpolation leading the pack in `Text` cases. -All results were tested on my local machine. If you'd like to attempt to replicate-the results, the benchmarks are in `bench/` and can be run with a simple-`stack bench`.+All results were tested on an AWS EC2 `t2.medium`, with GHC 8.6.5. If you'd+like to replicate the results, the benchmarks are located in `bench/`, and can+be run with `cabal v2-run string-interpolate-bench -O2 -fextended-benchmarks`. -(NB: If you're attempting to reproduce these benchmarks, note that the-benchmarks for **Interpolation** and **interpolatedstring-perl6** are commented-out by default, due to those packages not being in latest Stackage.)+#### Larger Text and ByteString++By default, **string-interpolate** is performance tuned for outputting smaller+strings. If you find yourself regularly needing extremely large outputs, however,+you can change the way output strings are constructed to optimize accordingly.+Enable either the `text-builder` or `bytestring-builder` Cabal flag, depending+on your need, and you should see speedups constructing large strings, at the+cost of slowing down smaller outputs.
− bench/Bench.hs
@@ -1,210 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE QuasiQuotes #-}--import Criterion ( bench, bgroup, env, nf )-import Criterion.Main ( defaultMain )--import qualified Data.ByteString as B-import qualified Data.Text as T--import qualified "string-interpolate" Data.String.Interpolate as SI-import qualified "interpolate" Data.String.Interpolate.IsString as I--- import "Interpolation" Data.String.Interpolation as N-import "formatting" Formatting ( (%) )-import qualified "formatting" Formatting as F-import qualified "formatting" Formatting.ShortFormatters as F--- import "interpolatedstring-perl6" Text.InterpolatedString.Perl6 as P-import qualified "neat-interpolation" NeatInterpolation as NI--import Test.QuickCheck------------------------------------------------------------------------------------- Interpolating Strings-----------------------------------------------------------------------------------stringSI :: String -> String-stringSI str = [SI.i|A fine day to die, #{str}.|]--stringI :: String -> String-stringI str = [I.i|A fine day to die, #{str}.|]--stringF :: String -> String-stringF = F.formatToString ("A fine day to die, " % F.s % ".")---- stringN :: String -> String--- stringN s = [str|A fine day to die, $s$.|]---- stringP :: String -> String--- stringP str = [qc|A fine day to die, {str}.|]------------------------------------------------------------------------------------- Interpolating Text-----------------------------------------------------------------------------------textSI :: T.Text -> T.Text-textSI t = [SI.i|A fine day to die, #{t}.|]--textI :: T.Text -> T.Text-textI t = [I.i|A fine day to die, #{t}.|]--textF :: T.Text -> T.Text-textF = F.sformat ("A fine day to die, " % F.st % ".")---- textN :: T.Text -> T.Text--- textN t = [str|A fine day to die, $t$.|]---- textP :: T.Text -> T.Text--- textP t = [qc|A fine day to die, {t}.|]--textNI :: T.Text -> T.Text-textNI t = [NI.text|A fine day to die, $t.|]------------------------------------------------------------------------------------- Interpolating ByteString-----------------------------------------------------------------------------------byteStringSI :: B.ByteString -> B.ByteString-byteStringSI b = [SI.i|A fine day to die, #{b}.|]--byteStringI :: B.ByteString -> B.ByteString-byteStringI b = [I.i|A fine day to die, #{b}.|]---- byteStringN :: B.ByteString -> B.ByteString--- byteStringN b = [str|A fine day to die, $b$.|]---- byteStringP :: B.ByteString -> B.ByteString--- byteStringP b = [qc|A fine day to die, {b}.|]------------------------------------------------------------------------------------- Multiple String interpolations-----------------------------------------------------------------------------------multiStringSI :: (Int, String, Bool) -> String-multiStringSI (x, y, z) = [SI.i| foo #{x} bar #{y} baz #{z} quux |]--multiStringI :: (Int, String, Bool) -> String-multiStringI (x, y, z) = [I.i| foo #{x} bar #{y} baz #{z} quux |]--multiStringF :: (Int, String, Bool) -> String-multiStringF (x, y, z) =- F.formatToString (" foo " % F.d % " bar " % F.s % " baz " % F.sh % " quux ") x y z---- multiStringN :: (Int, String, Bool) -> String--- multiStringN (x, y, z) = [str| foo $:x$ bar $y$ baz $:z$ quux |]---- multiStringP :: (Int, String, Bool) -> String--- multiStringP (x, y, z) = [qc| foo {x} bar {y} baz {z} quux |]------------------------------------------------------------------------------------- Multiple Text interpolations-----------------------------------------------------------------------------------multiTextSI :: (Int, T.Text, Bool) -> T.Text-multiTextSI (x, y, z) = [SI.i| foo #{x} bar #{y} baz #{z} quux |]--multiTextI :: (Int, T.Text, Bool) -> T.Text-multiTextI (x, y, z) = [I.i| foo #{x} bar #{y} baz #{z} quux |]--multiTextF :: (Int, T.Text, Bool) -> T.Text-multiTextF (x, y, z) =- F.sformat (" foo " % F.d % " bar " % F.st % " baz " % F.sh % " quux ") x y z---- multiTextN :: (Int, T.Text, Bool) -> T.Text--- multiTextN (x, y, z) = [str| foo $:x$ bar $y$ baz $:z$ quux |]---- multiTextP :: (Int, T.Text, Bool) -> T.Text--- multiTextP (x, y, z) = [qc| foo {x} bar {y} baz {z} quux |]--multiTextNI :: (Int, T.Text, Bool) -> T.Text-multiTextNI (x, y, z) =- let x' = T.pack $ show x- z' = T.pack $ show z- in [NI.text| foo $x' bar $y baz $z' quux |]------------------------------------------------------------------------------------- Multiple ByteString interpolations-----------------------------------------------------------------------------------multiByteStringSI :: (Int, B.ByteString, Bool) -> B.ByteString-multiByteStringSI (x, y, z) = [SI.i| foo #{x} bar #{y} baz #{z} quux |]--multiByteStringI :: (Int, B.ByteString, Bool) -> B.ByteString-multiByteStringI (x, y, z) = [I.i| foo #{x} bar #{y} baz #{z} quux |]---- multiByteStringN :: (Int, B.ByteString, Bool) -> B.ByteString--- multiByteStringN (x, y, z) = [str| foo $:x$ bar $y$ baz $:z$ quux |]---- multiByteStringP :: (Int, B.ByteString, Bool) -> B.ByteString--- multiByteStringP (x, y, z) = [qc| foo {x} bar {y} baz {z} quux |]--main :: IO ()-main = defaultMain $- [ bgroup "Small Strings Bench" $- [ bench "string-interpolate" $ nf stringSI "William"- , bench "interpolate" $ nf stringI "William"- , bench "formatting" $ nf stringF "William"- -- , bench "Interpolation" $ nf stringN "William"- -- , bench "interpolatedstring-perl6" $ nf stringP "William"- ]- , bgroup "Small Text Bench" $- [ bench "string-interpolate" $ nf textSI "William"- , bench "interpolate" $ nf textI "William"- , bench "formatting" $ nf textF "William"- -- , bench "Interpolation" $ nf textN "William"- -- , bench "interpolatedstring-perl6" $ nf textP "William"- , bench "neat-interpolation" $ nf textNI "William"- ]- , bgroup "Small ByteString Bench" $- [ bench "string-interpolate" $ nf byteStringSI "William"- , bench "interpolate" $ nf byteStringI "William"- -- "formatting" doesn't support ByteStrings.- -- , bench "Interpolation" $ nf byteStringN "William"- -- , bench "interpolatedstring-perl6" $ nf byteStringP "William"- ]- , bgroup "Multiple Interpolations String Bench" $- [ bench "string-interpolate" $ nf multiStringSI (42, "CATALLAXY", True)- , bench "interpolate" $ nf multiStringI (42, "CATALLAXY", True)- , bench "formatting" $ nf multiStringF (42, "CATALLAXY", True)- -- , bench "Interpolation" $ nf multiStringN (42, "CATALLAXY", True)- -- , bench "interpolatedstring-perl6" $ nf multiStringP (42, "CATALLAXY", True)- ]- , bgroup "Multiple Interpolations Text Bench" $- [ bench "string-interpolate" $ nf multiTextSI (42, "CATALLAXY", True)- , bench "interpolate" $ nf multiTextI (42, "CATALLAXY", True)- , bench "formatting" $ nf multiTextF (42, "CATALLAXY", True)- -- , bench "Interpolation" $ nf multiTextN (42, "CATALLAXY", True)- -- , bench "interpolatedstring-perl6" $ nf multiTextP (42, "CATALLAXY", True)- , bench "neat-interpolation" $ nf multiTextNI (42, "CATALLAXY", True)- ]- , bgroup "Multiple Interpolations ByteString Bench" $- [ bench "string-interpolate" $ nf multiByteStringSI (42, "CATALLAXY", True)- , bench "interpolate" $ nf multiByteStringI (42, "CATALLAXY", True)- -- "formatting" doesn't support ByteStrings.- -- , bench "Interpolation" $ nf multiByteStringN (42, "CATALLAXY", True)- -- , bench "interpolatedstring-perl6" $ nf multiByteStringP (42, "CATALLAXY", True)- ]- , env largeishText $ \ ~t -> bgroup "Largeish Text Bench" $- [ bench "string-interpolate" $ nf textSI t- , bench "interpolate" $ nf textI t- , bench "formatting" $ nf textF t- -- , bench "Interpolation" $ nf textN t- -- , bench "interpolatedstring-perl6" $ nf textP t- , bench "neat-interpolation" $ nf textNI t- ]- , env largeishByteString $ \ ~bs -> bgroup "Largeish ByteString Bench" $- [ bench "string-interpolate" $ nf byteStringSI bs- , bench "interpolate" $ nf byteStringI bs- -- "formatting" doesn't support ByteStrings.- -- , bench "Interpolation" $ nf byteStringN bs- -- , bench "interpolatedstring-perl6" $ nf byteStringP bs- ]- ]--largeishText :: IO T.Text-largeishText =- generate $ T.pack <$> Prelude.take 100000 <$> infiniteListOf arbitrary--largeishByteString :: IO B.ByteString-largeishByteString =- generate $ B.pack <$> Prelude.take 100000 <$> infiniteListOf arbitrary
+ bench/bench.hs view
@@ -0,0 +1,229 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeApplications #-}++import Criterion ( Benchmark, bench, bgroup, env, nf )+import Criterion.Main ( defaultMain )++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as LB+import qualified Data.String as S+import qualified Data.Text as T+import qualified Data.Text.Lazy as LT++import qualified "string-interpolate" Data.String.Interpolate as SI+import qualified "string-interpolate" Data.String.Interpolate.Conversion as SI+import qualified "interpolate" Data.String.Interpolate.IsString as I+import "formatting" Formatting ( (%) )+import qualified "formatting" Formatting as F+import qualified "formatting" Formatting.ShortFormatters as F+import qualified "neat-interpolation" NeatInterpolation as NI++import Control.DeepSeq++import Test.QuickCheck++#ifdef EXTENDED_BENCHMARKS+import "Interpolation" Data.String.Interpolation as N+import "interpolatedstring-perl6" Text.InterpolatedString.Perl6 as P+#endif++type SIInterpolatable str flag =+ ( SI.IsCustomSink str ~ flag+ , SI.InterpSink flag str+ , SI.Interpolatable flag str str+ , SI.Interpolatable flag Int str+ , SI.Interpolatable flag Bool str+ )++type AllInterpolatable str flag =+ ( SIInterpolatable str flag+ , Show str+ , S.IsString str+ , Monoid str+ )++--------------------+-- string-interpolate+--------------------++singleInterpSI :: SIInterpolatable str flag => str -> str+singleInterpSI str = [SI.i|A fine day to die, #{str}.|]++multiInterpSI :: SIInterpolatable str flag => (Int, str, Bool) -> str+multiInterpSI (x, y, z) = [SI.i| foo #{x} bar #{y} baz #{z} quux |]++--------------------+-- interpolate+--------------------++singleInterpI :: (Show str, S.IsString str) => str -> str+singleInterpI str = [I.i|A fine day to die, #{str}.|]++multiInterpI :: (Show str, S.IsString str) => (Int, str, Bool) -> str+multiInterpI (x, y, z) = [I.i| foo #{x} bar #{y} baz #{z} quux |]++--------------------+-- formatting+--------------------++stringF :: String -> String+stringF = F.formatToString ("A fine day to die, " % F.s % ".")++multiStringF :: (Int, String, Bool) -> String+multiStringF (x, y, z) =+ F.formatToString (" foo " % F.d % " bar " % F.s % " baz " % F.sh % " quux ") x y z++textF :: T.Text -> T.Text+textF = F.sformat ("A fine day to die, " % F.st % ".")++multiTextF :: (Int, T.Text, Bool) -> T.Text+multiTextF (x, y, z) =+ F.sformat (" foo " % F.d % " bar " % F.st % " baz " % F.sh % " quux ") x y z++lazyTextF :: LT.Text -> LT.Text+lazyTextF = F.format ("A find day to die, " % F.t % ".")++multiLazyTextF :: (Int, LT.Text, Bool) -> LT.Text+multiLazyTextF (x, y, z) =+ F.format (" foo " % F.d % " bar " % F.t % " baz " % F.sh % " quux ") x y z++--------------------+-- neat-interpolation+--------------------++textNI :: T.Text -> T.Text+textNI t = [NI.text|A fine day to die, $t.|]++multiTextNI :: (Int, T.Text, Bool) -> T.Text+multiTextNI (x, y, z) =+ let x' = T.pack $ show x+ z' = T.pack $ show z+ in [NI.text| foo $x' bar $y baz $z' quux |]++#ifdef EXTENDED_BENCHMARKS++--------------------+-- Interpolation+--------------------++singleInterpN :: (Monoid str, S.IsString str) => str -> str+singleInterpN t = [str|A fine day to die, $t$.|]++multiInterpN ::(Monoid str, S.IsString str) => (Int, str, Bool) -> str+multiInterpN (x, y, z) = [str| foo $:x$ bar $y$ baz $:z$ quux |]++--------------------+-- interpolatedstring-perl6+--------------------++singleInterpP :: (Monoid str, S.IsString str) => str -> str+singleInterpP t = [qc|A fine day to die, {t}.|]++multiInterpP :: (Monoid str, S.IsString str) => (Int, str, Bool) -> str+multiInterpP (x, y, z) = [qc| foo {x} bar {y} baz {z} quux |]++#endif++--------------------+-- BENCHMARK GROUPS+--------------------++singleInterpBenches :: AllInterpolatable str flag+ => [(String, (str -> str))]+singleInterpBenches =+ [ ("string-interpolate" , singleInterpSI)+ , ("interpolate" , singleInterpI)+#ifdef EXTENDED_BENCHMARKS+ , ("interpolatedstring-perl6", singleInterpP)+ , ("Interpolation" , singleInterpN)+#endif+ ]++multiInterpBenches :: AllInterpolatable str flag+ => [(String, ((Int, str, Bool) -> str))]+multiInterpBenches =+ [ ("string-interpolate" , multiInterpSI)+ , ("interpolate" , multiInterpI)+#ifdef EXTENDED_BENCHMARKS+ , ("interpolatedstring-perl6", multiInterpP)+ , ("Interpolation" , multiInterpN)+#endif+ ]++main :: IO ()+main = defaultMain $+ [ benches @String "Small Strings Bench" "William" $+ singleInterpBenches +++ [ ("formatting", stringF) ]+ , benches @T.Text "Small Text Bench" "William" $+ singleInterpBenches +++ [ ("formatting" , textF)+ , ("neat-interpolation", textNI)+ ]+ , benches @LT.Text "Small Lazy Text Bench" "William" $+ singleInterpBenches +++ [ ("formatting", lazyTextF) ]+ , benches @B.ByteString "Small ByteStrings Bench" "William" $+ singleInterpBenches+ , benches @LB.ByteString "Small Lazy ByteStrings Bench" "William" $+ singleInterpBenches+ , benches @String "Multiple Interpolations String Bench" (42, "CATALLAXY", True) $+ multiInterpBenches +++ [ ("formatting", multiStringF) ]+ , benches @T.Text "Multiple Interpolations Text Bench" (42, "CATALLAXY", True) $+ multiInterpBenches +++ [ ("formatting" , multiTextF)+ , ("neat-interpolation", multiTextNI)+ ]+ , benches @LT.Text "Multiple Interpolations Lazy Text Bench" (42, "CATALLAXY", True) $+ multiInterpBenches +++ [ ("formatting", multiLazyTextF) ]+ , benches @B.ByteString "Multiple Interpolations ByteString Bench" (42, "CATALLAXY", True) $+ multiInterpBenches+ , benches @LB.ByteString "Multiple Interpolations Lazy ByteString Bench" (42, "CATALLAXY", True) $+ multiInterpBenches+ , env largeishText $ \ ~t -> benches @T.Text "Largeish Text Bench" t $+ singleInterpBenches +++ [ ("formatting" , textF)+ , ("neat-interpolation", textNI)+ ]+ , env largeishLazyText $ \ ~lt -> benches @LT.Text "Largeish Lazy Text Bench" lt $+ singleInterpBenches +++ [ ("formatting", lazyTextF) ]+ , env largeishByteString $ \ ~bs -> benches @B.ByteString "Largeish ByteString Bench" bs $+ singleInterpBenches+ , env largeishLazyByteString $ \ ~lbs -> benches @LB.ByteString "Largeish Lazy ByteString Bench" lbs $+ singleInterpBenches+ ]++largeishText :: IO T.Text+largeishText =+ generate $ T.pack <$> Prelude.take 100000 <$> infiniteListOf arbitrary++largeishLazyText :: IO LT.Text+largeishLazyText =+ generate $ LT.pack <$> Prelude.take 100000 <$> infiniteListOf arbitrary++largeishByteString :: IO B.ByteString+largeishByteString =+ generate $ B.pack <$> Prelude.take 100000 <$> infiniteListOf arbitrary++largeishLazyByteString :: IO LB.ByteString+largeishLazyByteString =+ generate $ LB.pack <$> Prelude.take 100000 <$> infiniteListOf arbitrary++--------------------+-- BENCHMARK UTIL+--------------------++benches :: forall b a. NFData b => String -> a -> [(String, a -> b)] -> Benchmark+benches groupname arg fs = bgroup groupname (fmap benchF fs)+ where benchF (bname, f) = bench bname $ nf f arg
src/lib/Data/String/Interpolate.hs view
@@ -7,7 +7,7 @@ -- Stability : experimental -- Portability : POSIX ----- This module provides two quasiquoters, @i@ and @iii@, which:+-- This module provides three quasiquoters, `i', `__i', and `iii', which: -- -- * handle all of String\/Text\/ByteString, both strict and lazy -- * can interpolate /into/ anything that implements `IsString'@@ -16,9 +16,10 @@ -- * are fast -- * handle multiline strings ----- @i@ leaves newlines and whitespace intact as they are in the source code,--- while @iii@ collapses newlines/whitespace into single spaces, stripping--- leading/trailing whitespace as well.+-- `i' leaves newlines and whitespace intact as they are in the source+-- code. `__i' strips leading indentation and surrounding blank lines, while+-- leaving linebreaks intact. `iii' collapses newlines/whitespace into single+-- spaces, putting all the output on a single line. -- -- As an example, --@@ -42,12 +43,17 @@ -- for more details and examples. {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE LambdaCase #-} module Data.String.Interpolate- ( i, iii )+ ( i, __i, iii ) where import Data.Proxy+import Data.Function ( on )+import Data.Semigroup ( Min(..) )+import Data.List+import Data.List.Split import qualified Language.Haskell.Exts.Extension as Ext import Language.Haskell.Exts.Parser@@ -59,49 +65,202 @@ import Data.String.Interpolate.Conversion ( build, chompSpaces, finalize, interpolate, ofString ) import Data.String.Interpolate.Parse ( InterpSegment(..), dosToUnix, parseInterpSegments ) +--------------------+-- QUASIQUOTERS+--------------------++-- |+-- The basic, no-frills interpolator. Will interpolate anything you wrap in @#{}@, and+-- otherwise leaves what you write alone. i :: QuasiQuoter i = QuasiQuoter- { quoteExp = toExp . parseInterpSegments . dosToUnix- , quotePat = err "pattern"- , quoteType = err "type"- , quoteDec = err "declaration"+ { quoteExp = toExp . parseInterpSegments . dosToUnix+ , quotePat = errQQType "i" "pattern"+ , quoteType = errQQType "i" "type"+ , quoteDec = errQQType "i" "declaration" }- where err name = error ("Data.String.Interpolate.i: This QuasiQuoter cannot be used as a " ++ name)+ where toExp :: Either String [InterpSegment] -> Q Exp+ toExp parseResult = case parseResult of+ Left msg -> errQQ "i" msg+ Right segs -> interpToExp segs - toExp :: Either String [InterpSegment] -> Q Exp+-- |+-- An interpolator that handles indentation. Will interpolate anything you wrap in @#{}@,+-- remove leading indentation, and remove any blank lines before and after the content.+--+-- If the contained interpolation uses both tabs and spaces for indentation, @__i@+-- will assume the indentation type it finds in the first nonblank line, ignoring+-- indentation of the other type. Please don't use mixed indentation.+--+-- Note that only indentation you actually write in source code will be stripped;+-- @__i@ does not touch any lines or whitespace inserted by interpolations themselves.+--+-- There is no extra performance penalty for using @__i@.+__i :: QuasiQuoter+__i = QuasiQuoter+ { quoteExp = toExp . parseInterpSegments . dosToUnix+ , quotePat = errQQType "__i" "pattern"+ , quoteType = errQQType "__i" "type"+ , quoteDec = errQQType "__i" "declaration"+ }+ where toExp :: Either String [InterpSegment] -> Q Exp toExp parseResult = case parseResult of- Left msg -> fail $ "Data.String.Interpolate.i: " ++ msg- Right segs -> emitBuildExp segs+ Left msg -> errQQ "__i" msg+ Right segs -> unindent segs >>= interpToExp - emitBuildExp :: [InterpSegment] -> Q Exp- emitBuildExp segs = [|finalize Proxy $(go segs)|]- where go [] = [|ofString Proxy ""|]- go (Verbatim str : rest) =- [|build Proxy (ofString Proxy str) $(go rest)|]- go (Expression expr : rest) =- [|build Proxy (interpolate Proxy $(reifyExpression expr)) $(go rest)|]+ unindent :: [InterpSegment] -> Q [InterpSegment]+ unindent segs =+ let lines = interpLines segs+ mindent = mindentation lines+ in warnMixedIndent mindent lines >>+ (pure $! (interpUnlines . removeBlanksAround . reduceIndents mindent) lines) +-- |+-- An interpolator that strips excess whitespace. Will collapse any sequences of+-- multiple spaces or whitespace into a single space, putting the output onto a+-- single line with surrounding whitespace removed.+--+-- Incurs a performance penalty when used, compared to @i@. This penalty will+-- be removed in 0.3.0.0. iii :: QuasiQuoter iii = QuasiQuoter- { quoteExp = toExp . parseInterpSegments . dosToUnix- , quotePat = err "pattern"- , quoteType = err "type"- , quoteDec = err "declaration"+ { quoteExp = toExp . parseInterpSegments . dosToUnix+ , quotePat = errQQType "iii" "pattern"+ , quoteType = errQQType "iii" "type"+ , quoteDec = errQQType "iii" "declaration" }- where err name = error ("Data.String.Interpolate.iii: This QuasiQuoter cannot be used as a " ++ name)-- toExp :: Either String [InterpSegment] -> Q Exp+ where toExp :: Either String [InterpSegment] -> Q Exp toExp parseResult = case parseResult of- Left msg -> fail $ "Data.String.Interpolate.iii: " ++ msg- Right segs -> emitBuildExp segs+ Left msg -> errQQ "iii" msg+ Right segs -> [|chompSpaces $(interpToExp segs)|] - emitBuildExp :: [InterpSegment] -> Q Exp- emitBuildExp segs = [|chompSpaces (finalize Proxy $(go segs))|]- where go [] = [|ofString Proxy ""|]- go (Verbatim str : rest) =- [|build Proxy (ofString Proxy str) $(go rest)|]- go (Expression expr : rest) =- [|build Proxy (interpolate Proxy $(reifyExpression expr)) $(go rest)|]+--------------------+-- CONVERTING EXPRS+--------------------++interpLines :: [InterpSegment] -> [[InterpSegment]]+interpLines = split $ dropDelims $ whenElt (== Newline)++interpUnlines :: [[InterpSegment]] -> [InterpSegment]+interpUnlines = intercalate [Newline]++data Mindent = UsesSpaces Int | UsesTabs Int++mindentation :: [[InterpSegment]] -> Mindent+mindentation lines =+ let nonblank = filter (not . blankLine) lines+ withIndent = find (\case { Spaces _ : _ -> True; Tabs _ : _ -> True; _ -> False }) nonblank+ in case withIndent of+ Nothing -> UsesSpaces 0+ Just (Spaces _ : _) ->+ maybe (UsesSpaces 0) UsesSpaces $+ findMinIndent (\case { Spaces n -> Just n; _ -> Nothing }) Nothing nonblank+ Just (Tabs _ : _) ->+ maybe (UsesSpaces 0) UsesTabs $+ findMinIndent (\case { Tabs n -> Just n; _ -> Nothing }) Nothing nonblank+ Just _ -> UsesSpaces 0+ where findMinIndent :: (InterpSegment -> Maybe Int) -> Maybe Int -> [[InterpSegment]] -> Maybe Int+ findMinIndent _ found [] = found+ findMinIndent f found ((seg:_):rest) =+ findMinIndent f (getMin <$> on mappend (fmap Min) (f seg) found) rest+ findMinIndent f found ([]:rest) = findMinIndent f found rest++warnMixedIndent :: Mindent -> [[InterpSegment]] -> Q ()+warnMixedIndent mindent = go 1 . removeBlanksAround+ where go :: Int -> [[InterpSegment]] -> Q ()+ go _lineno [] = pure ()+ go lineno (line:lines) = do+ let ind = indentation line+ case (mindent, any isSpaces ind, any isTabs ind) of+ (UsesSpaces _, _, True) ->+ reportWarning $+ "splice line " ++ show lineno ++ ": found TAB character in indentation"+ (UsesTabs _, True, _) ->+ reportWarning $+ "splice line " ++ show lineno ++ ": found SPACE character in indentation"+ _ -> pure ()+ go (lineno+1) lines++ indentation :: [InterpSegment] -> [InterpSegment]+ indentation =+ takeWhile (\case { Spaces _ -> True; Tabs _ -> True; _ -> False })++ isSpaces :: InterpSegment -> Bool+ isSpaces (Spaces n) = n > 0+ isSpaces _ = False++ isTabs :: InterpSegment -> Bool+ isTabs (Tabs n) = n > 0+ isTabs _ = False++reduceIndents :: Mindent -> [[InterpSegment]] -> [[InterpSegment]]+reduceIndents _ [] = []+reduceIndents i@(UsesSpaces indent) ((Spaces n:line):rest) =+ (Spaces (n-indent):line) : reduceIndents i rest+reduceIndents i@(UsesTabs indent) ((Tabs n:line):rest) =+ (Tabs (n-indent):line) : reduceIndents i rest+reduceIndents i (line:rest) = line : reduceIndents i rest++removeBlanksAround :: [[InterpSegment]] -> [[InterpSegment]]+removeBlanksAround =+ reverse+ . dropWhile blankLine+ . reverse+ . dropWhile blankLine++blankLine :: [InterpSegment] -> Bool+blankLine [] = True+blankLine (Expression _ : _) = False+blankLine (Newline : rest) = blankLine rest+blankLine (Spaces _ : rest) = blankLine rest+blankLine (Tabs _ : rest) = blankLine rest+blankLine (Verbatim str:rest) = blank str && blankLine rest+ where blank :: String -> Bool+ blank = all (\c -> elem c [' ', '\t'])++interpToExp :: [InterpSegment] -> Q Exp+interpToExp segs = [|finalize Proxy $(go outputSegs)|]+ where outputSegs :: [OutputSegment]+ outputSegs = collapseStrings $ renderOutput segs++ renderExp :: OutputSegment -> Q Exp+ renderExp (OfString str) = [|ofString Proxy str|]+ renderExp (Interpolate expr) = [|interpolate Proxy $(reifyExpression expr)|]++ go :: [OutputSegment] -> Q Exp+ go = foldr+ (\seg qexp -> [|build Proxy $(renderExp seg) $(qexp)|])+ [|ofString Proxy ""|]++data OutputSegment+ = OfString String+ | Interpolate String++collapseStrings :: [OutputSegment] -> [OutputSegment]+collapseStrings [] = []+collapseStrings (OfString s1 : OfString s2 : rest) =+ collapseStrings ((OfString $ s1 ++ s2) : rest)+collapseStrings (other : rest) = other : collapseStrings rest++renderOutput :: [InterpSegment] -> [OutputSegment]+renderOutput = fmap renderSegment+ where renderSegment :: InterpSegment -> OutputSegment+ renderSegment (Verbatim str) = OfString str+ renderSegment Newline = OfString "\n"+ renderSegment (Spaces n) = OfString (replicate n ' ')+ renderSegment (Tabs n) = OfString (replicate n '\t')+ renderSegment (Expression str) = Interpolate str++--------------------+-- UTILITIES+--------------------++errQQ :: String -> String -> a+errQQ qqName msg =+ error ("Data.String.Interpolate." ++ qqName ++ ": " ++ msg)++errQQType :: String -> String -> a+errQQType qqName = errQQ qqName . ("This QuasiQuoter cannot be used as a " ++) reifyExpression :: String -> Q Exp reifyExpression s = do
src/lib/Data/String/Interpolate/Conversion.hs view
@@ -1,11 +1,20 @@+-- |+-- Module : Data.String.Interpolate.Conversion+-- Copyright : (c) William Yao, 2019-2020+-- License : BSD-3+-- Maintainer : williamyaoh@gmail.com+-- Stability : experimental+-- Portability : POSIX++{-# OPTIONS -Wno-orphans #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE Strict #-} module Data.String.Interpolate.Conversion ( IsCustomSink, InterpSink(..), Interpolatable(..)@@ -14,12 +23,7 @@ ) where -import Data.Char ( isSpace )-import Data.Int ( Int64 )-import Data.Kind ( Type )-import Data.Proxy import Data.String ( IsString, fromString )-import Data.Text.Conversions import qualified Data.ByteString as B import qualified Data.ByteString.Builder as LB@@ -31,55 +35,17 @@ import qualified "utf8-string" Data.ByteString.Lazy.UTF8 as LUTF8 import qualified "utf8-string" Data.ByteString.UTF8 as UTF8 -import "base" Control.Category ( (>>>) )+import Data.String.Interpolate.Conversion.Classes+import Data.String.Interpolate.Conversion.Encoding+import Data.String.Interpolate.Conversion.TextSink ()+import Data.String.Interpolate.Conversion.ByteStringSink () -- Remove some imports above GHC 8.8.X #if MIN_VERSION_base(4,13,0) #else-import "base" Data.Monoid ( (<>) ) import "base" Text.Show ( ShowS, showChar, showString ) #endif --- |--- We wrap the builders in B so that we can add a phantom type parameter.--- This gives the inner `interpolate's enough information to know where--- they're going and pick an instance, forcing all the types into lockstep.-newtype B dst a = B { unB :: a }- deriving (Eq, Show)---- | Does this type require special behavior when something is interpolated /into/ it?-type family IsCustomSink dst where- IsCustomSink T.Text = 'True- IsCustomSink LT.Text = 'True- IsCustomSink LT.Builder = 'True- IsCustomSink B.ByteString = 'True- IsCustomSink LB.ByteString = 'True- IsCustomSink LB.Builder = 'True- IsCustomSink _ = 'False---- | Something that can be interpolated into.-class IsCustomSink dst ~ flag => InterpSink (flag :: Bool) dst where- type Builder flag dst :: Type-- -- | Meant to be used only for verbatim parts of the interpolation.- ofString :: Proxy flag -> String -> B dst (Builder flag dst)- -- |- -- `build' should be 'in-order'; that is, the left builder comes from- -- a string on the left, and the right builder comes from a string on the right.- build :: Proxy flag -> B dst (Builder flag dst) -> B dst (Builder flag dst) -> B dst (Builder flag dst)- finalize :: Proxy flag -> B dst (Builder flag dst) -> dst---- |--- Represents that we can interpolate objects of type src into a an--- interpolation string that returns type dst.-class InterpSink flag dst => Interpolatable (flag :: Bool) src dst where- interpolate :: Proxy flag -> src -> B dst (Builder flag dst)---- |--- We can collapse whitespace in the given type.-class SpaceChompable a where- chompSpaces :: a -> a- instance (IsCustomSink str ~ 'False, IsString str) => InterpSink 'False str where type Builder 'False str = ShowS @@ -87,48 +53,6 @@ build _ (B f) (B g) = B $ f . g finalize _ = fromString . ($ "") . unB -instance InterpSink 'True T.Text where- type Builder 'True T.Text = LT.Builder-- ofString _ = B . LT.fromString- build _ (B l) (B r) = B $ l <> r- finalize _ = LT.toStrict . LT.toLazyText . unB--instance InterpSink 'True LT.Text where- type Builder 'True LT.Text = LT.Builder-- ofString _ = B . LT.fromString- build _ (B l) (B r) = B $ l <> r- finalize _ = LT.toLazyText . unB--instance InterpSink 'True LT.Builder where- type Builder 'True LT.Builder = LT.Builder-- ofString _ = B . LT.fromString- build _ (B l) (B r) = B $ l <> r- finalize _ = unB--instance InterpSink 'True B.ByteString where- type Builder 'True B.ByteString = LB.Builder-- ofString _ = B . LB.byteString . unUTF8 . convertText- build _ (B l) (B r) = B $ l <> r- finalize _ = LB.toStrict . LB.toLazyByteString . unB--instance InterpSink 'True LB.ByteString where- type Builder 'True LB.ByteString = LB.Builder-- ofString _ = B . LB.lazyByteString . unUTF8 . convertText- build _ (B l) (B r) = B $ l <> r- finalize _ = LB.toLazyByteString . unB--instance InterpSink 'True LB.Builder where- type Builder 'True LB.Builder = LB.Builder-- ofString _ = B . LB.lazyByteString . unUTF8 . convertText- build _ (B l) (B r) = B $ l <> r- finalize _ = unB- instance {-# OVERLAPPABLE #-} (Show src, IsString dst, IsCustomSink dst ~ 'False) => Interpolatable 'False src dst where interpolate _ = B . shows instance {-# OVERLAPS #-} (IsString dst, IsCustomSink dst ~ 'False) => Interpolatable 'False Char dst where@@ -148,178 +72,7 @@ instance {-# OVERLAPS #-} (IsString dst, IsCustomSink dst ~ 'False) => Interpolatable 'False LB.Builder dst where interpolate _ = B . showString . LUTF8.toString . LB.toLazyByteString -instance {-# OVERLAPPABLE #-} Show src => Interpolatable 'True src T.Text where- interpolate _ = B . LT.fromString . show-instance {-# OVERLAPS #-} Interpolatable 'True Char T.Text where- interpolate _ = B . LT.singleton-instance {-# OVERLAPS #-} Interpolatable 'True String T.Text where- interpolate _ = B . LT.fromString-instance {-# OVERLAPS #-} Interpolatable 'True T.Text T.Text where- interpolate _ = B . LT.fromText-instance {-# OVERLAPS #-} Interpolatable 'True LT.Text T.Text where- interpolate _ = B . LT.fromLazyText-instance {-# OVERLAPS #-} Interpolatable 'True LT.Builder T.Text where- interpolate _ = B-instance {-# OVERLAPS #-} Interpolatable 'True B.ByteString T.Text where- interpolate _ = B . bsToTextBuilder-instance {-# OVERLAPS #-} Interpolatable 'True LB.ByteString T.Text where- interpolate _ = B . lbsToTextBuilder-instance {-# OVERLAPS #-} Interpolatable 'True LB.Builder T.Text where- interpolate _ = B . lbsToTextBuilder . LB.toLazyByteString--instance {-# OVERLAPPABLE #-} Show src => Interpolatable 'True src LT.Text where- interpolate _ = B . LT.fromString . show-instance {-# OVERLAPS #-} Interpolatable 'True Char LT.Text where- interpolate _ = B . LT.singleton-instance {-# OVERLAPS #-} Interpolatable 'True String LT.Text where- interpolate _ = B . LT.fromString-instance {-# OVERLAPS #-} Interpolatable 'True T.Text LT.Text where- interpolate _ = B . LT.fromText-instance {-# OVERLAPS #-} Interpolatable 'True LT.Text LT.Text where- interpolate _ = B . LT.fromLazyText-instance {-# OVERLAPS #-} Interpolatable 'True LT.Builder LT.Text where- interpolate _ = B-instance {-# OVERLAPS #-} Interpolatable 'True B.ByteString LT.Text where- interpolate _ = B . bsToTextBuilder-instance {-# OVERLAPS #-} Interpolatable 'True LB.ByteString LT.Text where- interpolate _ = B . lbsToTextBuilder-instance {-# OVERLAPS #-} Interpolatable 'True LB.Builder LT.Text where- interpolate _ = B . lbsToTextBuilder . LB.toLazyByteString--instance {-# OVERLAPPABLE #-} Show src => Interpolatable 'True src LT.Builder where- interpolate _ = B . LT.fromString . show-instance {-# OVERLAPS #-} Interpolatable 'True Char LT.Builder where- interpolate _ = B . LT.singleton-instance {-# OVERLAPS #-} Interpolatable 'True String LT.Builder where- interpolate _ = B . LT.fromString-instance {-# OVERLAPS #-} Interpolatable 'True T.Text LT.Builder where- interpolate _ = B . LT.fromText-instance {-# OVERLAPS #-} Interpolatable 'True LT.Text LT.Builder where- interpolate _ = B . LT.fromLazyText-instance {-# OVERLAPS #-} Interpolatable 'True LT.Builder LT.Builder where- interpolate _ = B-instance {-# OVERLAPS #-} Interpolatable 'True B.ByteString LT.Builder where- interpolate _ = B . bsToTextBuilder-instance {-# OVERLAPS #-} Interpolatable 'True LB.ByteString LT.Builder where- interpolate _ = B . lbsToTextBuilder-instance {-# OVERLAPS #-} Interpolatable 'True LB.Builder LT.Builder where- interpolate _ = B . lbsToTextBuilder . LB.toLazyByteString--instance {-# OVERLAPPABLE #-} Show src => Interpolatable 'True src B.ByteString where- interpolate _ = B . LB.byteString . unUTF8 . convertText . show-instance {-# OVERLAPS #-} Interpolatable 'True Char B.ByteString where- interpolate _ = B . encodeCharUTF8-instance {-# OVERLAPS #-} Interpolatable 'True String B.ByteString where- interpolate _ = B . LB.byteString . unUTF8 . convertText-instance {-# OVERLAPS #-} Interpolatable 'True T.Text B.ByteString where- interpolate _ = B . LB.byteString . unUTF8 . convertText-instance {-# OVERLAPS #-} Interpolatable 'True LT.Text B.ByteString where- interpolate _ = B . LB.byteString . unUTF8 . convertText-instance {-# OVERLAPS #-} Interpolatable 'True LT.Builder B.ByteString where- interpolate _ = B . LB.byteString . unUTF8 . convertText . LT.toLazyText-instance {-# OVERLAPS #-} Interpolatable 'True B.ByteString B.ByteString where- interpolate _ = B . LB.byteString-instance {-# OVERLAPS #-} Interpolatable 'True LB.ByteString B.ByteString where- interpolate _ = B . LB.lazyByteString-instance {-# OVERLAPS #-} Interpolatable 'True LB.Builder B.ByteString where- interpolate _ = B--instance {-# OVERLAPPABLE #-} Show src => Interpolatable 'True src LB.ByteString where- interpolate _ = B . LB.lazyByteString . unUTF8 . convertText . show-instance {-# OVERLAPS #-} Interpolatable 'True Char LB.ByteString where- interpolate _ = B . encodeCharUTF8-instance {-# OVERLAPS #-} Interpolatable 'True String LB.ByteString where- interpolate _ = B . LB.lazyByteString . unUTF8 . convertText-instance {-# OVERLAPS #-} Interpolatable 'True T.Text LB.ByteString where- interpolate _ = B . LB.lazyByteString . unUTF8 . convertText-instance {-# OVERLAPS #-} Interpolatable 'True LT.Text LB.ByteString where- interpolate _ = B . LB.lazyByteString . unUTF8 . convertText-instance {-# OVERLAPS #-} Interpolatable 'True LT.Builder LB.ByteString where- interpolate _ = B . LB.lazyByteString . unUTF8 . convertText . LT.toLazyText-instance {-# OVERLAPS #-} Interpolatable 'True B.ByteString LB.ByteString where- interpolate _ = B . LB.byteString-instance {-# OVERLAPS #-} Interpolatable 'True LB.ByteString LB.ByteString where- interpolate _ = B . LB.lazyByteString-instance {-# OVERLAPS #-} Interpolatable 'True LB.Builder LB.ByteString where- interpolate _ = B--instance {-# OVERLAPPABLE #-} Show src => Interpolatable 'True src LB.Builder where- interpolate _ = B . LB.lazyByteString . unUTF8 . convertText . show-instance {-# OVERLAPS #-} Interpolatable 'True Char LB.Builder where- interpolate _ = B . encodeCharUTF8-instance {-# OVERLAPS #-} Interpolatable 'True String LB.Builder where- interpolate _ = B . LB.lazyByteString . unUTF8 . convertText-instance {-# OVERLAPS #-} Interpolatable 'True T.Text LB.Builder where- interpolate _ = B . LB.lazyByteString . unUTF8 . convertText-instance {-# OVERLAPS #-} Interpolatable 'True LT.Text LB.Builder where- interpolate _ = B . LB.lazyByteString . unUTF8 . convertText-instance {-# OVERLAPS #-} Interpolatable 'True LT.Builder LB.Builder where- interpolate _ = B . LB.lazyByteString . unUTF8 . convertText . LT.toLazyText-instance {-# OVERLAPS #-} Interpolatable 'True B.ByteString LB.Builder where- interpolate _ = B . LB.byteString-instance {-# OVERLAPS #-} Interpolatable 'True LB.ByteString LB.Builder where- interpolate _ = B . LB.lazyByteString-instance {-# OVERLAPS #-} Interpolatable 'True LB.Builder LB.Builder where- interpolate _ = B- instance {-# OVERLAPPABLE #-} (Show a, IsString a) => SpaceChompable a where chompSpaces = fromString . chompSpaces . show instance {-# OVERLAPS #-} SpaceChompable String where chompSpaces = unwords . words-instance {-# OVERLAPS #-} SpaceChompable T.Text where- chompSpaces = T.unwords . T.words-instance {-# OVERLAPS #-} SpaceChompable LT.Text where- chompSpaces = LT.unwords . LT.words---- | For storing state while we fold over the ByteString.-data BSChomper = BSChomper- { bscNumWS :: !Int64- , bscBuilder :: !(Maybe LB.Builder) -- ^ We use Maybe here to know if we've processed- -- non-whitespace characters yet.- }--chompBS :: BSChomper -> Char -> BSChomper-chompBS bsc c = case (isSpace c, bscNumWS bsc, bscBuilder bsc) of- (True, _, Nothing) -> bsc- (True, n, Just _) -> bsc { bscNumWS = n + 1 }- (False, _, Nothing) -> bsc { bscBuilder = Just (encodeCharUTF8 c) }- (False, 0, Just builder) -> bsc { bscBuilder = Just (builder <> encodeCharUTF8 c) }- (False, _, Just builder) -> bsc { bscBuilder = Just (builder <> encodeCharUTF8 ' ' <> encodeCharUTF8 c)- , bscNumWS = 0- }--finalizeBSC :: BSChomper -> LB.ByteString-finalizeBSC bsc = case bscBuilder bsc of- Nothing -> mempty- Just builder -> LB.toLazyByteString builder--instance {-# OVERLAPS #-} SpaceChompable B.ByteString where- chompSpaces = UTF8.foldl chompBS (BSChomper 0 Nothing)- >>> finalizeBSC- >>> LB.toStrict-instance {-# OVERLAPS #-} SpaceChompable LB.ByteString where- chompSpaces = LUTF8.foldl chompBS (BSChomper 0 Nothing)- >>> finalizeBSC---- |--- Convert a strict ByteString into a Text `LT.Builder', converting any invalid--- characters into the Unicode replacement character � (U+FFFD).-bsToTextBuilder :: B.ByteString -> LT.Builder-bsToTextBuilder = UTF8.foldr (\char bldr -> LT.singleton char <> bldr) mempty---- |--- Convert a lazy ByteString into a Text `LT.Builder', converting any invalid--- characters into the Unicode replacement character � (U+FFFD).-lbsToTextBuilder :: LB.ByteString -> LT.Builder-lbsToTextBuilder = LUTF8.foldr (\char bldr -> LT.singleton char <> bldr) mempty---- |--- "Data.ByteString.Builder" provides `charUtf8' to do this, but it doesn't--- correctly handle invalid characters.-encodeCharUTF8 :: Char -> LB.Builder-encodeCharUTF8 c =- let normalized = case c of- '\xFFFE' -> '\xFFFD'- '\xFFFF' -> '\xFFFD'- _ -> c- in LB.charUtf8 normalized
+ src/lib/Data/String/Interpolate/Conversion/ByteStringSink.hs view
@@ -0,0 +1,215 @@+{-# OPTIONS -Wno-orphans #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE Strict #-}+{-# LANGUAGE TypeFamilies #-}++module Data.String.Interpolate.Conversion.ByteStringSink+ ()+where++import Data.Char ( isSpace )+import Data.Int ( Int64 )+import Data.Text.Conversions++import qualified Data.ByteString as B+import qualified Data.ByteString.Builder as LB+import qualified Data.ByteString.Lazy as LB+import qualified Data.Text as T+import qualified Data.Text.Lazy as LT hiding ( singleton )+import qualified Data.Text.Lazy.Builder as LT++import qualified "utf8-string" Data.ByteString.Lazy.UTF8 as LUTF8+import qualified "utf8-string" Data.ByteString.UTF8 as UTF8++import "base" Control.Category ( (>>>) )++import Data.String.Interpolate.Conversion.Classes+import Data.String.Interpolate.Conversion.Encoding ( encodeCharUTF8 )++--------------------+-- SINK DEFINITIONS+--------------------++#ifdef BYTESTRING_BUILDER++instance InterpSink 'True B.ByteString where+ type Builder 'True B.ByteString = LB.Builder++ ofString _ = B . LB.byteString . unUTF8 . convertText+ build _ (B l) (B r) = B $ l `mappend` r+ finalize _ = LB.toStrict . LB.toLazyByteString . unB++instance InterpSink 'True LB.ByteString where+ type Builder 'True LB.ByteString = LB.Builder++ ofString _ = B . LB.lazyByteString . unUTF8 . convertText+ build _ (B l) (B r) = B $ l `mappend` r+ finalize _ = LB.toLazyByteString . unB++#else++instance InterpSink 'True B.ByteString where+ type Builder 'True B.ByteString = B.ByteString++ ofString _ = B . unUTF8 . convertText+ build _ (B l) (B r) = B $ l `mappend` r+ finalize _ = unB++instance InterpSink 'True LB.ByteString where+ type Builder 'True LB.ByteString = LB.ByteString++ ofString _ = B . unUTF8 . convertText+ build _ (B l) (B r) = B $ l `mappend` r+ finalize _ = unB++#endif++instance InterpSink 'True LB.Builder where+ type Builder 'True LB.Builder = LB.Builder++ ofString _ = B . LB.lazyByteString . unUTF8 . convertText+ build _ (B l) (B r) = B $ l `mappend` r+ finalize _ = unB++--------------------+-- INTERPOLATION INSTANCES+--------------------++#ifdef BYTESTRING_BUILDER++instance {-# OVERLAPPABLE #-} Show src => Interpolatable 'True src B.ByteString where+ interpolate _ = B . LB.byteString . unUTF8 . convertText . show+instance {-# OVERLAPS #-} Interpolatable 'True Char B.ByteString where+ interpolate _ = B . encodeCharUTF8+instance {-# OVERLAPS #-} Interpolatable 'True String B.ByteString where+ interpolate _ = B . LB.byteString . unUTF8 . convertText+instance {-# OVERLAPS #-} Interpolatable 'True T.Text B.ByteString where+ interpolate _ = B . LB.byteString . unUTF8 . convertText+instance {-# OVERLAPS #-} Interpolatable 'True LT.Text B.ByteString where+ interpolate _ = B . LB.byteString . unUTF8 . convertText+instance {-# OVERLAPS #-} Interpolatable 'True LT.Builder B.ByteString where+ interpolate _ = B . LB.byteString . unUTF8 . convertText . LT.toLazyText+instance {-# OVERLAPS #-} Interpolatable 'True B.ByteString B.ByteString where+ interpolate _ = B . LB.byteString+instance {-# OVERLAPS #-} Interpolatable 'True LB.ByteString B.ByteString where+ interpolate _ = B . LB.lazyByteString+instance {-# OVERLAPS #-} Interpolatable 'True LB.Builder B.ByteString where+ interpolate _ = B++instance {-# OVERLAPPABLE #-} Show src => Interpolatable 'True src LB.ByteString where+ interpolate _ = B . LB.lazyByteString . unUTF8 . convertText . show+instance {-# OVERLAPS #-} Interpolatable 'True Char LB.ByteString where+ interpolate _ = B . encodeCharUTF8+instance {-# OVERLAPS #-} Interpolatable 'True String LB.ByteString where+ interpolate _ = B . LB.lazyByteString . unUTF8 . convertText+instance {-# OVERLAPS #-} Interpolatable 'True T.Text LB.ByteString where+ interpolate _ = B . LB.lazyByteString . unUTF8 . convertText+instance {-# OVERLAPS #-} Interpolatable 'True LT.Text LB.ByteString where+ interpolate _ = B . LB.lazyByteString . unUTF8 . convertText+instance {-# OVERLAPS #-} Interpolatable 'True LT.Builder LB.ByteString where+ interpolate _ = B . LB.lazyByteString . unUTF8 . convertText . LT.toLazyText+instance {-# OVERLAPS #-} Interpolatable 'True B.ByteString LB.ByteString where+ interpolate _ = B . LB.byteString+instance {-# OVERLAPS #-} Interpolatable 'True LB.ByteString LB.ByteString where+ interpolate _ = B . LB.lazyByteString+instance {-# OVERLAPS #-} Interpolatable 'True LB.Builder LB.ByteString where+ interpolate _ = B++#else++instance {-# OVERLAPPABLE #-} Show src => Interpolatable 'True src B.ByteString where+ interpolate _ = B . unUTF8 . convertText . show+instance {-# OVERLAPS #-} Interpolatable 'True Char B.ByteString where+ interpolate _ = B . LB.toStrict . LB.toLazyByteString . encodeCharUTF8+instance {-# OVERLAPS #-} Interpolatable 'True String B.ByteString where+ interpolate _ = B . unUTF8 . convertText+instance {-# OVERLAPS #-} Interpolatable 'True T.Text B.ByteString where+ interpolate _ = B . unUTF8 . convertText+instance {-# OVERLAPS #-} Interpolatable 'True LT.Text B.ByteString where+ interpolate _ = B . unUTF8 . convertText+instance {-# OVERLAPS #-} Interpolatable 'True LT.Builder B.ByteString where+ interpolate _ = B . unUTF8 . convertText . LT.toLazyText+instance {-# OVERLAPS #-} Interpolatable 'True B.ByteString B.ByteString where+ interpolate _ = B+instance {-# OVERLAPS #-} Interpolatable 'True LB.ByteString B.ByteString where+ interpolate _ = B . LB.toStrict+instance {-# OVERLAPS #-} Interpolatable 'True LB.Builder B.ByteString where+ interpolate _ = B . LB.toStrict . LB.toLazyByteString++instance {-# OVERLAPPABLE #-} Show src => Interpolatable 'True src LB.ByteString where+ interpolate _ = B . unUTF8 . convertText . show+instance {-# OVERLAPS #-} Interpolatable 'True Char LB.ByteString where+ interpolate _ = B . LB.toLazyByteString . encodeCharUTF8+instance {-# OVERLAPS #-} Interpolatable 'True String LB.ByteString where+ interpolate _ = B . unUTF8 . convertText+instance {-# OVERLAPS #-} Interpolatable 'True T.Text LB.ByteString where+ interpolate _ = B . unUTF8 . convertText+instance {-# OVERLAPS #-} Interpolatable 'True LT.Text LB.ByteString where+ interpolate _ = B . unUTF8 . convertText+instance {-# OVERLAPS #-} Interpolatable 'True LT.Builder LB.ByteString where+ interpolate _ = B . unUTF8 . convertText . LT.toLazyText+instance {-# OVERLAPS #-} Interpolatable 'True B.ByteString LB.ByteString where+ interpolate _ = B . LB.fromStrict+instance {-# OVERLAPS #-} Interpolatable 'True LB.ByteString LB.ByteString where+ interpolate _ = B+instance {-# OVERLAPS #-} Interpolatable 'True LB.Builder LB.ByteString where+ interpolate _ = B . LB.toLazyByteString++#endif++instance {-# OVERLAPPABLE #-} Show src => Interpolatable 'True src LB.Builder where+ interpolate _ = B . LB.lazyByteString . unUTF8 . convertText . show+instance {-# OVERLAPS #-} Interpolatable 'True Char LB.Builder where+ interpolate _ = B . encodeCharUTF8+instance {-# OVERLAPS #-} Interpolatable 'True String LB.Builder where+ interpolate _ = B . LB.lazyByteString . unUTF8 . convertText+instance {-# OVERLAPS #-} Interpolatable 'True T.Text LB.Builder where+ interpolate _ = B . LB.lazyByteString . unUTF8 . convertText+instance {-# OVERLAPS #-} Interpolatable 'True LT.Text LB.Builder where+ interpolate _ = B . LB.lazyByteString . unUTF8 . convertText+instance {-# OVERLAPS #-} Interpolatable 'True LT.Builder LB.Builder where+ interpolate _ = B . LB.lazyByteString . unUTF8 . convertText . LT.toLazyText+instance {-# OVERLAPS #-} Interpolatable 'True B.ByteString LB.Builder where+ interpolate _ = B . LB.byteString+instance {-# OVERLAPS #-} Interpolatable 'True LB.ByteString LB.Builder where+ interpolate _ = B . LB.lazyByteString+instance {-# OVERLAPS #-} Interpolatable 'True LB.Builder LB.Builder where+ interpolate _ = B++--------------------+-- SPACE CHOMPABLE+--------------------++-- | For storing state while we fold over the ByteString.+data BSChomper = BSChomper+ { bscNumWS :: !Int64+ , bscBuilder :: !(Maybe LB.Builder) -- ^ We use Maybe here to know if we've processed+ -- non-whitespace characters yet.+ }++chompBS :: BSChomper -> Char -> BSChomper+chompBS bsc c = case (isSpace c, bscNumWS bsc, bscBuilder bsc) of+ (True, _, Nothing) -> bsc+ (True, n, Just _) -> bsc { bscNumWS = n + 1 }+ (False, _, Nothing) -> bsc { bscBuilder = Just (encodeCharUTF8 c) }+ (False, 0, Just builder) -> bsc { bscBuilder = Just (builder `mappend` encodeCharUTF8 c) }+ (False, _, Just builder) -> bsc { bscBuilder = Just (builder `mappend` encodeCharUTF8 ' ' `mappend` encodeCharUTF8 c)+ , bscNumWS = 0+ }++finalizeBSC :: BSChomper -> LB.ByteString+finalizeBSC bsc = case bscBuilder bsc of+ Nothing -> mempty+ Just builder -> LB.toLazyByteString builder++instance {-# OVERLAPS #-} SpaceChompable B.ByteString where+ chompSpaces = UTF8.foldl chompBS (BSChomper 0 Nothing)+ >>> finalizeBSC+ >>> LB.toStrict+instance {-# OVERLAPS #-} SpaceChompable LB.ByteString where+ chompSpaces = LUTF8.foldl chompBS (BSChomper 0 Nothing)+ >>> finalizeBSC
+ src/lib/Data/String/Interpolate/Conversion/Classes.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}++module Data.String.Interpolate.Conversion.Classes+ ( B(..)+ , IsCustomSink, InterpSink(..), Interpolatable(..), SpaceChompable(..)+ )+where++import Data.Kind ( Type )+import Data.Proxy++import qualified Data.ByteString as B+import qualified Data.ByteString.Builder as LB+import qualified Data.ByteString.Lazy as LB+import qualified Data.Text as T+import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.Builder as LT++-- |+-- We wrap the builders in B so that we can add a phantom type parameter.+-- This gives the inner `interpolate's enough information to know where+-- they're going and pick an instance, forcing all the types into lockstep.+newtype B dst a = B { unB :: a }+ deriving (Eq, Show)++-- | Does this type require special behavior when something is interpolated /into/ it?+type family IsCustomSink dst where+ IsCustomSink T.Text = 'True+ IsCustomSink LT.Text = 'True+ IsCustomSink LT.Builder = 'True+ IsCustomSink B.ByteString = 'True+ IsCustomSink LB.ByteString = 'True+ IsCustomSink LB.Builder = 'True+ IsCustomSink _ = 'False++-- | Something that can be interpolated into.+class IsCustomSink dst ~ flag => InterpSink (flag :: Bool) dst where+ type Builder flag dst :: Type++ -- | Meant to be used only for verbatim parts of the interpolation.+ ofString :: Proxy flag -> String -> B dst (Builder flag dst)+ -- |+ -- `build' should be 'in-order'; that is, the left builder comes from+ -- a string on the left, and the right builder comes from a string on the right.+ build :: Proxy flag -> B dst (Builder flag dst) -> B dst (Builder flag dst) -> B dst (Builder flag dst)+ finalize :: Proxy flag -> B dst (Builder flag dst) -> dst++-- |+-- Represents that we can interpolate objects of type src into a an+-- interpolation string that returns type dst.+class InterpSink flag dst => Interpolatable (flag :: Bool) src dst where+ interpolate :: Proxy flag -> src -> B dst (Builder flag dst)++-- |+-- We can collapse whitespace in the given type.+class SpaceChompable a where+ chompSpaces :: a -> a
+ src/lib/Data/String/Interpolate/Conversion/Encoding.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE Strict #-}++module Data.String.Interpolate.Conversion.Encoding+ ( bsToTextBuilder, lbsToTextBuilder, encodeCharUTF8 )+where++import qualified Data.ByteString as B+import qualified Data.ByteString.Builder as LB+import qualified Data.ByteString.Lazy as LB+import qualified Data.Text.Lazy.Builder as LT++import qualified "utf8-string" Data.ByteString.Lazy.UTF8 as LUTF8+import qualified "utf8-string" Data.ByteString.UTF8 as UTF8++-- |+-- Convert a strict ByteString into a Text `LT.Builder', converting any invalid+-- characters into the Unicode replacement character � (U+FFFD).+bsToTextBuilder :: B.ByteString -> LT.Builder+bsToTextBuilder = UTF8.foldr (\char bldr -> LT.singleton char <> bldr) mempty++-- |+-- Convert a lazy ByteString into a Text `LT.Builder', converting any invalid+-- characters into the Unicode replacement character � (U+FFFD).+lbsToTextBuilder :: LB.ByteString -> LT.Builder+lbsToTextBuilder = LUTF8.foldr (\char bldr -> LT.singleton char <> bldr) mempty++-- |+-- "Data.ByteString.Builder" provides `charUtf8' to do this, but it doesn't+-- correctly handle invalid characters.+encodeCharUTF8 :: Char -> LB.Builder+encodeCharUTF8 c =+ let normalized = case c of+ '\xFFFE' -> '\xFFFD'+ '\xFFFF' -> '\xFFFD'+ _ -> c+ in LB.charUtf8 normalized
+ src/lib/Data/String/Interpolate/Conversion/TextSink.hs view
@@ -0,0 +1,185 @@+{-# OPTIONS -Wno-orphans #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE Strict #-}+{-# LANGUAGE TypeFamilies #-}++module Data.String.Interpolate.Conversion.TextSink+ ()+where++import qualified Data.ByteString as B+import qualified Data.ByteString.Builder as LB+import qualified Data.ByteString.Lazy as LB+import qualified Data.Text as T+import qualified Data.Text.Lazy as LT hiding ( singleton )+import qualified Data.Text.Lazy.Builder as LT++import Data.String.Interpolate.Conversion.Classes+import Data.String.Interpolate.Conversion.Encoding ( bsToTextBuilder, lbsToTextBuilder )++#ifdef TEXT_BUILDER+#else+import qualified Data.Text.Lazy+#endif++--------------------+-- SINK DEFINITIONS+--------------------++#ifdef TEXT_BUILDER++instance InterpSink 'True T.Text where+ type Builder 'True T.Text = LT.Builder++ ofString _ = B . LT.fromString+ build _ (B l) (B r) = B $ l `mappend` r+ finalize _ = LT.toStrict . LT.toLazyText . unB++instance InterpSink 'True LT.Text where+ type Builder 'True LT.Text = LT.Builder++ ofString _ = B . LT.fromString+ build _ (B l) (B r) = B $ l `mappend` r+ finalize _ = LT.toLazyText . unB++#else++instance InterpSink 'True T.Text where+ type Builder 'True T.Text = T.Text++ ofString _ = B . T.pack+ build _ (B l) (B r) = B $ l `mappend` r+ finalize _ = unB++instance InterpSink 'True LT.Text where+ type Builder 'True LT.Text = LT.Text++ ofString _ = B . LT.pack+ build _ (B l) (B r) = B $ l `mappend` r+ finalize _ = unB++#endif++instance InterpSink 'True LT.Builder where+ type Builder 'True LT.Builder = LT.Builder++ ofString _ = B . LT.fromString+ build _ (B l) (B r) = B $ l `mappend` r+ finalize _ = unB++--------------------+-- INTERPOLATION INSTANCES+--------------------++#ifdef TEXT_BUILDER++instance {-# OVERLAPPABLE #-} Show src => Interpolatable 'True src T.Text where+ interpolate _ = B . LT.fromString . show+instance {-# OVERLAPS #-} Interpolatable 'True Char T.Text where+ interpolate _ = B . LT.singleton+instance {-# OVERLAPS #-} Interpolatable 'True String T.Text where+ interpolate _ = B . LT.fromString+instance {-# OVERLAPS #-} Interpolatable 'True T.Text T.Text where+ interpolate _ = B . LT.fromText+instance {-# OVERLAPS #-} Interpolatable 'True LT.Text T.Text where+ interpolate _ = B . LT.fromLazyText+instance {-# OVERLAPS #-} Interpolatable 'True LT.Builder T.Text where+ interpolate _ = B+instance {-# OVERLAPS #-} Interpolatable 'True B.ByteString T.Text where+ interpolate _ = B . bsToTextBuilder+instance {-# OVERLAPS #-} Interpolatable 'True LB.ByteString T.Text where+ interpolate _ = B . lbsToTextBuilder+instance {-# OVERLAPS #-} Interpolatable 'True LB.Builder T.Text where+ interpolate _ = B . lbsToTextBuilder . LB.toLazyByteString++instance {-# OVERLAPPABLE #-} Show src => Interpolatable 'True src LT.Text where+ interpolate _ = B . LT.fromString . show+instance {-# OVERLAPS #-} Interpolatable 'True Char LT.Text where+ interpolate _ = B . LT.singleton+instance {-# OVERLAPS #-} Interpolatable 'True String LT.Text where+ interpolate _ = B . LT.fromString+instance {-# OVERLAPS #-} Interpolatable 'True T.Text LT.Text where+ interpolate _ = B . LT.fromText+instance {-# OVERLAPS #-} Interpolatable 'True LT.Text LT.Text where+ interpolate _ = B . LT.fromLazyText+instance {-# OVERLAPS #-} Interpolatable 'True LT.Builder LT.Text where+ interpolate _ = B+instance {-# OVERLAPS #-} Interpolatable 'True B.ByteString LT.Text where+ interpolate _ = B . bsToTextBuilder+instance {-# OVERLAPS #-} Interpolatable 'True LB.ByteString LT.Text where+ interpolate _ = B . lbsToTextBuilder+instance {-# OVERLAPS #-} Interpolatable 'True LB.Builder LT.Text where+ interpolate _ = B . lbsToTextBuilder . LB.toLazyByteString++#else++instance {-# OVERLAPPABLE #-} Show src => Interpolatable 'True src T.Text where+ interpolate _ = B . T.pack . show+instance {-# OVERLAPS #-} Interpolatable 'True Char T.Text where+ interpolate _ = B . T.singleton+instance {-# OVERLAPS #-} Interpolatable 'True String T.Text where+ interpolate _ = B . T.pack+instance {-# OVERLAPS #-} Interpolatable 'True T.Text T.Text where+ interpolate _ = B+instance {-# OVERLAPS #-} Interpolatable 'True LT.Text T.Text where+ interpolate _ = B . LT.toStrict+instance {-# OVERLAPS #-} Interpolatable 'True LT.Builder T.Text where+ interpolate _ = B . LT.toStrict . LT.toLazyText+instance {-# OVERLAPS #-} Interpolatable 'True B.ByteString T.Text where+ interpolate _ = B . LT.toStrict . LT.toLazyText . bsToTextBuilder+instance {-# OVERLAPS #-} Interpolatable 'True LB.ByteString T.Text where+ interpolate _ = B . LT.toStrict . LT.toLazyText . lbsToTextBuilder+instance {-# OVERLAPS #-} Interpolatable 'True LB.Builder T.Text where+ interpolate _ = B . LT.toStrict . LT.toLazyText . lbsToTextBuilder . LB.toLazyByteString++instance {-# OVERLAPPABLE #-} Show src => Interpolatable 'True src LT.Text where+ interpolate _ = B . LT.pack . show+instance {-# OVERLAPS #-} Interpolatable 'True Char LT.Text where+ interpolate _ = B . Data.Text.Lazy.singleton+instance {-# OVERLAPS #-} Interpolatable 'True String LT.Text where+ interpolate _ = B . LT.pack+instance {-# OVERLAPS #-} Interpolatable 'True T.Text LT.Text where+ interpolate _ = B . LT.fromStrict+instance {-# OVERLAPS #-} Interpolatable 'True LT.Text LT.Text where+ interpolate _ = B+instance {-# OVERLAPS #-} Interpolatable 'True LT.Builder LT.Text where+ interpolate _ = B . LT.toLazyText+instance {-# OVERLAPS #-} Interpolatable 'True B.ByteString LT.Text where+ interpolate _ = B . LT.toLazyText . bsToTextBuilder+instance {-# OVERLAPS #-} Interpolatable 'True LB.ByteString LT.Text where+ interpolate _ = B . LT.toLazyText . lbsToTextBuilder+instance {-# OVERLAPS #-} Interpolatable 'True LB.Builder LT.Text where+ interpolate _ = B . LT.toLazyText . lbsToTextBuilder . LB.toLazyByteString++#endif++instance {-# OVERLAPPABLE #-} Show src => Interpolatable 'True src LT.Builder where+ interpolate _ = B . LT.fromString . show+instance {-# OVERLAPS #-} Interpolatable 'True Char LT.Builder where+ interpolate _ = B . LT.singleton+instance {-# OVERLAPS #-} Interpolatable 'True String LT.Builder where+ interpolate _ = B . LT.fromString+instance {-# OVERLAPS #-} Interpolatable 'True T.Text LT.Builder where+ interpolate _ = B . LT.fromText+instance {-# OVERLAPS #-} Interpolatable 'True LT.Text LT.Builder where+ interpolate _ = B . LT.fromLazyText+instance {-# OVERLAPS #-} Interpolatable 'True LT.Builder LT.Builder where+ interpolate _ = B+instance {-# OVERLAPS #-} Interpolatable 'True B.ByteString LT.Builder where+ interpolate _ = B . bsToTextBuilder+instance {-# OVERLAPS #-} Interpolatable 'True LB.ByteString LT.Builder where+ interpolate _ = B . lbsToTextBuilder+instance {-# OVERLAPS #-} Interpolatable 'True LB.Builder LT.Builder where+ interpolate _ = B . lbsToTextBuilder . LB.toLazyByteString++--------------------+-- SPACE CHOMPABLE+--------------------++instance {-# OVERLAPS #-} SpaceChompable T.Text where+ chompSpaces = T.unwords . T.words+instance {-# OVERLAPS #-} SpaceChompable LT.Text where+ chompSpaces = LT.unwords . LT.words
src/lib/Data/String/Interpolate/Parse.hs view
@@ -1,3 +1,15 @@+-- |+-- Module : Data.String.Interpolate.Parse+-- Copyright : (c) William Yao, 2019-2020+-- License : BSD-3+-- Maintainer : williamyaoh@gmail.com+-- Stability : experimental+-- Portability : POSIX+--+-- YOU SHOULD NOT USE THIS MODULE.+--+-- This is exported mainly so tests can introspect on the implementation.+ {-# LANGUAGE PackageImports #-} module Data.String.Interpolate.Parse@@ -7,7 +19,12 @@ import Data.Char import qualified "base" Numeric as N -data InterpSegment = Expression String | Verbatim String+data InterpSegment+ = Expression String+ | Verbatim String+ | Newline+ | Spaces Int+ | Tabs Int deriving (Eq, Show) -- |@@ -16,19 +33,47 @@ -- -- Returns an error message if parsing fails. parseInterpSegments :: String -> Either String [InterpSegment]-parseInterpSegments = go ""- where go :: String -> String -> Either String [InterpSegment]- go acc parsee = case parsee of- "" -> Right [Verbatim $ reverse acc]- '\\':'#':rest -> go ('#':acc) rest- '\\':_rest -> case unescapeChar parsee of- (Nothing, rest) -> go acc rest- (Just c, rest) -> go (c:acc) rest- '#':'{':rest -> case span (/= '}') rest of- (expr, _:rest') ->- ((Verbatim . reverse) acc :) . (Expression expr :) <$> go "" rest'- (_, "") -> Left "unterminated #{...} interpolation"- c:cs -> go (c:acc) cs+parseInterpSegments = switch+ -- Given how complicated this is getting, it might be worth switching+ -- to megaparsec instead of hand-rolling this.+ where switch :: String -> Either String [InterpSegment]+ switch "" = pure []+ switch ('#':'{':rest) = expr rest+ switch ('#':rest) = verbatim "#" rest+ switch ('\n':rest) = newline rest -- CRLF handled by `dosToUnix'+ switch (' ':rest) = spaces 1 rest+ switch ('\t':rest) = tabs 1 rest+ switch other = verbatim "" other++ verbatim :: String -> String -> Either String [InterpSegment]+ verbatim acc parsee = case parsee of+ "" ->+ ((Verbatim . reverse) acc :) <$> switch parsee+ (c:_) | c `elem` ['#', ' ', '\t', '\n'] ->+ ((Verbatim . reverse) acc :) <$> switch parsee+ ('\\':'#':rest) ->+ verbatim ('#':acc) rest+ ('\\':_) -> case unescapeChar parsee of+ (Nothing, rest) -> verbatim acc rest+ (Just c, rest) -> verbatim (c:acc) rest+ c:cs ->+ verbatim (c:acc) cs++ expr :: String -> Either String [InterpSegment]+ expr parsee = case span (/= '}') parsee of+ (_, "") -> Left "unterminated #{...} interpolation"+ (expr, _:rest) -> (Expression expr :) <$> switch rest++ newline :: String -> Either String [InterpSegment]+ newline parsee = (Newline :) <$> switch parsee++ spaces :: Int -> String -> Either String [InterpSegment]+ spaces n (' ':rest) = spaces (n+1) rest+ spaces n other = (Spaces n :) <$> switch other++ tabs :: Int -> String -> Either String [InterpSegment]+ tabs n ('\t':rest) = tabs (n+1) rest+ tabs n other = (Tabs n :) <$> switch other dosToUnix :: String -> String dosToUnix = go
string-interpolate.cabal view
@@ -1,7 +1,7 @@ cabal-version: 1.18 name: string-interpolate-version: 0.2.0.3+version: 0.2.1.0 synopsis: Haskell string/text/bytestring interpolation that just works description: Unicode-aware string interpolation that handles all textual types. .@@ -23,22 +23,55 @@ type: git location: https://www.gitlab.com/williamyaoh/string-interpolate.git +flag extended-benchmarks+ description: Enable benchmarks for Interpolation and interpolatedstring-perl6+ manual: True+ default: False++flag text-builder+ description:+ Use Text Builders to construct Text outputs instead of the+ Text type itself. If you're regularly constructing large (>50KB)+ text objects, enabling this can speed up your code. Otherwise,+ enabling this is likely to be a net slowdown.+ manual: False+ default: False++flag bytestring-builder+ description:+ Use ByteString Builders to construct ByteString outputs instead of+ the ByteString type itself. If you're regularly constructing large+ (>50KB) bytestrings, enabling this can speed up your code. Otherwise,+ enabling this is likely to be a net slowdown.+ manual: False+ default: False+ library exposed-modules: Data.String.Interpolate Data.String.Interpolate.Conversion- other-modules:+ Data.String.Interpolate.Conversion.TextSink+ Data.String.Interpolate.Conversion.ByteStringSink Data.String.Interpolate.Parse+ other-modules:+ Data.String.Interpolate.Conversion.Classes+ Data.String.Interpolate.Conversion.Encoding+ other-modules: Paths_string_interpolate hs-source-dirs: src/lib ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wnoncanonical-monad-instances -fno-warn-name-shadowing+ if flag(text-builder)+ cpp-options: -DTEXT_BUILDER+ if flag(bytestring-builder)+ cpp-options: -DBYTESTRING_BUILDER build-depends: base ==4.* , bytestring <0.11 , text <1.3+ , split <0.3 , haskell-src-exts <1.24 , haskell-src-meta <0.9 , template-haskell <2.16@@ -48,40 +81,45 @@ test-suite string-interpolate-test type: exitcode-stdio-1.0- main-is: Spec.hs+ main-is: spec.hs other-modules: Paths_string_interpolate hs-source-dirs: test ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base ==4.*- , string-interpolate -any+ , string-interpolate , QuickCheck <2.14 , bytestring <0.11 , text <1.3+ , template-haskell <2.16 , hspec <2.8 , quickcheck-instances <0.4 , quickcheck-text <0.2 , quickcheck-unicode <1.1- , random-shuffle <0.1 , unordered-containers <0.3 default-language: Haskell2010 benchmark string-interpolate-bench type: exitcode-stdio-1.0- main-is: Bench.hs+ main-is: bench.hs other-modules: Paths_string_interpolate hs-source-dirs: bench build-depends: base ==4.*- , string-interpolate -any+ , string-interpolate , QuickCheck <2.14 , bytestring <0.11 , text <1.3+ , deepseq <1.5 , criterion <1.6 , formatting <6.4 , interpolate <0.3- -- , interpolatedstring-perl6 <1.1 , neat-interpolation <0.4+ if flag(extended-benchmarks)+ cpp-options: -DEXTENDED_BENCHMARKS+ build-depends:+ interpolatedstring-perl6 <1.1+ , Interpolation <0.4 default-language: Haskell2010
− test/Spec.hs
@@ -1,490 +0,0 @@-{-# OPTIONS -Wno-orphans #-}-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}--import qualified Data.ByteString as B-import qualified Data.ByteString.Builder as LB-import qualified Data.ByteString.Lazy as LB-import Data.Char ( chr, isSpace )-import Data.Foldable ( foldMap )-import qualified Data.HashMap.Strict as HM-import Data.List ( sort )-import Data.Semigroup-import qualified Data.Text as T-import qualified Data.Text.Lazy as LT-import Data.Word--import Control.Monad.IO.Class ( liftIO )--import System.Random.Shuffle--import "hspec" Test.Hspec-import "hspec" Test.Hspec.QuickCheck-import "QuickCheck" Test.QuickCheck-import "quickcheck-instances" Test.QuickCheck.Instances.ByteString ()-import "QuickCheck" Test.QuickCheck.Monadic-import "quickcheck-unicode" Test.QuickCheck.Unicode--import Data.String.Interpolate ( i, iii )-import Data.String.Interpolate.Conversion hiding- ( build, finalize, interpolate, ofString, chompSpaces )--main :: IO ()-main = hspec $ parallel $ do- describe "i" $ modifyMaxSuccess (const 10000) $ modifyMaxSize (const 500) $ do- it "should allow an escaped backslash right before an interp" $ do- let var :: String = "bar"- expected :: String = "foo\\bar"- [i|foo\\#{var}|] `shouldBe` expected-- it "should only escape verbatim segments a single time" $ do- let expected :: String = "\\\\\\\\"- [i|\\\\\\\\|] `shouldBe` expected-- it "should parse TypeApplications" $ do- let expected :: String = "2"- [i|#{show @Int 2}|] `shouldBe` expected-- context "when using String as a parameter" $ do- prop "just interpolating should be id" $- \(UTF8S str) -> [i|#{str}|] == str-- prop "should passthrough a conversion to strict Text and back unchanged" $- \(UTF8S str) -> iID @String @T.Text str- prop "should passthrough a conversion to lazy Text and back unchanged" $- \(UTF8S str) -> iID @String @LT.Text str- prop "should passthrough a conversion to strict ByteString and back unchanged" $- \(UTF8S str) -> iID @String @B.ByteString str- prop "should passthrough a conversion to lazy ByteString and back unchanged" $- \(UTF8S str) -> iID @String @LB.ByteString str-- context "when using strict Text as a parameter" $ do- prop "just interpolating should be id" $- \(t :: T.Text) -> [i|#{t}|] == t-- prop "should passthrough a conversion to String and back unchanged" $ iID @T.Text @String- prop "should passthrough a conversion to lazy Text and back unchanged" $ iID @T.Text @LT.Text- prop "should passthrough a conversion to strict ByteString and back unchanged" $ iID @T.Text @B.ByteString- prop "should passthrough a conversion to lazy ByteString and back unchanged" $ iID @T.Text @LB.ByteString-- context "when using lazy Text as a parameter" $ do- prop "just interpolating should be id" $- \(lt :: LT.Text) -> [i|#{lt}|] == lt-- prop "should passthrough a conversion to String and back unchanged" $ iID @LT.Text @String- prop "should passthrough a conversion to strict Text and back unchanged" $ iID @LT.Text @T.Text- prop "should passthrough a conversion to strict ByteString and back unchanged" $ iID @LT.Text @B.ByteString- prop "should passthrough a conversion to lazy ByteString and back unchanged" $ iID @LT.Text @LB.ByteString-- context "when using strict ByteString as a parameter" $ do- prop "just interpolating should be id" $- \(b :: B.ByteString) -> [i|#{b}|] == b-- prop "should passthrough a conversion to lazy ByteString and back unchanged" $ iID @B.ByteString @LB.ByteString-- context "and the ByteString is valid UTF8" $ do- prop "should passthrough a conversion to String and back unchanged" $ do- \(UTF8BS b) -> iID @B.ByteString @String b- prop "should passthrough a conversion to strict Text and back unchanged" $ do- \(UTF8BS b) -> iID @B.ByteString @T.Text b- prop "should passthrough a conversion to lazy Text and back unchanged" $ do- \(UTF8BS b) -> iID @B.ByteString @LT.Text b-- context "when using lazy ByteString as a parameter" $ do- prop "just interpolating should be id" $- \(lb :: LB.ByteString) -> [i|#{lb}|] == lb-- prop "should passthrough a conversion to strict ByteString and back unchanged" $ iID @LB.ByteString @B.ByteString-- context "and the ByteString is valid UTF8" $ do- prop "should passthrough a conversion to String and back unchanged" $- \(UTF8LBS lb) -> iID @LB.ByteString @String lb- prop "should passthrough a conversion to strict Text and back unchanged" $- \(UTF8LBS lb) -> iID @LB.ByteString @T.Text lb- prop "should passthrough a conversion to lazy Text and back unchanged" $- \(UTF8LBS lb) -> iID @LB.ByteString @LT.Text lb-- context "when using Char as a parameter" $ do- prop "interpolating into a String shouldn't have quotes" $- \(UTF8C c) -> [i|#{c}|] == [c]- prop "interpolating into strict Text shouldn't have quotes" $- \(UTF8C c) -> [i|#{c}|] == T.singleton c- prop "interpolating into lazy Text shouldn't have quotes" $- \(UTF8C c) -> [i|#{c}|] == LT.singleton c- prop "interpolating into strict ByteString shouldn't have quotes" $- \(UTF8C c) -> [i|#{c}|] == (LB.toStrict $ LB.toLazyByteString $ LB.charUtf8 c)- prop "interpolating into lazy ByteString shouldn't have quotes" $- \(UTF8C c) -> [i|#{c}|] == (LB.toLazyByteString $ LB.charUtf8 c)-- context "when interpolating into strict ByteString" $ do- it "should handle literal Unicode strings correctly" $ do- let interpolated :: B.ByteString = [i|λ|]- expected :: B.ByteString = "\xCE\xBB"- interpolated `shouldBe` expected-- context "when interpolating into lazy ByteString" $ do- it "should handle literal Unicode strings correctly" $ do- let interpolated :: LB.ByteString = [i|λ|]- expected :: LB.ByteString = "\xCE\xBB"- interpolated `shouldBe` expected-- -- describe "__i" $ modifyMaxSuccess (const 10000) $ modifyMaxSize (const 500) $ do- -- context "when there are no newlines" $ do- -- prop "is the same as i" $- -- \(NonwhitespaceText t) ->- -- let iResult :: T.Text = [i|#{t}|]- -- __iResult :: T.Text = [__i|#{t}|]- -- in iResult == __iResult-- -- context "when there are newlines" $ do- -- it "handles a small code snippet correctly" $ do- -- let interpolated :: T.Text =- -- [__i|- -- id :: a -> a- -- id x = y- -- where y = x- -- |]- -- expected :: T.Text = "id :: a -> a\nid x = y\n where y = x"- -- interpolated `shouldBe` expected-- -- prop "produces the same output for different indentation levels" $- -- \(lines :: [(Word8, T.Text)]) (indent :: Word8) ->- -- let unindented = flip fmap (unshift lines) $ \(level, line) ->- -- leftPad (fromIntegral level) ' ' line- -- indented = (leftPad (fromIntegral indent) ' ') <$> unindented- -- unindentedResult :: T.Text = [__i|#{T.unlines unindented}|]- -- indentedResult :: T.Text = [__i|#{T.unlines indented}|]- -- in unindentedResult == indentedResult-- -- context "is idempotent" $ do- -- prop "into String" $ __iIdempotent @String- -- prop "into strict Text" $ __iIdempotent @T.Text- -- prop "into lazy Text" $ __iIdempotent @LT.Text- -- prop "into strict ByteString" $ __iIdempotent @B.ByteString- -- prop "into lazy ByteString" $ __iIdempotent @LB.ByteString-- -- context "is idempotently its own inverse" $ do- -- context "from String" $ do- -- prop "into strict Text" $ __iIdempotentInverse @String @T.Text- -- prop "into lazy Text" $ __iIdempotentInverse @String @LT.Text- -- prop "into strict ByteString" $ __iIdempotentInverse @String @B.ByteString- -- prop "into lazy ByteString" $ __iIdempotentInverse @String @LB.ByteString-- -- context "from strict Text" $ do- -- prop "into String" $ __iIdempotentInverse @T.Text @String- -- prop "into lazy Text" $ __iIdempotentInverse @T.Text @LT.Text- -- prop "into strict ByteString" $ __iIdempotentInverse @T.Text @B.ByteString- -- prop "into lazy ByteString" $ __iIdempotentInverse @T.Text @LB.ByteString-- -- context "from lazy Text" $ do- -- prop "into String" $ __iIdempotentInverse @LT.Text @String- -- prop "into strict Text" $ __iIdempotentInverse @LT.Text @T.Text- -- prop "into strict ByteString" $ __iIdempotentInverse @LT.Text @B.ByteString- -- prop "into lazy ByteString" $ __iIdempotentInverse @LT.Text @LB.ByteString-- -- context "from strict ByteString" $ do- -- prop "into String" $ __iIdempotentInverse @B.ByteString @String- -- prop "into strict Text" $ __iIdempotentInverse @B.ByteString @T.Text- -- prop "into lazy Text" $ __iIdempotentInverse @B.ByteString @LT.Text- -- prop "into lazy ByteString" $ __iIdempotentInverse @B.ByteString @LB.ByteString-- -- context "from lazy ByteString" $ do- -- prop "into String" $ __iIdempotentInverse @LB.ByteString @String- -- prop "into strict Text" $ __iIdempotentInverse @LB.ByteString @T.Text- -- prop "into lazy Text" $ __iIdempotentInverse @LB.ByteString @LT.Text- -- prop "into strict ByteString" $ __iIdempotentInverse @LB.ByteString @B.ByteString-- -- -- I'm not sure whether these laws actually hold, because of tabs. Will- -- -- have to look at this more closely.- -- prop "is commutative with reversing lines" $- -- \(SpaceyText t) ->- -- [__i|#{T.unlines (reverse (T.lines t))}|] == T.unlines (reverse (T.lines [__i|#{t}|]))-- -- prop "is commutative with sorting lines" $- -- \(SpaceyText t) ->- -- [__i|#{T.unlines (sort (T.lines t))}|] == T.unlines (sort (T.lines [__i|#{t}|]))-- -- prop "removes same indentation when lines rearranged" $- -- \(SpaceyText t) ->- -- monadicIO $ do- -- shuffled <- T.unlines <$> liftIO (shuffleM $ T.lines t)- -- assert $ sort (T.lines [__i|#{shuffled}|]) == sort (T.lines [__i|#{t}|])-- -- prop "non-whitespace chars in output same as in input" $- -- \(SpaceyText t) -> charFrequencies [__i|#{t}|] == charFrequencies t-- -- prop "output string length <= input string length" $- -- \(SpaceyText t) -> T.length [__i|#{t}|] <= T.length t-- -- prop "output words = input words" $- -- \(SpaceyText t) -> T.words t == T.words [__i|#{t}|]-- describe "iii" $ modifyMaxSuccess (const 10000) $ modifyMaxSize (const 500) $ do- context "when there isn't any whitespace" $ do- prop "is the same as i" $- \(NonwhitespaceText t) ->- let iResult :: T.Text = [i|#{t}|]- iiiResult :: T.Text = [iii|#{t}|]- in iResult == iiiResult-- context "when there is whitespace" $ do- it "collapses a small example of whitespace" $ do- let interpolated :: T.Text = [iii| foo bar baz |]- expected :: T.Text = "foo bar baz"- interpolated `shouldBe` expected-- it "collapses a small example of newlines" $ do- let interpolated :: T.Text =- [iii|- Lorem ipsum dolor sit amet,- consectetur adipiscing elit.- Aenean congue iaculis dui,- at iaculis sapien interdum nec.- |]- expected :: T.Text = "Lorem ipsum dolor sit amet, consectetur adipiscing elit. Aenean congue iaculis dui, at iaculis sapien interdum nec."- interpolated `shouldBe` expected-- prop "never has any newlines" $- \(SpaceyText t) -> T.all (/= '\n') [iii|#{t}|]-- prop "never has more than one consecutive space" $- \(SpaceyText t) ->- let chunks = T.groupBy (\c1 c2 -> isSpace c1 == isSpace c2) [iii|#{t}|]- in all (\chunk -> T.all (not . isSpace) chunk || T.length chunk <= 1) chunks-- prop "never has leading whitespace" $- \(SpaceyText t) -> T.null $ T.takeWhile isSpace [iii|#{t}|]-- prop "never has trailing whitespace" $- \(SpaceyText t) -> T.null $ T.takeWhileEnd isSpace [iii|#{t}|]-- context "is idempotent" $ do- prop "into String" $ iiiIdempotent @String- prop "into strict Text" $ iiiIdempotent @T.Text- prop "into lazy Text" $ iiiIdempotent @LT.Text- prop "into strict ByteString" $ iiiIdempotent @B.ByteString- prop "into lazy ByteString" $ iiiIdempotent @LB.ByteString-- context "is idempotently its own inverse" $ do- context "from String" $ do- prop "into strict Text" $ iiiIdempotentInverse @String @T.Text- prop "into lazy Text" $ iiiIdempotentInverse @String @LT.Text- prop "into strict ByteString" $ iiiIdempotentInverse @String @B.ByteString- prop "into lazy ByteString" $ iiiIdempotentInverse @String @LB.ByteString-- context "from strict Text" $ do- prop "into String" $ iiiIdempotentInverse @T.Text @String- prop "into lazy Text" $ iiiIdempotentInverse @T.Text @LT.Text- prop "into strict ByteString" $ iiiIdempotentInverse @T.Text @B.ByteString- prop "into lazy ByteString" $ iiiIdempotentInverse @T.Text @LB.ByteString-- context "from lazy Text" $ do- prop "into String" $ iiiIdempotentInverse @LT.Text @String- prop "into strict Text" $ iiiIdempotentInverse @LT.Text @T.Text- prop "into strict ByteString" $ iiiIdempotentInverse @LT.Text @B.ByteString- prop "into lazy ByteString" $ iiiIdempotentInverse @LT.Text @LB.ByteString-- context "from strict ByteString" $ do- prop "into String" $ iiiIdempotentInverse @B.ByteString @String- prop "into strict Text" $ iiiIdempotentInverse @B.ByteString @T.Text- prop "into lazy Text" $ iiiIdempotentInverse @B.ByteString @LT.Text- prop "into lazy ByteString" $ iiiIdempotentInverse @B.ByteString @LB.ByteString-- context "from lazy ByteString" $ do- prop "into String" $ iiiIdempotentInverse @LB.ByteString @String- prop "into strict Text" $ iiiIdempotentInverse @LB.ByteString @T.Text- prop "into lazy Text" $ iiiIdempotentInverse @LB.ByteString @LT.Text- prop "into strict ByteString" $ iiiIdempotentInverse @LB.ByteString @B.ByteString-- prop "is commutative with string reversal" $- \(SpaceyText t) -> [iii|#{T.reverse t}|] == T.reverse [iii|#{t}|]-- prop "non-whitespace chars in output same as in input" $- \(SpaceyText t) -> charFrequencies [iii|#{t}|] == charFrequencies t-- prop "output string length <= input string length" $- \(SpaceyText t) -> T.length [iii|#{t}|] <= T.length t-- prop "output words = input words" $- \(SpaceyText t) -> T.words t == T.words [iii|#{t}|]--iID :: forall from to fromflag toflag.- ( Eq from- , Interpolatable fromflag to from- , Interpolatable toflag from to- )- => from- -> Bool-iID from =- let to :: to = [i|#{from}|]- from' :: from = [i|#{to}|]- in from == from'---- __iIdempotent :: forall to toflag.--- ( Eq to--- , Interpolatable toflag to to--- , Interpolatable toflag T.Text to--- )--- => SpaceyText--- -> Bool--- __iIdempotent (SpaceyText t) =--- let x :: to = [__i|#{t}|]--- x' :: to = [__i|#{x}|]--- in x == x'--iiiIdempotent :: forall to toflag.- ( Eq to- , Interpolatable toflag to to- , Interpolatable toflag T.Text to- , SpaceChompable to- )- => SpaceyText- -> Bool-iiiIdempotent (SpaceyText t) =- let x :: to = [iii|#{t}|]- x' :: to = [iii|#{x}|]- in x == x'---- __iIdempotentInverse :: forall from to fromflag toflag.--- ( Eq from--- , Interpolatable fromflag T.Text from--- , Interpolatable toflag from to--- , Interpolatable fromflag to from--- )--- => SpaceyText--- -> Bool--- __iIdempotentInverse (SpaceyText t) =--- let x :: from = [__i|#{t}|]--- x' :: to = [__i|#{x}|]--- x'' :: from = [__i|#{x'}|]--- in x == x''--iiiIdempotentInverse :: forall from to fromflag toflag.- ( Eq from- , Interpolatable fromflag T.Text from- , Interpolatable toflag from to- , Interpolatable fromflag to from- , SpaceChompable from- , SpaceChompable to- )- => SpaceyText- -> Bool-iiiIdempotentInverse (SpaceyText t) =- let x :: from = [iii|#{t}|]- x' :: to = [iii|#{x}|]- x'' :: from = [iii|#{x'}|]- in x == x''---- -- |--- -- Reduce each index by the minimum index in the array.--- unshift :: (Ord a, Num a) => [(a, b)] -> [(a, b)]--- unshift [] = []--- unshift l@((x, _) : xs) =--- let min = getMin $ foldr (\(x, _) m -> Min x <> m) (Min x) xs--- in (\(x, y) -> (x - min, y)) <$> l---- -- |--- -- Add the given number of the specific characters to the left.--- leftPad :: Int -> Char -> T.Text -> T.Text--- leftPad amt c t = T.replicate amt (T.singleton c) <> t---- |--- The default Arbitrary for Char generates U+FFFF and U+FFFE, which aren't--- valid Unicode. Sigh...-newtype UTF8Char = UTF8C { unUTF8C :: Char }- deriving newtype (Eq, Show)--newtype UTF8String = UTF8S { unUTF8S :: String }- deriving newtype (Eq, Show)--newtype UTF8ByteString = UTF8BS B.ByteString- deriving newtype (Eq, Show)-newtype UTF8LazyByteString = UTF8LBS LB.ByteString- deriving newtype (Eq, Show)--newtype SpaceyText = SpaceyText T.Text- deriving newtype (Eq, Show)-newtype NonwhitespaceText = NonwhitespaceText T.Text- deriving newtype (Eq, Show)--instance Arbitrary UTF8Char where- arbitrary = UTF8C <$> unicodeChar- shrink (UTF8C c) = UTF8C <$> shrinkChar c--instance Arbitrary UTF8String where- arbitrary = do- chars <- listOf arbitrary- pure $ UTF8S (unUTF8C <$> chars)- shrink (UTF8S str) = case str of- [] -> []- (_:[]) -> []- _ -> let mid = length str `div` 2- in [UTF8S $ take mid str, UTF8S $ drop mid str]--instance Arbitrary T.Text where- arbitrary = T.pack . unUTF8S <$> arbitrary- shrink t = if T.null t || T.length t == 1- then []- else let mid = T.length t `div` 2- in [T.take mid t, T.drop mid t]--instance Arbitrary LT.Text where- arbitrary = LT.pack . unUTF8S <$> arbitrary- shrink lt = if LT.null lt || LT.length lt == 1- then []- else let mid = LT.length lt `div` 2- in [LT.take mid lt, LT.drop mid lt]--instance Arbitrary UTF8ByteString where- arbitrary = UTF8BS . LB.toStrict . LB.toLazyByteString . foldMap LB.charUtf8 . unUTF8S- <$> arbitrary--instance Arbitrary UTF8LazyByteString where- arbitrary = UTF8LBS . LB.toLazyByteString . foldMap LB.charUtf8 . unUTF8S- <$> arbitrary---- Basically, we want this to be an 'alternation' of sequences of printable--- characters and whitespace characters.-instance Arbitrary SpaceyText where- arbitrary = SpaceyText . foldMap id- <$> scale- (round . sqrt @Double . fromIntegral)- (listOf (oneof [whitespace, nonwhitespace]))--instance Arbitrary NonwhitespaceText where- arbitrary = NonwhitespaceText <$> nonwhitespace--charFrequencies :: T.Text -> HM.HashMap Char Int-charFrequencies = T.foldl' (flip $ HM.alter increment) HM.empty . T.filter (not . isSpace)- where increment :: Maybe Int -> Maybe Int- increment Nothing = Just 1- increment (Just x) = Just (x + 1)--whitespace :: Gen T.Text-whitespace = T.pack- <$> listOf1 (elements [' ', '\r', '\t', '\n', '\x1680', '\x2000', '\x2006'])--nonwhitespace :: Gen T.Text-nonwhitespace = T.pack- <$> listOf1 nonwhitespaceChar--nonwhitespaceChar :: Gen Char-nonwhitespaceChar = unicodeChar `suchThat` (not . isSpace)--unicodeChar :: Gen Char-unicodeChar = chr `fmap` points- where points = flip suchThat (not . reserved) $ oneof- [ ascii- , plane0- , plane1- , plane2- , plane14- ]
+ test/spec.hs view
@@ -0,0 +1,482 @@+{-# OPTIONS -Wno-orphans #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE LambdaCase #-}++import qualified Data.ByteString as B+import qualified Data.ByteString.Builder as LB+import qualified Data.ByteString.Lazy as LB+import Data.Char ( chr, isSpace )+import Data.Foldable ( foldMap )+import qualified Data.HashMap.Strict as HM+import Data.List ( sort )+import Data.Semigroup+import qualified Data.Text as T+import qualified Data.Text.Lazy as LT+import Data.Word++import Language.Haskell.TH+import Language.Haskell.TH.Quote ( QuasiQuoter(..) )++import Control.Monad.IO.Class ( liftIO )++import "hspec" Test.Hspec+import "hspec" Test.Hspec.QuickCheck+import "QuickCheck" Test.QuickCheck+import "quickcheck-instances" Test.QuickCheck.Instances.ByteString ()+import "QuickCheck" Test.QuickCheck.Monadic+import "quickcheck-unicode" Test.QuickCheck.Unicode++import Data.String.Interpolate ( i, iii, __i )+import Data.String.Interpolate.Conversion hiding+ ( build, finalize, interpolate, ofString, chompSpaces )+import Data.String.Interpolate.Parse ( InterpSegment(..), parseInterpSegments )++main :: IO ()+main = hspec $ parallel $ do+ describe "parseInterpSegments" $ modifyMaxSuccess (const 10000) $ modifyMaxSize (const 500) $ do+ -- A pretty weaksauce test, but we've had issues with this before.+ prop "terminates" $+ \(UTF8S str) -> parseInterpSegments str `seq` True++ describe "i" $ modifyMaxSuccess (const 10000) $ modifyMaxSize (const 500) $ do+ it "should allow an escaped backslash right before an interp" $ do+ let var :: String = "bar"+ expected :: String = "foo\\bar"+ [i|foo\\#{var}|] `shouldBe` expected++ it "should only escape verbatim segments a single time" $ do+ let expected :: String = "\\\\\\\\"+ [i|\\\\\\\\|] `shouldBe` expected++ it "should copy hanging # verbatim" $ do+ let expected :: String = "#"+ [i|#|] `shouldBe` expected++ -- it "should error on hanging #" $ do+ -- runQ (quoteExp i "#") `shouldThrow` anyException++ it "should error on unclosed expression" $ do+ runQ (quoteExp i "#{") `shouldThrow` anyException++ it "should parse TypeApplications" $ do+ let expected :: String = "2"+ [i|#{show @Int 2}|] `shouldBe` expected++ context "when using String as a parameter" $ do+ prop "just interpolating should be id" $+ \(UTF8S str) -> [i|#{str}|] == str++ prop "should passthrough a conversion to strict Text and back unchanged" $+ \(UTF8S str) -> iID @String @T.Text str+ prop "should passthrough a conversion to lazy Text and back unchanged" $+ \(UTF8S str) -> iID @String @LT.Text str+ prop "should passthrough a conversion to strict ByteString and back unchanged" $+ \(UTF8S str) -> iID @String @B.ByteString str+ prop "should passthrough a conversion to lazy ByteString and back unchanged" $+ \(UTF8S str) -> iID @String @LB.ByteString str++ context "when using strict Text as a parameter" $ do+ prop "just interpolating should be id" $+ \(t :: T.Text) -> [i|#{t}|] == t++ prop "should passthrough a conversion to String and back unchanged" $ iID @T.Text @String+ prop "should passthrough a conversion to lazy Text and back unchanged" $ iID @T.Text @LT.Text+ prop "should passthrough a conversion to strict ByteString and back unchanged" $ iID @T.Text @B.ByteString+ prop "should passthrough a conversion to lazy ByteString and back unchanged" $ iID @T.Text @LB.ByteString++ context "when using lazy Text as a parameter" $ do+ prop "just interpolating should be id" $+ \(lt :: LT.Text) -> [i|#{lt}|] == lt++ prop "should passthrough a conversion to String and back unchanged" $ iID @LT.Text @String+ prop "should passthrough a conversion to strict Text and back unchanged" $ iID @LT.Text @T.Text+ prop "should passthrough a conversion to strict ByteString and back unchanged" $ iID @LT.Text @B.ByteString+ prop "should passthrough a conversion to lazy ByteString and back unchanged" $ iID @LT.Text @LB.ByteString++ context "when using strict ByteString as a parameter" $ do+ prop "just interpolating should be id" $+ \(b :: B.ByteString) -> [i|#{b}|] == b++ prop "should passthrough a conversion to lazy ByteString and back unchanged" $ iID @B.ByteString @LB.ByteString++ context "and the ByteString is valid UTF8" $ do+ prop "should passthrough a conversion to String and back unchanged" $ do+ \(UTF8BS b) -> iID @B.ByteString @String b+ prop "should passthrough a conversion to strict Text and back unchanged" $ do+ \(UTF8BS b) -> iID @B.ByteString @T.Text b+ prop "should passthrough a conversion to lazy Text and back unchanged" $ do+ \(UTF8BS b) -> iID @B.ByteString @LT.Text b++ context "when using lazy ByteString as a parameter" $ do+ prop "just interpolating should be id" $+ \(lb :: LB.ByteString) -> [i|#{lb}|] == lb++ prop "should passthrough a conversion to strict ByteString and back unchanged" $ iID @LB.ByteString @B.ByteString++ context "and the ByteString is valid UTF8" $ do+ prop "should passthrough a conversion to String and back unchanged" $+ \(UTF8LBS lb) -> iID @LB.ByteString @String lb+ prop "should passthrough a conversion to strict Text and back unchanged" $+ \(UTF8LBS lb) -> iID @LB.ByteString @T.Text lb+ prop "should passthrough a conversion to lazy Text and back unchanged" $+ \(UTF8LBS lb) -> iID @LB.ByteString @LT.Text lb++ context "when using Char as a parameter" $ do+ prop "interpolating into a String shouldn't have quotes" $+ \(UTF8C c) -> [i|#{c}|] == [c]+ prop "interpolating into strict Text shouldn't have quotes" $+ \(UTF8C c) -> [i|#{c}|] == T.singleton c+ prop "interpolating into lazy Text shouldn't have quotes" $+ \(UTF8C c) -> [i|#{c}|] == LT.singleton c+ prop "interpolating into strict ByteString shouldn't have quotes" $+ \(UTF8C c) -> [i|#{c}|] == (LB.toStrict $ LB.toLazyByteString $ LB.charUtf8 c)+ prop "interpolating into lazy ByteString shouldn't have quotes" $+ \(UTF8C c) -> [i|#{c}|] == (LB.toLazyByteString $ LB.charUtf8 c)++ context "when interpolating into strict ByteString" $ do+ it "should handle literal Unicode strings correctly" $ do+ let interpolated :: B.ByteString = [i|λ|]+ expected :: B.ByteString = "\xCE\xBB"+ interpolated `shouldBe` expected++ context "when interpolating into lazy ByteString" $ do+ it "should handle literal Unicode strings correctly" $ do+ let interpolated :: LB.ByteString = [i|λ|]+ expected :: LB.ByteString = "\xCE\xBB"+ interpolated `shouldBe` expected++ describe "__i" $ modifyMaxSuccess (const 250) $ modifyMaxSize (const 500) $ do+ context "when there are newlines" $ do+ it "handles a small code snippet correctly/1" $ do+ let interpolated :: T.Text =+ [__i|+ id :: a -> a+ id x = y+ where y = x+ |]+ expected :: T.Text = "id :: a -> a\nid x = y\n where y = x"+ interpolated `shouldBe` expected++ it "handles a small code snippet correctly/2" $ do+ let interpolated :: T.Text =+ [__i|+++ This is an example message.++ Title: Foo+ Description: Bar+ Categories:++++ This is an example body.++ |]+ expected :: T.Text = "This is an example message.\n\n Title: Foo\n Description: Bar\n Categories:\n\n\n\nThis is an example body."+ interpolated `shouldBe` expected++ it "handles a small code snippet correctly/3" $ do+ let input :: Int = 42+ interpolated :: T.Text =+ [__i|+ add :: Int -> Int -> Int+ add x y =+ let result = x + y + #{input}+ in result+ |]+ expected :: T.Text = "add :: Int -> Int -> Int\nadd x y =\n let result = x + y + 42\n in result"+ interpolated `shouldBe` expected++ it "handles tabs" $ do+ let interpolated :: T.Text =+ [__i|+ id :: a -> a+ id x = y+ where y = x+ |]+ expected = "id :: a -> a\nid x = y\n\twhere y = x"+ interpolated `shouldBe` expected++ -- prop "produces the same output for different indentation levels" $+ -- \(segs :: [InterpSegment], indent :: Word8, offset :: Word8) -> monadicIO $ do+ -- let interpLines = lines $ interpToString $+ -- filter (\case { Expression _ -> False; _ -> True }) segs+ -- fi = fromIntegral+ -- lessIO = runQ $ quoteExp __i (unlines $ leftPad (fi (indent + 1)) ' ' <$> interpLines)+ -- moreIO = runQ $ quoteExp __i (unlines $ leftPad (fi (indent + offset + 2)) ' ' <$> interpLines)+ -- lessExp <- run lessIO+ -- moreExp <- run moreIO+ -- assert $! lessExp == moreExp++ -- prop "non-whitespace chars in output same as in input" $+ -- \(SpaceyText t) -> charFrequencies [__i|#{t}|] == charFrequencies t++ -- prop "output string length <= input string length" $+ -- \(SpaceyText t) -> T.length [__i|#{t}|] <= T.length t++ -- prop "output words = input words" $+ -- \(SpaceyText t) -> T.words t == T.words [__i|#{t}|]++ describe "iii" $ modifyMaxSuccess (const 10000) $ modifyMaxSize (const 500) $ do+ context "when there isn't any whitespace" $ do+ prop "is the same as i" $+ \(NonwhitespaceText t) ->+ let iResult :: T.Text = [i|#{t}|]+ iiiResult :: T.Text = [iii|#{t}|]+ in iResult == iiiResult++ context "when there is whitespace" $ do+ it "collapses a small example of whitespace" $ do+ let interpolated :: T.Text = [iii| foo bar baz |]+ expected :: T.Text = "foo bar baz"+ interpolated `shouldBe` expected++ it "collapses a small example of newlines" $ do+ let interpolated :: T.Text =+ [iii|+ Lorem ipsum dolor sit amet,+ consectetur adipiscing elit.+ Aenean congue iaculis dui,+ at iaculis sapien interdum nec.+ |]+ expected :: T.Text = "Lorem ipsum dolor sit amet, consectetur adipiscing elit. Aenean congue iaculis dui, at iaculis sapien interdum nec."+ interpolated `shouldBe` expected++ prop "never has any newlines" $+ \(SpaceyText t) -> T.all (/= '\n') [iii|#{t}|]++ prop "never has more than one consecutive space" $+ \(SpaceyText t) ->+ let chunks = T.groupBy (\c1 c2 -> isSpace c1 == isSpace c2) [iii|#{t}|]+ in all (\chunk -> T.all (not . isSpace) chunk || T.length chunk <= 1) chunks++ prop "never has leading whitespace" $+ \(SpaceyText t) -> T.null $ T.takeWhile isSpace [iii|#{t}|]++ prop "never has trailing whitespace" $+ \(SpaceyText t) -> T.null $ T.takeWhileEnd isSpace [iii|#{t}|]++ context "is idempotent" $ do+ prop "into String" $ iiiIdempotent @String+ prop "into strict Text" $ iiiIdempotent @T.Text+ prop "into lazy Text" $ iiiIdempotent @LT.Text+ prop "into strict ByteString" $ iiiIdempotent @B.ByteString+ prop "into lazy ByteString" $ iiiIdempotent @LB.ByteString++ context "is idempotently its own inverse" $ do+ context "from String" $ do+ prop "into strict Text" $ iiiIdempotentInverse @String @T.Text+ prop "into lazy Text" $ iiiIdempotentInverse @String @LT.Text+ prop "into strict ByteString" $ iiiIdempotentInverse @String @B.ByteString+ prop "into lazy ByteString" $ iiiIdempotentInverse @String @LB.ByteString++ context "from strict Text" $ do+ prop "into String" $ iiiIdempotentInverse @T.Text @String+ prop "into lazy Text" $ iiiIdempotentInverse @T.Text @LT.Text+ prop "into strict ByteString" $ iiiIdempotentInverse @T.Text @B.ByteString+ prop "into lazy ByteString" $ iiiIdempotentInverse @T.Text @LB.ByteString++ context "from lazy Text" $ do+ prop "into String" $ iiiIdempotentInverse @LT.Text @String+ prop "into strict Text" $ iiiIdempotentInverse @LT.Text @T.Text+ prop "into strict ByteString" $ iiiIdempotentInverse @LT.Text @B.ByteString+ prop "into lazy ByteString" $ iiiIdempotentInverse @LT.Text @LB.ByteString++ context "from strict ByteString" $ do+ prop "into String" $ iiiIdempotentInverse @B.ByteString @String+ prop "into strict Text" $ iiiIdempotentInverse @B.ByteString @T.Text+ prop "into lazy Text" $ iiiIdempotentInverse @B.ByteString @LT.Text+ prop "into lazy ByteString" $ iiiIdempotentInverse @B.ByteString @LB.ByteString++ context "from lazy ByteString" $ do+ prop "into String" $ iiiIdempotentInverse @LB.ByteString @String+ prop "into strict Text" $ iiiIdempotentInverse @LB.ByteString @T.Text+ prop "into lazy Text" $ iiiIdempotentInverse @LB.ByteString @LT.Text+ prop "into strict ByteString" $ iiiIdempotentInverse @LB.ByteString @B.ByteString++ prop "is commutative with string reversal" $+ \(SpaceyText t) -> [iii|#{T.reverse t}|] == T.reverse [iii|#{t}|]++ prop "non-whitespace chars in output same as in input" $+ \(SpaceyText t) -> charFrequencies [iii|#{t}|] == charFrequencies t++ prop "output string length <= input string length" $+ \(SpaceyText t) -> T.length [iii|#{t}|] <= T.length t++ prop "output words = input words" $+ \(SpaceyText t) -> T.words t == T.words [iii|#{t}|]++iID :: forall from to fromflag toflag.+ ( Eq from+ , Interpolatable fromflag to from+ , Interpolatable toflag from to+ )+ => from+ -> Bool+iID from =+ let to :: to = [i|#{from}|]+ from' :: from = [i|#{to}|]+ in from == from'++iiiIdempotent :: forall to toflag.+ ( Eq to+ , Interpolatable toflag to to+ , Interpolatable toflag T.Text to+ , SpaceChompable to+ )+ => SpaceyText+ -> Bool+iiiIdempotent (SpaceyText t) =+ let x :: to = [iii|#{t}|]+ x' :: to = [iii|#{x}|]+ in x == x'++iiiIdempotentInverse :: forall from to fromflag toflag.+ ( Eq from+ , Interpolatable fromflag T.Text from+ , Interpolatable toflag from to+ , Interpolatable fromflag to from+ , SpaceChompable from+ , SpaceChompable to+ )+ => SpaceyText+ -> Bool+iiiIdempotentInverse (SpaceyText t) =+ let x :: from = [iii|#{t}|]+ x' :: to = [iii|#{x}|]+ x'' :: from = [iii|#{x'}|]+ in x == x''++-- |+-- Add the given number of the specific characters to the left.+leftPad :: Int -> Char -> String -> String+leftPad amt c t = replicate amt c <> t++-- |+-- The default Arbitrary for Char generates U+FFFF and U+FFFE, which aren't+-- valid Unicode. Sigh...+newtype UTF8Char = UTF8C { unUTF8C :: Char }+ deriving newtype (Eq, Show)++newtype UTF8String = UTF8S { unUTF8S :: String }+ deriving newtype (Eq, Show)++newtype UTF8ByteString = UTF8BS B.ByteString+ deriving newtype (Eq, Show)+newtype UTF8LazyByteString = UTF8LBS LB.ByteString+ deriving newtype (Eq, Show)++newtype SpaceyText = SpaceyText T.Text+ deriving newtype (Eq, Show)+newtype NonwhitespaceText = NonwhitespaceText T.Text+ deriving newtype (Eq, Show)++instance Arbitrary UTF8Char where+ arbitrary = UTF8C <$> unicodeChar+ shrink (UTF8C c) = UTF8C <$> shrinkChar c++instance Arbitrary UTF8String where+ arbitrary = do+ chars <- listOf arbitrary+ pure $ UTF8S (unUTF8C <$> chars)+ shrink (UTF8S str) = UTF8S <$> shrink str++instance Arbitrary T.Text where+ arbitrary = T.pack . unUTF8S <$> arbitrary+ shrink t = if T.null t || T.length t == 1+ then []+ else let mid = T.length t `div` 2+ in [T.take mid t, T.drop mid t]++instance Arbitrary LT.Text where+ arbitrary = LT.pack . unUTF8S <$> arbitrary+ shrink lt = if LT.null lt || LT.length lt == 1+ then []+ else let mid = LT.length lt `div` 2+ in [LT.take mid lt, LT.drop mid lt]++instance Arbitrary UTF8ByteString where+ arbitrary = UTF8BS . LB.toStrict . LB.toLazyByteString . foldMap LB.charUtf8 . unUTF8S+ <$> arbitrary++instance Arbitrary UTF8LazyByteString where+ arbitrary = UTF8LBS . LB.toLazyByteString . foldMap LB.charUtf8 . unUTF8S+ <$> arbitrary++-- Basically, we want this to be an 'alternation' of sequences of printable+-- characters and whitespace characters.+instance Arbitrary SpaceyText where+ arbitrary = SpaceyText . foldMap id+ <$> scale+ (round . sqrt @Double . fromIntegral)+ (listOf (oneof [whitespace, nonwhitespace]))++instance Arbitrary NonwhitespaceText where+ arbitrary = NonwhitespaceText <$> nonwhitespace++instance Arbitrary InterpSegment where+ arbitrary = oneof+ [ Verbatim <$> listOf nonwhitespaceChar+ , Expression <$> arbitrary+ , pure Newline+ , Spaces <$> arbitrary+ , Tabs <$> arbitrary+ ]++ shrink (Verbatim t) = Verbatim <$> shrink t+ shrink (Expression t) = []+ shrink Newline = []+ shrink (Spaces n) = [Spaces (n `div` 2), Spaces (n-1)]+ shrink (Tabs n) = [Tabs (n `div` 2), Tabs (n-1)]++charFrequencies :: T.Text -> HM.HashMap Char Int+charFrequencies = T.foldl' (flip $ HM.alter increment) HM.empty . T.filter (not . isSpace)+ where increment :: Maybe Int -> Maybe Int+ increment Nothing = Just 1+ increment (Just x) = Just (x + 1)++whitespace :: Gen T.Text+whitespace = T.pack+ <$> listOf1 (elements [' ', '\r', '\t', '\n', '\x1680', '\x2000', '\x2006'])++nonwhitespace :: Gen T.Text+nonwhitespace = T.pack+ <$> listOf1 nonwhitespaceChar++nonwhitespaceChar :: Gen Char+nonwhitespaceChar = unicodeChar `suchThat` (not . isSpace)++unicodeChar :: Gen Char+unicodeChar = chr `fmap` points+ where points = flip suchThat (not . reserved) $ oneof+ [ ascii+ , plane0+ , plane1+ , plane2+ , plane14+ ]++-- Get back the compile time string that would create a given interpolation.+interpToString :: [InterpSegment] -> String+interpToString [] = ""+interpToString (Expression expr : rest) = "#{" ++ expr ++ "}" ++ interpToString rest+interpToString (Newline : rest) = '\n' : interpToString rest+interpToString (Spaces n : rest) = replicate n ' ' ++ interpToString rest+interpToString (Tabs n : rest) = replicate n '\t' ++ interpToString rest+interpToString (Verbatim str : rest) = interpEscape str ++ interpToString rest+ where interpEscape :: String -> String+ interpEscape "" = ""+ interpEscape ('\\':cs) = '\\':'\\':interpEscape cs+ interpEscape ('#':cs) = '\\':'#':interpEscape cs+ interpEscape (c:cs) = c:interpEscape cs