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

-- |Module `Format` include types of so called "formats" and methods for work
--  with them.
--
--  Format is object for simple pattern matching and generating strings by
--  template.
module Format (
    SimpleFormat,
    TaggedFormat,
    MultiFormat,
    MaybeFormat(..),
    isFormat,
    MaybeSimpleFormat,
    MaybeTaggedFormat,
    format,
    apply,
    format2str,
    match,
  ) where

import Data.List (isPrefixOf, isSuffixOf, intercalate)
import Data.Function ((&))
import Data.Maybe (isJust)
import Control.Applicative ((<|>))

data SimpleFormat = SimpleFormat String String

data TaggedFormat = TaggedFormat String String String

unTagged :: TaggedFormat -> SimpleFormat
unTagged :: TaggedFormat -> SimpleFormat
unTagged (TaggedFormat String
st String
_ String
fn) = String -> String -> SimpleFormat
SimpleFormat String
st String
fn

newtype MultiFormat = MultiFormat [String]

data MaybeFormat f =
      JustFormat f
    | JustString String

isFormat :: MaybeFormat f -> Bool
isFormat :: MaybeFormat f -> Bool
isFormat (JustFormat f
_) = Bool
True
isFormat MaybeFormat f
_ = Bool
False

type MaybeSimpleFormat = MaybeFormat SimpleFormat

type MaybeTaggedFormat = MaybeFormat TaggedFormat

class Format f where
    format_ :: MonadFail m => Char -> Char -> String -> m f

instance Format SimpleFormat where
    format_ :: Char -> Char -> String -> m SimpleFormat
format_ Char
op Char
cp = String -> String -> m SimpleFormat
forall (m :: * -> *).
MonadFail m =>
String -> String -> m SimpleFormat
go String
"" where
        go :: String -> String -> m SimpleFormat
go String
acc (Char
op':Char
cp':String
cs) | Char
op' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
op Bool -> Bool -> Bool
&& Char
cp' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
cp =
            SimpleFormat -> m SimpleFormat
forall (m :: * -> *) a. Monad m => a -> m a
return (SimpleFormat -> m SimpleFormat) -> SimpleFormat -> m SimpleFormat
forall a b. (a -> b) -> a -> b
$ String -> String -> SimpleFormat
SimpleFormat (String -> String
forall a. [a] -> [a]
reverse String
acc) String
cs
        go String
acc (Char
c:String
cs) = String -> String -> m SimpleFormat
go (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
acc) String
cs
        go String
_ String
"" = String -> m SimpleFormat
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m SimpleFormat) -> String -> m SimpleFormat
forall a b. (a -> b) -> a -> b
$
            String
"SimpleFormat must contain \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
op, Char
cp] String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" substring"

instance Format TaggedFormat where
    format_ :: Char -> Char -> String -> m TaggedFormat
format_ Char
op Char
cp = Bool -> String -> String -> String -> m TaggedFormat
forall (m :: * -> *).
MonadFail m =>
Bool -> String -> String -> String -> m TaggedFormat
go Bool
False String
"" String
"" where
        go :: Bool -> String -> String -> String -> m TaggedFormat
go Bool
False String
acc1 String
acc2 (Char
op':String
cs) | Char
op' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
op =
            Bool -> String -> String -> String -> m TaggedFormat
go Bool
True String
acc1 String
acc2 String
cs
        go Bool
True String
acc1 String
acc2 (Char
cp':String
cs) | Char
cp' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
cp =
            TaggedFormat -> m TaggedFormat
forall (m :: * -> *) a. Monad m => a -> m a
return (TaggedFormat -> m TaggedFormat) -> TaggedFormat -> m TaggedFormat
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> TaggedFormat
TaggedFormat (String -> String
forall a. [a] -> [a]
reverse String
acc1) (String -> String
forall a. [a] -> [a]
reverse String
acc2) String
cs
        go Bool
False String
acc1 String
acc2 (Char
c:String
cs) = Bool -> String -> String -> String -> m TaggedFormat
go Bool
False (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
acc1) String
acc2 String
cs
        go Bool
True String
acc1 String
acc2 (Char
c:String
cs) = Bool -> String -> String -> String -> m TaggedFormat
go Bool
True  String
acc1 (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
acc2) String
cs
        go Bool
_ String
_ String
_ String
_ = String -> m TaggedFormat
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m TaggedFormat) -> String -> m TaggedFormat
forall a b. (a -> b) -> a -> b
$
            String
"TaggedFormat must contain substring surrounded by '" String -> String -> String
forall a. [a] -> [a] -> [a]
++
            [Char
op] String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' and '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
cp] String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' chars"

instance Format MultiFormat where
    format_ :: Char -> Char -> String -> m MultiFormat
