-- | 

module Reflex.Dom.TH
  (dom, domFile, merge)
where


import Text.Megaparsec.Error

import Language.Haskell.TH.Quote
import Language.Haskell.TH
import Language.Haskell.TH.Syntax

import Reflex.Dom.TH.Parser
import Reflex.Dom.Widget.Basic 
import qualified Data.Map as M
import Data.Map (Map)
--import Data.Maybe
import Data.List (insert)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Array

type Ref = Int
data CElement = CElement { CElement -> String
cTag :: String
                         , CElement -> [Ref]
cSiblingsRefs :: [Ref]
                         , CElement -> [Ref]
cChildRefs :: [Ref]
                         , CElement -> [Ref]
cOutRefs :: [Ref]
                         , CElement -> Maybe Ref
cMyRef :: Maybe Ref
                         , CElement -> [(String, String)]
cAttrs :: [(String, String)]
                         , CElement -> [CElement]
cChilds :: [CElement] }
               | CText String
               | CComment String
               | CWidget String
               deriving Ref -> CElement -> ShowS
[CElement] -> ShowS
CElement -> String
(Ref -> CElement -> ShowS)
-> (CElement -> String) -> ([CElement] -> ShowS) -> Show CElement
forall a.
(Ref -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CElement] -> ShowS
$cshowList :: [CElement] -> ShowS
show :: CElement -> String
$cshow :: CElement -> String
showsPrec :: Ref -> CElement -> ShowS
$cshowsPrec :: Ref -> CElement -> ShowS
Show

merge :: Ord a => [a] -> [a] -> [a]
merge :: [a] -> [a] -> [a]
merge [a]
a [] = [a]
a
merge [] [a]
b = [a]
b
merge  a :: [a]
a@(a
ah:[a]
at) b :: [a]
b@(a
bh:[a]
bt)
  | a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
ah a
bh Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
GT = a
bh a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [a]
forall a. Ord a => [a] -> [a] -> [a]
merge [a]
a [a]
bt
  | Bool
otherwise = a
ah a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [a]
forall a. Ord a => [a] -> [a] -> [a]
merge [a]
at [a]
b


--  do (r1, (r1a, r1b)) <- el1 $ el1a >>= \ r1a -> el1b >>= \r1b -> return (r1a, r1b)



compile :: [TElement] -> [CElement] -> [Ref] -> ([CElement], [Ref])
compile :: [TElement] -> [CElement] -> [Ref] -> ([CElement], [Ref])
compile [] [CElement]
acc [Ref]
inRefs = ([CElement] -> [CElement]
forall a. [a] -> [a]
reverse [CElement]
acc, [Ref]
inRefs)
compile ((TElement {String
[Attribute]
[TElement]
Maybe Ref
tChilds :: TElement -> [TElement]
tAttrs :: TElement -> [Attribute]
tRef :: TElement -> Maybe Ref
tTag :: TElement -> String
tChilds :: [TElement]
tAttrs :: [Attribute]
tRef :: Maybe Ref
tTag :: String
..}):[TElement]
etail) [CElement]
acc [Ref]
inRefs =
      [TElement] -> [CElement] -> [Ref] -> ([CElement], [Ref])
compile [TElement]
etail (CElement
elem'CElement -> [CElement] -> [CElement]
forall a. a -> [a] -> [a]
:[CElement]
acc) [Ref]
expRefs
  where
    elem' :: CElement
elem' = String
-> [Ref]
-> [Ref]
-> [Ref]
-> Maybe Ref
-> [(String, String)]
-> [CElement]
-> CElement
CElement String
tTag [Ref]
inRefs [Ref]
childRefs [Ref]
outRefs Maybe Ref
tRef [(String, String)]
attrs [CElement]
childs
    ([CElement]
childs, [Ref]
childRefs) = [TElement] -> [CElement] -> [Ref] -> ([CElement], [Ref])
compile [TElement]
tChilds [] []
    outRefs :: [Ref]
outRefs = ([Ref] -> [Ref])
-> (Ref -> [Ref] -> [Ref]) -> Maybe Ref -> [Ref] -> [Ref]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Ref] -> [Ref]
forall a. a -> a
id Ref -> [Ref] -> [Ref]
forall a. Ord a => a -> [a] -> [a]
insert Maybe Ref
tRef [Ref]
childRefs
    expRefs :: [Ref]
