-- | 

module Reflex.Dom.TH.Parser
( TElement(..),
  parseTemplate
  )
where

import Data.Char
import Data.List


import Text.Megaparsec
import Text.Megaparsec.Char
import qualified Text.Megaparsec.Char.Lexer as L 
import Data.Void
import Control.Monad
import Language.Haskell.TH.Syntax

type Parser = Parsec Void String
type TTag = String
type Attribute = (String, String)
type Ref = Int
data TElement = TElement { TElement -> TTag
tTag :: TTag
                         , TElement -> Maybe Ref
tRef :: Maybe Ref
                         , TElement -> [Attribute]
tAttrs :: [Attribute]
                         , TElement -> Maybe TTag
tDynAttrs :: Maybe String
                         , TElement -> [TElement]
tChilds :: [TElement] }
               | TText String
               | TComment String
               | TWidget String (Maybe Ref)
               deriving Ref -> TElement -> ShowS
[TElement] -> ShowS
TElement -> TTag
(Ref -> TElement -> ShowS)
-> (TElement -> TTag) -> ([TElement] -> ShowS) -> Show TElement
forall a.
(Ref -> a -> ShowS) -> (a -> TTag) -> ([a] -> ShowS) -> Show a
showList :: [TElement] -> ShowS
$cshowList :: [TElement] -> ShowS
show :: TElement -> TTag
$cshow :: TElement -> TTag
showsPrec :: Ref -> TElement -> ShowS
$cshowsPrec :: Ref -> TElement -> ShowS
Show

refOpt :: Parser (Maybe Int)
refOpt :: Parser (Maybe Ref)
refOpt = ParsecT Void TTag Identity Ref -> Parser (Maybe Ref)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ParsecT Void TTag Identity Ref -> Parser (Maybe Ref))
-> (ParsecT Void TTag Identity Ref
    -> ParsecT Void TTag Identity Ref)
-> ParsecT Void TTag Identity Ref
-> Parser (Maybe Ref)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT Void TTag Identity Ref -> ParsecT Void TTag Identity Ref
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT Void TTag Identity Ref -> Parser (Maybe Ref))
-> ParsecT Void TTag Identity Ref -> Parser (Maybe Ref)
forall a b. (a -> b) -> a -> b
$ do
      ParsecT Void TTag Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space1
      ParsecT Void TTag Identity Char -> ParsecT Void TTag Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void TTag Identity Char -> ParsecT Void TTag Identity ())
-> ParsecT Void TTag Identity Char -> ParsecT Void TTag Identity ()
forall a b. (a -> b) -> a -> b
$ Token TTag -> ParsecT Void TTag Identity (Token TTag)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token TTag
'#'
      ParsecT Void TTag Identity Ref
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
L.decimal ParsecT Void TTag Identity Ref
-> ParsecT Void TTag Identity () -> ParsecT Void TTag Identity Ref
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void TTag Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space

openTag :: Parser (String, [TElement] -> TElement)
openTag :: Parser (TTag, [TElement] -> TElement)
openTag =  
     ParsecT Void TTag Identity Char
-> ParsecT Void TTag Identity Char
-> Parser (TTag, [TElement] -> TElement)
-> Parser (TTag, [TElement] -> TElement)
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Token TTag -> ParsecT Void TTag Identity (Token TTag)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token TTag
'<') (Token TTag -> ParsecT Void TTag Identity (Token TTag)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token TTag
'>') (Parser (TTag, [TElement] -> TElement)
 -> Parser (TTag, [TElement] -> TElement))
-> Parser (TTag, [TElement] -> TElement)
-> Parser (TTag, [TElement] -> TElement)
forall a b. (a -> b) -> a -> b
$ do
       TTag
tag <- ParsecT Void TTag Identity Char -> ParsecT Void TTag Identity TTag
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (ParsecT Void TTag Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
alphaNumChar ParsecT Void TTag Identity Char
-> ParsecT Void TTag Identity Char
-> ParsecT Void TTag Identity Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token TTag -> ParsecT Void TTag Identity (Token TTag)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token TTag
'-')
       Maybe Ref
ref <- Parser (Maybe Ref)
refOpt
       ParsecT Void TTag Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
       [Attribute]
attrs <- Parser [Attribute]
attributes
       ParsecT Void TTag Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
       Maybe TTag
dynAttr <- ParsecT Void TTag Identity TTag
-> ParsecT Void TTag Identity (Maybe TTag)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ParsecT Void TTag Identity TTag
varRef
       (TTag, [TElement] -> TElement)
-> Parser (TTag, [TElement] -> TElement)
forall (m :: * -> *) a. Monad m => a -> m a
return ((TTag, [TElement] -> TElement)
 -> Parser (TTag, [TElement] -> TElement))
-> (TTag, [TElement] -> TElement)
-> Parser (TTag, [TElement] -> TElement)
forall a b. (a -> b) -> a -> b
$ (TTag
tag, TTag
-> Maybe Ref -> [Attribute] -> Maybe TTag -> [TElement] -> TElement
TElement TTag
tag Maybe Ref
ref [Attribute]
attrs Maybe TTag
dynAttr)

