custom-interpolation (empty) → 0.1.0.0

raw patch · 11 files changed

+607/−0 lines, 11 filesdep +basedep +custom-interpolationdep +data-default-class

Dependencies added: base, custom-interpolation, data-default-class, doctest-parallel, haskell-src-meta, mtl, parsec, template-haskell

Files

• LICENSE +30/−0
• changelog.md +5/−0
• custom-interpolation.cabal +91/−0
• readme.md +67/−0
• src/CustomInterpolation.hs +38/−0
• src/CustomInterpolation/Config.hs +79/−0
• src/CustomInterpolation/Parser.hs +133/−0
• src/CustomInterpolation/TH.hs +44/−0
• test/doctests/Main.hs +7/−0
• test/simple/Main.hs +52/−0
• test/simple/QQ.hs +61/−0

@@ -0,0 +1,30 @@+BSD 3-Clause License++Copyright (c) 2013, Taylor Hedberg+Copyright (c) 2014, Google, Inc.+Copyright (c) 2023, ruby0b++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.++3. Neither the name of the copyright holder nor the names of its+   contributors may be used to endorse or promote products derived from+   this software without specific prior written permission.++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 HOLDER 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.

@@ -0,0 +1,5 @@+# Changelog++## 0.1.0.0++* Initial version

@@ -0,0 +1,91 @@+cabal-version:      3.0+name:               custom-interpolation+version:            0.1.0.0+synopsis:           Customizable string interpolation quasiquoters+description:+  Please see the readme at https://github.com/ruby0b/custom-interpolation#readme.++license:            BSD-3-Clause+license-file:       LICENSE+author:             ruby0b+maintainer:         ruby0b+category:           Interpolation, QuasiQuotes, Text+homepage:           https://github.com/ruby0b/custom-interpolation+tested-with:        GHC ==8.10.7 || ==9.2.5 || ==9.4.4+extra-doc-files:    readme.md+extra-source-files:+  changelog.md+  readme.md++source-repository head+  type:     git+  location: git://github.com/ruby0b/custom-interpolation.git++library+  -- cabal-fmt: expand src+  exposed-modules:+    CustomInterpolation+    CustomInterpolation.Config+    CustomInterpolation.Parser+    CustomInterpolation.TH++  default-extensions:+    ExistentialQuantification+    FlexibleContexts+    LambdaCase+    MultiWayIf+    NamedFieldPuns+    QuasiQuotes+    RecordWildCards+    StrictData+    TemplateHaskell+    TupleSections++  build-depends:+    , base                >=4.14 && <5+    , data-default-class  ^>=0.1+    , haskell-src-meta    >=0.6  && <0.9+    , mtl                 >=2.1  && <2.4+    , parsec              ^>=3.1+    , template-haskell    >=2.16 && <2.20++  hs-source-dirs:     src+  ghc-options:        -Wall+  default-language:   Haskell2010++test-suite simple-tests+  type:             exitcode-stdio-1.0+  main-is:          Main.hs++  -- cabal-fmt: expand test/simple -Main+  other-modules:    QQ+  hs-source-dirs:   test/simple+  build-depends:+    , base+    , custom-interpolation+    , template-haskell++  ghc-options:      -Wall -Wno-type-defaults -Wno-missing-signatures+  default-language: Haskell2010++flag doctests+  description:+    Run doctests using doctests-parallel, disabled by default due to https://github.com/martijnbastiaan/doctest-parallel/issues/22++  default:     False+  manual:      True++test-suite doctests+  if !flag(doctests)+    buildable: False++  type:             exitcode-stdio-1.0+  hs-source-dirs:   test/doctests+  main-is:          Main.hs+  ghc-options:      -threaded -Wno-type-defaults+  build-depends:+    , base+    , custom-interpolation+    , doctest-parallel      >=0.1++  default-language: Haskell2010

