Interpolation.hs

{-# LANGUAGE QuasiQuotes,TemplateHaskell,DeriveDataTypeable #-}
module Data.String.Interpolation(str) where
import Language.Haskell.TH as TH
import Language.Haskell.TH.Quote
import Data.Data
import Data.Maybe
import Data.Char
import Data.List(intercalate)

quoteExprExp :: String -> TH.ExpQ
-- | Quasiquote 'str' implements multiline strings with interpolation.
--   Interpolating a value of parameter a into the string is done by $a$
--   and interpolating anything with instance Show is $:a$.
--
--   Repetitive patterns can be made by # symbol using the following syntax: 
--
--  @
--  \#\<var\> in \<list\>: \<interpolated string\> (|\<interpolated string\>)\#
--  @
--   
--   Where (|\<interpolated string\>) denotes optional separator for the 
--   elements.
--   
--
--   Example:
-- 
--   @
--    \#i in myList: this is $i$|--\#
--   @
--   
--   Which will evaluate to @ 1--2--3 @ given myList of [1,2,3]
--   
-- 
--   Multiline indentation is handled by aligning on smallest un-empty
--   line after the first.
--
--   Pattern matching is not supported. 
--

str  :: QuasiQuoter
str  =  QuasiQuoter quoteExprExp undefined
--
quoteExprExp s = psToStringE (parParse $ norming s)
--

psToStringE :: PieceString -> TH.Q TH.Exp
psToStringE [] = TH.stringE ""
psToStringE (x:xs) = TH.infixE (Just $ sbitToExp x)
                               ([| (++) |])
                               (Just $ psToStringE xs)

sbitToExp :: StringBits -> ExpQ
sbitToExp (Str x) =  TH.stringE x 
sbitToExp (Var x)  =  (TH.varE (TH.mkName x))
sbitToExp (SVar x) = TH.appE (TH.varE (TH.mkName "show"))
                        (TH.varE (TH.mkName 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) = break (==':') s
                       (hasSep,expr,sepS) = takeRep $ drop 1 exprS
                       (sep,restS) = break (=='#') $ sepS
                       rest = drop 1 restS
                       [varName,"in",listName] = words bind
                    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 -> (Bool,String,String)
takeRep x = takeRep' x []

takeRep' :: String -> String -> (Bool,String,String)
takeRep' [] _ = error "Repetition template does not end"
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)


-- Normalize the indentation to match second line

norming :: String -> String
norming = unlines . norming' . lines

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