closeTag :: String -> Parser ()
closeTag :: TTag -> ParsecT Void TTag Identity ()
closeTag TTag
tag = ParsecT Void TTag Identity () -> ParsecT Void TTag Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void TTag Identity () -> ParsecT Void TTag Identity ())
-> ParsecT Void TTag Identity () -> ParsecT Void TTag Identity ()
forall a b. (a -> b) -> a -> b
$ ParsecT Void TTag Identity ()
-> ParsecT Void TTag Identity Char
-> ParsecT Void TTag Identity ()
-> ParsecT Void TTag Identity ()
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Tokens TTag -> ParsecT Void TTag Identity (Tokens TTag)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens TTag
"</" ParsecT Void TTag Identity TTag
-> ParsecT Void TTag Identity () -> ParsecT Void TTag Identity ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT Void TTag Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space) (Token TTag -> ParsecT Void TTag Identity (Token TTag)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token TTag
'>') (Tokens TTag -> ParsecT Void TTag Identity (Tokens TTag)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string TTag
Tokens TTag
tag ParsecT Void TTag Identity TTag
-> ParsecT Void TTag Identity () -> ParsecT Void TTag Identity ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT Void TTag Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space)

comment :: Parser TElement
comment :: Parser TElement
comment = TTag -> TElement
TComment (TTag -> TElement)
-> ParsecT Void TTag Identity TTag -> Parser TElement
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Tokens TTag -> ParsecT Void TTag Identity (Tokens TTag)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens TTag
"<!--") ParsecT Void TTag Identity TTag
-> ParsecT Void TTag Identity TTag
-> ParsecT Void TTag Identity TTag
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (ParsecT Void TTag Identity Char
-> ParsecT Void TTag Identity TTag
-> ParsecT Void TTag Identity TTag
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
manyTill ParsecT Void TTag Identity Char
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle (Tokens TTag -> ParsecT Void TTag Identity (Tokens TTag)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens TTag
"-->")))


stringLiteral :: Parser String
stringLiteral :: ParsecT Void TTag Identity TTag
stringLiteral = Token TTag -> ParsecT Void TTag Identity (Token TTag)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token TTag
'\"' ParsecT Void TTag Identity Char
-> ParsecT Void TTag Identity TTag
-> ParsecT Void TTag Identity TTag
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void TTag Identity Char
-> ParsecT Void TTag Identity Char
-> ParsecT Void TTag Identity TTag
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
manyTill ParsecT Void TTag Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m Char
L.charLiteral (Token TTag -> ParsecT Void TTag Identity (Token TTag)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token TTag
'\"')

attribute :: Parser Attribute
attribute :: Parser Attribute
attribute = (,) (TTag -> TTag -> Attribute)
-> ParsecT Void TTag Identity TTag
-> ParsecT Void TTag Identity (TTag -> Attribute)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>  (ParsecT Void TTag Identity Char -> ParsecT Void TTag Identity TTag
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some (ParsecT Void TTag Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
alphaNumChar ParsecT Void TTag Identity Char
-> ParsecT Void TTag Identity Char
-> ParsecT Void TTag Identity Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token TTag -> ParsecT Void TTag Identity (Token TTag)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token TTag
'-') ParsecT Void TTag Identity TTag
-> ParsecT Void TTag Identity Char
-> ParsecT Void TTag Identity TTag
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Token TTag -> ParsecT Void TTag Identity (Token TTag)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token TTag
'=') ParsecT Void TTag Identity (TTag -> Attribute)
-> ParsecT Void TTag Identity TTag -> Parser Attribute
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void TTag Identity TTag
stringLiteral


attributes :: Parser [Attribute]
attributes :: Parser [Attribute]
attributes = Parser Attribute
-> ParsecT Void TTag Identity () -> Parser [Attribute]
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
sepEndBy Parser Attribute
attribute ParsecT Void TTag Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space1 Parser [Attribute]
-> ParsecT Void TTag Identity () -> Parser [Attribute]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void TTag Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
                     

node :: Parser TElement
node :: Parser TElement
node = do
  (TTag
tag, [TElement] -> TElement
mkElem) <- Parser (TTag, [TElement] -> TElement)
openTag
  ParsecT Void TTag Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
  [TElement]
childs <- Parser TElement
-> ParsecT Void TTag Identity ()
-> ParsecT Void TTag Identity [TElement]
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
manyTill Parser TElement
element (TTag -> ParsecT Void TTag Identity ()
closeTag TTag
tag)
  TElement -> Parser TElement
forall (m :: * -> *) a. Monad m => a -> m a
return (TElement -> Parser TElement) -> TElement -> Parser TElement
forall a b. (a -> b) -> a -> b
$ [TElement] -> TElement
mkElem [TElement]
childs

