{-# LANGUAGE ExistentialQuantification, FlexibleInstances, StandaloneDeriving, GeneralizedNewtypeDeriving, TypeSynonymInstances #-}
{-# OPTIONS_HADDOCK not-home #-}
module Text.StringTemplate.Classes
    (SElem(..), StringTemplateShows(..), ToSElem(..), SMap, STShow(..),
     StFirst(..), Stringable(..), stShowsToSE
    ) where
import qualified Data.Map as M
import Data.List
import Data.Monoid
import qualified Blaze.ByteString.Builder as BB
import qualified Blaze.ByteString.Builder.Char.Utf8 as BB
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as LB
--import qualified Data.ByteString.Lazy.Builder as DBB
import qualified Data.Semigroup as SG
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Builder as TB
import qualified Data.Text.Lazy.Encoding as LT
import qualified Text.PrettyPrint.HughesPJ as PP

newtype StFirst a = StFirst { StFirst a -> Maybe a
stGetFirst :: Maybe a }
        deriving (StFirst a -> StFirst a -> Bool
(StFirst a -> StFirst a -> Bool)
-> (StFirst a -> StFirst a -> Bool) -> Eq (StFirst a)
forall a. Eq a => StFirst a -> StFirst a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StFirst a -> StFirst a -> Bool
$c/= :: forall a. Eq a => StFirst a -> StFirst a -> Bool
== :: StFirst a -> StFirst a -> Bool
$c== :: forall a. Eq a => StFirst a -> StFirst a -> Bool
Eq, Eq (StFirst a)
Eq (StFirst a)
-> (StFirst a -> StFirst a -> Ordering)
-> (StFirst a -> StFirst a -> Bool)
-> (StFirst a -> StFirst a -> Bool)
-> (StFirst a -> StFirst a -> Bool)
-> (StFirst a -> StFirst a -> Bool)
-> (StFirst a -> StFirst a -> StFirst a)
-> (StFirst a -> StFirst a -> StFirst a)
-> Ord (StFirst a)
StFirst a -> StFirst a -> Bool
StFirst a -> StFirst a -> Ordering
StFirst a -> StFirst a -> StFirst a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (StFirst a)
forall a. Ord a => StFirst a -> StFirst a -> Bool
forall a. Ord a => StFirst a -> StFirst a -> Ordering
forall a. Ord a => StFirst a -> StFirst a -> StFirst a
min :: StFirst a -> StFirst a -> StFirst a
$cmin :: forall a. Ord a => StFirst a -> StFirst a -> StFirst a
max :: StFirst a -> StFirst a -> StFirst a
$cmax :: forall a. Ord a => StFirst a -> StFirst a -> StFirst a
>= :: StFirst a -> StFirst a -> Bool
$c>= :: forall a. Ord a => StFirst a -> StFirst a -> Bool
> :: StFirst a -> StFirst a -> Bool
$c> :: forall a. Ord a => StFirst a -> StFirst a -> Bool
<= :: StFirst a -> StFirst a -> Bool
$c<= :: forall a. Ord a => StFirst a -> StFirst a -> Bool
< :: StFirst a -> StFirst a -> Bool
$c< :: forall a. Ord a => StFirst a -> StFirst a -> Bool
compare :: StFirst a -> StFirst a -> Ordering
$ccompare :: forall a. Ord a => StFirst a -> StFirst a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (StFirst a)
Ord, ReadPrec [StFirst a]
ReadPrec (StFirst a)
Int -> ReadS (StFirst a)
ReadS [StFirst a]
(Int -> ReadS (StFirst a))
-> ReadS [StFirst a]
-> ReadPrec (StFirst a)
-> ReadPrec [StFirst a]
-> Read (StFirst a)
forall a. Read a => ReadPrec [StFirst a]
forall a. Read a => ReadPrec (StFirst a)
forall a. Read a => Int -> ReadS (StFirst a)
forall a. Read a => ReadS [StFirst a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [StFirst a]
$creadListPrec :: forall a. Read a => ReadPrec [StFirst a]
readPrec :: ReadPrec (StFirst a)
$creadPrec :: forall a. Read a => ReadPrec (StFirst a)
readList :: ReadS [StFirst a]
$creadList :: forall a. Read a => ReadS [StFirst a]
readsPrec :: Int -> ReadS (StFirst a)
$creadsPrec :: forall a. Read a => Int -> ReadS (StFirst a)
Read, Int -> StFirst a -> ShowS
[StFirst a] -> ShowS
StFirst a -> String
(Int -> StFirst a -> ShowS)
-> (StFirst a -> String)
-> ([StFirst a] -> ShowS)
-> Show (StFirst a)
forall a. Show a => Int -> StFirst a -> ShowS
forall a. Show a => [StFirst a] -> ShowS
forall a. Show a => StFirst a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StFirst a] -> ShowS
$cshowList :: forall a. Show a => [StFirst a] -> ShowS
show :: StFirst a -> String
$cshow :: forall a. Show a => StFirst a -> String
showsPrec :: Int -> StFirst a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> StFirst a -> ShowS
Show)
instance SG.Semigroup (StFirst a) where
        r :: StFirst a
r@(StFirst (Just a
_)) <> :: StFirst a -> StFirst a -> StFirst a
<> StFirst a
_ = StFirst a
r
        StFirst Maybe a
Nothing      <> StFirst a
r = StFirst a
r
instance Monoid (StFirst a) where
        mempty :: StFirst a
mempty  = Maybe a -> StFirst a
forall a. Maybe a -> StFirst a
StFirst Maybe a
forall a. Maybe a
Nothing
        mappend :: StFirst a -> StFirst a -> StFirst a
mappend = StFirst a -> StFirst a -> StFirst a
forall a. Semigroup a => a -> a -> a
(SG.<>)

instance Functor StFirst where
    fmap :: (a -> b) -> StFirst a -> StFirst b
fmap a -> b
f = Maybe b -> StFirst b
forall a. Maybe a -> StFirst a
StFirst (Maybe b -> StFirst b)
-> (StFirst a -> Maybe b) -> StFirst a -> StFirst b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (Maybe a -> Maybe b)
-> (StFirst a -> Maybe a) -> StFirst a -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StFirst a -> Maybe a
forall a. StFirst a -> Maybe a
stGetFirst

type SMap a = M.Map String (SElem a)

data SElem a = STR  String
             | BS   LB.ByteString
             | TXT  LT.Text
             | STSH STShow
             | SM (SMap a)
             | LI [SElem a]
             | SBLE a
             | SNAT a
             | SNull

-- | The ToSElem class should be instantiated for all types that can be
-- inserted as attributes into a StringTemplate.
class ToSElem a where
    toSElem :: Stringable b => a -> SElem b
    toSElemList :: Stringable b => [a] -> SElem b
    toSElemList = [SElem b] -> SElem b
forall a. [SElem a] -> SElem a
LI ([SElem b] -> SElem b) -> ([a] -> [SElem b]) -> [a] -> SElem b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> SElem b) -> [a] -> [SElem b]
forall a b. (a -> b) -> [a] -> [b]
map a -> SElem b
forall a b. (ToSElem a, Stringable b) => a -> SElem b
toSElem

-- | The StringTemplateShows class should be instantiated for all types that are
-- directly displayed in a StringTemplate, but take an optional format string. Each such type must have an appropriate ToSElem method defined as well.
class (Show a) => StringTemplateShows a where
    -- | Defaults to 'show'.
    stringTemplateShow :: a -> String
    stringTemplateShow = a -> String
forall a. Show a => a -> String
show
    -- | Defaults to  @ \ _ a -> stringTemplateShow a @
    stringTemplateFormattedShow :: String -> a -> String
    stringTemplateFormattedShow = (a -> ShowS) -> String -> a -> String
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((a -> ShowS) -> String -> a -> String)
-> (a -> ShowS) -> String -> a -> String
forall a b. (a -> b) -> a -> b
$ String -> ShowS
forall a b. a -> b -> a
const (String -> ShowS) -> (a -> String) -> a -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. StringTemplateShows a => a -> String
stringTemplateShow

-- | This method should be used to create ToSElem instances for
-- types defining a custom formatted show function.
stShowsToSE :: (StringTemplateShows a, Stringable b) => a -> SElem b
stShowsToSE :: a -> SElem b
stShowsToSE = STShow -> SElem b
forall a. STShow -> SElem a
STSH (STShow -> SElem b) -> (a -> STShow) -> a -> SElem b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> STShow
forall a. StringTemplateShows a => a -> STShow
STShow

data STShow = forall a.(StringTemplateShows a) => STShow a

-- | The Stringable class should be instantiated with care.
-- Generally, the provided instances should be enough for anything.
class Monoid a => Stringable a where
    stFromString :: String -> a
    stFromByteString :: LB.ByteString -> a
    stFromByteString = Text -> a
forall a. Stringable a => Text -> a
stFromText (Text -> a) -> (ByteString -> Text) -> ByteString -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
LT.decodeUtf8
    stFromText :: LT.Text -> a
    stFromText = String -> a
forall a. Stringable a => String -> a
stFromString (String -> a) -> (Text -> String) -> Text -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
LT.unpack
    stToString :: a -> String
    -- | Defaults to  @ mconcatMap m k = foldr (mappend . k) mempty m @
    mconcatMap :: [b] -> (b -> a) -> a
    mconcatMap [b]
m b -> a
k = (b -> a -> a) -> a -> [b] -> a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (a -> a -> a
forall a. Monoid a => a -> a -> a
mappend (a -> a -> a) -> (b -> a) -> b -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> a
k) a
forall a. Monoid a => a
mempty [b]
m
    -- | Defaults to  @ (mconcat .) . intersperse @
    mintercalate :: a -> [a] -> a
    mintercalate = ([a] -> a
forall a. Monoid a => [a] -> a
mconcat ([a] -> a) -> ([a] -> [a]) -> [a] -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) (([a] -> [a]) -> [a] -> a) -> (a -> [a] -> [a]) -> a -> [a] -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [a] -> [a]
forall a. a -> [a] -> [a]
intersperse
    -- | Defaults to  @  mlabel x y = mconcat [x, stFromString "[", y, stFromString "]"] @
    mlabel :: a -> a -> a
    mlabel a
x a
y = [a] -> a
forall a. Monoid a => [a] -> a
mconcat [a
x, String -> a
forall a. Stringable a => String -> a
stFromString String
"[", a
y, String -> a
forall a. Stringable a => String -> a
stFromString String
"]"]

instance Stringable String where
    stFromString :: ShowS
stFromString = ShowS
forall a. a -> a
id
    stToString :: ShowS
stToString = ShowS
forall a. a -> a
id

instance Stringable PP.Doc where
    stFromString :: String -> Doc
stFromString = String -> Doc
PP.text
    stToString :: Doc -> String
stToString = Doc -> String
PP.render
    mconcatMap :: [b] -> (b -> Doc) -> Doc
mconcatMap [b]
m b -> Doc
k = [Doc] -> Doc
PP.fcat ([Doc] -> Doc) -> ([b] -> [Doc]) -> [b] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> Doc) -> [b] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map b -> Doc
k ([b] -> Doc) -> [b] -> Doc
forall a b. (a -> b) -> a -> b
$ [b]
m
    mintercalate :: Doc -> [Doc] -> Doc
