-- | 

module Reflex.Dom.TH.Parser
( TElement(..),
  AttributeType(..),
  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
data AttributeType = Static | Dynamic deriving (Int -> AttributeType -> ShowS
[AttributeType] -> ShowS
AttributeType -> String
(Int -> AttributeType -> ShowS)
-> (AttributeType -> String)
-> ([AttributeType] -> ShowS)
-> Show AttributeType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AttributeType] -> ShowS
$cshowList :: [AttributeType] -> ShowS
show :: AttributeType -> String
$cshow :: AttributeType -> String
showsPrec :: Int -> AttributeType -> ShowS
$cshowsPrec :: Int -> AttributeType -> ShowS
Show, AttributeType -> Q Exp
AttributeType -> Q (TExp AttributeType)
(AttributeType -> Q Exp)
-> (AttributeType -> Q (TExp AttributeType)) -> Lift AttributeType
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: AttributeType -> Q (TExp AttributeType)
$cliftTyped :: AttributeType -> Q (TExp AttributeType)
lift :: AttributeType -> Q Exp
$clift :: AttributeType -> Q Exp
Lift)
type Attribute = (AttributeType, String, String)
type Ref = Int
data TElement = TElement { TElement -> String
tTag :: TTag
                         , TElement -> Maybe Int
tRef :: Maybe Ref
                         , TElement -> [Attribute]
tAttrs :: [Attribute]
                         , TElement -> [TElement]
tChilds :: [TElement] }
               | TText String
               | TComment String
               | TWidget String (Maybe Ref)
               deriving Int -> TElement -> ShowS
[TElement] -> ShowS
TElement -> String
(Int -> TElement -> ShowS)
-> (TElement -> String) -> ([TElement] -> ShowS) -> Show TElement
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TElement] -> ShowS
$cshowList :: [TElement] -> ShowS
show :: TElement -> String
$cshow :: TElement -> String
showsPrec :: Int -> TElement -> ShowS
$cshowsPrec :: Int -> TElement -> ShowS
Show

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

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

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

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


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

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


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

node :: Parser TElement
node :: Parser TElement
node = do
  (String
tag, Maybe Int
ref, [Attribute]
attrs) <- Parser (String, Maybe Int, [Attribute])
openTag
  ParsecT Void String Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
  [TElement]
childs <- Parser TElement
-> ParsecT Void String Identity ()
-> ParsecT Void String Identity [TElement]
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
manyTill Parser TElement
element (String -> ParsecT Void String Identity ()
closeTag String
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
$ String -> Maybe Int -> [Attribute] -> [TElement] -> TElement
TElement String
tag Maybe Int
ref [Attribute]
attrs [TElement]
childs

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

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

text :: Parser TElement
text :: Parser TElement
text =  String -> TElement
TText (String -> TElement) -> ShowS -> String -> 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 (String -> TElement)
-> ParsecT Void String Identity String -> Parser TElement
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>  ParsecT Void String Identity Char
-> ParsecT Void String Identity ()
-> ParsecT Void String Identity String
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
someTill ParsecT Void String Identity Char
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle (ParsecT Void String Identity () -> ParsecT Void String Identity ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead (Token String -> ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'<' ParsecT Void String Identity Char
-> ParsecT Void String Identity ()
-> ParsecT Void String Identity ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> () -> ParsecT Void String Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return () ParsecT Void String Identity ()
-> ParsecT Void String Identity ()
-> ParsecT Void String Identity ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tokens String -> ParsecT Void String Identity (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens String
"{{" ParsecT Void String Identity String
-> ParsecT Void String Identity ()
-> ParsecT Void String Identity ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> () -> ParsecT Void String 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 String Identity () -> Parser TElement
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void String Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
  
template :: Parser [TElement]
template :: ParsecT Void String Identity [TElement]
template = do
  ParsecT Void String Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
  [TElement]
result <- Parser TElement -> ParsecT Void String Identity [TElement]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many Parser TElement
element
  ParsecT Void String Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof
  [TElement] -> ParsecT Void String Identity [TElement]
forall (m :: * -> *) a. Monad m => a -> m a
return [TElement]
result


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