diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,10 @@ # Revision history for yasi +## 0.2.0.0 -- 2022-03-13 + + * Support interpolating arbitrary expressions. + * Use `Display` from the `text-display` package. + ## 0.1.2.1 -- 2021-03-15 * Allow to interpolate lazy into strict `ByteString`s and vice versa. diff --git a/src/Yasi.hs b/src/Yasi.hs --- a/src/Yasi.hs +++ b/src/Yasi.hs @@ -1,11 +1,11 @@ -- | Yet another string interpolator -- --- * Dead simple --- * No dependency on [haskell-src-meta](https://hackage.haskell.org/package/haskell-src-meta). --- It is not actively developed, has long compile times and several bugs, some of which are --- by design (e.g. operator fixities). --- * Supports interpolating 'String', 'Data.Text.Text', lazy 'Data.Text.Lazy.Text', --- 'Data.ByteString.ByteString' and lazy 'Data.ByteString.Lazy.ByteString' (UTF8). +-- * Very simple, few dependencies. +-- * Based on 'Data.Text.Display.Display' instead of 'Show'. +-- * Depends on [ghc-hs-meta](https://hackage.haskell.org/package/ghc-hs-meta) +-- instead of [haskell-src-meta](https://hackage.haskell.org/package/haskell-src-meta) +-- for interpolating arbitrary expressions. +-- This result in faster compile times and fewer bugs. module Yasi ( i, @@ -14,13 +14,9 @@ iS, iT, iTL, - iB, - iBL, ) where -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL import Data.String (IsString (..)) import qualified Data.Text as T import qualified Data.Text.Lazy as TL @@ -31,11 +27,14 @@ -- $setup -- >>> import Yasi -- >>> import Data.Text (Text) --- >>> import Data.ByteString (ByteString) +-- >>> import qualified Data.Text.Lazy int :: (TH.Exp -> TH.Exp) -> TH.QuasiQuoter int = interpolator '$' +intT :: TH.Name -> TH.QuasiQuoter +intT = int . flip TH.SigE . TH.ConT + -- | The main interpolator, intended to be used with -- [@QuasiQuotes@](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/exts/template_haskell.html#extension-QuasiQuotes). -- @@ -45,18 +44,13 @@ -- >>> [i|${foo}string $bar|] :: String -- "yet another string interpolator" -- +-- The result type can be 'String', strict 'T.Text' or lazy 'TL.Text'. +-- -- You can also use @${}@ to create a function interpolator (this "abstraction" feature is inspired by -- [interpolate](https://hackage.haskell.org/package/interpolate)): -- --- >>> [i|more ${}${} code|] "point" "free" :: Text --- "more pointfree code" --- --- To use 'show' to interpolate a value: --- --- >>> let x = 1 + 1 in [i|1 + 1 = ${show x}|] :: ByteString --- "1 + 1 = 2" --- >>> [i|2 + 2 = $show|] (2 + 2) :: Text --- "2 + 2 = 4" +-- >>> [i|more ${}${} code${replicate 3 '!'}|] "point" "free" :: Text +-- "more pointfree code!!!" i :: TH.QuasiQuoter i = int id @@ -69,9 +63,6 @@ iFS :: TH.QuasiQuoter iFS = int $ TH.AppE (TH.VarE 'fromString) -intT :: TH.Name -> TH.QuasiQuoter -intT = int . flip TH.SigE . TH.ConT - -- | Like 'i', but with the result type fixed to 'String'. -- -- @['iS'|...|] = ['i'|...|] :: 'String'@ @@ -81,7 +72,7 @@ iS :: TH.QuasiQuoter iS = intT ''String --- | Like 'i', but with the result type fixed to 'T.Text'. +-- | Like 'i', but with the result type fixed to strict 'T.Text'. -- -- @['iT'|...|] = ['i'|...|] :: 'T.Text'@ -- @@ -90,19 +81,11 @@ iT :: TH.QuasiQuoter iT = intT ''T.Text --- | Like 'iT', but lazy. -iTL :: TH.QuasiQuoter -iTL = intT ''TL.Text - --- | Like 'i', but with the result type fixed to 'B.ByteString'. +-- | Like 'i', but with the result type fixed to lazy 'TL.Text'. -- --- @['iB'|...|] = ['i'|...|] :: 'B.ByteString'@ +-- @['iTL'|...|] = ['i'|...|] :: 'TL.Text'@ -- --- >>> :t [iB|hi|] --- [iB|hi|] :: ByteString -iB :: TH.QuasiQuoter -iB = intT ''B.ByteString - --- | Like 'iB', but lazy. -iBL :: TH.QuasiQuoter -iBL = intT ''BL.ByteString +-- >>> :t [iTL|hi|] +-- [iTL|hi|] :: Data.Text.Lazy.Text +iTL :: TH.QuasiQuoter +iTL = intT ''TL.Text diff --git a/src/Yasi/Internal.hs b/src/Yasi/Internal.hs --- a/src/Yasi/Internal.hs +++ b/src/Yasi/Internal.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE UndecidableInstances #-} -- | Internal module, no stability guarantees module Yasi.Internal @@ -6,92 +6,88 @@ parseSegments, ipExpr, interpolator, - Stringy (..), + Displayish (..), + Stringish (..), ) where import Control.Monad ((>=>)) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL import qualified Data.Char as C import qualified Data.Text as T -import qualified Data.Text.Encoding as T +import qualified Data.Text.Display as TD import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Encoding as TL +import qualified Data.Text.Lazy.Builder as TLB import GHC.Generics (Generic) +import qualified Language.Haskell.Meta.Parse as GhcHsMeta +import qualified Language.Haskell.TH.Lib as TH import qualified Language.Haskell.TH.Quote as TH import qualified Language.Haskell.TH.Syntax as TH -#if !(MIN_VERSION_base(4,13,0)) -import Control.Monad.Fail (MonadFail) -#endif -#if !(MIN_VERSION_base(4,11,0)) -import Data.Semigroup ((<>)) -#endif - data Segment = Lit String - | Var String - | ShowVar String + | Exp String | Abs -- idea due to interpolate - | ShowAbs deriving (Show, Eq, Generic) parseSegments :: MonadFail m => Char -> String -> m [Segment] parseSegments c = fmap (group []) . go where - -- rewrite this + -- ugly, but simple enoughβ„’ go s | let (lit, rest) = span (/= c) s, not (null lit) = (Lit lit :) <$> go rest | s == "" = pure [] | s == [c] = fail $ "should not end with single " <> [c] | _ : c' : rest <- s, c == c' = (Lit [c] :) <$> go rest - | _ : '{' : rest <- s = case span (/= '}') rest of - (var, '}' : rest) -> - let seg = case var of - "" -> Abs - "show" -> ShowAbs - 's' : 'h' : 'o' : 'w' : ' ' : var -> ShowVar var - var -> Var var - in (seg :) <$> go rest - _ -> fail "missing closing bracket" + | _ : '{' : rest <- s = case span (/= '}') rest of -- TODO smarter? + (exp, '}' : rest) -> + let seg = if exp == "" then Abs else Exp exp + in (seg :) <$> go rest + _ -> fail "missing closing bracket" | _ : v : rest' <- s, isVarStartChar v = - let (vs, rest) = span isVarChar rest' - var = v : vs - s = if var == "show" then ShowAbs else Var var - in (s :) <$> go rest + let (vs, rest) = span isVarChar rest' + in (Exp (v : vs) :) <$> go rest | otherwise = fail $ "invalid char after " <> [c] isVarStartChar v = C.isAscii v && C.isAlpha v isVarChar v = C.isAscii v && (C.isAlphaNum v || v == '_' || v == '\'') group ls [] = lit ls group ls (Lit l : ss) = group (l : ls) ss - group ls (s : ss) = lit ls ++ (s : group [] ss) + group ls (s : ss) = lit ls <> (s : group [] ss) lit [] = [] lit ls = [Lit $ mconcat $ reverse ls] -ipExpr :: TH.Exp -> (TH.Exp -> TH.Exp) -> [Segment] -> TH.Q TH.Exp -ipExpr cast combine segs = do +ipExpr :: (TH.Exp -> TH.Exp) -> [Segment] -> TH.Q TH.Exp +ipExpr transform segs = do (ls, lams) <- go segs - pure $ lams $ combine $ TH.ListE ls + pure + . lams + . transform + . TH.AppE (TH.VarE 'stringish) + . foldr (flip TH.UInfixE (TH.VarE '(<>))) (TH.VarE 'mempty) + $ ls where go = \case [] -> pure ([], id) - (s : ss) -> prep (go ss) $ case s of - Lit l -> pure (TH.SigE (TH.LitE (TH.StringL l)) (TH.ConT ''String), id) - Var v -> pure (TH.VarE (TH.mkName v), id) - ShowVar v -> pure (TH.AppE (TH.VarE 'show) $ TH.VarE (TH.mkName v), id) + s : ss -> prep (go ss) case s of + Lit l -> (,id) <$> [|$(TH.stringE l) :: String|] + Exp e -> do + exts <- TH.extsEnabled + exp <- case GhcHsMeta.parseExpWithExts exts e of + Right e -> pure e + Left (line, col, msg) -> + fail . unlines $ + [ "Parse error at splice `" <> e <> "`:", + show line <> ":" <> show col <> ": " <> msg + ] + pure (exp, id) Abs -> do n <- TH.newName "int" pure (TH.VarE n, TH.LamE [TH.VarP n]) - ShowAbs -> do - n <- TH.newName "showint" - pure (TH.AppE (TH.VarE 'show) $ TH.VarE n, TH.LamE [TH.VarP n]) prep asg af = do (as, g) <- asg (a, f) <- af - pure (TH.AppE cast a : as, f . g) + pure (TH.AppE (TH.VarE 'displayish) a : as, f . g) interpolator :: Char -> @@ -100,67 +96,29 @@ TH.QuasiQuoter interpolator c pp = TH.QuasiQuoter {..} where - quoteExp = parseSegments c >=> ipExpr (TH.VarE 'stringy) (pp . TH.AppE (TH.VarE 'mconcat)) + quoteExp = parseSegments c >=> ipExpr pp quotePat = const $ fail "pattern context not supported" quoteType = const $ fail "type context not supported" quoteDec = const $ fail "declaration context not supported" -class Stringy a b where - stringy :: a -> b - -instance Stringy String String where - stringy = id - -instance Stringy String T.Text where - stringy = T.pack - -instance Stringy String TL.Text where - stringy = TL.pack - -instance Stringy String B.ByteString where - stringy = T.encodeUtf8 . T.pack - -instance Stringy String BL.ByteString where - stringy = TL.encodeUtf8 . TL.pack - -instance Stringy T.Text T.Text where - stringy = id - -instance Stringy T.Text String where - stringy = T.unpack - -instance Stringy T.Text TL.Text where - stringy = TL.fromStrict - -instance Stringy T.Text B.ByteString where - stringy = T.encodeUtf8 - -instance Stringy T.Text BL.ByteString where - stringy = BL.fromStrict . T.encodeUtf8 - -instance Stringy TL.Text TL.Text where - stringy = id - -instance Stringy TL.Text String where - stringy = TL.unpack - -instance Stringy TL.Text T.Text where - stringy = TL.toStrict +class Displayish a where + displayish :: a -> TLB.Builder -instance Stringy TL.Text B.ByteString where - stringy = BL.toStrict . TL.encodeUtf8 +instance {-# OVERLAPPABLE #-} TD.Display a => Displayish a where + displayish = TD.displayBuilder -instance Stringy TL.Text BL.ByteString where - stringy = TL.encodeUtf8 +-- String is still used too pervasively... +instance Displayish String where + displayish = TLB.fromString -instance Stringy B.ByteString B.ByteString where - stringy = id +class Stringish a where + stringish :: TLB.Builder -> a -instance Stringy B.ByteString BL.ByteString where - stringy = BL.fromStrict +instance Stringish String where + stringish = TL.unpack . TLB.toLazyText -instance Stringy BL.ByteString BL.ByteString where - stringy = id +instance Stringish T.Text where + stringish = TL.toStrict . TLB.toLazyText -instance Stringy BL.ByteString B.ByteString where - stringy = BL.toStrict +instance Stringish TL.Text where + stringish = TLB.toLazyText diff --git a/test/Interpolations.hs b/test/Interpolations.hs --- a/test/Interpolations.hs +++ b/test/Interpolations.hs @@ -1,44 +1,39 @@ -{-# LANGUAGE CPP #-} - module Interpolations where +import Control.Applicative (Const (..)) import qualified Data.Text as T -import qualified Data.Text.Encoding as T +import Data.Text.Display (display) +import qualified Data.Text.Lazy as TL import Hedgehog import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import Test.Tasty +import Test.Tasty.HUnit import Test.Tasty.Hedgehog import Yasi -#if !(MIN_VERSION_base(4,11,0)) -import Data.Semigroup ((<>)) -#endif - test_interpolation :: TestTree test_interpolation = testGroup "interpolation" - [ testProperty "to String" . property $ do + [ testPropertyNamed "to String" "interpolation_to_String" . property $ do (a, b, c) <- (,,) <$> forAll genString <*> forAll genText <*> forAll genString [i|${a}++$bπŸ™€πŸ™€πŸ™€πŸ™€$cπŸ™€|] === a <> "++" <> T.unpack b <> "πŸ™€πŸ™€πŸ™€πŸ™€" <> c <> "πŸ™€", - testProperty "to Text" . property $ do + testPropertyNamed "to Text" "interpolation_to_Text" . property $ do (a, b, c) <- (,,) <$> forAll genText <*> forAll genText <*> forAll genString [i|😢😢$a😢😢$b😢😢$c😢😢|] === "😢😢" <> a <> "😢😢" <> b <> "😢😢" <> T.pack c <> "😢😢", - testProperty "to ByteString" . property $ do - (a, b, c) <- (,,) <$> forAll genBS <*> forAll genText <*> forAll genString - let p = T.encodeUtf8 "β„˜" - [i|β„˜$aβ„˜$bβ„˜$cβ„˜|] === p <> a <> p <> T.encodeUtf8 b <> p <> T.encodeUtf8 (T.pack c) <> p, - testProperty "abstractions" . property $ do - (a, b) <- (,) <$> forAll genText <*> forAll genInt - [i|xxx-${}$show-yyy|] a (b :: Int) === "xxx-" <> a <> T.pack (show b) <> "-yyy", - testProperty "variants" . property $ do - (a, b) <- (,) <$> forAll genText <*> forAll genInt - [iT|xxx-${}$show-yyy|] a (b :: Int) === "xxx-" <> a <> T.pack (show b) <> "-yyy" + testPropertyNamed "abstractions" "interpolation_abstractions" . property $ do + (a, b :: Int) <- (,) <$> forAll genText <*> forAll genInt + [i|xxx-${}${}-yyy|] a b === "xxx-" <> a <> display b <> "-yyy", + testCase "interpolationg expressions" do + let foo :: Int -> Int -> Int + foo a b = a + b - 3 + [iT|${1+1 :: Int}-${foo 2 4}|] @?= T.pack "2-3" + [iTL|${1+1 :: Int}-${foo 2 4}|] @?= TL.pack "2-3" + [iFS|${1+1 :: Int}-${foo 2 4}|] @?= (Const "2-3" :: Const String (Int -> Bool)) ] where - genString = Gen.string range Gen.unicodeAll - genText = Gen.text range Gen.unicodeAll - genBS = Gen.bytes range + genString = Gen.string range Gen.unicode + genText = Gen.text range Gen.unicode range = Range.constant 0 20 genInt = Gen.integral $ Range.constant 0 1000 diff --git a/test/Segments.hs b/test/Segments.hs --- a/test/Segments.hs +++ b/test/Segments.hs @@ -6,22 +6,18 @@ unit_segment_parsing :: IO () unit_segment_parsing = do ps "foo\\\"" @?= Just [Lit "foo\\\""] - ps "$a-$b" @?= Just [Var "a", Lit "-", Var "b"] + ps "$a-$b" @?= Just [Exp "a", Lit "-", Exp "b"] ps "asef$" @?= Nothing ps "lol$${}" @?= Just [Lit "lol${}"] ps "lol$$${}" @?= Just [Lit "lol$", Abs] - ps "${89+}${}" @?= Just [Var "89+", Abs] + ps "${89+}${}" @?= Just [Exp "89+", Abs] ps "${}}" @?= Just [Abs, Lit "}"] - ps "asdf${show bar}$$" @?= Just [Lit "asdf", ShowVar "bar", Lit "$"] ps "a$$b" @?= Just [Lit "a$b"] - ps "$a$b$c" @?= Just [Var "a", Var "b", Var "c"] + ps "$a$b$c" @?= Just [Exp "a", Exp "b", Exp "c"] ps "" @?= Just [] ps " " @?= Just [Lit " "] - ps "$foobar:\n - $b" @?= Just [Var "foobar", Lit ":\n - ", Var "b"] + ps "$foobar:\n - $b" @?= Just [Exp "foobar", Lit ":\n - ", Exp "b"] ps "${foobar]" @?= Nothing ps "test-$0foo" @?= Nothing - ps "${show }" @?= Just [ShowVar ""] - ps "${show}" @?= Just [ShowAbs] - ps "$show" @?= Just [ShowAbs] where ps = parseSegments '$' diff --git a/test/Util.hs b/test/Util.hs --- a/test/Util.hs +++ b/test/Util.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP #-} - module Util where import qualified Data.Text as T @@ -11,17 +9,13 @@ import Test.Tasty.Hedgehog import Yasi.Util -#if !(MIN_VERSION_base(4,11,0)) -import Data.Semigroup ((<>)) -#endif - test_unindent :: TestTree test_unindent = testGroup "unindentation" [ testCase "empty string" $ do unindent "" @?= "", - testProperty "single line" . property $ do + testPropertyNamed "single line" "unindentation_single_line" . property $ do t <- forAll genTextWONL unindent t === (T.dropWhile (== ' ') t <> "\n"), testCase "multi line" $ do diff --git a/yasi.cabal b/yasi.cabal --- a/yasi.cabal +++ b/yasi.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: yasi -version: 0.1.2.1 +version: 0.2.0.0 synopsis: Yet another string interpolator description: @@ -23,27 +23,23 @@ common commons default-language: Haskell2010 - ghc-options: -Wall -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fno-warn-name-shadowing - if impl(ghc >= 8.2) - ghc-options: -fhide-source-paths - if impl(ghc >= 8.10) - ghc-options: -Wunused-packages - default-extensions: DeriveGeneric FlexibleContexts FlexibleInstances LambdaCase MultiParamTypeClasses OverloadedStrings QuasiQuotes RecordWildCards TemplateHaskell + ghc-options: -Wall -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fno-warn-name-shadowing -Wunused-packages + default-extensions: BlockArguments DeriveGeneric FlexibleContexts FlexibleInstances LambdaCase MultiParamTypeClasses OverloadedStrings QuasiQuotes RecordWildCards ScopedTypeVariables TemplateHaskell TupleSections library import: commons - if impl(ghc >= 8.4) - ghc-options: -Wmissing-export-lists + ghc-options: -Wmissing-export-lists hs-source-dirs: src exposed-modules: Yasi Yasi.Internal Yasi.Util build-depends: - base >= 4.9 && < 5 - , template-haskell >= 2.11 && < 2.18 - , text ^>= 1.2 - , bytestring >= 0.10.8 && < 0.12 + base >= 4.14 && < 5 + , template-haskell >= 2.16 && < 2.19 + , text >= 1.2 && < 2.1 + , text-display ^>= 0.0 + , ghc-hs-meta ^>= 0.1 test-suite tasty import: commons @@ -57,10 +53,11 @@ base , yasi , text - , tasty >= 1.3 && <= 1.5 + , text-display + , tasty >= 1.3 && < 1.5 , tasty-hunit ^>= 0.10 - , tasty-hedgehog ^>= 1.0 - , hedgehog ^>= 1.0 + , tasty-hedgehog >= 1.0 && < 1.3 + , hedgehog >= 1.0 && < 1.2 other-modules: Segments Interpolations