{-# 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