format_ Char
op Char
cp = ([String] -> MultiFormat) -> m [String] -> m MultiFormat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [String] -> MultiFormat
MultiFormat (m [String] -> m MultiFormat)
-> (String -> m [String]) -> String -> m MultiFormat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> m [String]
forall (m :: * -> *). MonadFail m => String -> String -> m [String]
go String
"" where
        go :: String -> String -> m [String]
go String
_ (Char
op1:Char
cp1:Char
op2:Char
cp2:String
_)
            | Char
op1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
op Bool -> Bool -> Bool
&& Char
cp1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
cp Bool -> Bool -> Bool
&& Char
op2 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
op Bool -> Bool -> Bool
&& Char
cp2 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
cp =
                String -> m [String]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m [String]) -> String -> m [String]
forall a b. (a -> b) -> a -> b
$
                    String
"MultiFormat mustn't contain \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                    [Char
op, Char
cp, Char
op, Char
cp] String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" substring"
        go String
acc (Char
op':Char
cp':String
cs)
            | Char
op' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
op Bool -> Bool -> Bool
&& Char
cp' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
cp = (String -> String
forall a. [a] -> [a]
reverse String
acc String -> [String] -> [String]
forall a. a -> [a] -> [a]
:) ([String] -> [String]) -> m [String] -> m [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> String -> m [String]
go String
"" String
cs
        go String
acc (Char
c:String
cs) = String -> String -> m [String]
go (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
acc) String
cs
        go String
acc String
"" = [String] -> m [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> String
forall a. [a] -> [a]
reverse String
acc]

instance Format f => Format (MaybeFormat f) where
    format_ :: Char -> Char -> String -> m (MaybeFormat f)
format_ Char
op Char
cp String
s = MaybeFormat f -> m (MaybeFormat f)
forall (m :: * -> *) a. Monad m => a -> m a
return (MaybeFormat f -> m (MaybeFormat f))
-> MaybeFormat f -> m (MaybeFormat f)
forall a b. (a -> b) -> a -> b
$
        case Char -> Char -> String -> Maybe f
forall f (m :: * -> *).
(Format f, MonadFail m) =>
Char -> Char -> String -> m f
format_ Char
op Char
cp String
s of
            Just f
f  -> f -> MaybeFormat f
forall f. f -> MaybeFormat f
JustFormat f
f
            Maybe f
Nothing -> String -> MaybeFormat f
forall f. String -> MaybeFormat f
JustString String
s

format :: (Format f, MonadFail m) => String -> m f
format :: String -> m f
format = Char -> Char -> String -> m f
forall f (m :: * -> *).
(Format f, MonadFail m) =>
Char -> Char -> String -> m f
format_ Char
'{' Char
'}'

class Format f => Apply f i where
    apply :: f -> i -> String

instance Apply SimpleFormat String where
    apply :: SimpleFormat -> String -> String
apply (SimpleFormat String
st String
fn) String
s = String
st String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fn

instance Apply TaggedFormat String where
    apply :: TaggedFormat -> String -> String
apply TaggedFormat
f String
s = SimpleFormat -> String -> String
forall f i. Apply f i => f -> i -> String
apply (TaggedFormat -> SimpleFormat
unTagged TaggedFormat
f) String
s

instance Apply TaggedFormat () where
    apply :: TaggedFormat -> () -> String
apply (TaggedFormat String
st String
md String
fn) () = String
st String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
md String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fn

instance Apply MultiFormat [String] where
    apply :: MultiFormat -> [String] -> String
apply (MultiFormat [String]
ss) [String]
ss' = (String -> String -> String) -> String -> [String] -> String
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr String -> String -> String
forall a. [a] -> [a] -> [a]
(++) String
"" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> String -> String) -> [String] -> [String] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith String -> String -> String
forall a. [a] -> [a] -> [a]
(++) [String]
ss ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [String]
ss' [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ String -> [String]
forall a. a -> [a]
repeat String
""

instance Apply f i => Apply (MaybeFormat f) i where
    apply :: MaybeFormat f -> i -> String
apply (JustFormat f
f) i
s = f -> i -> String
forall f i. Apply f i => f -> i -> String
apply f
f i
s
    apply (JustString String
s) i
_ = String
s

format2str :: Apply f () => f -> String
format2str :: f -> String
format2str = (f -> () -> String) -> () -> f -> String
forall a b c. (a -> b -> c) -> b -> a -> c
flip f -> () -> String
forall f i. Apply f i => f -> i -> String
apply ()

class Format f => Match f r where
    match :: f -> String -> r

instance Match SimpleFormat Bool where
    match :: SimpleFormat -> String -> Bool
match (SimpleFormat String
st String
fn) String
s =
        String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
st String
s Bool -> Bool -> Bool
&&
        String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isSuffixOf String
fn String
s Bool -> Bool -> Bool
&&
        String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
st Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
fn

instance MonadFail m => Match SimpleFormat (m String) where
    match :: SimpleFormat -> String -> m String