@@ -0,0 +1,67 @@+<h1 align="center">custom-interpolation</h1>++<p align="center">+  <a href="https://hackage.haskell.org/package/custom-interpolation"><img src="https://img.shields.io/hackage/v/custom-interpolation" alt="Hackage"></a>+  <a href="https://github.com/ruby0b/custom-interpolation/actions/workflows/haskell-ci.yml"><img src="https://github.com/ruby0b/custom-interpolation/actions/workflows/haskell-ci.yml/badge.svg" alt="Build Status"></a>+  <a href="https://github.com/simmsb/calamity/blob/master/LICENSE"><img src="https://img.shields.io/github/license/ruby0b/custom-interpolation" alt="License"></a>+  <a href="https://hackage.haskell.org/package/custom-interpolation"><img src="https://img.shields.io/hackage-deps/v/custom-interpolation" alt="Hackage-Deps"></a>+</p>++This library provides tools for easily generating string interpolation quasiquoters.+The interpolation behavior is customizable and multiple different interpolation methods may be used in a single quasiquoter.++## Usage Examples++### Example 1: Multiple interpolators++Let's define a basic string interpolation quasiquoter that++- interpolates any Haskell expressions using `{}` and+- shows the first 10 elements of a list using `@{}`:++```hs+i = interpolateQQ simpleConfig+  { handlers = [ simpleInterpolator {prefix = ""}+               , (applyInterpolator [|show . take 10|]) {prefix = "@"} ] }+```++```hs+>>> [i|2^10 = {show (2 ^ 10)}. Some Fibonacci numbers: @{let x = (\fibs -> 1 : 1 : zipWith (+) fibs (tail fibs)) x in x}.|]+"2^10 = 1024. Some Fibonacci numbers: [1,1,2,3,5,8,13,21,34,55]."+```++### Example 2: SQL substitution++Now for a more complicated example; defining an SQL query quasiquoter that prevents SQL injection.++We can achieve this by replacing expressions between `{}` with `?` and accumulating the actual expression in the first output of the [`Interpolator`](https://hackage.haskell.org/package/custom-interpolation/docs/CustomInterpolation.html#t:Interpolator) handler.+This allows us to then apply some SQL library function to the string and the accumulated expressions which takes care of the actual substitution.++```hs+import Language.Haskell.TH (appE, listE, Exp, Q)++-- Need an existential type to wrap the differently typed interpolated expressions+data SQLData = forall a. Show a => SQLData a+instance Show SQLData where show (SQLData x) = show x++-- Dummy function that would normally run the query+runSQL sql ds = (sql, ds)++-- The quasiquoter itself+consumeInterpolated :: ([Q Exp], Q Exp) -> Q Exp+consumeInterpolated (exprs, strExpr) = appE (appE [|runSQL|] strExpr) (listE (map (appE [|SQLData|]) exprs))++sql = interpolateQQ defaultConfig+    { finalize = consumeInterpolated,+      handlers = [simpleInterpolator { handler = (\q -> (q, [|"?"|])) }]+    }+```++```hs+>>> [sql|SELECT * FROM user WHERE id = {(11 ^ 5)} AND lastName = {"Smith"}|]+("SELECT * FROM user WHERE id = ? AND lastName = ?",[161051,"Smith"])+```++## Acknowledgements++The [`CustomInterpolation.Parser`](https://github.com/ruby0b/custom-interpolation/blob/main/src/CustomInterpolation/Parser.hs) module was derived from the [`here` package](https://github.com/tmhedberg/here).

@@ -0,0 +1,38 @@+{- |+This module reexports all the relevant tools of the @custom-interpolation@ package.+-}+module CustomInterpolation (+  -- * Quickstart+  -- $quickstart++  -- * Template Haskell+  --+  -- | The main entry points of the library. Use these to build your template haskell functions and quasiquoters.+  interpolateQQ,+  interpolate,++  -- * Configuration+  InterpolationConfig (..),+  simpleConfig,+  defaultConfig,++  -- * Interpolators+  Interpolator (..),+  Prefix,++  -- ** Interpolator Helpers+  --+  -- | Constructors for common 'Interpolator's.+  simpleInterpolator,+  applyInterpolator,++  -- ** Brackets+  Brackets (..),+  curlyBrackets,+  roundBrackets,+  squareBrackets,+  angleBrackets,+) where++import CustomInterpolation.Config+import CustomInterpolation.TH

