{-# LANGUAGE TemplateHaskell, TypeSynonymInstances, FlexibleInstances,
  UndecidableInstances, MultiParamTypeClasses #-}

-- | QuasiQuoter for interpolated strings using Perl 6 syntax.
--
-- The 'q' form does one thing and does it well: It contains a multi-line string with
-- no interpolation at all:
--
-- @
-- {-\# LANGUAGE QuasiQuotes, ExtendedDefaultRules #-}
-- import Text.InterpolatedString.QQ2 (q)
-- foo :: String -- 'Text', 'ByteString' etc also works
-- foo = [q|
--
-- Well here is a
--     multi-line string!
--
-- |]
-- @
--
-- Any instance of the 'IsString' class is permitted.
--
-- The 'qc' form interpolates curly braces: expressions inside #{} will be
-- directly interpolated if it's a 'Char', 'String', 'Text' or 'ByteString', or
-- it will have 'show' called if it is not.
--
-- Escaping of '{' is done with backslash.
--
-- For interpolating numeric expressions without an explicit type signature,
-- use the ExtendedDefaultRules lanuage pragma, as shown below:
--
-- @
-- {-\# LANGUAGE QuasiQuotes, ExtendedDefaultRules #-}
-- import Text.InterpolatedString.QQ2 (qc)
-- bar :: String
-- bar = [qc| Well #{\"hello\" ++ \" there\"} #{6 * 7} |]
-- @
--
-- bar will have the value \" Well hello there 42 \".
--
-- If you want control over how 'show' works on your types, define a custom
-- 'ShowQ' instance:
--
-- For example, this instance allows you to display interpolated lists of strings as
-- a sequence of words, removing those pesky brackets, quotes, and escape sequences.
--
-- @
-- {-\# LANGUAGE FlexibleInstances #-}
-- import Text.InterpolatedString.QQ2 (qc, ShowQ(..))
-- instance ShowQ [String] where
--     showQ = unwords
-- @
--
-- 'qc' permits output to any types with both 'IsString' and 'Monoid'
-- instances.
--
-- @
-- {-# LANGUAGE QuasiQuotes, OverloadedStrings #-}
-- import Text.InterpolatedString.QQ2 (qc)
-- import Data.Text (Text)
-- import Data.ByteString.Char8 (ByteString)
-- qux :: ByteString
-- qux = [qc| This will convert #{\"Text\" :: Text} to #{\"ByteString\" :: ByteString} |]
-- @

module Text.InterpolatedString.QQ2 (qc, q, ShowQ(..)) where

import           Data.ByteString.Char8 as Strict (ByteString, unpack)
import           Data.ByteString.Lazy.Char8 as Lazy (ByteString, unpack)
import           Data.Monoid (Monoid(..))
import           Data.Text as T (Text, unpack)
import           Data.Text.Lazy as LazyT(Text, unpack)
import           GHC.Exts (IsString(..))
import           Language.Haskell.Meta.Parse
import qualified Language.Haskell.TH as TH
import           Language.Haskell.TH.Quote

-- |A class for types that use special interpolation rules.
-- Instances of 'ShowQ' that are also instances of 'IsString' should obey the
-- following law:
--
-- @
-- fromString (showQ s) == s
-- @
--
-- because this library relies on this fact to optimize
-- away needless string conversions.
class ShowQ a where
    showQ :: a -> String

instance ShowQ Char where
    showQ = (:[])

instance ShowQ String where
    showQ = id

instance ShowQ Strict.ByteString where
    showQ = Strict.unpack

instance ShowQ Lazy.ByteString where
    showQ = Lazy.unpack

instance ShowQ T.Text where
    showQ = T.unpack

instance ShowQ LazyT.Text where
    showQ = LazyT.unpack

instance {-# OVERLAPPABLE #-} Show a => ShowQ a where
    showQ = show

-- todo: this should really be rewritten into RULES pragmas, but so far
-- I can't convince GHC to let the rules fire.
class QQ a string where
    toQQ :: a -> string

instance {-# INCOHERENT #-} IsString s => QQ s s where
    toQQ = id

instance {-# INCOHERENT #-} (ShowQ a, IsString s) => QQ a s where
    toQQ = fromString . showQ

data StringPart = Literal String | AntiQuote String deriving Show

unQC :: [Char] -> [Char] -> [StringPart]
unQC a []          = [Literal (reverse a)]
unQC a ('\\':x:xs) = unQC (x:a) xs
unQC a ('\\':[])   = unQC ('\\':a) []
unQC a ('}':xs)    = AntiQuote (reverse a) : parseQC [] xs
unQC a (x:xs)      = unQC (x:a) xs

parseQC :: [Char] -> [Char] -> [StringPart]
parseQC a []             = [Literal (reverse a)]
parseQC a ('\\':'\\':xs) = parseQC ('\\':a) xs
parseQC a ('\\':'#':xs)  = parseQC ('#':a) xs
parseQC a ('\\':[])      = parseQC ('\\':a) []
parseQC a ('#':'{':xs)   = Literal (reverse a) : unQC [] xs
parseQC a (x:xs)         = parseQC (x:a) xs

makeExpr :: [StringPart] -> TH.Q TH.Exp
makeExpr [] = [| mempty |]
makeExpr ((Literal a):xs)   = TH.appE [| mappend (fromString a) |]
                              $ makeExpr xs
makeExpr ((AntiQuote a):xs) = TH.appE [| mappend (toQQ $(reify a)) |]
                              $ makeExpr xs

reify :: String -> TH.Q TH.Exp
reify s =
    case parseExp s of
        Left s'  -> TH.reportError s' >> [| mempty |]
        Right e ->  return e

-- | QuasiQuoter for interpolating '{expr}' into a string literal. The pattern portion is undefined.
qc :: QuasiQuoter
qc = QuasiQuoter (makeExpr . parseQC [] . filter (/= '\r'))
                 (error "Cannot use qc as a pattern")
                 (error "Cannot use qc as a type")
                 (error "Cannot use qc as a dec")

-- | QuasiQuoter for a non-interpolating string literal. The pattern portion is undefined.
q :: QuasiQuoter
q = QuasiQuoter ((\a -> [|fromString a|]) . filter (/= '\r'))
                 (error "Cannot use q as a pattern")
                 (error "Cannot use q as a type")
                 (error "Cannot use q as a dec")