diff --git a/benchmark/Main.hs b/benchmark/Main.hs new file mode 100644 --- /dev/null +++ b/benchmark/Main.hs @@ -0,0 +1,43 @@ +module Main where + +import Criterion.Main (bench, bgroup, defaultMain, whnf) +import qualified Data.Text.Lazy.Builder as Text +import Data.Text.Lazy.Builder (toLazyText) +import Exon.Class.Exon (exonProcess) +import Exon.Data.Segment (Segment) +import qualified Exon.Data.Segment as Segment (Segment (Expression)) + +newtype Str = + Str Text + deriving stock (Eq, Show, Generic) + deriving newtype (IsString) + +newtype Nam = + Nam Str + deriving stock (Eq, Show, Generic) + deriving newtype (IsString) + +s2 :: IsString a => a +s2 = + "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" + +segments :: NonEmpty (Segment Nam) +segments = + (const (Segment.Expression s2)) <$> [1 :: Int .. 1000] + +strings :: [Text] +strings = + replicate 1000 s2 + +bench_manual :: [Text] -> Text +bench_manual s = + toStrict (toLazyText (foldMap Text.fromText s)) + +main :: IO () +main = + defaultMain [ + bgroup "exon" [ + bench "build" (whnf exonProcess segments), + bench "manual" (whnf bench_manual strings) + ] + ] diff --git a/exon.cabal b/exon.cabal --- a/exon.cabal +++ b/exon.cabal @@ -5,8 +5,8 @@ -- see: https://github.com/sol/hpack name: exon -version: 0.5.0.0 -synopsis: Monoidal Quasiquote Interpolation +version: 1.0.0.0 +synopsis: Customizable Quasiquote Interpolation description: See https://hackage.haskell.org/package/exon/docs/Exon.html category: String homepage: https://github.com/tek/exon#readme @@ -26,10 +26,13 @@ exposed-modules: Exon Exon.Class.Exon + Exon.Class.Newtype + Exon.Class.ToSegment Exon.Combinators Exon.Data.RawSegment Exon.Data.Result Exon.Data.Segment + Exon.Generic Exon.Parse Exon.Quote hs-source-dirs: @@ -100,11 +103,12 @@ build-depends: base >=4.12 && <5 , flatparse >=0.3.5.1 + , generics-sop , haskell-src-exts <1.24 , haskell-src-meta <0.9 , incipit-base >=0.2 , template-haskell - , text + , type-errors-pretty mixins: base hiding (Prelude) , incipit-base (IncipitBase as Prelude) @@ -116,9 +120,11 @@ main-is: Main.hs other-modules: Exon.Test.BasicTest - Exon.Test.KeepWsTest + Exon.Test.BuildTest + Exon.Test.NewtypeTest Exon.Test.Quote Exon.Test.ShowsPrecTest + Exon.Test.SkipWsTest hs-source-dirs: test default-extensions: @@ -192,7 +198,85 @@ , tasty , tasty-hedgehog , template-haskell - , text + mixins: + base hiding (Prelude) + , incipit-base (IncipitBase as Prelude) + , incipit-base hiding (IncipitBase) + default-language: Haskell2010 + +benchmark exon-bench + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: + benchmark + default-extensions: + AllowAmbiguousTypes + ApplicativeDo + BangPatterns + BinaryLiterals + BlockArguments + ConstraintKinds + DataKinds + DefaultSignatures + DeriveAnyClass + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + DerivingVia + DisambiguateRecordFields + DoAndIfThenElse + DuplicateRecordFields + EmptyCase + EmptyDataDecls + ExistentialQuantification + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + InstanceSigs + KindSignatures + LambdaCase + LiberalTypeSynonyms + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + OverloadedLabels + OverloadedLists + OverloadedStrings + PackageImports + PartialTypeSignatures + PatternGuards + PatternSynonyms + PolyKinds + QuantifiedConstraints + QuasiQuotes + RankNTypes + RecordWildCards + RecursiveDo + RoleAnnotations + ScopedTypeVariables + StandaloneDeriving + TemplateHaskell + TupleSections + TypeApplications + TypeFamilies + TypeFamilyDependencies + TypeOperators + TypeSynonymInstances + UndecidableInstances + UnicodeSyntax + ViewPatterns + ghc-options: -Wall -Wredundant-constraints -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Widentities -Wunused-packages + build-depends: + base >=4.12 && <5 + , criterion + , exon + , incipit-base >=0.2 mixins: base hiding (Prelude) , incipit-base (IncipitBase as Prelude) diff --git a/lib/Exon.hs b/lib/Exon.hs --- a/lib/Exon.hs +++ b/lib/Exon.hs @@ -1,51 +1,236 @@ --- |Monoidal Quasiquote Interpolation +-- |Customizable Quasiquote Interpolation module Exon ( + -- * Introduction -- $intro + + -- * Implicit conversion #conversion# + -- $conversion + exon, exonws, + intron, + exun, exonWith, + + -- * Performance + -- $performance + -- * Customizing Concatenation - module Exon.Class.Exon, + -- $custom + + Exon (..), + ExonBuild (..), + ExonAppend (..), + ExonSegment (..), + ExonBuilder (..), + ExonString (..), + ToSegment (..), + SkipWs (..), + skipWs, + ExonUse (..), + + -- * Type inference + -- $inference + -- * Combinators module Exon.Combinators, + -- * Data Types module Exon.Data.Segment, module Exon.Data.Result, ) where -import Exon.Class.Exon (Exon (..), ExonDefault, KeepWhitespace) +import Exon.Class.Exon ( + Exon (..), + ExonAppend (..), + ExonBuild (..), + ExonBuilder (..), + ExonSegment (..), + ExonString (..), + ExonUse (..), + SkipWs (..), + skipWs, + ) +import Exon.Class.ToSegment (ToSegment (..)) import Exon.Combinators (intercalate) import Exon.Data.Result (Result (..)) import Exon.Data.Segment (Segment (..)) -import Exon.Quote (exon, exonWith, exonws) +import Exon.Quote (exon, exonWith, exun, intron, exonws) --- $intro --- This Haskell library provides quasiquote string interpolation with customizable concatenation for arbitrary types. --- --- The default case uses `Monoid` and `IsString`: --- --- @ --- import Exon (exon) --- import Data.Text (toUpper) --- --- newtype Name = --- Name Text --- deriving newtype (Show, Monoid, IsString) --- --- instance Semigroup Name where --- Name l <> Name r = Name (l <> " | " <> r) --- --- lastName :: Name --- lastName = "Fry" --- --- up :: Name -> Name --- up (Name name) = Name (toUpper name) --- --- >>> [exon|Philip J. #{up lastName}|] --- Name "Philip | J. | FRY" --- --- @ --- --- Individual segments are tokenized at whitespace boundaries, expressions between `#{` and `}` are inserted verbatim. --- --- The default implementation ignores whitespace when concatenating, while it is preserved for `GHC.String`, `Text` etc. +{- $intro +This Haskell library provides quasiquote string interpolation with customizable concatenation for arbitrary types. + +A quasiquote with the quoter 'exon' is transformed into a chain of concatenations, allowing expressions to be +interpolated between the characters @#{@ and @}@. +A common use case is plain text interpolation: + +>>> :set -XOverloadedStrings +>>> animal = "snake" +>>> location = "a tree" +>>> [exon|#{animal} in #{location}|] +"snake in a tree" + +The quote is effectively converted to a sequence of 'Semigroup' concatenations: + +>>> animal <> " " <> "in" <> " " <> location +"snake in a tree" + +It is precisely converted to an intermediate data structure, 'Segment', and concatenated using customizable classes: + +>>> exonProcess [Expression animal, String " in ", Expression location] +"snake in a tree" + +The default implementation uses `Monoid` and `IsString`, resulting in something like: + +>>> foldl' (<>) mempty [animal, fromString " ", fromString "in", fromString " ", location] :: String +"snake in a tree" + +This allows any type that implements those two classes to be used as the result: + +>>> newtype Str = Str Text deriving stock (Show) deriving newtype (IsString, Semigroup, Monoid) +>>> [exon|#{animal} in #{location}|] :: Str +Str "snake in a tree" + +The astute reader might notice that it is unclear what type @animal@ is expected to be – it hasn't been annotated, yet +it works for both the quote without type annotation as well as the one of type @Str@. + +The reason for this phenomenon is that GHC types @animal = "snake"@ as @animal :: IsString a => a@ thanks to +@OverloadedStrings@. +When the quote is written without annotation, the evaluator defaults to @String@ in order to print it (for example, +@hls-eval-plugin@ or GHCi). + +When the two names are used in the quote with @Str@, they will be instantiated as @Str@ as well. + +One neat application of Exon is for writing 'Text.Show.showsPrec' methods, whose type is @t'String' -> t'String'@ and +which are used to stringify a type with automatic parentheses when contained in a larger type: + +> data Numbers = +> Numbers Int (Maybe Int) Value +> +> instance Show Numbers where +> showsPrec d Numbers number maybeNumber value = +> showParen (d > 10) +> [exon|Numbers #{showsPrec 11 number} #{showsPrec 11 maybeNumber} #{showsPrec 11 value}|] + +-} + +{- $conversion +Values of different types can be interpolated if they meet one of two conditions: + +- They are instances of 'Generic' and representationally equal to the result type (i.e. newtypes) +- They are one of the common stringly types: t'String', 'Text', 'LText', 'ByteString' and 'LByteString' + +Exon requires auto-converted values to be interpolated with a different bracket, @##{@, to avoid accidents: + +>>> newtype Str = Str Text deriving stock (Show) deriving newtype (IsString, Semigroup, Monoid) +>>> newtype Animal = Animal ByteString deriving stock (Generic) +>>> animal = Animal "lemur" +>>> location = "a tree" +>>> [exon|##{animal} in #{location}|] :: Str +Str "lemur in a tree" + +In this case, the two conditions are even combined – the @Animal@ is unwrapped, UTF-8-decoded to @Text@, and rewrapped +into @Str@. + +If you absolutely want to splice newtypes with the same brackets, you can use the quoter 'exun' (the @un@ stands for +@unsafe@). +-} + +{- $performance +Generic string concatenation can be quite expensive. +If a quote's result type is 'Text', as in: + +>>> [exon|#{"x"} #{"y"}|] :: Text + +then the resulting concatenation will use the 'Semigroup' operation for 'Text', which has @O(n)@ complexity for each +pair of appended strings. + +In order to improve performance, Exon allows the type used for concatenation (the /builder/) to differ from the result +type, which is implemented by the class 'ExonBuilder'. +For example, the instance for 'Text' selects 'Text.Builder' as the builder type and converts the segments and the result +accordingly. +In a quote of 1000 segments, this improves performance by a factor of 100! + +However, if the result type is a newtype, the 'Text' builder will not be used: + +>>> newtype Str = Str Text deriving stock (Show) deriving newtype (IsString, Semigroup, Monoid) +>>> [exon|#{"x"} #{"y"}|] :: Str + +This restriction can be circumvented by making @Str@ an instance of 'Generic' – in that case, Exon will unwrap the type +(even multiply nested newtypes) and use the builder associated with the inner type. +@Str@ doesn't even need to derive 'IsString', 'Semigroup' and 'Monoid' in this case, as all the operations are performed +on 'Text.Builder'. + +In principle, this conversion could be done with 'Coercible' as well, but type inference is really bad with that method. + +/Note/ that when using [generic segment conversion]("Exon#g:conversion") in conjunction with this, the result type must +also derive 'IsString'. +-} + +{- $custom +Quote types don't have to be transparent wrappers for strings. +Concatenation can be changed in a type's 'Semigroup': + +>>> import Data.Text (toUpper) +>>> newtype Name = Name Text deriving newtype (Show, IsString) +>>> instance Semigroup Name where Name l <> Name r = Name (l <> " | " <> r) +>>> deriving instance Monoid Name +>>> lastName = Name "Fry" +>>> [intron|Philip J. #{lastName}|] +"Philip | J. | Fry" + +This example uses the quoter 'intron', which ignores whitespace. +The 'Semigroup' then inserts custom separators. + +The same result can be achieved by using the whitespace-aware quoter 'exonws' and providing a specialized instance of +some of Exon's classes, like 'ExonString': + +> newtype Name = Name Text deriving stock (Generic) +> instance ExonString Name Text.Builder where +> exonWhitespace _ = Result " | " + +This example additionally uses the 'Generic' newtype unwrapping feature, allowing the customization to be performed +directly in the efficient builder type. +-} + +{- $inference +The type of an expression segment is usually known, for example when the interpolated value is an argument of the +enclosing function: + +>>> f :: Text -> Text; f t = [exon|value: #{t}|] +>>> f "snake" +"value: snake" + +Here both the interpolated expression and the quote's result type are known. + +However, expressions may be polymorphic: + +>>> t :: IsString a => a; t = "snake" +>>> f :: Text; f = [exon|value: #{t}|] +>>> f +"value: snake" + +The quasiquote parser turns this into the expression: + +> [Segment.String "value: ", Segment.Expression t] :: Text + +The list of segments has the known type 'Text', obtained from the type signature of @f@. +In this case, the type of @t@ is instantiated as 'Text' as well, causing no type inference problems. + +However, if the quote is used polymorphically as well, as in: + +> printThing :: Show a => a -> IO () +> printThing [exon|value: #{t}|] + +the type of the segment list would be @∀ a . IsString => [a]@, which would not be possible to concatenate, so @t@ must +be annotated. + +Since the segment list is typechecked like any other expression, an expression segment with known type will determine +the result type of an otherwise polymorphic quote: + +>>> newtype Str = Str Text deriving stock (Show) deriving newtype (IsString, Semigroup, Monoid) +>>> [exon|pre #{"x" :: Str} post|] +Str "pre x post" + +The result type is unambiguously fixed to @Str@. +-} diff --git a/lib/Exon/Class/Exon.hs b/lib/Exon/Class/Exon.hs --- a/lib/Exon/Class/Exon.hs +++ b/lib/Exon/Class/Exon.hs @@ -1,203 +1,265 @@ -- |Description: Internal module Exon.Class.Exon where +import qualified Data.ByteString.Builder as ByteString +import Data.ByteString.Builder (toLazyByteString) +import qualified Data.Text.Lazy.Builder as Text +import Data.Text.Lazy.Builder (toLazyText) import Text.Show (showString) +import Exon.Class.Newtype (OverNewtypes, overNewtypes) import Exon.Data.Result (Result (Empty, Result)) import qualified Exon.Data.Segment as Segment import Exon.Data.Segment (Segment) --- |The tag for the default quoter 'Exon.exon'. -data ExonDefault - --- |The tag for the quoter 'Exon.exonws', keeping whitespace verbatim. -data KeepWhitespace - -{- | -This class is responsible for combining segments of an interpolated string, allowing users to define their own rules -for how the result is constructed. -The default implementation converts each literal part with 'IsString' and uses the result type's 'Monoid' to -concatenate them. - -The raw parts are encoded as 'Segment', getting combined into a 'Result'. +-- |Wrapping a quote type with this causes whitespace to be ignored. +-- +-- @since 1.0.0.0 +newtype SkipWs a = + SkipWs a + deriving stock (Eq, Show, Generic) + deriving newtype (IsString) -The default for 'convertSegment' skips whitespace by encoding it into the 'Result' constructor 'Empty', which is a -unit object. -To change this behavior, it can be easily overridden: +-- |Defined separately because TH chokes on the selector. +-- +-- @since 1.0.0.0 +skipWs :: SkipWs a -> a +skipWs (SkipWs a) = + a -@ -newtype Thing = Thing String deriving newtype (IsString, Semigroup, Monoid, Show) +-- |Wrapping a quote type with this causes @a@ to be used irrespective of whether it is an unwrappable newtype. +-- +-- @since 1.0.0.0 +newtype ExonUse a = + ExonUse { exonUse :: a } + deriving stock (Eq, Show) + deriving newtype (IsString) -instance Exon ExonDefault Thing where - convertSegment = \case - Segment.String s -> Result (Thing s) - Segment.Expression thing -> Result thing - Segment.Whitespace _ -> Result (Thing " >>> ") +-- |This class converts a segment into a builder. +-- +-- A builder is an auxiliary data type that may improve performance when concatenating segments, like 'Text.Builder'. +-- The default instance uses no builder and is implemented as 'id'. +-- +-- @since 1.0.0.0 +class ExonBuilder (inner :: Type) (builder :: Type) | inner -> builder where + -- |Construct a builder from the newtype-unwrapped result type. + exonBuilder :: inner -> builder - insertWhitespace s1 ws s2 = - appendSegment @ExonDefault (appendSegment @ExonDefault s1 (Segment.Whitespace ws)) s2 -@ --} -class Exon (tag :: Type) (a :: Type) where + -- |Convert the result of the builder concatenation back to the newtype-unwrapped result type. + exonBuilderExtract :: Result builder -> inner - -- |This check is used to allow empty expression segments to be skipped when they are empty. - -- The default is to never skip expressions. - isEmpty :: a -> Bool - isEmpty = - const False +instance {-# overlappable #-} ( + Monoid builder, + result ~ builder + ) => ExonBuilder result builder where + exonBuilder = + id + {-# inline exonBuilder #-} + exonBuilderExtract = + fold + {-# inline exonBuilderExtract #-} - -- |Convert a 'Segment' to a 'Result'. - -- The default implementation uses 'IsString' and ignores whitespace, returning 'Empty'. - convertSegment :: Segment a -> Result a +instance ( + ExonBuilder a builder + ) => ExonBuilder (ExonUse a) builder where + exonBuilder = + exonBuilder @a . exonUse + exonBuilderExtract = + ExonUse . exonBuilderExtract - default convertSegment :: IsString a => Segment a -> Result a - convertSegment = \case - Segment.String a -> - Result (fromString a) - Segment.Expression a | isEmpty @tag a -> - Empty - Segment.Expression a -> - Result a - Segment.Whitespace _ -> - Empty +instance ExonBuilder Text Text.Builder where + exonBuilder = + Text.fromText + {-# inline exonBuilder #-} + exonBuilderExtract = + foldMap (toStrict . toLazyText) + {-# inline exonBuilderExtract #-} - -- |Append a 'Segment' to a 'Result'. - -- The default implementation uses '(<>)'. - appendSegment :: Result a -> Segment a -> Result a +instance ExonBuilder LText Text.Builder where + exonBuilder = + Text.fromLazyText + exonBuilderExtract = + foldMap toLazyText - default appendSegment :: Semigroup a => Result a -> Segment a -> Result a - appendSegment z a = - z <> convertSegment @tag a +instance ExonBuilder ByteString ByteString.Builder where + exonBuilder = + ByteString.byteString + exonBuilderExtract = + foldMap (toStrict . toLazyByteString) - -- |Append whitespace and a 'Segment' to a 'Result', i.e. joining two parts of the interpolation by whitespace. - -- The default implementation ignores the whitespace, calling 'appendSegment' with the second argument. - insertWhitespace :: Result a -> String -> Segment a -> Result a +instance ExonBuilder LByteString ByteString.Builder where + exonBuilder = + ByteString.lazyByteString + exonBuilderExtract = + foldMap toLazyByteString - default insertWhitespace :: Result a -> String -> Segment a -> Result a - insertWhitespace s1 _ = - appendSegment @tag s1 +-- |This class generalizes 'IsString' for use in 'ExonSegment'. +-- +-- When a plain text segment (not interpolated) is processed, it is converted to the result type, which usually happens +-- via 'fromString'. +-- +-- For the type of 'Text.Show.showsPrec' (@'String' -> 'String'@), there is no instance of 'IsString', so this class +-- provides an instance that works around that by calling 'showString'. +-- +-- @since 1.0.0.0 +class ExonString (result :: Type) (builder :: Type) where + -- |Convert a 'String' to the builder type. + exonString :: String -> Result builder - -- |The entry point for concatenation, taking a list of segments parsed from the interpolation. - -- The default implementation skips leading whitespace and calls 'appendSegment' and 'insertWhitespace' to - -- concatenate. - concatSegments :: NonEmpty (Segment a) -> a + default exonString :: IsString builder => String -> Result builder + exonString = + Result . fromString + {-# inline exonString #-} - default concatSegments :: Monoid a => NonEmpty (Segment a) -> a - concatSegments (h :| t) = - fold (spin (convertSegment @tag h) t) - where - spin :: Result a -> [Segment a] -> Result a - spin Empty = \case - [] -> - Empty - Segment.Whitespace _ : ss -> - spin Empty ss - s1 : ss -> - spin (convertSegment @tag s1) ss - spin (Result s1) = \case - [] -> - Result s1 - Segment.Whitespace _ : (Segment.Expression a) : ss | isEmpty @tag a -> - spin (Result s1) ss - Segment.Whitespace ws : s2 : ss -> - spin (insertWhitespace @tag (Result s1) ws s2) ss - [Segment.Whitespace _] -> - (Result s1) - s2 : ss -> - spin (appendSegment @tag (Result s1) s2) ss + -- |Convert a 'String' containing whitespace to the builder type. + -- This is only used by whitespace-aware quoters, like 'Exon.exonws' or 'Exon.intron'. + exonWhitespace :: String -> Result builder -instance {-# overlappable #-} ( - Monoid a, - IsString a - ) => Exon ExonDefault a where + default exonWhitespace :: String -> Result builder + exonWhitespace = + exonString @result @builder + {-# inline exonWhitespace #-} --- |Variant of 'convertSegment' that preserves whitespace verbatim. -convertKeepWs :: - IsString a => - Segment a -> - Result a -convertKeepWs = \case - Segment.String a -> - Result (fromString a) - Segment.Expression a -> - Result a - Segment.Whitespace a -> - Result (fromString a) +instance {-# overlappable #-} IsString a => ExonString result a where --- |Variant of 'concatSegments' that preserves whitespace verbatim. -concatKeepWs :: - ∀ tag a . - Monoid a => - Exon tag a => - NonEmpty (Segment a) -> - a -concatKeepWs = - fold . foldl' (appendSegment @tag) Empty +-- |The instance for the type used by 'Text.Show.showsPrec'. +instance ExonString result (String -> String) where + exonString = + Result . showString + {-# inline exonString #-} +-- |The instance used when the result type is wrapped in 'SkipWs', which is done by 'Exon.intron'. +-- +-- It returns 'Empty' for any whitespace. instance ( - Monoid a, - IsString a - ) => Exon KeepWhitespace a where - convertSegment = - convertKeepWs - - concatSegments = - concatKeepWs @KeepWhitespace - -instance Exon ExonDefault String where - convertSegment = - convertKeepWs - - concatSegments = - concatKeepWs @ExonDefault + IsString builder + ) => ExonString (SkipWs result) builder where + exonWhitespace _ = + Empty + {-# inline exonWhitespace #-} -instance Exon ExonDefault Text where - convertSegment = - convertSegment @KeepWhitespace +-- |This class converts a 'Segment' to a builder. +-- +-- The default implementation performs the following conversions for the differnet segment variants: +-- +-- - [Segment.String]('Segment.String') and [Segment.Whitespace]('Segment.Whitespace') are plain 'String's parsed +-- literally from the quasiquote. +-- They are converted to the builder type by 'fromString' (handled by 'ExonString'). +-- +-- - [Segment.Whitespace]('Segment.Whitespace') is ignored when the quoter 'Exon.intron' was used. +-- +-- - [Segment.Expression]('Segment.Expression') contains a value of the builder type, which is returned as-is. +-- +-- @since 1.0.0.0 +class ExonSegment (result :: Type) (builder :: Type) where + -- |Convert literal string segments to the result type. + exonSegment :: Segment builder -> Result builder - concatSegments = - concatSegments @KeepWhitespace +instance {-# overlappable #-} ( + ExonString result builder + ) => ExonSegment result builder where + exonSegment = \case + Segment.String a -> + exonString @result a + Segment.Expression a -> + Result a + Segment.Whitespace a -> + exonWhitespace @result a + {-# inline exonSegment #-} -instance Exon ExonDefault LText where - convertSegment = - convertSegment @KeepWhitespace +-- |This class handles concatenation of segments, which might be a builder or the result type. +-- +-- The default instance simply uses '(<>)', and there is only one special instance for @'String' -> 'String'@, the type +-- used by 'Text.Show.showsPrec'. +-- +-- @since 1.0.0.0 +class ExonAppend (result :: Type) (builder :: Type) where + -- |Concatenate two segments of the builder type. + exonAppend :: builder -> builder -> Result builder - concatSegments = - concatSegments @KeepWhitespace +instance {-# overlappable #-} ( + Semigroup builder + ) => ExonAppend result builder where + exonAppend z a = + Result (z <> a) + {-# inline exonAppend #-} -instance Exon ExonDefault ByteString where - convertSegment = - convertSegment @KeepWhitespace +instance ExonAppend result (String -> String) where + exonAppend z a = + Result (z . a) + {-# inline exonAppend #-} - concatSegments = - concatSegments @KeepWhitespace +-- |Wrapper for 'exonAppend' that handles the 'Empty' case. +-- +-- @since 1.0.0.0 +exonAppendResult :: + ∀ result builder . + ExonAppend result builder => + Result builder -> + Result builder -> + Result builder +exonAppendResult (Result z) (Result a) = + exonAppend @result z a +exonAppendResult z Empty = + z +exonAppendResult Empty a = + a +{-# inline exonAppendResult #-} -instance Exon ExonDefault LByteString where - convertSegment = - convertSegment @KeepWhitespace +-- |This class implements the 'Segment' concatenation logic. +-- +-- 1. Each 'Segment.Expression' is converted to the builder type by 'ExonBuilder'. +-- 2. Each 'Segment.String' and 'Segment.Whitespace' is converted to the builder type by 'ExonSegment' and 'ExonString'. +-- 3. The segments are folded over 'ExonAppend'. +-- 4. The result is converted from the builder type to the original type by 'ExonBuilder'. +-- +-- Each step may be overridden individually +-- +-- @since 1.0.0.0 +class ExonBuild (result :: Type) (inner :: Type) where + -- |Concatenate a list of 'Segment's. + exonBuild :: NonEmpty (Segment inner) -> inner - concatSegments = - concatSegments @KeepWhitespace +instance {-# overlappable #-} ( + ExonAppend result builder, + ExonSegment result builder, + ExonBuilder inner builder + ) => ExonBuild result inner where + exonBuild = + exonBuilderExtract . + foldl1 (exonAppendResult @result) . + fmap (exonSegment @result . fmap exonBuilder) + {-# inline exonBuild #-} -instance Exon ExonDefault (String -> String) where - convertSegment = \case - Segment.String a -> - Result (showString a) - Segment.Expression a | isEmpty @ExonDefault a -> - Empty - Segment.Expression a -> - Result a - Segment.Whitespace ws -> - Result (showString ws) +-- |This class is the main entry point for Exon. +-- +-- The default instance unwraps all newtypes that are 'Generic' and passes the innermost type to 'ExonBuild'. +-- +-- The original type is also used as a parameter to 'ExonBuild', so customizations can be based on it. +class Exon (result :: Type) where + -- |Concatenate a list of 'Segment's. + -- + -- @since 1.0.0.0 + exonProcess :: NonEmpty (Segment result) -> result - appendSegment z a = - case (z, convertSegment @ExonDefault a) of - (Result z', Result a') -> - Result (z' . a') - (z', Empty) -> - z' - (Empty, a') -> - a' +instance {-# overlappable #-} ( + OverNewtypes result inner, + ExonBuild result inner + ) => Exon result where + exonProcess = + overNewtypes @result (exonBuild @result) + {-# inline exonProcess #-} - concatSegments = - concatKeepWs @ExonDefault +-- |Call 'exonProcess', but unwrap the arguments and rewrap the result using the supplied functions. +-- +-- @since 1.0.0.0 +exonProcessWith :: + ∀ wrapped result . + Exon wrapped => + (result -> wrapped) -> + (wrapped -> result) -> + NonEmpty (Segment result) -> + result +exonProcessWith unwrap wrap = + wrap . exonProcess @wrapped . fmap (fmap unwrap) +{-# inline exonProcessWith #-} diff --git a/lib/Exon/Class/Newtype.hs b/lib/Exon/Class/Newtype.hs new file mode 100644 --- /dev/null +++ b/lib/Exon/Class/Newtype.hs @@ -0,0 +1,38 @@ +-- |Description: Internal +module Exon.Class.Newtype where + +import Exon.Data.Segment (Segment) +import Exon.Generic (IsNewtype, OverNt) +import Unsafe.Coerce (unsafeCoerce) + +-- |Internal auxiliary class that applies a function to the value inside of a nested chain of 'Generic' newtypes. +class OverNewtype (current :: Type) (wrapped :: Maybe Type) (inner :: Type) | current -> inner where + overNewtype :: (NonEmpty (Segment inner) -> inner) -> NonEmpty (Segment current) -> current + +instance ( + OverNt current wrapped, + IsNewtype wrapped next, + OverNewtype wrapped next inner + ) => OverNewtype current ('Just wrapped) inner where + overNewtype f segments = + unsafeCoerce (overNewtype @wrapped @next @inner f (fmap unsafeCoerce <$> segments)) + {-# inline overNewtype #-} + +instance OverNewtype current 'Nothing current where + overNewtype = + id + {-# inline overNewtype #-} + +-- |Internal auxiliary class that applies a function to the value inside of a nested chain of 'Generic' newtypes. +-- +-- The method only passes its arguments to 'overNewtypes', but the class hides the intermediate parameter. +class OverNewtypes (result :: Type) (inner :: Type) | result -> inner where + overNewtypes :: (NonEmpty (Segment inner) -> inner) -> NonEmpty (Segment result) -> result + +instance ( + IsNewtype result wrapped, + OverNewtype result wrapped inner + ) => OverNewtypes result inner where + overNewtypes = + overNewtype @result @wrapped + {-# inline overNewtypes #-} diff --git a/lib/Exon/Class/ToSegment.hs b/lib/Exon/Class/ToSegment.hs new file mode 100644 --- /dev/null +++ b/lib/Exon/Class/ToSegment.hs @@ -0,0 +1,95 @@ +{-# options_haddock prune #-} + +-- |Description: Internal +module Exon.Class.ToSegment where + +import GHC.TypeLits (ErrorMessage) +import Generics.SOP (SOP (SOP), unZ, I (I), NP ((:*), Nil)) +import Generics.SOP.GGP (GCode, GFrom, gfrom) +import Type.Errors.Pretty (type (%), type (<>)) + +import Exon.Generic (IsNewtype) + +class NewtypeSegment (wrapped :: Maybe Type) a b where + newtypeSegment :: a -> b + +instance ( + Generic a, + GFrom a, + GCode a ~ '[ '[b]], + ToSegment b c + ) => NewtypeSegment ('Just b) a c where + newtypeSegment (gfrom -> SOP (unZ -> I b :* Nil)) = + toSegment b + +type family Q (a :: k) :: ErrorMessage where + Q a = "‘" <> a <> "’" + +type family NoGenericMessage (a :: Type) (b :: Type) :: Constraint where + NoGenericMessage a a = a ~ a + NoGenericMessage a b = + TypeError ( + "Found an expression of type " <> Q a <> " in a quote of type " <> Q b <> "." % + "If " <> Q a <> " is a newtype of " <> Q b <> " that should be converted automatically," % + "you need to add " <> Q "deriving (Generic)" <> " to its declaration." % + "You can also implement " <> Q ("instance ToSegment " <> a <> " " <> b) <> " for custom interpolation." + ) + +instance ( + NoGenericMessage a b, + a ~ b + ) => NewtypeSegment 'Nothing a b where + newtypeSegment = + id + +-- |This class determines how an expression is converted to an interpolation quote's result type. +-- +-- For a quote like @[exon|a #{exp :: T} c|] :: R@, the instance @ToSegment T R@ is used to turn @T@ into @R@. +-- Aside from specialized instances for stringly types, the default implementation uses 'Generic' to unwrap newtypes +-- that either match the result type exactly, or uses 'fromString' for result types that implement 'IsString'. +-- +-- So given: +-- +-- >>> newtype T = T Text deriving newtype (Generic) +-- >>> newtype R = R Text deriving newtype (IsString, Semigroup, Monoid) +-- +-- the quote from earlier would generically unwrap @T@ and use 'fromString' to construct an @R@. +class ToSegment a b where + toSegment :: a -> b + +instance {-# incoherent #-} ( + IsNewtype a wrapped, + NewtypeSegment wrapped a b + ) => ToSegment a b where + toSegment = + newtypeSegment @wrapped + +instance {-# overlappable #-} ( + IsString a + ) => ToSegment String a where + toSegment = + fromString . toString + +instance {-# overlappable #-} ( + IsString a + ) => ToSegment Text a where + toSegment = + fromString . toString + +instance {-# overlappable #-} ( + IsString a + ) => ToSegment LText a where + toSegment = + fromString . toString + +instance {-# overlappable #-} ( + IsString a + ) => ToSegment ByteString a where + toSegment = + fromString . decodeUtf8 + +instance {-# overlappable #-} ( + IsString a + ) => ToSegment LByteString a where + toSegment = + fromString . decodeUtf8 diff --git a/lib/Exon/Data/RawSegment.hs b/lib/Exon/Data/RawSegment.hs --- a/lib/Exon/Data/RawSegment.hs +++ b/lib/Exon/Data/RawSegment.hs @@ -9,4 +9,6 @@ StringSegment String | ExpSegment String + | + AutoExpSegment String deriving stock (Eq, Show) diff --git a/lib/Exon/Data/Segment.hs b/lib/Exon/Data/Segment.hs --- a/lib/Exon/Data/Segment.hs +++ b/lib/Exon/Data/Segment.hs @@ -9,4 +9,8 @@ Whitespace String | Expression a - deriving stock (Eq, Show) + deriving stock (Eq, Show, Functor) + +instance IsString (Segment a) where + fromString = + String diff --git a/lib/Exon/Generic.hs b/lib/Exon/Generic.hs new file mode 100644 --- /dev/null +++ b/lib/Exon/Generic.hs @@ -0,0 +1,46 @@ +{-# options_haddock prune #-} + +-- |Description: Internal +module Exon.Generic where + +import Generics.SOP (All2, I (I), NP (Nil, (:*)), NS (S, Z), SOP (SOP), Top) +import Generics.SOP.GGP (GCode, GDatatypeInfoOf, GFrom, GTo, gfrom, gto) +import Generics.SOP.Type.Metadata (DatatypeInfo (Newtype)) + +type ReifySOP (a :: Type) (ass :: [[Type]]) = + (Generic a, GTo a, GCode a ~ ass, All2 Top ass) + +type ConstructSOP (a :: Type) (ass :: [[Type]]) = + (Generic a, GFrom a, GCode a ~ ass, All2 Top ass) + +type ReifyNt (a :: Type) (b :: Type) = + ReifySOP a '[ '[b] ] + +type GenNt (a :: Type) (b :: Type) = + ConstructSOP a '[ '[b] ] + +type OverNt (a :: Type) (b :: Type) = + (ReifyNt a b, GenNt a b) + +unwrap :: + GenNt a b => + a -> + b +unwrap a = + case gfrom a of + SOP (Z (I b :* Nil)) -> b + SOP (S n) -> case n of + +wrap :: + ReifyNt a b => + b -> + a +wrap b = + gto (SOP (Z (I b :* Nil))) + +class GDatatypeInfoIsNewtype (dss :: [[Type]]) (info :: DatatypeInfo) (wrapped :: Maybe Type) | dss info -> wrapped +instance {-# incoherent #-} wrapped ~ 'Nothing => GDatatypeInfoIsNewtype dss info wrapped +instance wrapped ~ 'Just d => GDatatypeInfoIsNewtype '[ '[d]] ('Newtype m n c) wrapped + +class IsNewtype d (wrapped :: Maybe Type) | d -> wrapped +instance GDatatypeInfoIsNewtype (GCode d) (GDatatypeInfoOf d) wrapped => IsNewtype d wrapped diff --git a/lib/Exon/Parse.hs b/lib/Exon/Parse.hs --- a/lib/Exon/Parse.hs +++ b/lib/Exon/Parse.hs @@ -20,14 +20,14 @@ runParserS, satisfy, some_, - withSpan, string, takeRest, + withSpan, (<|>), ) import Prelude hiding (empty, span, (<|>)) -import Exon.Data.RawSegment (RawSegment (ExpSegment, StringSegment, WsSegment)) +import Exon.Data.RawSegment (RawSegment (AutoExpSegment, ExpSegment, StringSegment, WsSegment)) type Parser = FlatParse.Parser Int Text @@ -69,32 +69,62 @@ 0 -> unit cur -> put (cur - 1) *> $(char '}') *> expr -interpolation :: Parser RawSegment -interpolation = +autoInterpolation :: Parser RawSegment +autoInterpolation = + $(string "##{") *> (AutoExpSegment <$> span expr) <* $(char '}') + +verbatimInterpolation :: Parser RawSegment +verbatimInterpolation = $(string "#{") *> (ExpSegment <$> span expr) <* $(char '}') untilTokenEnd :: Parser () untilTokenEnd = branch $(char '\\') (anyChar *> untilTokenEnd) $ - finishBefore ($(string "#{") <|> void ws) $ + finishBefore ($(string "##{") <|> $(string "#{")) $ eof <|> (anyChar *> untilTokenEnd) +untilTokenEndWs :: Parser () +untilTokenEndWs = + branch $(char '\\') (anyChar *> untilTokenEndWs) $ + finishBefore ($(string "##{") <|> $(string "#{") <|> void ws) $ + eof <|> (anyChar *> untilTokenEndWs) + text :: Parser RawSegment text = StringSegment <$> span untilTokenEnd +textWs :: Parser RawSegment +textWs = + StringSegment <$> span untilTokenEndWs + segment :: Parser RawSegment segment = - branch eof empty (whitespace <|> interpolation <|> text) + branch eof empty (autoInterpolation <|> verbatimInterpolation <|> text) +segmentWs :: Parser RawSegment +segmentWs = + branch eof empty (whitespace <|> autoInterpolation <|> verbatimInterpolation <|> textWs) + parser :: Parser [RawSegment] parser = FlatParse.many segment -parse :: String -> Either Text [RawSegment] -parse = - runParserS parser 0 0 >>> \case +parserWs :: Parser [RawSegment] +parserWs = + FlatParse.many segmentWs + +parseWith :: Parser [RawSegment] -> String -> Either Text [RawSegment] +parseWith p = + runParserS p 0 0 >>> \case OK a _ "" -> Right a OK _ _ u -> Left ("unconsumed: " <> decodeUtf8 u) Fail -> Left "fail" Err e -> Left e + +parse :: String -> Either Text [RawSegment] +parse = + parseWith parser + +parseWs :: String -> Either Text [RawSegment] +parseWs = + parseWith parserWs diff --git a/lib/Exon/Quote.hs b/lib/Exon/Quote.hs --- a/lib/Exon/Quote.hs +++ b/lib/Exon/Quote.hs @@ -17,10 +17,11 @@ import Language.Haskell.TH.Quote (QuasiQuoter (QuasiQuoter)) import Language.Haskell.TH.Syntax (Quasi) -import Exon.Class.Exon (ExonDefault, KeepWhitespace, concatSegments) -import Exon.Data.RawSegment (RawSegment (ExpSegment, StringSegment, WsSegment)) +import Exon.Class.Exon (SkipWs (SkipWs), exonProcess, exonProcessWith, skipWs) +import Exon.Class.ToSegment (toSegment) +import Exon.Data.RawSegment (RawSegment (AutoExpSegment, ExpSegment, StringSegment, WsSegment)) import qualified Exon.Data.Segment as Segment -import Exon.Parse (parse) +import Exon.Parse (parse, parseWs) exonError :: ToString e => @@ -32,12 +33,13 @@ segmentsQ :: QOrIO m => + Bool -> String -> m (NonEmpty RawSegment) -segmentsQ "" = +segmentsQ _ "" = exonError ("empty interpolation" :: String) -segmentsQ s = - parse s & fmap nonEmpty & \case +segmentsQ whitespace s = + (if whitespace then parseWs else parse) s & fmap nonEmpty & \case Right (Just segs) -> pure segs Right Nothing -> pure (pure (StringSegment "")) Left err -> exonError err @@ -65,80 +67,133 @@ reifySegments :: QOrIO m => + Bool -> NonEmpty RawSegment -> m (NonEmpty Exp) -reifySegments segs = do +reifySegments unsafe segs = do expCon <- runQ [e|Segment.Expression|] + expToSegment <- runQ [e|toSegment|] for segs \case StringSegment s -> runQ [e|Segment.String s|] + ExpSegment s | unsafe -> do + e <- reifyExp s + pure (AppE expCon (AppE expToSegment e)) ExpSegment s -> do e <- reifyExp s pure (AppE expCon e) + AutoExpSegment s -> do + e <- reifyExp s + pure (AppE expCon (AppE expToSegment e)) WsSegment s -> runQ [e|Segment.Whitespace s|] quoteExpWith :: QOrIO m => - Q TH.Type -> + Maybe (Q TH.Exp, Q TH.Exp) -> + Bool -> + Bool -> String -> m Exp -quoteExpWith tag code = do - raw <- segmentsQ code - hseg :| segs <- reifySegments raw - conc <- runQ [e|concatSegments @($tag)|] +quoteExpWith wrapper whitespace unsafe code = do + raw <- segmentsQ whitespace code + hseg :| segs <- reifySegments unsafe raw + conc <- runQ $ maybe [e|exonProcess|] wrapped wrapper consE <- runQ [e|(:|)|] pure (AppE conc (InfixE (Just hseg) consE (Just (ListE segs)))) + where + wrapped (wrap, unwrap) = do + [e|exonProcessWith ($wrap) $(unwrap)|] quoteExp :: QOrIO m => + Bool -> + Bool -> String -> m Exp quoteExp = - quoteExpWith [t|ExonDefault|] + quoteExpWith Nothing --- |Constructor for a quasiquoter for an arbitrary tag. +quoteSegments :: + QOrIO m => + String -> + m Exp +quoteSegments code = do + raw <- segmentsQ True code + hseg :| segs <- reifySegments False raw + consE <- runQ [e|(:|)|] + pure (InfixE (Just hseg) consE (Just (ListE segs))) + +-- |Constructor for a quasiquoter that wraps all segments with the first expression and unwraps the result with the +-- second. -- --- This can be used to define quoters with custom logic, requiring an instance of 'Exon.Class.Exon' for the given type: +-- This can be used to define quoters with custom logic by providing instances of any of the classes in +-- "Exon.Class.Exon" with the result type argument set to the wrapper type: -- --- >>> import Exon.Class.Exon (Exon(..)) +-- >>> import Exon.Class.Exon (ExonString (..)) -- >>> import Exon.Data.Segment (Segment(String)) --- >>> data Nl --- >>> instance (Monoid a, IsString a) => Exon Nl a where insertWhitespace s1 _ s2 = appendSegment @Nl (appendSegment @Nl s1 (String "\n")) s2 --- >>> exonnl = exonWith [t|Nl|] +-- >>> import qualified Data.Text.Lazy.Builder as Text +-- >>> newtype Nl = Nl Text deriving (Generic) +-- >>> getNl (Nl t) = t +-- >>> instance ExonString Nl Text.Builder where exonWhitespace _ = exonString @Nl "\n" +-- >>> exonnl = exonWith (Just ([e|Nl|], [e|getNl|])) True False -- >>> [exonnl|one two three|] -- "one\ntwo\nthree" -- -- @since 0.2.0.0 -exonWith :: Q TH.Type -> QuasiQuoter -exonWith tag = - QuasiQuoter (quoteExpWith tag) (err "pattern") (err "type") (err "decl") +exonWith :: + Maybe (Q TH.Exp, Q TH.Exp) -> + Bool -> + Bool -> + QuasiQuoter +exonWith wrapper whitespace unsafe = + QuasiQuoter (quoteExpWith wrapper whitespace unsafe) (err "pattern") (err "type") (err "decl") where err :: String -> String -> Q a err tpe _ = exonError ("Cannot quote " <> tpe) --- |A quasiquoter that allows interpolation, concatenating the resulting segments monoidally. +-- |A quasiquoter that allows interpolation, concatenating the resulting segments with '(<>)' or a an arbitrary +-- user-defined implementation. +-- See the [introduction]("Exon") for details. -- --- >>> [exon|write #{show @Text (5 :: Int)} lines of code|] :: Text +-- >>> [exon|write #{show (5 :: Int)} lines of ##{"code" :: ByteString}|] :: Text -- "write 5 lines of code" --- --- The default implementation for any non-stringly type uses 'IsString' to construct the literal segments and 'mappend' --- to combine them, ignoring whitespace segments. +exon :: QuasiQuoter +exon = + exonWith Nothing False False + +-- |Unsafe version of 'exon', allowing automatic conversion with the same splice brackets as matching types. -- --- >>> newtype Part = Part Text deriving newtype (Show, Semigroup, Monoid, IsString) +-- @since 1.0.0.0 +exun :: QuasiQuoter +exun = + exonWith Nothing False True + +-- |A variant of 'exon' that ignores all literal whitespace in the quote (not in interpolated expressions). -- --- >>> [exon|x #{Part "y"}z|] :: Part --- "xyz" +-- > [intron|x|] === skipWs [exonws|x|] -- --- This behavior can be customized by writing an instance of 'Exon.Exon'. -exon :: QuasiQuoter -exon = - exonWith [t|ExonDefault|] +-- @since 1.0.0.0 +intron :: QuasiQuoter +intron = + exonWith (Just ([e|SkipWs|], [e|skipWs|])) True False --- |A variant of 'exon' that always keeps whitespace verbatim. +-- |A variant of 'exon' that creates segments for each sequence of whitespace characters that can be processed +-- differently by 'Exon.ExonAppend', 'Exon.ExonSegment' or 'Exon.ExonString'. -- --- @since 0.2.0.0 +-- @since 1.0.0.0 exonws :: QuasiQuoter exonws = - exonWith [t|KeepWhitespace|] + exonWith Nothing True False + +-- |Internal debugging quoter that produces the raw segments. +-- +-- @since 1.0.0.0 +exonSegments :: QuasiQuoter +exonSegments = + QuasiQuoter quoteSegments (err "pattern") (err "type") (err "decl") + where + err :: String -> String -> Q a + err tpe _ = + exonError ("Cannot quote " <> tpe) diff --git a/test/Exon/Test/BasicTest.hs b/test/Exon/Test/BasicTest.hs --- a/test/Exon/Test/BasicTest.hs +++ b/test/Exon/Test/BasicTest.hs @@ -3,10 +3,10 @@ import Data.Text (toUpper) import Hedgehog (TestT, (===)) -import Exon.Class.Exon (Exon(..), ExonDefault) +import Exon.Class.Exon (ExonSegment (exonSegment), SkipWs (SkipWs), skipWs) +import Exon.Data.Result (Result (Result)) import qualified Exon.Data.Segment as Segment -import Exon.Quote (exon) -import Exon.Data.Result (Result(Result)) +import Exon.Quote (exon, exonws, intron) newtype Mon = Mon String @@ -38,26 +38,26 @@ test_basic :: TestT IO () test_basic = do - Mon "fooandbar" === [exon|foo + Mon "fooandbar" === [intron|foo #{var} bar|] "foo and \\#{bar}" === ([exon|foo #{var} \#{bar}|] :: Text) - "Philip | J. | FRY" === [exon|Philip J. #{up lastName}|] + "Philip | J. | FRY" === [intron|Philip J. #{up lastName}|] + "Philip | J. | FRY" === skipWs [exonws|Philip J. #{SkipWs (up lastName)}|] + "Philip J. | FRY" === [exon|Philip J.#{up lastName}|] + ("abc" :: Text) === skipWs [exonws|a ##{"b" :: Text} #{"c"}|] where var :: IsString a => a var = "and" -newtype Thing = Thing String deriving newtype (IsString, Semigroup, Monoid, Show, Eq) +newtype Thing = Thing String deriving stock (Generic) deriving newtype (IsString, Show, Eq) -instance Exon ExonDefault Thing where - convertSegment = \case - Segment.String s -> Result (Thing s) +instance ExonSegment Thing String where + exonSegment = \case + Segment.String s -> Result s Segment.Expression thing -> Result thing - Segment.Whitespace _ -> Result (Thing " >>> ") - - insertWhitespace s1 ws s2 = - appendSegment @ExonDefault (appendSegment @ExonDefault s1 (Segment.Whitespace ws)) s2 + Segment.Whitespace _ -> Result " >>> " test_customWhitespace :: TestT IO () test_customWhitespace = - Thing "1 >>> 2 >>> 3" === [exon|1 #{Thing "2"} 3|] + Thing "1 >>> 2 >>> 3" === [exonws|1 #{Thing "2"} 3|] diff --git a/test/Exon/Test/BuildTest.hs b/test/Exon/Test/BuildTest.hs new file mode 100644 --- /dev/null +++ b/test/Exon/Test/BuildTest.hs @@ -0,0 +1,33 @@ +module Exon.Test.BuildTest where + +import Hedgehog (TestT, (===)) + +import Exon.Class.Exon (SkipWs (SkipWs), exonProcess, exonProcessWith, skipWs) +import Exon.Class.ToSegment (toSegment) +import Exon.Data.Segment (Segment (Expression, Whitespace)) + +newtype Str = + Str String + deriving stock (Eq, Show) + deriving newtype (IsString, Semigroup, Monoid) + +segments :: + IsString a => + NonEmpty (Segment a) +segments = + [ + Whitespace " ", + "pre", + Whitespace " ", + Expression (toSegment "exp"), + Whitespace " ", + "post", + Whitespace " " + ] + +test_build :: TestT IO () +test_build = do + " pre exp post " === exonProcess @Text segments + "preexppost" === exonProcessWith @(SkipWs Text) SkipWs skipWs segments + " pre exp post " === exonProcess @Str segments + "preexppost" === exonProcessWith @(SkipWs Str) SkipWs skipWs segments diff --git a/test/Exon/Test/KeepWsTest.hs b/test/Exon/Test/KeepWsTest.hs deleted file mode 100644 --- a/test/Exon/Test/KeepWsTest.hs +++ /dev/null @@ -1,21 +0,0 @@ -module Exon.Test.KeepWsTest where - -import Hedgehog (TestT, (===)) - -import Exon.Quote (exon, exonws) - -newtype Mon = - Mon String - deriving stock (Eq, Show) - deriving newtype (IsString, Semigroup, Monoid) - -test_keepWs :: TestT IO () -test_keepWs = do - Mon "foo\n and bar" === [exonws|foo - #{var} bar|] - "foo and bar" === [exon|foo #{var @Text} bar|] - "foo and bar" === [exon|foo #{var @ByteString} bar|] - where - var :: IsString a => a - var = - "and" diff --git a/test/Exon/Test/NewtypeTest.hs b/test/Exon/Test/NewtypeTest.hs new file mode 100644 --- /dev/null +++ b/test/Exon/Test/NewtypeTest.hs @@ -0,0 +1,57 @@ +module Exon.Test.NewtypeTest where + +import Hedgehog (TestT, (===)) + +import Exon.Class.Exon (exonUse, skipWs) +import Exon.Quote (exon, exonws, exun) + +newtype Nt = + Nt Text + deriving stock (Eq, Show, Generic) + +newtype Str = + Str Text + deriving stock (Eq, Show) + deriving newtype (IsString, Semigroup, Monoid) + +newtype StrGen = + StrGen Text + deriving stock (Eq, Show, Generic) + deriving newtype (IsString) + +newtype BS = + BS ByteString + deriving stock (Eq, Show, Generic) + deriving newtype (IsString) + +newtype StrUse = + StrUse StrGen + deriving stock (Eq, Show, Generic) + deriving newtype (IsString) + +instance Semigroup StrUse where + StrUse (StrGen l) <> StrUse (StrGen r) = + StrUse (StrGen (l <> "|" <> r)) + +instance Monoid StrUse where + mempty = + StrUse (StrGen "") + +nt :: Nt +nt = + Nt "nt" + +test_newtype :: TestT IO () +test_newtype = do + ("pre nt Text" :: Text) === [exon|pre ##{nt} #{"Text" :: Text}|] + ("pre nt Nt \"nt\"" :: Text) === [exon|pre ##{nt} #{show nt}|] + ("pre nt Nt \"nt\" IsString" :: Text) === [exon|pre ##{nt} #{show nt} #{"IsString"}|] + ("pre nt Nt \"nt\" IsString Text" :: Text) === [exon|pre ##{nt} #{show nt} #{"IsString"} #{"Text" :: Text}|] + ("pre nt Nt \"nt\" Text Str" :: Str) === [exon|pre ##{nt} #{show nt} ##{"Text" :: Text} #{"Str" :: Str}|] + ("pre nt Nt \"nt\" Text Str" :: StrGen) === [exon|pre ##{nt} #{show nt} ##{"Text" :: Text} #{"Str" :: StrGen}|] + ("pre BS IsString ByteString" :: ByteString) === [exon|pre ##{"BS" :: BS} #{"IsString"} #{"ByteString" :: ByteString}|] + ("pre BS IsString LByteString" :: Str) === [exon|pre ##{"BS" :: BS} #{"IsString"} ##{"LByteString" :: LByteString}|] + ("pre BS IsString LByteString" :: Str) === [exun|pre #{"BS" :: BS} #{"IsString"} #{"LByteString" :: LByteString}|] + ("pre|post" :: StrUse) === exonUse (skipWs [exonws|pre ##{"post" :: Text}|]) + ("prepost" :: StrUse) === skipWs [exonws|pre ##{"post" :: Text}|] + ("pre post" :: Str) === [exon|pre ##{StrUse "post"}|] diff --git a/test/Exon/Test/SkipWsTest.hs b/test/Exon/Test/SkipWsTest.hs new file mode 100644 --- /dev/null +++ b/test/Exon/Test/SkipWsTest.hs @@ -0,0 +1,21 @@ +module Exon.Test.SkipWsTest where + +import Hedgehog (TestT, (===)) + +import Exon.Quote (exon, intron) + +newtype Mon = + Mon String + deriving stock (Eq, Show) + deriving newtype (IsString, Semigroup, Monoid) + +test_skipWs :: TestT IO () +test_skipWs = do + Mon "foo\n and bar" === [exon|foo + #{var} bar|] + Mon "fooandbar" === [intron|foo + #{var} bar|] + where + var :: IsString a => a + var = + "and" diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,8 +1,10 @@ module Main where import Exon.Test.BasicTest (test_basic, test_customWhitespace) -import Exon.Test.KeepWsTest (test_keepWs) +import Exon.Test.BuildTest (test_build) +import Exon.Test.NewtypeTest (test_newtype) import Exon.Test.ShowsPrecTest (test_showsPrec) +import Exon.Test.SkipWsTest (test_skipWs) import Hedgehog (TestT, property, test, withTests) import Test.Tasty (TestName, TestTree, defaultMain, testGroup) import Test.Tasty.Hedgehog (testProperty) @@ -17,10 +19,12 @@ tests :: TestTree tests = testGroup "all" [ + unitTest "build" test_build, unitTest "basic" test_basic, unitTest "custom whitespace handling" test_customWhitespace, unitTest "concat showsPrec fragments" test_showsPrec, - unitTest "keep whitespace quoter" test_keepWs + unitTest "skip whitespace quoter" test_skipWs, + unitTest "segment newtype conversion" test_newtype ] main :: IO ()