@@ -0,0 +1,79 @@+module CustomInterpolation.Config where++import Data.Default.Class (Default (..))+import Language.Haskell.TH (Exp, Q, appE)++{- $setup+=== __ __+>>> import CustomInterpolation -- doctest setup, ignore this+-}++-- | Rules for interpolating a string.+data InterpolationConfig a = InterpolationConfig+  { -- | The 'Interpolator's that handle interpolated expressions.+    handlers :: [Interpolator a],+    -- | Used for complex 'Interpolator's that return additional values. Reduces these accumulated values to a single @'Q' 'Exp'@.+    finalize :: ([a], Q Exp) -> Q Exp,+    -- | Handle backslash-escaped characters (can be used to add special characters like \n).+    escape :: Char -> Char+  }++{- | Type-restricted simple version of 'defaultConfig'.+Use this if you just want to substitute interpolated segments with a string expression.+-}+simpleConfig :: InterpolationConfig ()+simpleConfig = defaultConfig++{- | Default 'InterpolationConfig'.+Has no 'handlers', 'finalize' ignores any extra values returned when interpolating and 'escape' does nothing.+-}+defaultConfig :: InterpolationConfig a+defaultConfig = InterpolationConfig {handlers = [], finalize = snd, escape = id}++-- | @'def' = 'defaultConfig'@+instance Default (InterpolationConfig a) where+  def = defaultConfig++data Interpolator a = Interpolator+  { -- | InterpolationConfig prefix, a prefix of e.g. @"$"@ will lead to anything inside @${expr}@ being interpolated (assuming 'curlyBrackets').+    prefix :: Prefix,+    -- | Transforms the interpolated string segment into a string expression and some value of type @a@ to accumulate.+    handler :: Q Exp -> (a, Q Exp),+    -- | The brackets to use for the interpolation syntax.+    brackets :: Brackets+  }++type Prefix = String++data Brackets = Brackets {opening :: Char, closing :: Char} deriving (Show)++-- | @{}@+curlyBrackets :: Brackets+curlyBrackets = Brackets '{' '}'++-- | @()@+roundBrackets :: Brackets+roundBrackets = Brackets '(' ')'++-- | @[]@+squareBrackets :: Brackets+squareBrackets = Brackets '[' ']'++-- | @<>@+angleBrackets :: Brackets+angleBrackets = Brackets '<' '>'++{- | Default 'Interpolator'.+Inserts the interpolated expression as is and uses 'curlyBrackets' with no 'prefix'.+-}+simpleInterpolator :: Interpolator ()+simpleInterpolator = Interpolator {prefix = "", handler = pure, brackets = curlyBrackets}++{- | Create an 'Interpolator' that applies a quoted function to the interpolated expression. Uses 'curlyBrackets' and no 'prefix'.++==== __Example__+>>> $(interpolate (simpleConfig {handlers = [applyInterpolator [|show . (^ 2)|]]}) "two squared equals {2}")+"two squared equals 4"+-}+applyInterpolator :: Monoid a => Q Exp -> Interpolator a+applyInterpolator funExp = simpleInterpolator {handler = pure . appE funExp}

