string-interpolate 0.3.0.2 → 0.3.1.0
raw patch · 10 files changed
+602/−294 lines, 10 files
Files
- CHANGELOG.md +5/−0
- README.md +36/−0
- src/lib/Data/String/Interpolate.hs +177/−209
- src/lib/Data/String/Interpolate/Conversion.hs +5/−5
- src/lib/Data/String/Interpolate/Lines.hs +105/−0
- src/lib/Data/String/Interpolate/Parse.hs +89/−58
- src/lib/Data/String/Interpolate/Types.hs +15/−0
- src/lib/Data/String/Interpolate/Whitespace.hs +34/−0
- string-interpolate.cabal +6/−4
- test/spec.hs +130/−18
CHANGELOG.md view
@@ -2,6 +2,11 @@ ## Unreleased +## v0.3.1.0 (2021-02-12)+++ Added variant interpolators, `__i'E`, `__i'L`, `iii'E`, `iii'L`, that handle+ surrounding newlines in a different way based on suffix.+ ## v0.3.0.2 (2020-10-01) + Removed upper bounds on `base16-bytestring`. Safe to do so now that
README.md view
@@ -30,6 +30,14 @@ collapse into a single line, use `iii`. If you need to remove extra indentation but keep linebreaks, use `__i`. +If you need even *more* specific functionality in how you handle whitespace,+there are variants of `__i` and `iii` with different behavior for+surrounding newlines. These are suffixed by either `'E` or `'L` depending+on what behavior you need. For instance, `__i'E` will remove extra indentation+from its body, but will leave any surrounding newlines intact. `iii'L` will+collapse its body into a single line, and collapse any surrounding newlines+at the beginning/end into a single newline.+ ## Unicode handling **string-interpolate** handles converting to/from Unicode when converting@@ -175,6 +183,34 @@ * `iii`: Look at the i's as individual lines which have been collapsed into a single line * `__i`: Look at the i as being indented++In addition, there are variants of `iii` and `__i`, desginated by a letter+suffix. For instance, `__i'L` will reduce indentation, while collapsing+any surrounding newlines into a single newline.++```haskell+λ> :{+ | [__i'L|+ |+ | id :: a -> a+ | id x = y+ | where y = x+ |+ | |] :: String+ | :}+>>> "\nid :: a -> a\nid x = y\n where y = x\n"+```++Currently there are two variant suffixes, `'E` and `'L`'++* `'E`: Leave any surrounding newlines intact. To remember what this does, look+ visually at the capital E; the multiple horizontal lines suggests multiple+ newlines.+* `'L`: Collapse any surrounding newlines into a single newline. To remember what+ this does, look visually at the capital L; the single horizontal line suggests+ a single newline.++Check the Haddock documentation for all the available variants. Backslashes are handled exactly the same way they are in normal Haskell strings. If you need to put a literal `#{` into your string, prefix the pound symbol with
src/lib/Data/String/Interpolate.hs view
@@ -1,7 +1,7 @@ -- | -- Module : Data.String.Interpolate -- Description : Unicode-aware string interpolation that handles all textual types.--- Copyright : (c) William Yao, 2019-2020+-- Copyright : (c) William Yao, 2019-2021 -- License : BSD-3 -- Maintainer : williamyaoh@gmail.com -- Stability : experimental@@ -39,28 +39,29 @@ -- > |] :: String -- > >>> "\nName: Tatiana\nAge: 33\n" --+-- There are also variants of `__i' and `iii' which have different behavior+-- for surrounding newlines.+-- -- See the README at <https://gitlab.com/williamyaoh/string-interpolate/blob/master/README.md> -- for more details and examples. {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE CPP #-} module Data.String.Interpolate- ( i, __i, iii )+ (+ -- * Basic interpolators+ i, __i, iii+ -- * Interpolator variants for newline handling+ , __i'E, __i'L, iii'E, iii'L+ ) where -import Prelude hiding ( fail )+import Control.Monad ( (<=<) ) -import Data.Char ( isSpace )+import Data.Foldable ( traverse_ )+import Data.List ( intercalate ) import Data.Proxy-import Data.Function ( on, (&) )-import Data.Semigroup ( Min(..) )-import Data.List-import Data.List.Split -import Control.Monad.Fail- import qualified Language.Haskell.Exts.Extension as Ext import Language.Haskell.Exts.Parser ( ParseMode(..), ParseResult(..), defaultParseMode, parseExpWithMode )@@ -69,26 +70,88 @@ import Language.Haskell.TH.Quote ( QuasiQuoter(..) ) import Data.String.Interpolate.Conversion ( build, finalize, interpolate, ofString )-import Data.String.Interpolate.Parse ( InterpSegment(..), dosToUnix, parseInterpSegments ) ------------------------ QUASIQUOTERS---------------------+import Data.String.Interpolate.Lines ( IndentWarning(..), Mindent(..), handleIndents )+import Data.String.Interpolate.Parse+import Data.String.Interpolate.Types+import Data.String.Interpolate.Whitespace ( collapseWhitespace ) +data OutputSegment+ = OfString String+ | Interpolate String+ -- |+-- Singleton list of the first element, if there is one.+fore :: [a] -> [a]+fore [] = []+fore (x:_) = [x]++-- |+-- Singleton list of the last element, if there is one.+aft :: [a] -> [a]+aft [] = []+aft [x] = [x]+aft (_:xs) = aft xs++collapseStrings :: [OutputSegment] -> [OutputSegment]+collapseStrings [] = []+collapseStrings (OfString s1 : OfString s2 : rest) =+ collapseStrings ((OfString $ s1 ++ s2) : rest)+collapseStrings (other : rest) = other : collapseStrings rest++renderLines :: Lines -> [OutputSegment]+renderLines = intercalate [OfString "\n"] . fmap renderLine+ where+ renderLine :: Line -> [OutputSegment]+ renderLine = fmap renderSegment++ renderSegment :: InterpSegment -> OutputSegment+ renderSegment (Expression expr) = Interpolate expr+ renderSegment (Verbatim str) = OfString str+ renderSegment (Spaces n) = OfString (replicate n ' ')+ renderSegment (Tabs n) = OfString (replicate n '\t')++-- |+-- Produce the final Template Haskell expression. Handles collapsing+-- intermediate strings.+outputToExp :: [OutputSegment] -> Q Exp+outputToExp segs = [|finalize Proxy $(go (collapseStrings segs))|]+ where+ go :: [OutputSegment] -> Q Exp+ go = foldr+ (\seg qexp -> [|build Proxy $(renderExp seg) $(qexp)|])+ [|ofString Proxy ""|]++ renderExp :: OutputSegment -> Q Exp+ renderExp (OfString str) = [|ofString Proxy str|]+ renderExp (Interpolate expr) = [|interpolate Proxy $(reifyExpression expr)|]++type Interpolator = ParseOutput -> Q Lines++-- |+-- Fundamentally all our interpolators are, are functions from the parse+-- input to some transformed lines. The rest is just boilerplate.+interpolator :: String -> Interpolator -> QuasiQuoter+interpolator qqName transform = QuasiQuoter+ { quoteExp =+ outputToExp+ <=< (pure . renderLines)+ <=< transform+ <=< unwrap qqName . parseInput . dosToUnix+ , quotePat = const $ errQQType qqName "pattern"+ , quoteType = const $ errQQType qqName "type"+ , quoteDec = const $ errQQType qqName "declaration"+ }++-- | -- The basic, no-frills interpolator. Will interpolate anything you wrap in @#{}@, and -- otherwise leaves what you write alone. i :: QuasiQuoter-i = QuasiQuoter- { quoteExp = toExp . parseInterpSegments . dosToUnix- , quotePat = const $ errQQType "i" "pattern"- , quoteType = const $ errQQType "i" "type"- , quoteDec = const $ errQQType "i" "declaration"- }- where toExp :: Either String [InterpSegment] -> Q Exp- toExp parseResult = case parseResult of- Left msg -> errQQ "i" msg- Right segs -> interpToExp segs+i = interpolator "i" transform+ where+ transform :: Interpolator+ transform (ParseOutput header content footer) =+ pure $! mconcat [header, content, footer] -- | -- An interpolator that handles indentation. Will interpolate anything you wrap in @#{}@,@@ -103,25 +166,45 @@ -- -- There is no extra performance penalty for using @__i@. __i :: QuasiQuoter-__i = QuasiQuoter- { quoteExp = toExp . parseInterpSegments . dosToUnix- , quotePat = const $ errQQType "__i" "pattern"- , quoteType = const $ errQQType "__i" "type"- , quoteDec = const $ errQQType "__i" "declaration"- }- where toExp :: Either String [InterpSegment] -> Q Exp- toExp parseResult = case parseResult of- Left msg -> errQQ "__i" msg- Right segs -> unindent segs >>= interpToExp+__i = interpolator "__i" transform+ where+ transform :: Interpolator+ transform (ParseOutput _ content _) = do+ let (warns, withoutIndent) = handleIndents content+ traverse_ reportIndentWarning warns+ pure $! withoutIndent - unindent :: [InterpSegment] -> Q [InterpSegment]- unindent segs =- let lines = interpLines segs- mindent = mindentation lines- in warnMixedIndent mindent lines >>- (pure $! (interpUnlines . removeBlanksAround . reduceIndents mindent) lines)+-- |+-- Like `__i', but leaves any surrounding newlines intact.+--+-- The way to remember which is which is to look at the suffix character;+-- the multiple horizontal lines of the capital @E@ suggests multiple+-- textual lines.+__i'E :: QuasiQuoter+__i'E = interpolator "__i'E" transform+ where+ transform :: Interpolator+ transform (ParseOutput header content footer) = do+ let (warns, withoutIndent) = handleIndents content+ traverse_ reportIndentWarning warns+ pure $! mconcat [header, withoutIndent, footer] -- |+-- Like `__i', but collapses any surrounding newlines into a single newline.+--+-- The way to remember which is which is to look at the suffix character;+-- the single horizontal line of the capital @L@ suggests that it leaves+-- only a single newline.+__i'L :: QuasiQuoter+__i'L = interpolator "__i'L" transform+ where+ transform :: Interpolator+ transform (ParseOutput header content footer) = do+ let (warns, withoutIndent) = handleIndents content+ traverse_ reportIndentWarning warns+ pure $! mconcat [aft header, withoutIndent, fore footer]++-- | -- An interpolator that strips excess whitespace. Will collapse any sequences of -- multiple spaces or whitespace into a single space, putting the output onto a -- single line with surrounding whitespace removed.@@ -131,185 +214,59 @@ -- -- There is no extra performance penalty for using @iii@. iii :: QuasiQuoter-iii = QuasiQuoter- { quoteExp = toExp . parseInterpSegments . dosToUnix- , quotePat = const $ errQQType "iii" "pattern"- , quoteType = const $ errQQType "iii" "type"- , quoteDec = const $ errQQType "iii" "declaration"- }- where toExp :: Either String [InterpSegment] -> Q Exp- toExp parseResult = case parseResult of- Left msg -> errQQ "iii" msg- Right segs -> collapse segs-- collapse :: [InterpSegment] -> Q Exp- collapse segs = renderOutput segs- & collapseStrings- & fmap outputCollapseWS- & removeWSAround- & outputToExp-- outputCollapseWS :: OutputSegment -> OutputSegment- outputCollapseWS (OfString str) = OfString $ collapseWhitespace str- outputCollapseWS other = other------------------------- STRIPPING INDENTATION-----------------------interpLines :: [InterpSegment] -> [[InterpSegment]]-interpLines = split $ dropDelims $ whenElt (== Newline)--interpUnlines :: [[InterpSegment]] -> [InterpSegment]-interpUnlines = intercalate [Newline]--data Mindent = UsesSpaces Int | UsesTabs Int--mindentation :: [[InterpSegment]] -> Mindent-mindentation lines =- let nonblank = filter (not . blankLine) lines- withIndent = find (\case { Spaces _ : _ -> True; Tabs _ : _ -> True; _ -> False }) nonblank- in case withIndent of- Nothing -> UsesSpaces 0- Just (Spaces _ : _) ->- maybe (UsesSpaces 0) UsesSpaces $- findMinIndent (\case { Spaces n -> Just n; _ -> Nothing }) Nothing nonblank- Just (Tabs _ : _) ->- maybe (UsesSpaces 0) UsesTabs $- findMinIndent (\case { Tabs n -> Just n; _ -> Nothing }) Nothing nonblank- Just _ -> UsesSpaces 0- where findMinIndent :: (InterpSegment -> Maybe Int) -> Maybe Int -> [[InterpSegment]] -> Maybe Int- findMinIndent _ found [] = found- findMinIndent f found ((seg:_):rest) =- findMinIndent f (getMin <$> on mappend (fmap Min) (f seg) found) rest- findMinIndent f found ([]:rest) = findMinIndent f found rest--warnMixedIndent :: Mindent -> [[InterpSegment]] -> Q ()-warnMixedIndent mindent = go 1 . removeBlanksAround- where go :: Int -> [[InterpSegment]] -> Q ()- go _lineno [] = pure ()- go lineno (line:lines) = do- let ind = indentation line- case (mindent, any isSpaces ind, any isTabs ind) of- (UsesSpaces _, _, True) ->- reportWarning $- "splice line " ++ show lineno ++ ": found TAB character in indentation"- (UsesTabs _, True, _) ->- reportWarning $- "splice line " ++ show lineno ++ ": found SPACE character in indentation"- _ -> pure ()- go (lineno+1) lines-- indentation :: [InterpSegment] -> [InterpSegment]- indentation =- takeWhile (\case { Spaces _ -> True; Tabs _ -> True; _ -> False })-- isSpaces :: InterpSegment -> Bool- isSpaces (Spaces n) = n > 0- isSpaces _ = False-- isTabs :: InterpSegment -> Bool- isTabs (Tabs n) = n > 0- isTabs _ = False--reduceIndents :: Mindent -> [[InterpSegment]] -> [[InterpSegment]]-reduceIndents _ [] = []-reduceIndents i@(UsesSpaces indent) ((Spaces n:line):rest) =- (Spaces (n-indent):line) : reduceIndents i rest-reduceIndents i@(UsesTabs indent) ((Tabs n:line):rest) =- (Tabs (n-indent):line) : reduceIndents i rest-reduceIndents i (line:rest) = line : reduceIndents i rest--removeBlanksAround :: [[InterpSegment]] -> [[InterpSegment]]-removeBlanksAround =- reverse- . dropWhile blankLine- . reverse- . dropWhile blankLine--blankLine :: [InterpSegment] -> Bool-blankLine [] = True-blankLine (Expression _ : _) = False-blankLine (Newline : rest) = blankLine rest-blankLine (Spaces _ : rest) = blankLine rest-blankLine (Tabs _ : rest) = blankLine rest-blankLine (Verbatim str:rest) = blank str && blankLine rest- where blank :: String -> Bool- blank = all (\c -> elem c [' ', '\t'])------------------------- COLLAPSING WHITESPACE-----------------------byWhitespace :: String -> [String]-byWhitespace = split $ condense $ whenElt isSpace--collapseWhitespace :: String -> String-collapseWhitespace =- foldMap (\s -> if all isSpace s && not (null s) then " " else s)- . byWhitespace---- Frankly this is a really ugly function; it feels too specific and like--- we're making too many assumptions. But we need to strip that whitespace...-removeWSAround :: [OutputSegment] -> [OutputSegment]-removeWSAround =- transformLeading (dropWhile isSpace)- . reverse- . transformLeading (reverse . dropWhile isSpace . reverse)- . reverse- where transformLeading :: (String -> String) -> [OutputSegment] -> [OutputSegment]- transformLeading _ [] = []- transformLeading f (OfString str:rest) = OfString (f str) : rest- transformLeading _ other = other------------------------- CONVERTING EXPRS-----------------------interpToExp :: [InterpSegment] -> Q Exp-interpToExp = outputToExp . collapseStrings . renderOutput--outputToExp :: [OutputSegment] -> Q Exp-outputToExp segs = [|finalize Proxy $(go segs)|]- where renderExp :: OutputSegment -> Q Exp- renderExp (OfString str) = [|ofString Proxy str|]- renderExp (Interpolate expr) = [|interpolate Proxy $(reifyExpression expr)|]-- go :: [OutputSegment] -> Q Exp- go = foldr- (\seg qexp -> [|build Proxy $(renderExp seg) $(qexp)|])- [|ofString Proxy ""|]--data OutputSegment- = OfString String- | Interpolate String+iii = interpolator "iii" transform+ where+ transform :: Interpolator+ transform (ParseOutput _ content _) =+ pure $! [collapseWhitespace content] -collapseStrings :: [OutputSegment] -> [OutputSegment]-collapseStrings [] = []-collapseStrings (OfString s1 : OfString s2 : rest) =- collapseStrings ((OfString $ s1 ++ s2) : rest)-collapseStrings (other : rest) = other : collapseStrings rest+-- |+-- Like `iii', but leaves any surrounding newlines intact.+--+-- The way to remember which is which is to look at the suffix character;+-- the multiple horizontal lines of the capital @E@ suggests multiple+-- textual lines.+iii'E :: QuasiQuoter+iii'E = interpolator "iii'E" transform+ where+ transform :: Interpolator+ transform (ParseOutput header content footer) =+ let collapsed = collapseWhitespace content+ in pure $! mconcat [header, [collapsed], footer] -renderOutput :: [InterpSegment] -> [OutputSegment]-renderOutput = fmap renderSegment- where renderSegment :: InterpSegment -> OutputSegment- renderSegment (Verbatim str) = OfString str- renderSegment Newline = OfString "\n"- renderSegment (Spaces n) = OfString (replicate n ' ')- renderSegment (Tabs n) = OfString (replicate n '\t')- renderSegment (Expression str) = Interpolate str+-- |+-- Like `iii', but collapses any surrounding newlines into a single newline.+--+-- The way to remember which is which is to look at the suffix character;+-- the single horizontal line of the capital @L@ suggests that it leaves+-- only a single newline.+iii'L :: QuasiQuoter+iii'L = interpolator "iii'L" transform+ where+ transform :: Interpolator+ transform (ParseOutput header content footer) =+ let collapsed = collapseWhitespace content+ in pure $! mconcat [aft header, [collapsed], fore footer] -------------------- -- UTILITIES -------------------- -errQQ :: MonadFail m => String -> String -> m a+errQQ :: String -> String -> Q a errQQ qqName msg = fail ("Data.String.Interpolate." ++ qqName ++ ": " ++ msg) -errQQType :: MonadFail m => String -> String -> m a+errQQType :: String -> String -> Q a errQQType qqName = errQQ qqName . ("This QuasiQuoter cannot be used as a " ++) +unwrap :: String -> Either String a -> Q a+unwrap = unwrapWith id++unwrapWith :: (err -> String) -> String -> Either err a -> Q a+unwrapWith f qqName e = case e of+ Left err -> errQQ qqName $ f err+ Right x -> pure x+ reifyExpression :: String -> Q Exp reifyExpression s = do -- We want to explicitly use whatever extensions are enabled in current module@@ -319,3 +276,14 @@ ParseFailed _ err -> fail $ "Data.String.Interpolate.i: got error: '" ++ err ++ "' while parsing expression: " ++ s ParseOk e -> pure (toExp e)++reportIndentWarning :: IndentWarning -> Q ()+reportIndentWarning (IndentWarning line base) = do+ let+ header = case base of+ UsesSpaces _ -> "found TAB in SPACE-based indentation on this line:"+ UsesTabs _ -> "found SPACE in TAB-based indentation on this line:"+ message =+ header <> "\n\n"+ <> " " <> line <> "\n"+ reportWarning message
src/lib/Data/String/Interpolate/Conversion.hs view
@@ -12,9 +12,9 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PackageImports #-}+{-# LANGUAGE Strict #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE Strict #-} module Data.String.Interpolate.Conversion ( IsCustomSink, InterpSink(..), Interpolatable(..)@@ -22,7 +22,7 @@ ) where -import Data.String ( IsString, fromString )+import Data.String ( IsString, fromString ) import qualified Data.ByteString as B import qualified Data.ByteString.Builder as LB@@ -34,15 +34,15 @@ import qualified "utf8-string" Data.ByteString.Lazy.UTF8 as LUTF8 import qualified "utf8-string" Data.ByteString.UTF8 as UTF8 +import Data.String.Interpolate.Conversion.ByteStringSink () import Data.String.Interpolate.Conversion.Classes import Data.String.Interpolate.Conversion.Encoding-import Data.String.Interpolate.Conversion.TextSink ()-import Data.String.Interpolate.Conversion.ByteStringSink ()+import Data.String.Interpolate.Conversion.TextSink () -- Remove some imports above GHC 8.8.X #if MIN_VERSION_base(4,13,0) #else-import "base" Text.Show ( ShowS, showChar, showString )+import "base" Text.Show ( ShowS, showChar, showString ) #endif instance (IsCustomSink str ~ 'False, IsString str) => InterpSink 'False str where
+ src/lib/Data/String/Interpolate/Lines.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE LambdaCase #-}++module Data.String.Interpolate.Lines where++import Data.Function ( on )+import Data.List ( find )+import Data.Semigroup ( Min(..) )++import Data.String.Interpolate.Types++isBlankLine :: [InterpSegment] -> Bool+isBlankLine [] = True+isBlankLine (Expression _ : _) = False+isBlankLine (Spaces _ : rest) = isBlankLine rest+isBlankLine (Tabs _ : rest) = isBlankLine rest+isBlankLine (Verbatim str:rest) = blank str && isBlankLine rest+ where+ blank :: String -> Bool+ blank = all (\c -> elem c [' ', '\t'])++-- |+-- Go the other direction, from a `Line' to the input that produced it.+displayLine :: Line -> String+displayLine = foldMap displaySegment+ where+ displaySegment :: InterpSegment -> String+ displaySegment (Expression expr) = "#{" ++ expr ++ "}"+ displaySegment (Verbatim str) = str+ -- Above case is technically not correct due to escaped characters,+ -- but for the purposes of pinpointing where in a user's interpolation+ -- a problem is, it's good enough.+ displaySegment (Spaces n) = replicate n ' '+ displaySegment (Tabs n) = replicate n '\t'++-- |+-- Remove min indentation from given lines, using the minimum indentation+-- found within the lines. Gives back warnings for mixed indentation if+-- any are found.+handleIndents :: Lines -> ([IndentWarning], Lines)+handleIndents lines =+ let mindent = mindentation lines+ in (findMixedIndents mindent lines, reduceIndents mindent lines)++data Mindent = UsesSpaces Int | UsesTabs Int++data IndentWarning = IndentWarning+ { indentLine :: String+ , indentBase :: Mindent+ }++mindentation :: Lines -> Mindent+mindentation lines =+ let+ nonblank = filter (not . isBlankLine) lines+ withIndent = find (\case { Spaces _ : _ -> True; Tabs _ : _ -> True; _ -> False }) nonblank+ in case withIndent of+ Nothing -> UsesSpaces 0+ Just (Spaces _ : _) ->+ maybe (UsesSpaces 0) UsesSpaces $+ findMinIndent (\case { Spaces n -> Just n; _ -> Nothing }) Nothing nonblank+ Just (Tabs _ : _) ->+ maybe (UsesSpaces 0) UsesTabs $+ findMinIndent (\case { Tabs n -> Just n; _ -> Nothing }) Nothing nonblank+ Just _ -> UsesSpaces 0+ where+ findMinIndent :: (InterpSegment -> Maybe Int) -> Maybe Int -> [[InterpSegment]] -> Maybe Int+ findMinIndent _ found [] = found+ findMinIndent f found ((seg:_):rest) =+ findMinIndent f (getMin <$> on mappend (fmap Min) (f seg) found) rest+ findMinIndent f found ([]:rest) = findMinIndent f found rest++reduceIndents :: Mindent -> Lines -> Lines+reduceIndents _ [] = []+reduceIndents i@(UsesSpaces indent) ((Spaces n:line):rest) =+ (Spaces (n-indent):line) : reduceIndents i rest+reduceIndents i@(UsesTabs indent) ((Tabs n:line):rest) =+ (Tabs (n-indent):line) : reduceIndents i rest+reduceIndents i (line:rest) = line : reduceIndents i rest++findMixedIndents :: Mindent -> Lines -> [IndentWarning]+findMixedIndents mindent = go+ where+ go :: [[InterpSegment]] -> [IndentWarning]+ go [] = []+ go (line:lines) = do+ let+ ind = indentation line+ warn = IndentWarning+ { indentLine = displayLine line, indentBase = mindent }+ case (mindent, any isSpaces ind, any isTabs ind) of+ (UsesSpaces _, _, True) -> warn : go lines+ (UsesTabs _, True, _) -> warn : go lines+ _ -> go lines++ indentation :: [InterpSegment] -> [InterpSegment]+ indentation =+ takeWhile (\case { Spaces _ -> True; Tabs _ -> True; _ -> False })++ isSpaces :: InterpSegment -> Bool+ isSpaces (Spaces n) = n > 0+ isSpaces _ = False++ isTabs :: InterpSegment -> Bool+ isTabs (Tabs n) = n > 0+ isTabs _ = False
src/lib/Data/String/Interpolate/Parse.hs view
@@ -1,6 +1,6 @@ -- | -- Module : Data.String.Interpolate.Parse--- Copyright : (c) William Yao, 2019-2020+-- Copyright : (c) William Yao, 2019-2021 -- License : BSD-3 -- Maintainer : williamyaoh@gmail.com -- Stability : experimental@@ -13,18 +13,29 @@ {-# LANGUAGE PackageImports #-} module Data.String.Interpolate.Parse- ( InterpSegment(..), parseInterpSegments, dosToUnix )+ ( ParseOutput(..)+ , parseInput, parseInterpSegments+ , dosToUnix+ ) where +import "base" Data.Bifunctor import Data.Char-import qualified "base" Numeric as N+import qualified "base" Numeric as N -data InterpSegment- = Expression String- | Verbatim String- | Newline- | Spaces Int- | Tabs Int+import Data.String.Interpolate.Lines ( isBlankLine )+import Data.String.Interpolate.Types++-- |+-- Each section here is a list of lines.+--+-- "Content" here is defined by the contiguous sequence of lines begining+-- with the first non-blank line and ending with the last non-blank line+data ParseOutput = ParseOutput+ { poHeaderWS :: Lines+ , poContent :: Lines+ , poFooterWS :: Lines+ } deriving (Eq, Show) -- |@@ -32,57 +43,76 @@ -- we need to output the actual expression. -- -- Returns an error message if parsing fails.-parseInterpSegments :: String -> Either String [InterpSegment]-parseInterpSegments = switch+parseInterpSegments :: String -> Either String Lines+parseInterpSegments = switch [] -- Given how complicated this is getting, it might be worth switching -- to megaparsec instead of hand-rolling this.- where switch :: String -> Either String [InterpSegment]- switch "" = pure []- switch ('#':'{':rest) = expr rest- switch ('#':_) = Left "unescaped # symbol without interpolation brackets"- switch ('\n':rest) = newline rest -- CRLF handled by `dosToUnix'- switch (' ':rest) = spaces 1 rest- switch ('\t':rest) = tabs 1 rest- switch other = verbatim "" other+ where+ switch :: Line -> String -> Either String Lines+ switch line "" = pure [reverse line]+ switch line ('#':'{':rest) = expr line rest+ switch _ ('#':_) = Left "unescaped # symbol without interpolation brackets"+ switch line ('\n':rest) = newline line rest -- CRLF handled by `dosToUnix'+ switch line (' ':rest) = spaces line 1 rest+ switch line ('\t':rest) = tabs line 1 rest+ switch line other = verbatim line "" other - verbatim :: String -> String -> Either String [InterpSegment]- verbatim acc parsee = case parsee of- "" ->- ((Verbatim . reverse) acc :) <$> switch parsee- (c:_) | c `elem` ['#', ' ', '\t', '\n'] ->- ((Verbatim . reverse) acc :) <$> switch parsee- ('\\':'#':rest) ->- verbatim ('#':acc) rest- ('\\':_) -> case unescapeChar parsee of- (FoundChar c, rest) -> verbatim (c:acc) rest- (EscapeEmpty, rest) -> verbatim acc rest- (EscapeUnterminated, _) -> Left "unterminated backslash escape at end of string"- (UnknownEscape esc, _) -> Left ("unknown escape character: " ++ [esc])- c:cs ->- verbatim (c:acc) cs+ verbatim :: Line -> String -> String -> Either String Lines+ verbatim line acc parsee = case parsee of+ "" ->+ switch ((Verbatim . reverse) acc : line) parsee+ (c:_) | c `elem` ['#', ' ', '\t', '\n'] ->+ switch ((Verbatim . reverse) acc : line) parsee+ ('\\':'#':rest) ->+ verbatim line ('#':acc) rest+ ('\\':_) -> case unescapeChar parsee of+ (FoundChar c, rest) -> verbatim line (c:acc) rest+ (EscapeEmpty, rest) -> verbatim line acc rest+ (EscapeUnterminated, _) -> Left "unterminated backslash escape at end of string"+ (UnknownEscape esc, _) -> Left ("unknown escape character: " ++ [esc])+ c:cs ->+ verbatim line (c:acc) cs - expr :: String -> Either String [InterpSegment]- expr parsee = case span (/= '}') parsee of- (_, "") -> Left "unterminated #{...} interpolation"- (expr, _:rest) -> (Expression expr :) <$> switch rest+ expr :: Line -> String -> Either String Lines+ expr line parsee = case span (/= '}') parsee of+ (_, "") -> Left "unterminated #{...} interpolation"+ (expr, _:rest) -> switch (Expression expr : line) rest - newline :: String -> Either String [InterpSegment]- newline parsee = (Newline :) <$> switch parsee+ newline :: Line -> String -> Either String Lines+ newline line parsee = (reverse line :) <$> switch [] parsee - spaces :: Int -> String -> Either String [InterpSegment]- spaces n (' ':rest) = spaces (n+1) rest- spaces n other = (Spaces n :) <$> switch other+ spaces :: Line -> Int -> String -> Either String Lines+ spaces line n (' ':rest) = spaces line (n+1) rest+ spaces line n other = switch (Spaces n : line) other - tabs :: Int -> String -> Either String [InterpSegment]- tabs n ('\t':rest) = tabs (n+1) rest- tabs n other = (Tabs n :) <$> switch other+ tabs :: Line -> Int -> String -> Either String Lines+ tabs line n ('\t':rest) = tabs line (n+1) rest+ tabs line n other = switch (Tabs n : line) other +-- |+-- Like `parseInterpSegments', but for cases where we need to do+-- more complicated transformations on the input. Separates the+-- interpolation input into its content, whitespace header, and+-- whitespace footer.+parseInput :: String -> Either String ParseOutput+parseInput parsee = do+ lines <- parseInterpSegments parsee+ let (headerWS, tail) = break (not . isBlankLine) lines+ (footerWS, init) = bimap reverse reverse $+ break (not . isBlankLine) (reverse tail)+ pure $! ParseOutput+ { poHeaderWS = headerWS+ , poContent = init+ , poFooterWS = footerWS+ }+ dosToUnix :: String -> String dosToUnix = go- where go xs = case xs of- '\r' : '\n' : ys -> '\n' : go ys- y : ys -> y : go ys- [] -> []+ where+ go xs = case xs of+ '\r' : '\n' : ys -> '\n' : go ys+ y : ys -> y : go ys+ [] -> [] data EscapeResult = FoundChar Char@@ -185,12 +215,13 @@ "" -> (EscapeUnterminated, "") x:xs -> (FoundChar x, xs) - where readHex :: String -> Int- readHex xs = case N.readHex xs of- [(n, "")] -> n- _ -> error "Data.String.Interpolate.Util.readHex: no parse"+ where+ readHex :: String -> Int+ readHex xs = case N.readHex xs of+ [(n, "")] -> n+ _ -> error "Data.String.Interpolate.Util.readHex: no parse" - readOct :: String -> Int- readOct xs = case N.readOct xs of- [(n, "")] -> n- _ -> error "Data.String.Interpolate.Util.readHex: no parse"+ readOct :: String -> Int+ readOct xs = case N.readOct xs of+ [(n, "")] -> n+ _ -> error "Data.String.Interpolate.Util.readHex: no parse"
+ src/lib/Data/String/Interpolate/Types.hs view
@@ -0,0 +1,15 @@+module Data.String.Interpolate.Types+ ( InterpSegment(..)+ , Line, Lines+ )+where++data InterpSegment+ = Expression String+ | Verbatim String+ | Spaces Int+ | Tabs Int+ deriving (Eq, Show)++type Line = [InterpSegment]+type Lines = [Line]
+ src/lib/Data/String/Interpolate/Whitespace.hs view
@@ -0,0 +1,34 @@+module Data.String.Interpolate.Whitespace where++import Data.List ( intercalate )++import Data.String.Interpolate.Types++-- |+-- Collapse all the lines given into a single line, collapsing any whitespace+-- found into a single space and removing begining/trailing whitespace.+collapseWhitespace :: Lines -> Line+collapseWhitespace lines =+ let oneliner = intercalate [Spaces 1] lines+ in removeSurroundingWS $ toSingleSpace oneliner++toSingleSpace :: Line -> Line+toSingleSpace [] = []+toSingleSpace (x:y:xs) | isSpace x && isSpace y =+ toSingleSpace (Spaces 1 : xs)+toSingleSpace (x:xs) | isSpace x =+ Spaces 1 : toSingleSpace xs+toSingleSpace (x:xs) =+ x : toSingleSpace xs++removeSurroundingWS :: Line -> Line+removeSurroundingWS =+ dropWhile isSpace+ . reverse+ . dropWhile isSpace+ . reverse++isSpace :: InterpSegment -> Bool+isSpace (Spaces _) = True+isSpace (Tabs _) = True+isSpace _other = False
string-interpolate.cabal view
@@ -1,7 +1,7 @@ cabal-version: 1.18 name: string-interpolate-version: 0.3.0.2+version: 0.3.1.0 synopsis: Haskell string/text/bytestring interpolation that just works description: Unicode-aware string interpolation that handles all textual types. .@@ -11,7 +11,7 @@ bug-reports: https://gitlab.com/williamyaoh/string-interpolate/issues author: William Yao maintainer: williamyaoh@gmail.com-copyright: 2019-2020 William Yao+copyright: 2019-2021 William Yao license: BSD3 license-file: LICENSE build-type: Simple@@ -52,11 +52,13 @@ Data.String.Interpolate.Conversion Data.String.Interpolate.Conversion.TextSink Data.String.Interpolate.Conversion.ByteStringSink+ Data.String.Interpolate.Types Data.String.Interpolate.Parse other-modules: Data.String.Interpolate.Conversion.Classes Data.String.Interpolate.Conversion.Encoding- other-modules:+ Data.String.Interpolate.Lines+ Data.String.Interpolate.Whitespace Paths_string_interpolate hs-source-dirs: src/lib@@ -115,7 +117,7 @@ , text <1.3 , deepseq <1.5 , criterion <1.6- , formatting <6.4+ , formatting <7.2 , interpolate <0.3 , neat-interpolation <0.6 if flag(extended-benchmarks)
test/spec.hs view
@@ -39,10 +39,11 @@ import "QuickCheck" Test.QuickCheck.Monadic import "quickcheck-unicode" Test.QuickCheck.Unicode -import Data.String.Interpolate ( i, iii, __i )+import Data.String.Interpolate ( i, iii, __i, __i'E, __i'L, iii'E, iii'L ) import Data.String.Interpolate.Conversion hiding ( build, finalize, interpolate, ofString, chompSpaces )-import Data.String.Interpolate.Parse ( InterpSegment(..), parseInterpSegments )+import Data.String.Interpolate.Types ( InterpSegment(..) )+import Data.String.Interpolate.Parse ( parseInterpSegments ) main :: IO () main = hspecWith testConfig $ parallel $ do@@ -233,6 +234,93 @@ -- prop "output words = input words" $ -- \(SpaceyText t) -> T.words t == T.words [__i|#{t}|] + describe "__i'E" $ modifyMaxSuccess (const 250) $ modifyMaxSize (const 500) $ do+ context "when there are newlines" $ do+ it "handles a small code snippet correctly/1" $ do+ let interpolated :: T.Text =+ [__i'E|+ id :: a -> a+ id x = y+ where y = x+ |]+ expected :: T.Text = "\nid :: a -> a\nid x = y\n where y = x\n "+ interpolated `shouldBe` expected++ it "handles a small code snippet correctly/2" $ do+ let interpolated :: T.Text =+ [__i'E|+++ This is an example message.++ Title: Foo+ Description: Bar+ Categories:++++ This is an example body.++ |]+ expected :: T.Text = "\n\n\nThis is an example message.\n\n Title: Foo\n Description: Bar\n Categories:\n\n\n\nThis is an example body.\n\n "+ interpolated `shouldBe` expected++ it "handles a small code snippet correctly/3" $ do+ let input :: Int = 42+ interpolated :: T.Text =+ [__i'E|+ add :: Int -> Int -> Int+ add x y =+ let result = x + y + #{input}+ in result+ |]+ expected :: T.Text = "\nadd :: Int -> Int -> Int\nadd x y =\n let result = x + y + 42\n in result\n "+ interpolated `shouldBe` expected++ describe "__i'L" $ modifyMaxSuccess (const 250) $ modifyMaxSize (const 500) $ do+ context "when there are newlines" $ do+ it "handles a small code snippet correctly/1" $ do+ let interpolated :: T.Text =+ [__i'L|++ id :: a -> a+ id x = y+ where y = x+ |]+ expected :: T.Text = "\nid :: a -> a\nid x = y\n where y = x\n "+ interpolated `shouldBe` expected++ it "handles a small code snippet correctly/2" $ do+ let interpolated :: T.Text =+ [__i'L|+++ This is an example message.++ Title: Foo+ Description: Bar+ Categories:++++ This is an example body.++ |]+ expected :: T.Text = "\nThis is an example message.\n\n Title: Foo\n Description: Bar\n Categories:\n\n\n\nThis is an example body.\n"+ interpolated `shouldBe` expected++ it "handles a small code snippet correctly/3" $ do+ let input :: Int = 42+ interpolated :: T.Text =+ [__i'L|+ add :: Int -> Int -> Int+ add x y =+ let result = x + y + #{input}+ in result+ |]+ expected :: T.Text = "\nadd :: Int -> Int -> Int\nadd x y =\n let result = x + y + 42\n in result\n "+ interpolated `shouldBe` expected+ describe "iii" $ modifyMaxSuccess (const 10000) $ modifyMaxSize (const 500) $ do context "when there is whitespace" $ do it "collapses a small example of whitespace" $ do@@ -251,6 +339,46 @@ expected :: T.Text = "Lorem ipsum dolor sit amet, consectetur adipiscing elit. Aenean congue iaculis dui, at iaculis sapien interdum nec." interpolated `shouldBe` expected + describe "iii'E" $ modifyMaxSuccess (const 10000) $ modifyMaxSize (const 500) $ do+ context "when there is whitespace" $ do+ it "collapses a small example of whitespace" $ do+ let interpolated :: T.Text = [iii'E| foo bar baz |]+ expected :: T.Text = "foo bar baz"+ interpolated `shouldBe` expected++ it "collapses a small example of newlines" $ do+ let interpolated :: T.Text =+ [iii'E|++ Lorem ipsum dolor sit amet,+ consectetur adipiscing elit.+ Aenean congue iaculis dui,+ at iaculis sapien interdum nec.++ |]+ expected :: T.Text = "\n\nLorem ipsum dolor sit amet, consectetur adipiscing elit. Aenean congue iaculis dui, at iaculis sapien interdum nec.\n\n "+ interpolated `shouldBe` expected++ describe "iii'L" $ modifyMaxSuccess (const 10000) $ modifyMaxSize (const 500) $ do+ context "when there is whitespace" $ do+ it "collapses a small example of whitespace" $ do+ let interpolated :: T.Text = [iii'L| foo bar baz |]+ expected :: T.Text = "foo bar baz"+ interpolated `shouldBe` expected++ it "collapses a small example of newlines" $ do+ let interpolated :: T.Text =+ [iii'L|++ Lorem ipsum dolor sit amet,+ consectetur adipiscing elit.+ Aenean congue iaculis dui,+ at iaculis sapien interdum nec.++ |]+ expected :: T.Text = "\nLorem ipsum dolor sit amet, consectetur adipiscing elit. Aenean congue iaculis dui, at iaculis sapien interdum nec.\n"+ interpolated `shouldBe` expected+ testConfig :: Config testConfig = defaultConfig { configDiff = True@@ -341,14 +469,12 @@ arbitrary = oneof [ Verbatim <$> listOf nonwhitespaceChar , Expression <$> arbitrary- , pure Newline , Spaces <$> arbitrary , Tabs <$> arbitrary ] shrink (Verbatim t) = Verbatim <$> shrink t shrink (Expression t) = []- shrink Newline = [] shrink (Spaces n) = [Spaces (n `div` 2), Spaces (n-1)] shrink (Tabs n) = [Tabs (n `div` 2), Tabs (n-1)] @@ -378,17 +504,3 @@ , plane2 , plane14 ]---- Get back the compile time string that would create a given interpolation.-interpToString :: [InterpSegment] -> String-interpToString [] = ""-interpToString (Expression expr : rest) = "#{" ++ expr ++ "}" ++ interpToString rest-interpToString (Newline : rest) = '\n' : interpToString rest-interpToString (Spaces n : rest) = replicate n ' ' ++ interpToString rest-interpToString (Tabs n : rest) = replicate n '\t' ++ interpToString rest-interpToString (Verbatim str : rest) = interpEscape str ++ interpToString rest- where interpEscape :: String -> String- interpEscape "" = ""- interpEscape ('\\':cs) = '\\':'\\':interpEscape cs- interpEscape ('#':cs) = '\\':'#':interpEscape cs- interpEscape (c:cs) = c:interpEscape cs