varName :: Parser String
varName :: ParsecT Void TTag Identity TTag
varName = (:) (Char -> ShowS)
-> ParsecT Void TTag Identity Char
-> ParsecT Void TTag Identity ShowS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void TTag Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
lowerChar ParsecT Void TTag Identity ShowS
-> ParsecT Void TTag Identity TTag
-> ParsecT Void TTag Identity TTag
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void TTag Identity Char -> ParsecT Void TTag Identity TTag
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many ParsecT Void TTag Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
alphaNumChar

varRef :: Parser String
varRef :: ParsecT Void TTag Identity TTag
varRef =  Tokens TTag -> ParsecT Void TTag Identity (Tokens TTag)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens TTag
"{{" ParsecT Void TTag Identity TTag
-> ParsecT Void TTag Identity () -> ParsecT Void TTag Identity ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void TTag Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space ParsecT Void TTag Identity ()
-> ParsecT Void TTag Identity TTag
-> ParsecT Void TTag Identity TTag
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void TTag Identity TTag
varName ParsecT Void TTag Identity TTag
-> ParsecT Void TTag Identity TTag
-> ParsecT Void TTag Identity TTag
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Tokens TTag -> ParsecT Void TTag Identity (Tokens TTag)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens TTag
"}}" ParsecT Void TTag Identity TTag
-> ParsecT Void TTag Identity () -> ParsecT Void TTag Identity TTag
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void TTag Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space

widget :: Parser TElement
widget :: Parser TElement
widget =  TTag -> Maybe Ref -> TElement
TWidget (TTag -> Maybe Ref -> TElement)
-> ParsecT Void TTag Identity TTag
-> ParsecT Void TTag Identity (Maybe Ref -> TElement)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Tokens TTag -> ParsecT Void TTag Identity (Tokens TTag)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens TTag
"{{" ParsecT Void TTag Identity TTag
-> ParsecT Void TTag Identity () -> ParsecT Void TTag Identity ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void TTag Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space ParsecT Void TTag Identity ()
-> ParsecT Void TTag Identity TTag
-> ParsecT Void TTag Identity TTag
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void TTag Identity TTag
varName) ParsecT Void TTag Identity (Maybe Ref -> TElement)
-> Parser (Maybe Ref) -> Parser TElement
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parser (Maybe Ref)
refOpt Parser (Maybe Ref)
-> ParsecT Void TTag Identity TTag -> Parser (Maybe Ref)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (Tokens TTag -> ParsecT Void TTag Identity (Tokens TTag)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens TTag
"}}"))

text :: Parser TElement
text :: Parser TElement
text =  TTag -> TElement
TText (TTag -> TElement) -> ShowS -> TTag -> TElement
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>  (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Char -> Bool
isSpace (TTag -> TElement)
-> ParsecT Void TTag Identity TTag -> Parser TElement
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>  ParsecT Void TTag Identity Char
-> ParsecT Void TTag Identity () -> ParsecT Void TTag Identity TTag
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
someTill ParsecT Void TTag Identity Char
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle (ParsecT Void TTag Identity () -> ParsecT Void TTag Identity ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead (Token TTag -> ParsecT Void TTag Identity (Token TTag)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token TTag
'<' ParsecT Void TTag Identity Char
-> ParsecT Void TTag Identity () -> ParsecT Void TTag Identity ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> () -> ParsecT Void TTag Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return () ParsecT Void TTag Identity ()
-> ParsecT Void TTag Identity () -> ParsecT Void TTag Identity ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tokens TTag -> ParsecT Void TTag Identity (Tokens TTag)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens TTag
"{{" ParsecT Void TTag Identity TTag
-> ParsecT Void TTag Identity () -> ParsecT Void TTag Identity ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> () -> ParsecT Void TTag Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return () ))

element :: Parser TElement     
element :: Parser TElement
element = (Parser TElement
comment Parser TElement -> Parser TElement -> Parser TElement
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>  Parser TElement
node Parser TElement -> Parser TElement -> Parser TElement
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser TElement
widget Parser TElement -> Parser TElement -> Parser TElement
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser TElement
text) Parser TElement -> ParsecT Void TTag Identity () -> Parser TElement
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void TTag Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
  
template :: Parser [TElement]
template :: ParsecT Void TTag Identity [TElement]
template = do
  ParsecT Void TTag Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
  [TElement]
result <- Parser TElement -> ParsecT Void TTag Identity [TElement]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many Parser TElement
element
  ParsecT Void TTag Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof
  [TElement] -> ParsecT Void TTag Identity [TElement]
forall (m :: * -> *) a. Monad m => a -> m a
return [TElement]
result


parseTemplate :: FilePath -> String -> Either (ParseErrorBundle String Void) [TElement]
parseTemplate :: TTag -> TTag -> Either (ParseErrorBundle TTag Void) [TElement]
parseTemplate TTag
fn = ParsecT Void TTag Identity [TElement]
-> TTag -> TTag -> Either (ParseErrorBundle TTag Void) [TElement]
forall e s a.
Parsec e s a -> TTag -> s -> Either (ParseErrorBundle s e) a
runParser ParsecT Void TTag Identity [TElement]
template TTag
fn