match f :: SimpleFormat
f@(SimpleFormat String
st String
fn) String
s =
        if SimpleFormat -> String -> Bool
forall f r. Match f r => f -> String -> r
match SimpleFormat
f String
s
        then String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
drop (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
st) (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
take (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
fn) String
s
        else String -> m String
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$
            String
"Can't match string \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" with format \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++
            String
st String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"{...}" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\""

instance Match SimpleFormat a => Match TaggedFormat a where
    match :: TaggedFormat -> String -> a
match TaggedFormat
f String
s = SimpleFormat -> String -> a
forall f r. Match f r => f -> String -> r
match (TaggedFormat -> SimpleFormat
unTagged TaggedFormat
f) String
s

instance Match MultiFormat (Maybe [String]) where
    match :: MultiFormat -> String -> Maybe [String]
match (MultiFormat [String]
ss) String
s =
        Maybe String -> String -> [String] -> Maybe [String]
go Maybe String
forall a. Maybe a
Nothing String
s [String]
ss Maybe [String]
-> (Maybe [String] -> Maybe [String]) -> Maybe [String]
forall a b. a -> (a -> b) -> b
& (
            (Maybe [String]
 -> ([String] -> Maybe [String])
 -> Maybe [String]
 -> Maybe [String])
-> ([String] -> Maybe [String])
-> Maybe [String]
-> Maybe [String]
-> Maybe [String]
forall a b c. (a -> b -> c) -> b -> a -> c
flip Maybe [String]
-> ([String] -> Maybe [String]) -> Maybe [String] -> Maybe [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [String] -> Maybe [String]
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [String] -> Maybe [String] -> Maybe [String])
-> Maybe [String] -> Maybe [String] -> Maybe [String]
forall a b. (a -> b) -> a -> b
$ String -> Maybe [String]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Maybe [String]) -> String -> Maybe [String]
forall a b. (a -> b) -> a -> b
$
                String
"Can't match string \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" with format \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"{...}" [String]
ss String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\""
          ) where
            go :: Maybe String -> String -> [String] -> Maybe [String]
go Maybe String
_ String
"" [String
""] = [String] -> Maybe [String]
forall a. a -> Maybe a
Just []
            go Maybe String
_ String
"" [String]
_ = Maybe [String]
forall a. Maybe a
Nothing
            go Maybe String
Nothing (Char
c:String
cs) ((Char
c':String
cs'):[String]
ss')
                | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c' = Maybe String -> String -> [String] -> Maybe [String]
go Maybe String
forall a. Maybe a
Nothing String
cs (String
cs'String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
ss')
                | Bool
otherwise = Maybe [String]
forall a. Maybe a
Nothing
            go Maybe String
Nothing String
cs (String
"":String
s':[String]
ss') = Maybe String -> String -> [String] -> Maybe [String]
go (String -> Maybe String
forall a. a -> Maybe a
Just String
"") String
cs (String
s'String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
ss')
            go Maybe String
Nothing String
_ [String
""] = Maybe [String]
forall a. Maybe a
Nothing
            go (Just String
acc) (Char
c:String
cs) [String]
ss' =
                (String -> String
forall a. [a] -> [a]
reverse String
acc String -> [String] -> [String]
forall a. a -> [a] -> [a]
:) ([String] -> [String]) -> Maybe [String] -> Maybe [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String -> String -> [String] -> Maybe [String]
go Maybe String
forall a. Maybe a
Nothing (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
cs) [String]
ss'
                  Maybe [String] -> Maybe [String] -> Maybe [String]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
                Maybe String -> String -> [String] -> Maybe [String]
go (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
acc) String
cs [String]
ss'
            go Maybe String
_ String
_ [String]
_ = Maybe [String]
forall a. Maybe a
Nothing

instance Match MultiFormat Bool where
    match :: MultiFormat -> String -> Bool
match MultiFormat
f String
s = Maybe [String] -> Bool
forall a. Maybe a -> Bool
isJust (MultiFormat -> String -> Maybe [String]
forall f r. Match f r => f -> String -> r
match MultiFormat
f String
s :: Maybe [String])

instance Match f Bool => Match (MaybeFormat f) Bool where
    match :: MaybeFormat f -> String -> Bool
match (JustFormat f
f) String
s = f -> String -> Bool
forall f r. Match f r => f -> String -> r
match f
f String
s
    match (JustString String
s') String
s = String
s' String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
s

instance (MonadFail m, Match f (m String)) => Match (MaybeFormat f) (m String) where
    match :: MaybeFormat f -> String -> m String
match (JustFormat f
f) String
s = f -> String -> m String
forall f r. Match f r => f -> String -> r
match f
f String
s
    match (JustString String
s') String
s =
        if String
s' String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
s
        then String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
        else String -> m String
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ 
            String
"Can't match string \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" with format \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\""