diff --git a/exon.cabal b/exon.cabal --- a/exon.cabal +++ b/exon.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: exon -version: 0.1.1.0 +version: 0.2.0.0 synopsis: Monoidal Quasiquote Interpolation description: See category: String @@ -120,6 +120,7 @@ main-is: Main.hs other-modules: Exon.Test.BasicTest + Exon.Test.KeepWsTest Exon.Test.Quote Exon.Test.ShowsPrecTest Paths_exon diff --git a/lib/Exon.hs b/lib/Exon.hs --- a/lib/Exon.hs +++ b/lib/Exon.hs @@ -1,6 +1,9 @@ +-- |Monoidal Quasiquote Interpolation module Exon ( -- $intro - module Exon.Quote, + exon, + exonws, + exonWith, -- * Customizing Concatenation module Exon.Class.Exon, -- * Combinators @@ -10,11 +13,11 @@ module Exon.Data.Result, ) where -import Exon.Class.Exon (Exon (..), ExonDefault) +import Exon.Class.Exon (Exon (..), ExonDefault, KeepWhitespace) +import Exon.Combinators (intercalate) import Exon.Data.Result (Result (..)) import Exon.Data.Segment (Segment (..)) -import Exon.Quote (exon) -import Exon.Combinators (intercalate) +import Exon.Quote (exon, exonWith, exonws) -- $intro -- This Haskell library provides quasiquote string interpolation with customizable concatenation for arbitrary types. @@ -45,4 +48,4 @@ -- -- 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 `String`, `Text` etc. +-- The default implementation ignores whitespace when concatenating, while it is preserved for `GHC.String`, `Text` etc. 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 @@ -7,8 +7,10 @@ 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 {- | @@ -109,6 +111,7 @@ IsString a ) => Exon ExonDefault a where +-- |Variant of 'convertSegment' that preserves whitespace verbatim. convertKeepWs :: IsString a => Segment a -> @@ -121,6 +124,7 @@ Segment.Whitespace a -> Result (fromString a) +-- |Variant of 'concatSegments' that preserves whitespace verbatim. concatKeepWs :: ∀ tag a . Monoid a => @@ -130,6 +134,16 @@ concatKeepWs = fold . foldl' (appendSegment @tag) Empty +instance ( + Monoid a, + IsString a + ) => Exon KeepWhitespace a where + convertSegment = + convertKeepWs + + concatSegments = + concatKeepWs @KeepWhitespace + instance Exon ExonDefault String where convertSegment = convertKeepWs @@ -139,31 +153,31 @@ instance Exon ExonDefault Text where convertSegment = - convertKeepWs + convertSegment @KeepWhitespace concatSegments = - concatKeepWs @ExonDefault + concatSegments @KeepWhitespace instance Exon ExonDefault LText where convertSegment = - convertKeepWs + convertSegment @KeepWhitespace concatSegments = - concatKeepWs @ExonDefault + concatSegments @KeepWhitespace instance Exon ExonDefault ByteString where convertSegment = - convertKeepWs + convertSegment @KeepWhitespace concatSegments = - concatKeepWs @ExonDefault + concatSegments @KeepWhitespace instance Exon ExonDefault LByteString where convertSegment = - convertKeepWs + convertSegment @KeepWhitespace concatSegments = - concatKeepWs @ExonDefault + concatSegments @KeepWhitespace instance Exon ExonDefault (String -> String) where convertSegment = \case 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 @@ -1,5 +1,8 @@ +-- |Description: Data Type 'RawSegment', Internal + module Exon.Data.RawSegment where +-- |An intermediate representation for internal use. data RawSegment = WsSegment String | 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 @@ -1,4 +1,4 @@ --- |Description: Internal +-- |Description: Data Type 'Segment' module Exon.Data.Segment where -- |The parts of an interpolation quasiquote. diff --git a/lib/Exon/Debug.hs b/lib/Exon/Debug.hs --- a/lib/Exon/Debug.hs +++ b/lib/Exon/Debug.hs @@ -1,3 +1,5 @@ +{-# options_haddock hide #-} +-- |Description: Debug Printing Combinators {-# language NoImplicitPrelude #-} module Exon.Debug where diff --git a/lib/Exon/Parse.hs b/lib/Exon/Parse.hs --- a/lib/Exon/Parse.hs +++ b/lib/Exon/Parse.hs @@ -1,4 +1,5 @@ --- |Description: Internal +{-# options_haddock prune #-} +-- |Description: The Quasiquote Body Parser module Exon.Parse where import Data.Char (isSpace) diff --git a/lib/Exon/Prelude.hs b/lib/Exon/Prelude.hs --- a/lib/Exon/Prelude.hs +++ b/lib/Exon/Prelude.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE NoImplicitPrelude #-} +{-# options_haddock hide #-} +-- |Description: Prelude +{-# language NoImplicitPrelude #-} module Exon.Prelude ( module Data.Kind, diff --git a/lib/Exon/Quote.hs b/lib/Exon/Quote.hs --- a/lib/Exon/Quote.hs +++ b/lib/Exon/Quote.hs @@ -1,3 +1,4 @@ +{-# options_haddock prune #-} -- |Description: Internal module Exon.Quote where @@ -11,11 +12,12 @@ parseExtension, ) import Language.Haskell.Meta (toExp) +import qualified Language.Haskell.TH as TH import Language.Haskell.TH (Exp (AppE, InfixE, ListE), Q, extsEnabled, runQ) import Language.Haskell.TH.Quote (QuasiQuoter (QuasiQuoter)) import Language.Haskell.TH.Syntax (Quasi) -import Exon.Class.Exon (ExonDefault, concatSegments) +import Exon.Class.Exon (ExonDefault, KeepWhitespace, concatSegments) import Exon.Data.RawSegment (RawSegment (ExpSegment, StringSegment, WsSegment)) import qualified Exon.Data.Segment as Segment import Exon.Parse (parse) @@ -74,17 +76,44 @@ WsSegment s -> runQ [e|Segment.Whitespace s|] -quoteExp :: +quoteExpWith :: QOrIO m => + Q TH.Type -> String -> m Exp -quoteExp code = do +quoteExpWith tag code = do raw <- segmentsQ code hseg :| segs <- reifySegments raw - conc <- runQ [e|concatSegments @ExonDefault|] + conc <- runQ [e|concatSegments @($tag)|] consE <- runQ [e|(:|)|] pure (AppE conc (InfixE (Just hseg) consE (Just (ListE segs)))) +quoteExp :: + QOrIO m => + String -> + m Exp +quoteExp = + quoteExpWith [t|ExonDefault|] + +-- |Constructor for a quasiquoter for an arbitrary tag. +-- +-- This can be used to define quoters with custom logic, requiring an instance of 'Exon.Class.Exon' for the given type: +-- +-- >>> import Exon.Class.Exon (Exon(..)) +-- >>> 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|] +-- >>> [exonnl|one two three|] +-- "one\ntwo\nthree" +exonWith :: Q TH.Type -> QuasiQuoter +exonWith tag = + QuasiQuoter (quoteExpWith tag) (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. -- -- >>> [exon|write #{show @Text (5 :: Int)} lines of code|] :: Text @@ -96,13 +125,14 @@ -- >>> newtype Part = Part Text deriving newtype (Show, Semigroup, Monoid, IsString) -- -- >>> [exon|x #{Part "y"}z|] :: Part --- Part "xyz" +-- "xyz" -- -- This behavior can be customized by writing an instance of 'Exon.Exon'. exon :: QuasiQuoter exon = - QuasiQuoter quoteExp (err "pattern") (err "type") (err "decl") - where - err :: String -> String -> Q a - err tpe _ = - exonError ("Cannot quote " <> tpe) + exonWith [t|ExonDefault|] + +-- |A variant of 'exon' that always keeps whitespace verbatim. +exonws :: QuasiQuoter +exonws = + exonWith [t|KeepWhitespace|] diff --git a/lib/Prelude.hs b/lib/Prelude.hs --- a/lib/Prelude.hs +++ b/lib/Prelude.hs @@ -1,3 +1,7 @@ +{-# options_haddock hide #-} +-- |Description: Prelude +{-# language NoImplicitPrelude #-} + module Prelude ( module Exon.Prelude, ) where 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 @@ -58,6 +58,6 @@ insertWhitespace s1 ws s2 = appendSegment @ExonDefault (appendSegment @ExonDefault s1 (Segment.Whitespace ws)) s2 -test_keepWhitespace :: TestT IO () -test_keepWhitespace = +test_customWhitespace :: TestT IO () +test_customWhitespace = Thing "1 >>> 2 >>> 3" === [exon|1 #{Thing "2"} 3|] diff --git a/test/Exon/Test/KeepWsTest.hs b/test/Exon/Test/KeepWsTest.hs new file mode 100644 --- /dev/null +++ b/test/Exon/Test/KeepWsTest.hs @@ -0,0 +1,21 @@ +module Exon.Test.KeepWsTest where + +import Hedgehog (TestT, (===)) + +import Exon.Quote (exon, exonws) + +newtype Mon = + Mon String + deriving (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/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,6 +1,7 @@ module Main where -import Exon.Test.BasicTest (test_basic, test_keepWhitespace) +import Exon.Test.BasicTest (test_basic, test_customWhitespace) +import Exon.Test.KeepWsTest (test_keepWs) import Exon.Test.ShowsPrecTest (test_showsPrec) import Hedgehog (TestT, property, test, withTests) import Test.Tasty (TestName, TestTree, defaultMain, testGroup) @@ -17,8 +18,9 @@ tests = testGroup "all" [ unitTest "basic" test_basic, - unitTest "keep whitespace" test_keepWhitespace, - unitTest "concat showsPrec fragments" test_showsPrec + unitTest "custom whitespace handling" test_customWhitespace, + unitTest "concat showsPrec fragments" test_showsPrec, + unitTest "keep whitespace quoter" test_keepWs ] main :: IO ()