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

-- | 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.Perl6 (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.Perl6 (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.Perl6 (qc, ShowQ(..))
-- instance ShowQ [String] where
--     showQ = unwords
-- @
--
-- The 'qq' form adds to the 'qc' form with a simple shorthand: '$foo' means '{foo}',
-- namely interpolating a single variable into the string.
--
-- @
-- {-\# LANGUAGE QuasiQuotes, ExtendedDefaultRules #-}
-- import Text.InterpolatedString.Perl6 (qq)
-- baz :: String
-- baz = [qq| Hello, $who |]
--     where
--     who = \"World\"
-- @
--
-- Both 'qc' and 'qq' permit output to any types with both 'IsString' and 'Monoid' 
-- instances.
-- 
-- @
-- {-# LANGUAGE QuasiQuotes, OverloadedStrings #-}
-- import Text.InterpolatedString.Perl6 (qc)
-- import Data.Text (Text)
-- import Data.ByteString.Char8 (ByteString)
-- qux :: ByteString
-- qux = [qc| This will convert {\"Text\" :: Text} to {\"ByteString\" :: ByteString} |]
-- @
--
-- The ability to define custom 'ShowQ' instances is particularly powerful with
-- cascading instances using 'qq'.
--
-- Below is a sample snippet from a script that converts Shape objects into
-- AppleScript suitable for drawing in OmniGraffle:
--
-- @
-- {-\# LANGUAGE QuasiQuotes, ExtendedDefaultRules, NamedFieldPuns, RecordWildCards #-}
-- import Text.InterpolatedString.Perl6
-- @ 
--
-- @ 
-- data Shape = Shape
--     { originX         :: Int
--     , originY         :: Int
--     , width           :: Int
--     , height          :: Int
--     , stroke          :: Stroke
--     , text            :: Text
--     }
-- instance ShowQ Shape where
--     showQ Shape{..} = [qq|
--         make new shape at end of graphics with properties
--             \\{ $text, $stroke, _size, $_origin }
--     |]
--         where         
--         _size   = [qq|size: \{$width, $height}|]
--         _origin = [qq|origin: \{$originX, $originY}|]
-- @ 
--
-- @ 
-- data Stroke = StrokeWhite | StrokeNone
-- instance ShowQ Stroke where
--     showQ StrokeNone = \"draws stroke:false\"
--     showQ StrokeWhite = \"stroke color: {1, 1, 1}\"
-- @ 
--
-- @ 
-- data Text   = Text
--     { txt   :: String
--     , color :: Color
--     }
-- instance ShowQ Text where
--     showQ Text{..} = [qq|text: \\{ text: \"$txt\", $color, alignment: center } |]
-- @ 
--
-- @ 
-- data Color = Color { red :: Float, green :: Float, blue :: Float }
-- instance ShowQ Color where
--     showQ Color{..} = [qq|color: \{$red, $green, $blue}|]
-- @ 
--
-- @ 
-- main :: IO ()
-- main = putStrLn [qq|
--     tell application \"OmniGraffle Professional 5\"
--         tell canvas of front window
--             { makeShape ... }
--         end tell
--     end tell
-- |]
-- @
--

module Text.InterpolatedString.Perl6 (qq, qc, q, ShowQ(..)) where

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

-- |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 :: Char -> String
showQ = (Char -> String -> String
forall a. a -> [a] -> [a]
:[])
    
instance ShowQ String where
    showQ :: String -> String
showQ = String -> String
forall a. a -> a
id

instance ShowQ Strict.ByteString where
    showQ :: ByteString -> String
showQ = ByteString -> String
Strict.unpack

instance ShowQ Lazy.ByteString where
    showQ :: ByteString -> String
showQ = ByteString -> String
Lazy.unpack

instance ShowQ T.Text where
    showQ :: Text -> String
showQ = Text -> String
T.unpack

instance ShowQ LazyT.Text where
    showQ :: Text -> String
showQ = Text -> String
LazyT.unpack

instance Show a => ShowQ a where
    showQ :: a -> String
showQ = a -> String
forall a. Show a => a -> String
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 IsString s => QQ s s where
    toQQ :: s -> s
toQQ = s -> s
forall a. a -> a
id

instance (ShowQ a, IsString s) => QQ a s where 
    toQQ :: a -> s
toQQ = String -> s
forall a. IsString a => String -> a
fromString (String -> s) -> (a -> String) -> a -> s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. ShowQ a => a -> String
showQ

data StringPart = Literal String | AntiQuote String deriving Int -> StringPart -> String -> String
[StringPart] -> String -> String
StringPart -> String
(Int -> StringPart -> String -> String)
-> (StringPart -> String)
-> ([StringPart] -> String -> String)
-> Show StringPart
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [StringPart] -> String -> String
$cshowList :: [StringPart] -> String -> String
show :: StringPart -> String
$cshow :: StringPart -> String
showsPrec :: Int -> StringPart -> String -> String
$cshowsPrec :: Int -> StringPart -> String -> String
Show

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

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

unQQ :: String -> String -> [StringPart]
unQQ String
a []          = [String -> StringPart
Literal (String -> String
forall a. [a] -> [a]
reverse String
a)]
unQQ String
a (Char
'\\':Char
x:String
xs) = String -> String -> [StringPart]
unQQ (Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String
a) String
xs
unQQ String
a (Char
'\\':[])   = String -> String -> [StringPart]
unQQ (Char
'\\'Char -> String -> String
forall a. a -> [a] -> [a]
:String
a) []
unQQ String
a (Char
'}':String
xs)    = String -> StringPart
AntiQuote (String -> String
forall a. [a] -> [a]
reverse String
a) StringPart -> [StringPart] -> [StringPart]
forall a. a -> [a] -> [a]
: String -> String -> [StringPart]
parseQQ [] String
xs
unQQ String
a (Char
x:String
xs)      = String -> String -> [StringPart]
unQQ (Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String
a) String
xs

parseQQ :: String -> String -> [StringPart]
parseQQ String
a []           = [String -> StringPart
Literal (String -> String
forall a. [a] -> [a]
reverse String
a)]
parseQQ String
a (Char
'\\':Char
x:String
xs)  = String -> String -> [StringPart]
parseQQ (Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String
a) String
xs
parseQQ String
a (Char
'\\':[])    = String -> String -> [StringPart]
parseQQ (Char
'\\'Char -> String -> String
forall a. a -> [a] -> [a]
:String
a) []
parseQQ String
a (Char
'$':Char
x:String
xs) | Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char -> Bool
isAlpha Char
x =
    String -> StringPart
Literal (String -> String
forall a. [a] -> [a]
reverse String
a) StringPart -> [StringPart] -> [StringPart]
forall a. a -> [a] -> [a]
: String -> StringPart
AntiQuote (Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String
pre) StringPart -> [StringPart] -> [StringPart]
forall a. a -> [a] -> [a]
: String -> String -> [StringPart]
parseQQ [] String
post
    where
    (String
pre, String
post) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isIdent String
xs
parseQQ String
a (Char
'{':String
xs)     = String -> StringPart
Literal (String -> String
forall a. [a] -> [a]
reverse String
a) StringPart -> [StringPart] -> [StringPart]
forall a. a -> [a] -> [a]
: String -> String -> [StringPart]
unQQ [] String
xs
parseQQ String
a (Char
x:String
xs)       = String -> String -> [StringPart]
parseQQ (Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String
a) String
xs

isIdent :: Char -> Bool
isIdent Char
'_'  = Bool
True
isIdent Char
'\'' = Bool
True
isIdent Char
x    = Char -> Bool
isAlphaNum Char
x

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

reify :: String -> ExpQ
reify String
s = 
    case String -> Either String Exp
parseExp String
s of
        Left String
s  -> Bool -> String -> Q ()
TH.report Bool
True String
s Q () -> ExpQ -> ExpQ
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [| mempty |]
        Right Exp
e ->  Exp -> ExpQ
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
e

-- | QuasiQuoter for interpolating '$var' and '{expr}' into a string literal. The pattern portion is undefined.
qq :: QuasiQuoter
qq :: QuasiQuoter
qq = (String -> ExpQ)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter ([StringPart] -> ExpQ
makeExpr ([StringPart] -> ExpQ)
-> (String -> [StringPart]) -> String -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> [StringPart]
parseQQ [] (String -> [StringPart])
-> (String -> String) -> String -> [StringPart]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\r'))
                 (String -> String -> Q Pat
forall a. HasCallStack => String -> a
error String
"Cannot use qq as a pattern")
                 (String -> String -> Q Type
forall a. HasCallStack => String -> a
error String
"Cannot use qq as a type")
                 (String -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error String
"Cannot use qq as a dec")

-- | QuasiQuoter for interpolating '{expr}' into a string literal. The pattern portion is undefined.
qc :: QuasiQuoter
qc :: QuasiQuoter
qc = (String -> ExpQ)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter ([StringPart] -> ExpQ
makeExpr ([StringPart] -> ExpQ)
-> (String -> [StringPart]) -> String -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> [StringPart]
parseQC [] (String -> [StringPart])
-> (String -> String) -> String -> [StringPart]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\r'))
                 (String -> String -> Q Pat
forall a. HasCallStack => String -> a
error String
"Cannot use qc as a pattern")
                 (String -> String -> Q Type
forall a. HasCallStack => String -> a
error String
"Cannot use qc as a type")
                 (String -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error String
"Cannot use qc as a dec")

-- | QuasiQuoter for a non-interpolating string literal. The pattern portion is undefined.
q :: QuasiQuoter
q :: QuasiQuoter
q = (String -> ExpQ)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter ((\String
a -> [|fromString a|]) (String -> ExpQ) -> (String -> String) -> String -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\r'))
                 (String -> String -> Q Pat
forall a. HasCallStack => String -> a
error String
"Cannot use q as a pattern")
                 (String -> String -> Q Type
forall a. HasCallStack => String -> a
error String
"Cannot use q as a type")
                 (String -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error String
"Cannot use q as a dec")