{-# LANGUAGE CPP,QuasiQuotes,TemplateHaskell,DeriveDataTypeable,PatternGuards #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-} -- | This module defines a quasiquoter for interpolated strings. For example: -- -- @ -- import qualified Data.Text.Lazy as LT -- let fb x | x \`mod\` 15 == 0 = \"FizzBuzz\" -- | x \`mod\` 5 == 0 = \"Buzz\" -- | x \`mod\` 3 == 0 = \"Fizz\" -- | otherwise = LT.pack (show x) -- @ -- -- >>> LT.take 85 [str|#x in [1..]:$fb x$|, #|] <> ".. " -- "1, 2, Fizz, 4, Buzz, Fizz, 7, 8, Fizz, Buzz, 11, Fizz, 13, 14, FizzBuzz, 16, 17, Fizz.. " -- -- module Data.String.Interpolation(str,prnt,endline,tab) where import Language.Haskell.TH as TH import Language.Haskell.TH.Quote import Data.Data import Data.Maybe import Data.Monoid import Data.Char import Data.String -- import Data.List(intercalate) quoteExprExp :: String -> TH.ExpQ -- | Quasiquote 'str' implements multiline strings with interpolation. -- Interpolating a value into the string is done by -- $\$ -- and interpolating anything with instance Show is -- $:\$. Due to pretty deep limitations, the parser -- is not able to properly deduce associtivity of infix operators, -- so use lots and lots of parenthesis. -- -- Repetitive patterns can be made with # symbol: -- -- @ -- \#\ in \: \ (|\)\# -- @ -- -- Where (|\) denotes optional separator for the -- elements. -- -- Multiline indentation is handled by aligning on smallest un-empty -- line after the first. Neither pattern matching nor nested #-patterns -- are supported, however, see example below. -- -- Normal '\\n' style escaping of special characters -- is intentionally not supported. Please use $endline$ or $"\n"$ -- style instead. -- -- As an example, let's plot set of vectors with gnuplot: -- -- @ -- plotVecs :: [(String,[Double])] -> String -- plotVecs vs = -- [$str| \#\# Plot multiple vectors -- plot \#(n,_) in vs:'-' with lines lw 5 title $:n$ |, \# -- \#d in map snd vs:$singleVec d$$endline$e$endline$\# |] -- where -- singleVec n = [$str|\#(e,i) in zip n [1..]: $:i$ $:e$|$endline$\#|] -- @ -- -- @ -- *Gnuplotter> plotVecs [(\"A\",[1..5]),(\"B\",[2..6])] -- \# Plot multiple vectors -- plot '-' with lines lw 5 title \"A\" , '-' with lines lw 5 title \"B\" -- 1 1.0 -- 2 2.0 -- 3 3.0 -- 4 4.0 -- 5 5.0 -- -- e -- 1 2.0 -- 2 3.0 -- 3 4.0 -- 4 5.0 -- 5 6.0 -- -- e -- @ -- -- | Quasiquoter for interpolating strings. Produces values of `(Monoid m, IsString m) => m` str :: QuasiQuoter str = QuasiQuoter {quoteExp = quoteExprExp} -- | Quasiquoter for printing an interpolated String prnt :: QuasiQuoter prnt = QuasiQuoter {quoteExp = quoteExprPExp} -- ** Predefined strings -- | End of the line endline :: IsString a => a endline = fromString "\n" -- | Tab tab :: IsString a => a tab = fromString "\t" -- quoteExprExp s = psToStringE (parParse $ norming s) quoteExprPExp :: String -> ExpQ quoteExprPExp = TH.appE [|putStr|] . quoteExprExp -- psToStringE :: PieceString -> TH.Q TH.Exp psToStringE [] = [|mempty|] --TH.stringE "" psToStringE (x:xs) = ([| mappend |]) `TH.appE` (sbitToExp x) `TH.appE` (psToStringE xs) runEither :: (Monad m) => [Char] -> Either [Char] t -> m t runEither _ (Right x) = return x runEither s (Left e) = error $ s ++" : "++ e appM :: String -> ExpQ appM expr = TH.varE $ TH.mkName expr sbitToExp :: StringBits -> ExpQ sbitToExp (Str x) = [| fromString |] `appE` TH.stringE x sbitToExp (Var x) = appM x sbitToExp (SVar x) = TH.appE [| fromString . show |]--(TH.varE (TH.mkName "show")) (sbitToExp (Var x)) sbitToExp (RepVar varName lstName rep sep) = [|intercalate $(sepr) (map $(lam) $(lstN))|] where sepr = psToStringE (fromMaybe [Str ""] sep) lam = TH.lamE [varN] (psToStringE rep) varN = TH.varP $ TH.mkName varName lstN = TH.varE $ TH.mkName lstName type PieceString = [StringBits] data StringBits = Str String | Var String | SVar String | RepVar String String PieceString (Maybe PieceString) deriving (Eq,Ord,Show,Typeable,Data) -- Split to string into pieces. This needs proper error messages. -- Perhaps parsec? parParse :: [Char] -> [StringBits] parParse [] = [] parParse ('$':'$':s) = Str "$":parParse s -- Parse escapes parParse ('#':'#':s) = Str "#":parParse s parParse ('$':':':s) = SVar (takeWhile (/='$') s) -- Parse antiquotes :parParse (drop 1 (dropWhile (/='$') s)) parParse ('$':s) = Var (takeWhile (/='$') s) :parParse (drop 1 (dropWhile (/='$') s)) parParse ('#':s) = let (bind,exprS) = escapingBreak (':') ("Repetition <"++s++"> missing body") $ s (hasSep,expr,sepS) = takeRep ("Repetition <"++s++"> missing #")$ exprS (sep,restS) = escapingBreak ('#') ("Repetition <"++s++"> missing #") $ sepS rest = restS (varNameS,listNameS) = break (=="in") . words $ bind listName = unwords . drop 1 $ listNameS varName = unwords varNameS in if hasSep then RepVar varName listName (parParse expr) (Just $ parParse sep) : parParse rest else RepVar varName listName (parParse expr) (Nothing) : parParse sepS parParse s = Str (takeWhile (notIn "$#") s) : parParse (dropWhile (notIn "$#") s) notIn :: (Eq a) => [a] -> a -> Bool notIn s x =not $ elem x s takeRep :: String -> String -> (Bool,String,String) takeRep e x = takeRep' x [] where takeRep' :: String -> String -> (Bool,String,String) takeRep' [] _ = error $ e takeRep' ('|':'|':s) acc = takeRep' s ('|':acc) takeRep' ('|':s) acc = (True,reverse acc,s) takeRep' ('#':s) acc = (False,reverse acc,s) takeRep' (r:s) acc = takeRep' s (r:acc) escapingBreak :: (Eq t) => t -> [Char] -> [t] -> ([t], [t]) escapingBreak s e st = eBreak [] st where eBreak acc (a:b:c) | a==s&&b==s = eBreak (s:acc) c | a==s = (reverse acc,b:c) | otherwise = eBreak (a:acc) (b:c) eBreak acc (a:c) | a==s = (reverse acc,c) | otherwise = eBreak (a:acc) c eBreak _ [] = error e -- Normalize the indentation to match second line norming :: String -> String norming = intercalate "\n" . norming' . lines . dropWhile isSpace norming':: [String] -> [String] norming' [] = [] norming' (l:lst) = l:map (drop (n)) lst where n = minimumD 0 $ map (length . takeWhile (==' ') ) $ (filter (not.isEmpty) lst) isEmpty = all (isSpace) minimumD :: (Ord a) => a -> [a] -> a minimumD d [] = d minimumD _ x = minimum x -- Re-implementation of intercalate and intersperse using monoid instead of lists intersperse :: a -> [a] -> [a] intersperse _ [] = [] intersperse sep (x:xs) = x : prependToAll sep xs prependToAll :: a -> [a] -> [a] prependToAll _ [] = [] prependToAll sep (x:xs) = sep : x : prependToAll sep xs intercalate :: Monoid a => a -> [a] -> a intercalate xs xss = mconcat (intersperse xs xss)