mintercalate = ([Doc] -> Doc
PP.fcat ([Doc] -> Doc) -> ([Doc] -> [Doc]) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) (([Doc] -> [Doc]) -> [Doc] -> Doc)
-> (Doc -> [Doc] -> [Doc]) -> Doc -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
PP.punctuate
    mlabel :: Doc -> Doc -> Doc
mlabel Doc
x Doc
y = Doc
x Doc -> Doc -> Doc
PP.$$ Int -> Doc -> Doc
PP.nest Int
1 Doc
y

instance Stringable B.ByteString where
    stFromString :: String -> ByteString
stFromString = String -> ByteString
B.pack
    stFromByteString :: ByteString -> ByteString
stFromByteString = [ByteString] -> ByteString
B.concat ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
LB.toChunks
    stToString :: ByteString -> String
stToString = ByteString -> String
B.unpack

instance Stringable LB.ByteString where
    stFromString :: String -> ByteString
stFromString = String -> ByteString
LB.pack
    stFromByteString :: ByteString -> ByteString
stFromByteString = ByteString -> ByteString
forall a. a -> a
id
    stToString :: ByteString -> String
stToString = ByteString -> String
LB.unpack

instance Stringable T.Text where
    stFromString :: String -> Text
stFromString = String -> Text
T.pack
    stFromByteString :: ByteString -> Text