@@ -0,0 +1,133 @@+module CustomInterpolation.Parser where++import Control.Monad.State (evalStateT, get, lift, modify, unless)+import CustomInterpolation.Config (Brackets (..), Interpolator (..))+import Data.Char (isDigit, isLetter)+import Data.Foldable (asum)+import Data.Functor (($>))+import Language.Haskell.Meta (parseExp)+import Language.Haskell.TH (Exp, Q)+import Text.Parsec (+  ParseError,+  State (statePos),+  anyChar,+  between,+  char,+  eof,+  getInput,+  incSourceColumn,+  lookAhead,+  manyTill,+  noneOf,+  parse,+  setInput,+  string,+  try,+  updateParserState,+  (<|>),+ )+import Text.Parsec.String (Parser)++-- | The raw segments the parser will cut the quasi-quoted string into+data StringPart a = Lit String | Esc Char | Anti (Interpolator a) (Q Exp)++data HsChompState = HsChompState+  { quoteState :: QuoteState,+    braceCt :: Int,+    consumed :: String,+    prevCharWasIdentChar :: Bool+  }+  deriving (Show)++data QuoteState = None | Single EscapeState | Double EscapeState deriving (Eq, Ord, Show)++data EscapeState = Escaped | Unescaped deriving (Bounded, Enum, Eq, Ord, Show)++parseInterpolations :: [Interpolator a] -> String -> Either ParseError [StringPart a]+parseInterpolations interps = parse (pInterp interps) ""++pInterp :: [Interpolator a] -> Parser [StringPart a]+pInterp interps = manyTill (pStringPart interps) eof++pStringPart :: [Interpolator a] -> Parser (StringPart a)+pStringPart interps = asum (map pAnti interps) <|> pEsc <|> pLit interps++pAnti :: Interpolator a -> Parser (StringPart a)+pAnti interp =+  Anti interp . parseExpQ+    <$> between+      (try (pAntiOpen interp))+      (pAntiClose interp)+      (pUntilUnbalancedCloseBracket interp)++-- | 'parseExp' but in the 'Q' Monad ('fail's on parsing errors).+parseExpQ :: String -> Q Exp+parseExpQ = either (fail . ("Error while parsing Haskell expression:\n" <>)) pure . parseExp++pAntiOpen :: Interpolator a -> Parser String+pAntiOpen Interpolator {prefix, brackets} = string (prefix ++ [opening brackets])++pAntiClose :: Interpolator a -> Parser String+pAntiClose Interpolator {brackets} = string [closing brackets]++pUntilUnbalancedCloseBracket :: Interpolator a -> Parser String+pUntilUnbalancedCloseBracket Interpolator {brackets = Brackets {opening, closing}} =+  evalStateT go $ HsChompState None 0 "" False+  where+    go = do+      c <- lift anyChar+      modify $ \st@HsChompState {consumed} -> st {consumed = c : consumed}+      HsChompState {..} <- get+      let next = setIdentifierCharState c *> go+      case quoteState of+        None ->+          if+              | c == opening -> incBraceCt 1 *> next+              | c == closing ->+                if braceCt > 0+                  then incBraceCt (-1) *> next+                  else stepBack $> reverse (tail consumed)+              | c == '\'' ->+                unless prevCharWasIdentChar (setQuoteState $ Single Unescaped)+                  *> next+              | c == '"' -> setQuoteState (Double Unescaped) *> next+              | otherwise -> next+        Single Unescaped -> do+          case c of+            '\\' -> setQuoteState (Single Escaped)+            '\'' -> setQuoteState None+            _ -> pure ()+          next+        Single Escaped -> setQuoteState (Single Unescaped) *> next+        Double Unescaped -> do+          case c of+            '\\' -> setQuoteState (Double Escaped)+            '"' -> setQuoteState None+            _ -> pure ()+          next+        Double Escaped -> setQuoteState (Double Unescaped) *> next+    stepBack =+      lift $+        updateParserState+          (\s -> s {statePos = incSourceColumn (statePos s) (-1)})+          *> getInput+          >>= setInput . (closing :)+    incBraceCt n = modify $ \st@HsChompState {braceCt} ->+      st {braceCt = braceCt + n}+    setQuoteState qs = modify $ \st -> st {quoteState = qs}+    setIdentifierCharState c = modify $ \st ->+      st+        { prevCharWasIdentChar = or [isLetter c, isDigit c, c == '_', c == '\'']+        }++pEsc :: Parser (StringPart a)+pEsc = Esc <$> (char '\\' *> anyChar)++pLit :: [Interpolator a] -> Parser (StringPart a)+pLit prefixes =+  Lit+    <$> ( try (litCharTill $ try $ asum (map (lookAhead . pAntiOpen) prefixes) <|> lookAhead (string "\\"))+            <|> litCharTill eof+        )+  where+    litCharTill = manyTill $ noneOf ['\\']

@@ -0,0 +1,44 @@+module CustomInterpolation.TH where++import CustomInterpolation.Config (InterpolationConfig (..), Interpolator (..))+import CustomInterpolation.Parser (StringPart (..), parseInterpolations)+import Language.Haskell.TH (Exp, Q, appE, listE)+import Language.Haskell.TH.Quote (QuasiQuoter (..))+import Text.Parsec (ParseError)++-- | Create a new 'QuasiQuoter' that interpolates strings as specified by the given 'InterpolationConfig'.+interpolateQQ :: InterpolationConfig a -> QuasiQuoter+interpolateQQ interpolation =+  QuasiQuoter+    { quoteExp = interpolate interpolation,+      quotePat = error "not used",+      quoteType = error "not used",+      quoteDec = error "not used"+    }++-- | Interpolate a string as specified by the given 'InterpolationConfig'.+interpolate :: InterpolationConfig a -> String -> Q Exp+interpolate defaultConfig@InterpolationConfig {handlers, finalize} str = do+  res <- either (parsingError str) (pure . concatParts defaultConfig) (parseInterpolations handlers str)+  finalize res++{- | Concatenate the literals and interpolated parts of a list of 'StringPart's.+The interpolations may also each return some value which gets accumulated as a list in the first output.+-}+concatParts :: InterpolationConfig a -> [StringPart a] -> ([a], Q Exp)+concatParts InterpolationConfig {escape} ps = (otherData, concatenatedE)+  where+    concatenatedE = appE [|concat|] $ listE stringListE+    (otherData, stringListE) = foldr step ([], []) ps+    step subExpr (ds, qs) = case subExpr of+      Lit str -> (ds, [|str|] : qs)+      Esc c -> let c' = escape c in (ds, [|[c']|] : qs)+      Anti Interpolator {handler} expr -> (\(d, q) -> (d : ds, q : qs)) $ handler expr++parsingError :: String -> ParseError -> Q a+parsingError expStr parseError =+  error $+    "Failed to parse interpolated expression in string: "+      <> expStr+      <> "\n"+      <> show parseError

