-- | 

module Reflex.Dom.TH
  (dom, domFile)
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.List (insert)
import Data.Array

type Ref = Int

data ChildResult =
   CREmpty
 | CRSimple Ref
 | CRTuple (Maybe Ref) [Ref]
 deriving Int -> ChildResult -> ShowS
[ChildResult] -> ShowS
ChildResult -> String
(Int -> ChildResult -> ShowS)
-> (ChildResult -> String)
-> ([ChildResult] -> ShowS)
-> Show ChildResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ChildResult] -> ShowS
$cshowList :: [ChildResult] -> ShowS
show :: ChildResult -> String
$cshow :: ChildResult -> String
showsPrec :: Int -> ChildResult -> ShowS
$cshowsPrec :: Int -> ChildResult -> ShowS
Show

data Chain = CBind CElement ChildResult Chain | CResult [Ref]
  deriving Int -> Chain -> ShowS
[Chain] -> ShowS
Chain -> String
(Int -> Chain -> ShowS)
-> (Chain -> String) -> ([Chain] -> ShowS) -> Show Chain
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Chain] -> ShowS
$cshowList :: [Chain] -> ShowS
show :: Chain -> String
$cshow :: Chain -> String
showsPrec :: Int -> Chain -> ShowS
$cshowsPrec :: Int -> Chain -> ShowS
Show

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


compile :: [TElement] -> [Ref] -> Chain
compile :: [TElement] -> [Int] -> Chain
compile [] [Int]
inRefs = [Int] -> Chain
CResult [Int]
inRefs
compile ((TElement {String
[Attribute]
[TElement]
Maybe Int
tChilds :: TElement -> [TElement]
tAttrs :: TElement -> [Attribute]
tRef :: TElement -> Maybe Int
tTag :: TElement -> String
tChilds :: [TElement]
tAttrs :: [Attribute]
tRef :: Maybe Int
tTag :: String
..}):[TElement]
etail) [Int]
inRefs =
      CElement -> ChildResult -> Chain -> Chain
CBind CElement
elem' (Maybe Int -> [Int] -> ChildResult
CRTuple Maybe Int
tRef [Int]
childRefs) ([TElement] -> [Int] -> Chain
compile [TElement]
etail [Int]
expRefs)
  where
    elem' :: CElement
elem' = String
-> [Int]
-> [Int]
-> [Int]
-> Maybe Int
-> [(String, String)]
-> Chain
-> CElement
CElement String
tTag [Int]
inRefs [Int]
childRefs [Int]
outRefs Maybe Int
tRef [(String, String)]
attrs Chain
childChain
    childChain :: Chain
childChain = [TElement] -> [Int] -> Chain
compile [TElement]
tChilds []
    childRefs :: [Int]
childRefs = Chain -> [Int]
chainOut Chain
childChain
    outRefs :: [Int]
outRefs = ([Int] -> [Int])
-> (Int -> [Int] -> [Int]) -> Maybe Int -> [Int] -> [Int]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Int] -> [Int]
forall a. a -> a
id Int -> [Int] -> [Int]
forall a. Ord a => a -> [a] -> [a]
insert Maybe Int
tRef [Int]
childRefs 
    expRefs :: [Int]
expRefs = [Int] -> [Int] -> [Int]
forall a. Ord a => [a] -> [a] -> [a]
merge [Int]
inRefs [Int]
outRefs
    attrs :: [(String, String)]
attrs = [ (String
k, String
v) | (AttributeType
Static, String
k, String
v) <- [Attribute]
tAttrs ]

compile (TWidget String
w Maybe Int
r:[TElement]
etail)  [Int]
inRefs =   CElement -> ChildResult -> Chain -> Chain
CBind (String -> Maybe Int -> CElement
CWidget String
w Maybe Int
r) (ChildResult -> (Int -> ChildResult) -> Maybe Int -> ChildResult
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ChildResult
CREmpty Int -> ChildResult
CRSimple Maybe Int
r) ([TElement] -> [Int] -> Chain
compile [TElement]
etail [Int]
expRefs)
    where expRefs :: [Int]
expRefs = ([Int] -> [Int])
-> (Int -> [Int] -> [Int]) -> Maybe Int -> [Int] -> [Int]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Int] -> [Int]
forall a. a -> a
id Int -> [Int] -> [Int]
forall a. Ord a => a -> [a] -> [a]
insert Maybe Int
r [Int]
inRefs
compile (TElement
e:[TElement]
etail) [Int]
inRefs =
      CElement -> ChildResult -> Chain -> Chain