expRefs = [Ref] -> [Ref] -> [Ref]
forall a. Ord a => [a] -> [a] -> [a]
merge [Ref]
inRefs [Ref]
outRefs
    attrs :: [(String, String)]
attrs = [ (String
k, String
v) | (AttributeType
Static, String
k, String
v) <- [Attribute]
tAttrs ]
compile (TElement
elem:[TElement]
etail) [CElement]
acc [Ref]
inRefs =
      [TElement] -> [CElement] -> [Ref] -> ([CElement], [Ref])
compile [TElement]
etail (TElement -> CElement
toC TElement
elem CElement -> [CElement] -> [CElement]
forall a. a -> [a] -> [a]
: [CElement]
acc) [Ref]
inRefs
  where
    toC :: TElement -> CElement
toC (TText String
text) = String -> CElement
CText String
text
    toC (TComment String
comment) = String -> CElement
CComment String
comment
    toC (TWidget String
widget) = String -> CElement
CWidget String
widget
    toC TElement
_ = CElement
forall a. HasCallStack => a
undefined
                           


opt :: (Ref -> Name) -> Maybe Ref -> Q Pat
opt :: (Ref -> Name) -> Maybe Ref -> Q Pat
opt Ref -> Name
var = Q Pat -> (Ref -> Q Pat) -> Maybe Ref -> Q Pat
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Q Pat -> Q Pat
forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [p| () |]) ((Ref -> Q Pat) -> Maybe Ref -> Q Pat)
-> (Ref -> Q Pat) -> Maybe Ref -> Q Pat
forall a b. (a -> b) -> a -> b
$ Name -> Q Pat
varP (Name -> Q Pat) -> (Ref -> Name) -> Ref -> Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ref -> Name
var

clambda :: (Ref -> Name) -> Maybe Ref -> [Ref] -> ExpQ -> ExpQ
clambda Ref -> Name
var Maybe Ref
Nothing [Ref]
crefs   =  [Q Pat] -> ExpQ -> ExpQ
lamE [[Q Pat] -> Q Pat
tupP ([Q Pat] -> Q Pat) -> [Q Pat] -> Q Pat
forall a b. (a -> b) -> a -> b
$ (Ref -> Q Pat) -> [Ref] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Q Pat
varP (Name -> Q Pat) -> (Ref -> Name) -> Ref -> Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ref -> Name
var) [Ref]
crefs ]
clambda Ref -> Name
var Maybe Ref
mref [Ref]
crefs =  [Q Pat] -> ExpQ -> ExpQ
lamE [[Q Pat] -> Q Pat
tupP [ (Ref -> Name) -> Maybe Ref -> Q Pat
opt Ref -> Name
var Maybe Ref
mref
                           , [Q Pat] -> Q Pat
tupP ([Q Pat] -> Q Pat) -> [Q Pat] -> Q Pat
forall a b. (a -> b) -> a -> b
$ (Ref -> Q Pat) -> [Ref] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Q Pat
varP (Name -> Q Pat) -> (Ref -> Name) -> Ref -> Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ref -> Name
var) [Ref]
crefs]]


cnodes :: (Ref -> Name) -> [CElement] ->  ExpQ
cnodes :: (Ref -> Name) -> [CElement] -> ExpQ
cnodes Ref -> Name
_ []  = [| blank |]
cnodes Ref -> Name
var [elem :: CElement
elem@(CElement String
_ [Ref]
_ [Ref]
crefs [Ref]
orefs Maybe Ref
mref [(String, String)]
_ [CElement]
_)]  
    | [Ref] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Ref]
orefs = [| $(cnode var elem) |]
    | Bool
