typist (empty) → 0.1.0.0
raw patch · 8 files changed
+374/−0 lines, 8 filesdep +basedep +deepseqdep +tasty
Dependencies added: base, deepseq, tasty, tasty-bench, tasty-hunit, text, text-show, typist
Files
- CHANGELOG.md +5/−0
- LICENSE +20/−0
- src/Typist.hs +9/−0
- src/Typist/Internal/Format.hs +81/−0
- src/Typist/TextShow.hs +48/−0
- test/Bench.hs +108/−0
- test/Test.hs +54/−0
- typist.cabal +49/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for safe-interpolate++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2023 Danil Berestov++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ src/Typist.hs view
@@ -0,0 +1,9 @@+module Typist + ( + Export.Format+ , Export.fmt+ , Export.Rec (..)+ , Export.Arg (..)+ ) where++import Typist.Internal.Format as Export
+ src/Typist/Internal/Format.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PolyKinds #-}++module Typist.Internal.Format (module Typist.Internal.Format) where++import Data.Data (Proxy (..))+import Data.String (IsString (..))+import qualified Data.Text.Lazy.Builder as Builder+import GHC.TypeLits (+ ConsSymbol,+ ErrorMessage (..),+ KnownSymbol,+ Nat,+ Symbol,+ TypeError,+ UnconsSymbol,+ symbolVal,+ type (+),+ )+import GHC.TypeNats (KnownNat, natVal)++type family Format (str :: Symbol) where+ Format str = ContFormat 0 (UnconsSymbol str)++newtype Arg (n :: Nat) (s :: Symbol) = Arg Builder.Builder++type family ContFormat (n :: Nat) (a :: Maybe (Char, Symbol)) where+ ContFormat n ('Just '( '\\', rest)) = SkipOne (n + 1) (UnconsSymbol rest)+ ContFormat n ('Just '( '#', rest)) = TryGetArg n (UnconsSymbol rest)+ ContFormat n ('Just '(a, rest)) = ContFormat (n + 1) (UnconsSymbol rest)+ ContFormat n 'Nothing = '[]++type family TryGetArg n rest where+ TryGetArg n ('Just '( '{', rest)) =+ Arg n (TakeName (UnconsSymbol rest))+ ': ContFormat (n + 2) (UnconsSymbol (SkipName (UnconsSymbol rest)))+ TryGetArg n 'Nothing = ContFormat n 'Nothing+ TryGetArg n ('Just '(a, rest)) = ContFormat (n + 2) (UnconsSymbol rest)++type family SkipOne (n :: Nat) (s :: Maybe (Char, Symbol)) where+ SkipOne n 'Nothing = ContFormat n 'Nothing+ SkipOne n ('Just '(a, rest)) = ContFormat (n + 1) (UnconsSymbol rest)++type family TakeName (a :: Maybe (Char, Symbol)) :: Symbol where+ TakeName ('Just '( '}', rest)) = ""+ TakeName ('Just '(a, rest)) = ConsSymbol a (TakeName (UnconsSymbol rest))+ TakeName 'Nothing = TypeError ('Text "Expected '}' but EOF found. Close placeholder with '}'. Example: #{name}")++type family SkipName (a :: Maybe (Char, Symbol)) :: Symbol where+ SkipName ('Just '( '}', rest)) = rest+ SkipName ('Just '(a, rest)) = SkipName (UnconsSymbol rest)+ SkipName 'Nothing = ""++class Interpolate args where+ interpolate :: Rec args -> Int -> String -> Builder.Builder -> Builder.Builder++instance Interpolate '[] where+ {-# INLINE interpolate #-}+ interpolate _ _ string acc = acc <> fromString string++instance (Interpolate args, KnownNat i) => Interpolate (Arg i n ': args) where+ {-# INLINE interpolate #-}+ interpolate (Arg s :& record) start string acc =+ interpolate @args+ record+ (nVal + 2)+ (drop 1 $ dropWhile (/= '}') $ drop (diff + 3) string)+ (acc <> fromString (take diff string) <> s)+ where+ nVal = fromIntegral $ natVal (Proxy @i)+ diff = nVal - start++data Rec as where+ RNil :: Rec '[]+ (:&) :: Arg n s -> Rec ns -> Rec (Arg n s ': ns)+++-- | See usage example next to @'Typist.TextShow.#='@ at "Typist.TextShow"+{-# INLINE fmt #-}+fmt :: forall str. (KnownSymbol str, Interpolate (Format str)) => (Rec '[] -> Rec (Format str)) -> Builder.Builder+fmt record_ = interpolate @(Format str) (record_ RNil) 0 (symbolVal (Proxy @str)) mempty
+ src/Typist/TextShow.hs view
@@ -0,0 +1,48 @@+module Typist.TextShow where+import TextShow+import GHC.OverloadedLabels+import GHC.TypeLits+import Typist+import qualified Data.Text as Text+import qualified Data.Text.Lazy as Text.Lazy+import qualified Data.Text.Lazy.Builder as Builder++data Name (s :: Symbol) = Name++instance IsLabel s (Name s) where+ fromLabel = Name++-- | Set parameter for template+--+-- @+-- ghci> :{+-- fmt \@"Hello, #{name}, do you like #{thing}?" $ +-- (#name \@= Unquoted \"Kitty\") . (#thing \@= Unquoted \"cheese\")+-- :}+-- "Hello, Kitty, do you like cheese?"+-- @+{-# INLINE (#=) #-}+(#=) :: (TextShow a) => Name s -> a -> (Rec as -> Rec (Arg n s ': as))+(#=) Name a = (Arg (showb a) :&)++-- | Use to render string as is without quotation+--+-- @+-- ghci> "> " <> showt "hello" <> " <"+-- "> \\"hello\\" <"+-- ghci> "> " <> showt (Unquoted "hello") <> " <"+-- "> hello <"+-- @+newtype Unquoted a = Unquoted a++instance TextShow (Unquoted String) where+ showb (Unquoted s) = fromString s++instance TextShow (Unquoted Text.Text) where+ showb (Unquoted s) = Builder.fromText s++instance TextShow (Unquoted Text.Lazy.Text) where+ showb (Unquoted s) = Builder.fromLazyText s++instance TextShow (Unquoted Builder.Builder) where+ showb (Unquoted s) = s
+ test/Bench.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++module Main (main) where++import Control.DeepSeq (rnf)+import Data.Foldable (Foldable (fold))+import qualified Data.Text as Strict+import qualified Data.Text.Lazy as Lazy+import qualified Data.Text.Lazy.Builder as Builder+import GHC.IO (evaluate)+import GHC.OverloadedLabels (IsLabel (fromLabel))+import GHC.TypeLits (Symbol)+import Test.Tasty.Bench (bench, bgroup, defaultMain, nf)+import TextShow+import Typist+import Typist.TextShow+import Typist.Internal.Format (Arg)++toStrictText = Lazy.toStrict . Builder.toLazyText++{-# INLINE get #-}+get :: (?list :: [a], ?f :: (a -> b)) => Int -> b+get i = ?f $ ?list !! i++{-# NOINLINE concatTest #-}+concatTest :: (TextShow a) => [a] -> Strict.Text+concatTest list =+ toStrictText+ let ?list = list+ ?f = showb+ in "1"+ <> get 0+ <> "22"+ <> get 1+ <> "333"+ <> get 2+ <> "4444"+ <> get 3+ <> "55555"+ <> get 4+ <> "666666"+ <> get 5+ <> "7777777"+ <> get 6+ <> "88888888"+ <> get 7+ <> "999999999"+ <> get 8+ <> "1010101010"+ <> get 9+ <> "11111111111"+ <> get 10+ <> "121212121212"+ <> get 11+ <> "1313131313131"+ <> get 12++{-# NOINLINE formatTest #-}+formatTest :: (TextShow a) => [a] -> Strict.Text+formatTest list =+ toStrictText+ let ?list = list+ ?f = id+ in fmt+ @"1#{i0}22#{i1}333#{i2}4444#{i3}55555#{i4}666666#{i5}7777777#{i6}88888888#{i7}\+ \999999999#{i8}1010101010#{i9}11111111111#{i10}121212121212#{i11}1313131313131#{i12}"+ $ (#i0 #= get 0)+ . (#i1 #= get 1)+ . (#i2 #= get 2)+ . (#i3 #= get 3)+ . (#i4 #= get 4)+ . (#i5 #= get 5)+ . (#i6 #= get 6)+ . (#i7 #= get 7)+ . (#i8 #= get 8)+ . (#i9 #= get 9)+ . (#i10 #= get 10)+ . (#i11 #= get 11)+ . (#i12 #= get 12)+++{-# NOINLINE jobs #-}+jobs :: Int -> ([a] -> Strict.Text) -> [[a] -> Strict.Text]+jobs = replicate++main :: IO ()+main = do+ let list = [1 .. 20] :: [Int]+ _ <- evaluate (rnf list)+ let benches =+ [1, 10, 100, 1000, 10000] >>= \n ->+ [ bgroup+ ("Formatting " <> show n <> " strings")+ [ bench "concat" $ nf (\l -> foldMap ($ l) $ jobs n concatTest) list+ , bench "format" $ nf (\l -> foldMap ($ l) $ jobs n formatTest) list+ ]+ ]+ defaultMain [bgroup "Formatting" benches]
+ test/Test.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE FlexibleInstances #-}++module Main (main) where++import Test.Tasty (defaultMain, testGroup)+import Test.Tasty.HUnit+import TextShow (TextShow(..))+import Data.String (IsString(..))+import Typist (fmt)+import Typist.TextShow+++main :: IO ()+main = defaultMain do+ testGroup+ "Interpolation"+ [ testGroup+ "No template"+ [ testCase "No arguments" do+ fmt @"Hello" id `shouldBe` "Hello"+ , testCase "One argument" do+ fmt @"Hello, #{name}!" (#name #= Unquoted @String "Kitty") `shouldBe` "Hello, Kitty!"+ , testCase "Two arguments" do+ let formatted = fmt @"Hello, #{name}, do you like #{dish}?" $+ (#name #= Unquoted @String "Mike") .+ (#dish #= Unquoted @String "pasta")+ formatted `shouldBe` "Hello, Mike, do you like pasta?"+ , testCase "Many arguments" do+ let formatted = fmt @"One: #{one}, two: #{two}, three: #{three}, four: #{four}, five: #{five}" $+ (#one #= (1 :: Int)) .+ (#two #= True) .+ (#three #= 'a') .+ (#four #= [5 :: Int]) .+ (#five #= ('a', False))+ formatted `shouldBe` "One: 1, two: True, three: 'a', four: [5], five: ('a',False)"+ ]+ , testGroup+ "Escaping"+ [ testCase "Should not consider escaped sequence as placeholder" do+ fmt @"Hello, \\#{huh} #{name}" (#name #= Unquoted @String "Kitty")+ `shouldBe` "Hello, \\#{huh} Kitty"++ fmt @"Hello, #{name} \\#{huh}" (#name #= Unquoted @String "Kitty")+ `shouldBe` "Hello, Kitty \\#{huh}"+ ]+ ]++shouldBe :: (Show a, Eq a) => a -> a -> Assertion+shouldBe a b = assertBool "" (a == b)
+ typist.cabal view
@@ -0,0 +1,49 @@+cabal-version: 3.0+name: typist+version: 0.1.0.0++license: MIT+license-file: LICENSE+author: Danil Berestov+maintainer: goosedb@yandex.ru++category: Text+extra-source-files: CHANGELOG.md+synopsis: Typelevel printf++library+ exposed-modules: Typist.Internal.Format, Typist.TextShow, Typist+ build-depends: base >= 4.16 && < 4.20, text, text-show+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall+ default-extensions:+ DataKinds,+ TypeOperators,+ TypeFamilies,+ UndecidableInstances,+ TypeApplications,+ ScopedTypeVariables,+ FlexibleInstances,+ MultiParamTypeClasses,+ DefaultSignatures,+ FlexibleContexts,+ AllowAmbiguousTypes,+ OverloadedLabels,+ BlockArguments+++test-suite typist-test+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Test.hs+ build-depends: base >= 4.16, typist, tasty, tasty-hunit, text-show++benchmark typist-bench+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Bench.hs+ ghc-options: -O2+ build-depends: base >= 4.16, typist, tasty, tasty-bench, text, deepseq, text-show