CBind (TElement -> CElement
toC TElement
e) ChildResult
CREmpty ([TElement] -> [Int] -> Chain
compile [TElement]
etail [Int]
inRefs)
  where
    toC :: TElement -> CElement
toC (TText String
t) = String -> CElement
CText String
t
    toC (TComment String
c) = String -> CElement
CComment String
c
    toC TElement
_ = String -> CElement
forall a. HasCallStack => String -> a
error String
"internal"
                           


opt :: (Ref -> Name) -> Maybe Ref -> Q Pat
opt :: (Int -> Name) -> Maybe Int -> Q Pat
opt Int -> Name
var = Q Pat -> (Int -> Q Pat) -> Maybe Int -> 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| () |]) ((Int -> Q Pat) -> Maybe Int -> Q Pat)
-> (Int -> Q Pat) -> Maybe Int -> Q Pat
forall a b. (a -> b) -> a -> b
$ Name -> Q Pat
varP (Name -> Q Pat) -> (Int -> Name) -> Int -> Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Name
var

clambda :: (Ref -> Name) -> ChildResult -> ExpQ -> ExpQ
clambda :: (Int -> Name) -> ChildResult -> ExpQ -> ExpQ
clambda Int -> Name
_    ChildResult
CREmpty       =  [Q Pat] -> ExpQ -> ExpQ
lamE [Q Pat
wildP]
clambda Int -> Name
var (CRSimple Int
v)  =  [Q Pat] -> ExpQ -> ExpQ
lamE [[Q Pat] -> Q Pat
tupP [Name -> Q Pat
varP (Name -> Q Pat) -> Name -> Q Pat
forall a b. (a -> b) -> a -> b
$ Int -> Name
var Int
v]]
clambda Int -> Name
var (CRTuple Maybe Int
Nothing [Int]
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
$ (Int -> Q Pat) -> [Int] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Q Pat
varP (Name -> Q Pat) -> (Int -> Name) -> Int -> Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Name
var) [Int]
crefs]
clambda Int -> Name
var (CRTuple Maybe Int
mref [Int]
crefs)  =  [Q Pat] -> ExpQ -> ExpQ
lamE [[Q Pat] -> Q Pat
tupP [ (Int -> Name) -> Maybe Int -> Q Pat
opt Int -> Name
var Maybe Int
mref
                                                , [Q Pat] -> Q Pat
tupP ([Q Pat] -> Q Pat) -> [Q Pat] -> Q Pat
forall a b. (a -> b) -> a -> b
$ (Int -> Q Pat) -> [Int] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Q Pat
varP (Name -> Q Pat) -> (Int -> Name) -> Int -> Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Name
var) [Int]
crefs]]
elWithAttr :: String -> [(String, String)] -> ExpQ
elWithAttr :: String -> [(String, String)] -> ExpQ
elWithAttr String
tag [] = [| el tag |]
elWithAttr String
tag [(String
"class", String
cl)] = [| elClass tag cl |]
elWithAttr String
tag [(String, String)]
attr = [| elAttr tag (M.fromList attr) |]

el'WithAttr :: String -> [(String, String)] -> ExpQ
el'WithAttr :: String -> [(String, String)] -> ExpQ
el'WithAttr String
tag [] = [| el' tag |]
el'WithAttr String
tag [(String
"class", String
cl)] = [| elClass' tag cl |]
el'WithAttr String
tag [(String, String)]
attr = [| elAttr' tag (M.fromList attr) |]


cchain :: (Ref -> Name) -> Chain ->  ExpQ
cchain :: (Int -> Name) -> Chain -> ExpQ
cchain Int -> Name
var (CResult [Int]
orefs)  = (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'return) ([ExpQ] -> ExpQ
tupE ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ (Int -> ExpQ) -> [Int] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> ExpQ
varE (Name -> ExpQ) -> (Int -> Name) -> Int -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Name
var) [Int]
orefs))
cchain Int -> Name
var (CBind CElement
ce ChildResult
cres Chain
rest)  = [| $(cnode var ce) >>=  $(clambda var cres (cchain var rest)) |]

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

chainOut :: Chain -> [Ref] 
chainOut :: Chain -> [Int]
chainOut (CBind CElement
_ ChildResult
_ Chain
next) = Chain -> [Int]
chainOut Chain
next
chainOut (CResult [Int]
out) = [Int]
out

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

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