otherwise = [| $(cnode var elem) >>=  $(clambda var mref crefs                                                                                        (appE (varE 'return) (tupE $ map (varE . var) orefs))) |]
cnodes Ref -> Name
var (elem :: CElement
elem@(CElement String
_ [Ref]
_ [Ref]
crefs [Ref]
orefs Maybe Ref
mref [(String, String)]
_ [CElement]
_):[CElement]
rest)  = [| $(cnode var elem) >>=  $(clambda var mref crefs (cnodes var rest)) |]
                                                         
cnodes  Ref -> Name
var [CElement
elem] = (Ref -> Name) -> CElement -> ExpQ
cnode Ref -> Name
var CElement
elem
cnodes Ref -> Name
var (CElement
h:[CElement]
t)  = [|  $(cnode var h) >> $(cnodes var t) |]

cnode :: (Ref -> Name) -> CElement -> ExpQ
cnode :: (Ref -> Name) -> CElement -> ExpQ
cnode Ref -> Name
var (CElement String
tag [Ref]
_ [Ref]
_ [Ref]
_ Maybe Ref
Nothing [(String, String)]
attr [CElement]
childs) = [|  elAttr tag (M.fromList attr) $(cnodes var childs)|]
cnode Ref -> Name
var (CElement String
tag [Ref]
_ [Ref]
_ [Ref]
_ (Just Ref
_) [(String, String)]
attr [CElement]
childs) = [|  elAttr' tag (M.fromList attr) $(cnodes var childs) |]
cnode Ref -> Name
_ (CText String
"") = [| blank |]
cnode Ref -> Name
_ (CText String
txt) = [| text txt |]
cnode Ref -> Name
_ (CWidget String
x) = Name -> ExpQ
unboundVarE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
x
cnode Ref -> Name
_ (CComment String
txt) = [| comment txt |]

domExp :: [TElement] -> Q Exp
domExp :: [TElement] -> ExpQ
domExp [TElement]
result =
  let ([CElement]
cns, [Ref]
out) = [TElement] -> [CElement] -> [Ref] -> ([CElement], [Ref])
compile [TElement]
result [] [] in do
    Array Ref Name
varNames <-  (Ref, Ref) -> [Name] -> Array Ref Name
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Ref
0, [Ref] -> Ref
forall (t :: * -> *) a. Foldable t => t a -> Ref
length [Ref]
out) ([Name] -> Array Ref Name) -> Q [Name] -> Q (Array Ref Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ref -> Q Name) -> [Ref] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ Ref
r -> String -> Q Name
newName (String
"r" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Ref -> String
forall a. Show a => a -> String
show Ref
r)) [Ref]
out
    (Ref -> Name) -> [CElement] -> ExpQ
cnodes (Array Ref Name
varNames Array Ref Name -> Ref -> Name
forall i e. Ix i => Array i e -> i -> e
!) [CElement]
cns

dom :: QuasiQuoter
dom :: QuasiQuoter
dom = QuasiQuoter :: (String -> ExpQ)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
  { quoteExp :: String -> ExpQ
quoteExp  = \String
str ->
      case String
-> String -> Either (ParseErrorBundle String Void) [TElement]
parseTemplate String
"" String
str of
        Left ParseErrorBundle String Void
err -> String -> ExpQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ExpQ) -> String -> ExpQ
forall a b. (a -> b) -> a -> b
$ ParseErrorBundle String Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty ParseErrorBundle String Void
err
        Right [TElement]
result -> [TElement] -> ExpQ
domExp [TElement]
result
  , quotePat :: String -> Q Pat
quotePat  = String -> String -> Q Pat
forall a. HasCallStack => String -> a
error String
"Usage as a parttern is not supported"
  , quoteType :: String -> Q Type
quoteType = String -> String -> Q Type
forall a. HasCallStack => String -> a
error String
"Usage as a type is not supported"
  , quoteDec :: String -> Q [Dec]
quoteDec = String -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error String
"Usage as a decl is not supported"

  }


domFile :: FilePath -> Q Exp
domFile :: String -> ExpQ
domFile String
path = do
  String
str <- IO String -> Q String
forall a. IO a -> Q a
runIO (String -> IO String
readFile String
path)
  String -> Q ()
addDependentFile String
path
  case String
-> String -> Either (ParseErrorBundle String Void) [TElement]
parseTemplate String
path String
str of
        Left ParseErrorBundle String Void
err -> String -> ExpQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ExpQ) -> String -> ExpQ
forall a b. (a -> b) -> a -> b
$ ParseErrorBundle String Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty ParseErrorBundle String Void
err
        Right [TElement]
result  ->  [TElement] -> ExpQ
domExp [TElement]
result