packages feed

exon (empty) → 0.1.0.0

raw patch · 18 files changed

+1010/−0 lines, 18 filesdep +basedep +exondep +flatparse

Dependencies added: base, exon, flatparse, haskell-src-exts, haskell-src-meta, hedgehog, relude, tasty, tasty-hedgehog, template-haskell, text

Files

+ Changelog.md view
@@ -0,0 +1,9 @@+# 0.2.1.0+* add naive stderr interpreters for `DataLog` and `Log`.++# 0.2.0.0++* `DataLog` got a second constructor, `Local`. It takes a higher-order `Sem` and a transformation function, the latter+  of which is applied to all messages logged within the former.+  This allows context manipulation for blocks of code.+* `interceptDataLogConc` adds support for concurrent processing of log messages to any interpretation of `DataLog`.
+ LICENSE view
@@ -0,0 +1,34 @@+Copyright (c) 2020 Torsten Schmits++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the+following conditions are met:++  1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following+  disclaimer.+  2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following+  disclaimer in the documentation and/or other materials provided with the distribution.++Subject to the terms and conditions of this license, each copyright holder and contributor hereby grants to those+receiving rights under this license a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except+for failure to satisfy the conditions of this license) patent license to make, have made, use, offer to sell, sell,+import, and otherwise transfer this software, where such license applies only to those patent claims, already acquired+or hereafter acquired, licensable by such copyright holder or contributor that are necessarily infringed by:++  (a) their Contribution(s) (the licensed copyrights of copyright holders and non-copyrightable additions of+  contributors, in source or binary form) alone; or+  (b) combination of their Contribution(s) with the work of authorship to which such Contribution(s) was added by such+  copyright holder or contributor, if, at the time the Contribution is added, such addition causes such combination to+  be necessarily infringed. The patent license shall not apply to any other combinations which include the Contribution.++Except as expressly stated above, no rights or licenses from any copyright holder or contributor is granted under this+license, whether expressly, by implication, estoppel or otherwise.++DISCLAIMER++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,+WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF+THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ exon.cabal view
@@ -0,0 +1,202 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name:           exon+version:        0.1.0.0+synopsis:       Monoidal Quasiquote Interpolation+description:    See <https://hackage.haskell.org/package/exon/docs/Exon.html>+category:       String+homepage:       https://github.com/tek/exon#readme+bug-reports:    https://github.com/tek/exon/issues+author:         Torsten Schmits+maintainer:     haskell@tryp.io+copyright:      2021 Torsten Schmits+license:        BSD-2-Clause-Patent+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    readme.md+    Changelog.md++source-repository head+  type: git+  location: https://github.com/tek/exon++library+  exposed-modules:+      Exon+      Exon.Class.Exon+      Exon.Combinators+      Exon.Data.RawSegment+      Exon.Data.Result+      Exon.Data.Segment+      Exon.Debug+      Exon.Parse+      Exon.Prelude+      Exon.Quote+  other-modules:+      Prelude+      Paths_exon+  autogen-modules:+      Paths_exon+  hs-source-dirs:+      lib+  default-extensions:+      AllowAmbiguousTypes+      ApplicativeDo+      BangPatterns+      BinaryLiterals+      BlockArguments+      ConstraintKinds+      DataKinds+      DefaultSignatures+      DeriveAnyClass+      DeriveDataTypeable+      DeriveFoldable+      DeriveFunctor+      DeriveGeneric+      DeriveTraversable+      DerivingStrategies+      DerivingVia+      DisambiguateRecordFields+      DoAndIfThenElse+      DuplicateRecordFields+      EmptyDataDecls+      ExistentialQuantification+      FlexibleContexts+      FlexibleInstances+      FunctionalDependencies+      GADTs+      GeneralizedNewtypeDeriving+      InstanceSigs+      KindSignatures+      LambdaCase+      LiberalTypeSynonyms+      MultiParamTypeClasses+      MultiWayIf+      NamedFieldPuns+      OverloadedStrings+      OverloadedLists+      PackageImports+      PartialTypeSignatures+      PatternGuards+      PatternSynonyms+      PolyKinds+      QuantifiedConstraints+      QuasiQuotes+      RankNTypes+      RecordWildCards+      RecursiveDo+      ScopedTypeVariables+      StandaloneDeriving+      TemplateHaskell+      TupleSections+      TypeApplications+      TypeFamilies+      TypeFamilyDependencies+      TypeOperators+      TypeSynonymInstances+      UndecidableInstances+      UnicodeSyntax+      ViewPatterns+  ghc-options: -Wall -Wredundant-constraints -Wsimplifiable-class-constraints -Wunused-type-patterns+  build-depends:+      base ==4.*+    , flatparse ==0.2.*+    , haskell-src-exts <1.24+    , haskell-src-meta <0.9+    , relude >=0.7 && <1.2+    , template-haskell+    , text+  mixins:+      base hiding (Prelude)+  default-language: Haskell2010++test-suite exon-unit+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Exon.Test.BasicTest+      Exon.Test.Quote+      Paths_exon+  hs-source-dirs:+      test+  default-extensions:+      AllowAmbiguousTypes+      ApplicativeDo+      BangPatterns+      BinaryLiterals+      BlockArguments+      ConstraintKinds+      DataKinds+      DefaultSignatures+      DeriveAnyClass+      DeriveDataTypeable+      DeriveFoldable+      DeriveFunctor+      DeriveGeneric+      DeriveTraversable+      DerivingStrategies+      DerivingVia+      DisambiguateRecordFields+      DoAndIfThenElse+      DuplicateRecordFields+      EmptyDataDecls+      ExistentialQuantification+      FlexibleContexts+      FlexibleInstances+      FunctionalDependencies+      GADTs+      GeneralizedNewtypeDeriving+      InstanceSigs+      KindSignatures+      LambdaCase+      LiberalTypeSynonyms+      MultiParamTypeClasses+      MultiWayIf+      NamedFieldPuns+      OverloadedStrings+      OverloadedLists+      PackageImports+      PartialTypeSignatures+      PatternGuards+      PatternSynonyms+      PolyKinds+      QuantifiedConstraints+      QuasiQuotes+      RankNTypes+      RecordWildCards+      RecursiveDo+      ScopedTypeVariables+      StandaloneDeriving+      TemplateHaskell+      TupleSections+      TypeApplications+      TypeFamilies+      TypeFamilyDependencies+      TypeOperators+      TypeSynonymInstances+      UndecidableInstances+      UnicodeSyntax+      ViewPatterns+  ghc-options: -Wall -Wredundant-constraints -Wsimplifiable-class-constraints -Wunused-type-patterns -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base ==4.*+    , exon+    , flatparse ==0.2.*+    , haskell-src-exts <1.24+    , haskell-src-meta <0.9+    , hedgehog+    , relude >=0.7 && <1.2+    , tasty+    , tasty-hedgehog+    , template-haskell+    , text+  mixins:+      base hiding (Prelude)+    , exon hiding (Prelude)+    , exon (Exon.Prelude as Prelude)+  default-language: Haskell2010
+ lib/Exon.hs view
@@ -0,0 +1,48 @@+module Exon (+  -- $intro+  module Exon.Quote,+  -- * Customizing Concatenation+  module Exon.Class.Exon,+  -- * Combinators+  module Exon.Combinators,+  -- * Data Types+  module Exon.Data.Segment,+  module Exon.Data.Result,+) where++import Exon.Class.Exon (Exon (..), ExonDefault)+import Exon.Data.Result (Result (..))+import Exon.Data.Segment (Segment (..))+import Exon.Quote (exon)+import Exon.Combinators (intercalate)++-- $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 `String`, `Text` etc.
+ lib/Exon/Class/Exon.hs view
@@ -0,0 +1,164 @@+-- |Description: Internal+module Exon.Class.Exon where++import Exon.Data.Result (Result (Empty, Result))+import qualified Exon.Data.Segment as Segment+import Exon.Data.Segment (Segment)++data ExonDefault++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'.++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:++@+newtype Thing = Thing String deriving newtype (IsString, Semigroup, Monoid, Show)++instance Exon ExonDefault Thing where+  convertSegment = \case+    Segment.String s -> Result (Thing s)+    Segment.Expression thing -> Result thing+    Segment.Whitespace _ -> Result (Thing " >>> ")++  insertWhitespace s1 ws s2 =+    appendSegment @ExonDefault (appendSegment @ExonDefault s1 (Segment.Whitespace ws)) s2+@+-}+class Exon (tag :: Type) (a :: Type) where++  -- |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++  -- |Convert a 'Segment' to a 'Result'.+  -- The default implementation uses 'IsString' and ignores whitespace, returning 'Empty'.+  convertSegment :: Segment a -> Result a++  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++  -- |Append a 'Segment' to a 'Result'.+  -- The default implementation uses '(<>)'.+  appendSegment :: Result a -> Segment a -> Result a++  default appendSegment :: Semigroup a => Result a -> Segment a -> Result a+  appendSegment z a =+    z <> convertSegment @tag a++  -- |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++  default insertWhitespace :: Result a -> String -> Segment a -> Result a+  insertWhitespace s1 _ s2 =+    appendSegment @tag s1 s2++  -- |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 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++instance {-# overlappable #-} (+    Monoid a,+    IsString a+  ) => Exon ExonDefault a where++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)++concatKeepWs ::+  ∀ tag a .+  Monoid a =>+  Exon tag a =>+  NonEmpty (Segment a) ->+  a+concatKeepWs =+  fold . foldl' (appendSegment @tag) Empty++instance Exon ExonDefault String where+  convertSegment =+    convertKeepWs++  concatSegments =+    concatKeepWs @ExonDefault++instance Exon ExonDefault Text where+  convertSegment =+    convertKeepWs++  concatSegments =+    concatKeepWs @ExonDefault++instance Exon ExonDefault LText where+  convertSegment =+    convertKeepWs++  concatSegments =+    concatKeepWs @ExonDefault++instance Exon ExonDefault ByteString where+  convertSegment =+    convertKeepWs++  concatSegments =+    concatKeepWs @ExonDefault++instance Exon ExonDefault LByteString where+  convertSegment =+    convertKeepWs++  concatSegments =+    concatKeepWs @ExonDefault
+ lib/Exon/Combinators.hs view
@@ -0,0 +1,19 @@+-- |Description: Internal+module Exon.Combinators where++import Prelude hiding (intercalate)++-- |Monoidally combine all elements in the list, appending the separator between each pair of elements.+intercalate ::+  Monoid a =>+  Foldable t =>+  a ->+  t a ->+  a+intercalate sep =+  fold . foldl' f Nothing+  where+    f Nothing a =+      Just a+    f (Just z) a =+      Just (z <> sep <> a)
+ lib/Exon/Data/RawSegment.hs view
@@ -0,0 +1,9 @@+module Exon.Data.RawSegment where++data RawSegment =+  WsSegment String+  |+  StringSegment String+  |+  ExpSegment String+  deriving (Eq, Show)
+ lib/Exon/Data/Result.hs view
@@ -0,0 +1,18 @@+-- |Description: Internal+module Exon.Data.Result where++-- |The combined segments, either empty or a value.+data Result a =+  Empty+  |+  Result a +  deriving (Eq, Show, Foldable)++instance Semigroup a => Semigroup (Result a) where+  (<>) Empty a = a+  (<>) a Empty = a+  (<>) (Result l) (Result r) = Result (l <> r)++instance Monoid a => Monoid (Result a) where+  mempty =+    Result mempty
+ lib/Exon/Data/Segment.hs view
@@ -0,0 +1,12 @@+-- |Description: Internal+module Exon.Data.Segment where++-- |The parts of an interpolation quasiquote.+-- Text is split at each whitespace and interpolation splice marked by @#{@ and @}@.+data Segment a =+  String String+  |+  Whitespace String+  |+  Expression a+  deriving (Eq, Show)
+ lib/Exon/Debug.hs view
@@ -0,0 +1,100 @@+{-# language NoImplicitPrelude #-}++module Exon.Debug where++import qualified Data.Text as Text+import GHC.Stack (SrcLoc (..))+import Relude+import System.IO.Unsafe (unsafePerformIO)++srcLoc :: CallStack -> SrcLoc+srcLoc = \case+  (getCallStack -> (_, loc) : _) -> loc+  _ -> error "Debug.srcLoc: empty CallStack"++debugPrint ::+  SrcLoc ->+  Text ->+  IO ()+debugPrint SrcLoc{srcLocModule = toText -> slm, srcLocStartLine} msg =+  putStrLn (moduleName <> ":" <> show srcLocStartLine <> " " <> toString msg)+  where+    moduleName =+      toString $ fromMaybe slm $ listToMaybe $ reverse $ Text.splitOn "." slm++debugPrintWithLoc ::+  Monad m =>+  SrcLoc ->+  Text ->+  m ()+debugPrintWithLoc loc msg = do+  () <- return (unsafePerformIO (debugPrint loc msg))+  pure ()++dbg ::+  HasCallStack =>+  Monad m =>+  Text ->+  m ()+dbg =+  debugPrintWithLoc (srcLoc callStack)+{-# inline dbg #-}++dbgsWith ::+  HasCallStack =>+  Monad m =>+  Show a =>+  Text ->+  a ->+  m ()+dbgsWith prefix a =+  debugPrintWithLoc (srcLoc callStack) (prefix <> ": " <> show a)+{-# inline dbgsWith #-}++dbgs ::+  HasCallStack =>+  Monad m =>+  Show a =>+  a ->+  m ()+dbgs a =+  debugPrintWithLoc (srcLoc callStack) (show a)+{-# inline dbgs_ #-}++dbgs_ ::+  HasCallStack =>+  Monad m =>+  Show a =>+  a ->+  m a+dbgs_ a =+  a <$ debugPrintWithLoc (srcLoc callStack) (show a)+{-# inline dbgs #-}++tr ::+  HasCallStack =>+  Text ->+  a ->+  a+tr msg a =+  unsafePerformIO (a <$ debugPrint (srcLoc callStack) msg)+{-# inline tr #-}++trs ::+  Show a =>+  HasCallStack =>+  a ->+  a+trs a =+  unsafePerformIO (a <$ debugPrint (srcLoc callStack) (show a))+{-# inline trs #-}++trs' ::+  Show b =>+  HasCallStack =>+  b ->+  a ->+  a+trs' b a =+  unsafePerformIO (a <$ debugPrint (srcLoc callStack) (show b))+{-# inline trs' #-}
+ lib/Exon/Parse.hs view
@@ -0,0 +1,98 @@+-- |Description: Internal+module Exon.Parse where++import Data.Char (isSpace)+import qualified FlatParse.Stateful as FlatParse+import FlatParse.Stateful (+  Result (Err, Fail, OK),+  anyChar,+  branch,+  char,+  empty,+  eof,+  get,+  inSpan,+  lookahead,+  modify,+  put,+  runParserS,+  satisfy,+  some_,+  spanned,+  string,+  takeRest,+  (<|>),+  )+import Prelude hiding (empty, get, modify, put, span, (<|>))++import Exon.Data.RawSegment (RawSegment (ExpSegment, StringSegment, WsSegment))++type Parser =+  FlatParse.Parser Text++span :: Parser () -> Parser String+span seek =+  spanned seek \ _ sp -> inSpan sp takeRest++ws :: Parser Char+ws =+  satisfy isSpace++whitespace :: Parser RawSegment+whitespace =+  WsSegment <$> span (some_ ws)++before ::+  Parser a ->+  Parser () ->+  Parser () ->+  Parser ()+before =+  branch . lookahead++finishBefore ::+  Parser a ->+  Parser () ->+  Parser ()+finishBefore cond =+  before (lookahead cond) pass++expr :: Parser ()+expr =+  branch $(char '{') (modify (1 +) *> expr) $+  before $(char '}') closing (anyChar *> expr)+  where+    closing =+      get >>= \case+        0 -> pass+        cur -> put (cur - 1) *> $(char '}') *> expr++interpolation :: Parser RawSegment+interpolation =+  $(string "#{") *> (ExpSegment <$> span expr) <* $(char '}')++untilTokenEnd :: Parser ()+untilTokenEnd =+  branch $(char '\\') (anyChar *> untilTokenEnd) $+  finishBefore ($(string "#{") <|> void ws) $+  eof <|> (anyChar *> untilTokenEnd)++text :: Parser RawSegment+text =+  StringSegment <$> span untilTokenEnd++segment :: Parser RawSegment+segment =+  branch eof empty (whitespace <|> interpolation <|> text)++parser :: Parser [RawSegment]+parser =+  FlatParse.many segment++parse :: String -> Either Text [RawSegment]+parse =+  runParserS parser 0 0 >>> \case+    OK a _ "" -> Right a+    OK _ _ u -> Left ("unconsumed: " <> decodeUtf8 u)+    Fail -> Left "fail"+    Err e -> Left e
+ lib/Exon/Prelude.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Exon.Prelude (+  module Data.Kind,+  module Exon.Debug,+  module GHC.Err,+  module Relude,+) where++import Data.Kind (Type)+import GHC.Err (undefined)++import Exon.Debug (dbg, dbgs, dbgs_, tr, trs, trs')+import Relude hiding (Type, undefined)
+ lib/Exon/Quote.hs view
@@ -0,0 +1,108 @@+-- |Description: Internal+module Exon.Quote where++import Data.Traversable (for)+import Language.Haskell.Exts (+  Extension,+  ParseMode (extensions),+  ParseResult (ParseFailed, ParseOk),+  defaultParseMode,+  parseExpWithMode,+  parseExtension,+  )+import Language.Haskell.Meta (toExp)+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.Data.RawSegment (RawSegment (ExpSegment, StringSegment, WsSegment))+import qualified Exon.Data.Segment as Segment+import Exon.Parse (parse)++exonError ::+  ToString e =>+  MonadFail m =>+  e ->+  m a+exonError err =+  fail ("Exon: " <> toString err)++segmentsQ ::+  QOrIO m =>+  String ->+  m (NonEmpty RawSegment)+segmentsQ =+  parse >>> fmap nonEmpty >>> \case+    Right (Just segs) -> pure segs+    Right Nothing -> pure (pure (StringSegment ""))+    Left err -> exonError err++class Quasi m => QOrIO (m :: Type -> Type) where+  fileExtensions :: m [Extension]++instance QOrIO IO where+  fileExtensions =+    pure []++instance QOrIO Q where+  fileExtensions =+    fmap (fmap (parseExtension . show)) extsEnabled++reifyExp ::+  QOrIO m =>+  String ->+  m Exp+reifyExp s = do+  exts <- fileExtensions+  case parseExpWithMode defaultParseMode { extensions = exts } s of+    ParseFailed _ err -> exonError err+    ParseOk e -> pure (toExp e)++reifySegments ::+  QOrIO m =>+  NonEmpty RawSegment ->+  m (NonEmpty Exp)+reifySegments segs = do+  expCon <- runQ [e|Segment.Expression|]+  for segs \case+    StringSegment s ->+      runQ [e|Segment.String s|]+    ExpSegment s -> do+      e <- reifyExp s+      pure (AppE expCon e)+    WsSegment s ->+     runQ [e|Segment.Whitespace s|]++quoteExp ::+  QOrIO m =>+  String ->+  m Exp+quoteExp code = do+  raw <- segmentsQ code+  hseg :| segs <- reifySegments raw+  conc <- runQ [e|concatSegments @ExonDefault|]+  consE <- runQ [e|(:|)|]+  pure (AppE conc (InfixE (Just hseg) consE (Just (ListE segs))))++-- |A quasiquoter that allows interpolation, concatenating the resulting segments monoidally.+--+-- >>> [exon|write #{show @Text (5 :: Int)} lines of code|] :: 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.+--+-- >>> newtype Part = Part Text deriving newtype (Show, Semigroup, Monoid, IsString)+--+-- >>> [exon|x #{Part "y"}z|] :: Part+-- Part "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)
+ lib/Prelude.hs view
@@ -0,0 +1,5 @@+module Prelude (+  module Exon.Prelude,+) where++import Exon.Prelude
+ readme.md view
@@ -0,0 +1,66 @@+This Haskell library provides quasiquote string interpolation with customizable concatenation for arbitrary types.++The default case uses `Monoid` and `IsString`:++```haskell+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 `String`, `Text` etc.++# Customization++Concatenation is performed by the class `Exon.Exon`:++```haskell+class Exon (tag :: Type) (a :: Type) where+  convertSegment :: Segment a -> Result a++  appendSegment :: Result a -> Segment a -> Result a++  insertWhitespace :: Result a -> String -> Segment a -> Result a++  concatSegments :: NonEmpty (Segment a) -> a+```++All methods have default implementations.+The `tag` parameter is an arbitrary type that allows the creation of different quoters, with `exon` using the tag+`ExonDefault.`++In order to get the default quoter to support custom rules for a type, one simply has to write an instance:++```haskell+import Exon (Exon, ExonDefault, Result)+import qualified Exon as Segment (Segment(..))++instance Exon ExonDefault Name where+  convertSegment = \case+    Segment.String s -> Result (Name s)+    Segment.Expression name -> Result name+    Segment.Whitespace ws -> Result (Name " >>> ")+```++# Acknowledgments++Inspired by the magnificent [string-interpolate].++[string-interpolate]: https://hackage.haskell.org/package/string-interpolate
+ test/Exon/Test/BasicTest.hs view
@@ -0,0 +1,63 @@+module Exon.Test.BasicTest where++import Data.Text (toUpper)+import Hedgehog (TestT, (===))++import Exon.Class.Exon (Exon(..), ExonDefault)+import qualified Exon.Data.Segment as Segment+import Exon.Quote (exon)+import Exon.Data.Result (Result(Result))++newtype Mon =+  Mon String+  deriving (Eq, Show)+  deriving newtype (IsString)++instance Semigroup Mon where+  Mon l <> Mon r =+    Mon (l <> r)++instance Monoid Mon where+  mempty =+    Mon ""++newtype Name =+  Name Text+  deriving newtype (Eq, 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)++test_basic :: TestT IO ()+test_basic = do+  Mon "fooandbar" === [exon|foo+    #{var} bar|]+  "foo and \\#{bar}" === ([exon|foo #{var} \#{bar}|] :: Text)+  "Philip | J. | FRY" === [exon|Philip J. #{up lastName}|]+  where+    var :: IsString a => a+    var =+      "and"++newtype Thing = Thing String deriving newtype (IsString, Semigroup, Monoid, Show, Eq)++instance Exon ExonDefault Thing where+  convertSegment = \case+    Segment.String s -> Result (Thing s)+    Segment.Expression thing -> Result thing+    Segment.Whitespace _ -> Result (Thing " >>> ")++  insertWhitespace s1 ws s2 =+    appendSegment @ExonDefault (appendSegment @ExonDefault s1 (Segment.Whitespace ws)) s2++test_keepWhitespace :: TestT IO ()+test_keepWhitespace =+  Thing "1 >>> 2 >>> 3" === [exon|1 #{Thing "2"}    3|]
+ test/Exon/Test/Quote.hs view
@@ -0,0 +1,17 @@+module Exon.Test.Quote where++import Language.Haskell.TH.Quote (quoteExp, QuasiQuoter)+import Language.Haskell.TH (Q, Exp, runQ)+import Language.Haskell.TH.Ppr (pprint)++thLines :: Q Exp -> IO [Text]+thLines q =+  lines . toText <$> runQ (pprint <$> q)++qqLines :: QuasiQuoter -> String -> IO [Text]+qqLines qq code =+  thLines (quoteExp qq code)++runQuote :: QuasiQuoter -> String -> IO Exp+runQuote qq code =+  runQ (quoteExp qq code)
+ test/Main.hs view
@@ -0,0 +1,24 @@+module Main where++import Exon.Test.BasicTest (test_basic, test_keepWhitespace)+import Hedgehog (TestT, property, test, withTests)+import Test.Tasty (TestName, TestTree, defaultMain, testGroup)+import Test.Tasty.Hedgehog (testProperty)++unitTest ::+  TestName ->+  TestT IO () ->+  TestTree+unitTest desc =+  testProperty desc . withTests 1 . property . test++tests :: TestTree+tests =+  testGroup "all" [+    unitTest "basic" test_basic,+    unitTest "keep whitespace" test_keepWhitespace+  ]++main :: IO ()+main =+  defaultMain tests