stFromByteString = ByteString -> Text
T.decodeUtf8 (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
B.concat ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
LB.toChunks
    stFromText :: Text -> Text
stFromText = Text -> Text
LT.toStrict
    stToString :: Text -> String
stToString = Text -> String
T.unpack

instance Stringable LT.Text where
    stFromString :: String -> Text
stFromString = String -> Text
LT.pack
    stFromByteString :: ByteString -> Text
stFromByteString = ByteString -> Text
LT.decodeUtf8
    stFromText :: Text -> Text
stFromText = Text -> Text
forall a. a -> a
id
    stToString :: Text -> String
stToString = Text -> String
LT.unpack

instance Stringable BB.Builder where
    stFromString :: String -> Builder
stFromString = String -> Builder
BB.fromString
    stFromByteString :: ByteString -> Builder
stFromByteString = ByteString -> Builder
BB.fromLazyByteString
    stToString :: Builder -> String
stToString = ByteString -> String
LB.unpack (ByteString -> String)
-> (Builder -> ByteString) -> Builder -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
BB.toLazyByteString

{-
instance Stringable LBB.Builder where
    stFromString = stringUtf8
    stFromByteString = LBB.lazyByteString
    stToString = LB.unpack . LBB.toLazyByteString
-}

instance Stringable TB.Builder where
    stFromString :: String -> Builder
stFromString = String -> Builder
TB.fromString
    stFromText :: Text -> Builder
stFromText = Text -> Builder
TB.fromLazyText
    stToString :: Builder -> String
stToString = Text -> String
LT.unpack (Text -> String) -> (Builder -> Text) -> Builder -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
TB.toLazyText


--add dlist instance
instance Stringable (Endo String) where
    stFromString :: String -> Endo String
stFromString = ShowS -> Endo String
forall a. (a -> a) -> Endo a
Endo (ShowS -> Endo String)
-> (String -> ShowS) -> String -> Endo String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. [a] -> [a] -> [a]
(++)
    stToString :: Endo String -> String
stToString = (ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ []) (ShowS -> String)
-> (Endo String -> ShowS) -> Endo String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Endo String -> ShowS
forall a. Endo a -> a -> a
appEndo