@@ -0,0 +1,7 @@+module Main where++import Test.DocTest (mainFromCabal)+import System.Environment (getArgs)++main :: IO ()+main = mainFromCabal "custom-interpolation" =<< getArgs

@@ -0,0 +1,52 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++module Main where++import Data.Char (toUpper)+import QQ+import System.Exit (exitFailure, exitSuccess)++test :: String -> String -> IO Bool+test actual expected = do+  putStrLn $ "-- Expecting: \"" <> expected <> "\""+  putStrLn actual+  if expected == actual+    then do+      putStrLn "-- ^ Test passed.\n"+      return True+    else do+      putStrLn "-- ^ ERROR: NOT EQUAL!\n"+      return False++runTests :: [(String, String)] -> IO ()+runTests tests = do+  results <- mapM (uncurry test) tests+  if and results+    then exitSuccess+    else exitFailure++main :: IO ()+main = do+  runTests+    [ ( [itest|Escaped dollar sign: \$|],+        "Escaped dollar sign: $"+      ),+      ( [itest|Quoted expression containing an escaped closing brace evaluating to: ${case () of {() -> map toUpper ("hello world" ++ ['!'])}}|],+        "Quoted expression containing an escaped closing brace evaluating to: HELLO WORLD!"+      ),+      ( [itest|Quoted expressions evaluating to: ${map toUpper "hello"} and ++{41 :: Int}|],+        "Quoted expressions evaluating to: HELLO and 42"+      ),+      let x = 42.3 :: Double+       in ( [iManyBrackets|$<"<" <> "<" <> ">" <> ['>'] <> "<>>"> $(3 * (x - 6) + read "(7)") [[1, 2 ..] :: [Int]] {"hello"}|],+            "<<>><>> " ++ show (3 * (x - 6) + 7) ++ " [1,2,3,4] HELLO"+          ),+      -- readme examples+      ( [i|2^10 = {show (2 ^ 10)}. Some Fibonacci numbers: @{let x = (\fibs -> 1 : 1 : zipWith (+) fibs (tail fibs)) x in x}.|],+        "2^10 = 1024. Some Fibonacci numbers: [1,1,2,3,5,8,13,21,34,55]."+      ),+      ( show [sql|SELECT * FROM user WHERE id = {(11 ^ 5)} AND lastName = {"Smith"}|],+        "(\"SELECT * FROM user WHERE id = ? AND lastName = ?\",[161051,\"Smith\"])"+      )+    ]

@@ -0,0 +1,61 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}++module QQ where++import CustomInterpolation+import Data.Char+import Language.Haskell.TH (appE, listE, Exp, Q)+import Language.Haskell.TH.Quote (QuasiQuoter (..))++itest :: QuasiQuoter+itest =+  interpolateQQ+    simpleConfig+      { handlers =+          [ simpleInterpolator {prefix = "$"},+            (applyInterpolator [|show . (+ 1)|]) {prefix = "++"}+          ]+      }++iManyBrackets :: QuasiQuoter+iManyBrackets =+  interpolateQQ+    simpleConfig+      { handlers =+          [ (applyInterpolator [|show|]) {prefix = "$", brackets = roundBrackets},+            simpleInterpolator {prefix = "$", brackets = angleBrackets},+            (applyInterpolator [|show . take 4|]) {brackets = squareBrackets},+            (applyInterpolator [|map toUpper|]) {brackets = curlyBrackets}+          ]+      }++-- readme stuff+i =+  interpolateQQ+    simpleConfig+      { handlers =+          [ simpleInterpolator {prefix = ""},+            (applyInterpolator [|show . take 10|]) {prefix = "@"}+          ]+      }++-- Need an existential type to wrap the differently typed interpolated expression+data SQLData = forall a. Show a => SQLData a++instance Show SQLData where show (SQLData x) = show x++-- Dummy function that would normally run the query+runSQL sql' ds = (sql', ds)++-- The quasiquoter itself+consumeInterpolated :: ([Q Exp], Q Exp) -> Q Exp+consumeInterpolated (exprs, strExpr) = appE (appE [|runSQL|] strExpr) (listE (map (appE [|SQLData|]) exprs))++sql =+  interpolateQQ+    defaultConfig+      { finalize = consumeInterpolated,+        handlers = [simpleInterpolator {handler = (\q -> (q, [|"?"|]))}]+      }