-- | 

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, sortBy)
import Data.Array
import Data.Text (Text)
import qualified Data.Text as T
import Data.Function (on)
import Instances.TH.Lift()
import Control.Monad.Reader

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

type VarEnv a = Reader (Ref -> Name) a

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 -> [(Text, Text)]
cAttrs :: [(Text, Text)]
                         , CElement -> Maybe String
cDynAttrs :: Maybe 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
Maybe String
tChilds :: TElement -> [TElement]
tDynAttrs :: TElement -> Maybe String
tAttrs :: TElement -> [Attribute]
tRef :: TElement -> Maybe Int
tTag :: TElement -> String
tChilds :: [TElement]
tDynAttrs :: Maybe String
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
-> [(Text, Text)]
-> Maybe String
-> Chain
-> CElement
CElement String
tTag [Int]
inRefs [Int]
childRefs [Int]
outRefs Maybe Int
tRef [(Text, Text)]
attrs Maybe String
tDynAttrs 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 :: [(Text, Text)]
attrs    = ((Text, Text) -> (Text, Text) -> Ordering)
-> [(Text, Text)] -> [(Text, Text)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Text -> Text -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Text -> Text -> Ordering)
-> ((Text, Text) -> Text)
-> (Text, Text)
-> (Text, Text)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Text, Text) -> Text
forall a b. (a, b) -> a
fst) [ (String -> Text
T.pack String
k, String -> Text
T.pack String
v) | (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"
                           
withVarF :: MonadReader t m => (t -> b) -> m b
withVarF :: (t -> b) -> m b
withVarF t -> b
f = m t
forall r (m :: * -> *). MonadReader r m => m r
ask m t -> (t -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ t
var -> b -> m b
forall (m :: * -> *) a. Monad m => a -> m a
return (t -> b
f t
var)

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
wildP ((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

tupArg :: (t -> Name) -> [t] -> PatQ
tupArg :: (t -> Name) -> [t] -> Q Pat
tupArg t -> Name
var [t
x]   = Name -> Q Pat
varP (Name -> Q Pat) -> Name -> Q Pat
forall a b. (a -> b) -> a -> b
$ t -> Name
var t
x
tupArg t -> Name
var [t]
args  = [Q Pat] -> Q Pat
tupP ([Q Pat] -> Q Pat) -> [Q Pat] -> Q Pat
forall a b. (a -> b) -> a -> b
$ (t -> Q Pat) -> [t] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Q Pat
varP (Name -> Q Pat) -> (t -> Name) -> t -> Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Name
var) [t]
args

clambda :: ChildResult -> ExpQ -> VarEnv ExpQ
clambda :: ChildResult -> ExpQ -> VarEnv ExpQ
clambda ChildResult
CREmpty   ExpQ
e    =  ExpQ -> VarEnv ExpQ
forall (m :: * -> *) a. Monad m => a -> m a
return (ExpQ -> VarEnv ExpQ) -> ExpQ -> VarEnv ExpQ
forall a b. (a -> b) -> a -> b
$ [Q Pat] -> ExpQ -> ExpQ
lamE [Q Pat
wildP] ExpQ
e
clambda (CRSimple Int
v)  ExpQ
e =   ((Int -> Name) -> ExpQ) -> VarEnv ExpQ
forall t (m :: * -> *) b. MonadReader t m => (t -> b) -> m b
withVarF (((Int -> Name) -> ExpQ) -> VarEnv ExpQ)
-> ((Int -> Name) -> ExpQ) -> VarEnv ExpQ
forall a b. (a -> b) -> a -> b
$ \ Int -> Name
var -> [Q Pat] -> ExpQ -> ExpQ
lamE [Name -> Q Pat
varP (Name -> Q Pat) -> Name -> Q Pat
forall a b. (a -> b) -> a -> b
$ Int -> Name
var Int
v] ExpQ
e
clambda (CRTuple Maybe Int
Nothing [Int]
crefs) ExpQ
e =  ((Int -> Name) -> ExpQ) -> VarEnv ExpQ
forall t (m :: * -> *) b. MonadReader t m => (t -> b) -> m b
withVarF  (((Int -> Name) -> ExpQ) -> VarEnv ExpQ)
-> ((Int -> Name) -> ExpQ) -> VarEnv ExpQ
forall a b. (a -> b) -> a -> b
$ \ Int -> Name
var -> [Q Pat] -> ExpQ -> ExpQ
lamE [(Int -> Name) -> [Int] -> Q Pat
forall t. (t -> Name) -> [t] -> Q Pat
tupArg Int -> Name
var [Int]
crefs] ExpQ
e
clambda (CRTuple Maybe Int
mref [Int]
crefs) ExpQ
e =  ((Int -> Name) -> ExpQ) -> VarEnv ExpQ
forall t (m :: * -> *) b. MonadReader t m => (t -> b) -> m b
withVarF  (((Int -> Name) -> ExpQ) -> VarEnv ExpQ)
-> ((Int -> Name) -> ExpQ) -> VarEnv ExpQ
forall a b. (a -> b) -> a -> b
$ \ Int -> Name
var -> [Q Pat] -> ExpQ -> ExpQ
lamE [[Q Pat] -> Q Pat
tupP [ (Int -> Name) -> Maybe Int -> Q Pat
opt Int -> Name
var Maybe Int
mref
                                                                  , (Int -> Name) -> [Int] -> Q Pat
forall t. (t -> Name) -> [t] -> Q Pat
tupArg Int -> Name
var [Int]
crefs]] ExpQ
e

                                     
elWithAttr :: String -> [(Text, Text)] -> Maybe String -> ExpQ
elWithAttr :: String -> [(Text, Text)] -> Maybe String -> ExpQ
elWithAttr String
tag [] Maybe String
Nothing = [| el tag |]
elWithAttr String
tag [] (Just String
dynAttr) = [| elDynAttr tag $(unboundVarE $ mkName dynAttr) |]
elWithAttr String
tag [(Text
"class", Text
cl)] Maybe String
Nothing = [| elClass tag cl |]
elWithAttr String
tag [(Text, Text)]
attr Maybe String
Nothing = [| elAttr tag (M.fromAscList attr) |]
elWithAttr String
tag [(Text, Text)]
attr (Just String
dynAttr) = [| elDynAttr tag (flip M.union (M.fromAscList attr) <$>  $(unboundVarE $ mkName dynAttr)) |]

el'WithAttr :: String -> [(Text, Text)] -> Maybe String  -> ExpQ
el'WithAttr :: String -> [(Text, Text)] -> Maybe String -> ExpQ
el'WithAttr String
tag [] Maybe String
Nothing = [| el' tag |]
el'WithAttr String
tag [] (Just String
dynAttr) = [| elDynAttr' tag $(unboundVarE $ mkName dynAttr) |]
el'WithAttr String
tag [(Text
"class", Text
cl)] Maybe String
Nothing = [| elClass' tag cl |]
el'WithAttr String
tag [(Text, Text)]
attr Maybe String
Nothing = [| elAttr' tag (M.fromAscList attr) |]
el'WithAttr String
tag [(Text, Text)]
attr (Just String
dynAttr) = [| elDynAttr' tag (flip M.union (M.fromAscList attr) <$>  $(unboundVarE $ mkName dynAttr)) |]

tupRes :: (t -> Name) -> [t] -> ExpQ
tupRes :: (t -> Name) -> [t] -> ExpQ
tupRes t -> Name
var [t
a] = Name -> ExpQ
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ t -> Name
var t
a
tupRes t -> Name
var [t]
l   = [ExpQ] -> ExpQ
tupE ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ (t -> ExpQ) -> [t] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> ExpQ
varE (Name -> ExpQ) -> (t -> Name) -> t -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Name
var) [t]
l

cchain :: Chain ->  VarEnv ExpQ
cchain :: Chain -> VarEnv ExpQ
cchain (CResult [Int]
orefs)  = do
  Int -> Name
var <- ReaderT (Int -> Name) Identity (Int -> Name)
forall r (m :: * -> *). MonadReader r m => m r
ask
  ExpQ -> VarEnv ExpQ
forall (m :: * -> *) a. Monad m => a -> m a
return (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'return) ((Int -> Name) -> [Int] -> ExpQ
forall t. (t -> Name) -> [t] -> ExpQ
tupRes Int -> Name
var [Int]
orefs))
cchain (CBind CElement
ce ChildResult
cres Chain
rest)  = do
  ExpQ
n <- CElement -> VarEnv ExpQ
cnode CElement
ce
  ExpQ
r <- Chain -> VarEnv ExpQ
cchain Chain
rest
  ExpQ
l <- ChildResult -> ExpQ -> VarEnv ExpQ
clambda ChildResult
cres ExpQ
r
  ExpQ -> VarEnv ExpQ
forall (m :: * -> *) a. Monad m => a -> m a
return [| $(n) >>=  $(l) |]


cnode :: CElement -> VarEnv ExpQ
cnode :: CElement -> VarEnv ExpQ
cnode (CElement String
tag [Int]
_ [Int]
_ [Int]
_ Maybe Int
Nothing [(Text, Text)]
attr Maybe String
tDynAttrs Chain
childs) = Chain -> VarEnv ExpQ
cchain Chain
childs VarEnv ExpQ -> (ExpQ -> VarEnv ExpQ) -> VarEnv ExpQ
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ ExpQ
cs ->
     ExpQ -> VarEnv ExpQ
forall (m :: * -> *) a. Monad m => a -> m a
return [|  $(elWithAttr tag attr tDynAttrs) $(cs) |]
cnode  (CElement String
tag [Int]
_ [Int]
_ [Int]
_ (Just Int
_) [(Text, Text)]
attr Maybe String
tDynAttrs Chain
childs) = Chain -> VarEnv ExpQ
cchain Chain
childs VarEnv ExpQ -> (ExpQ -> VarEnv ExpQ) -> VarEnv ExpQ
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ ExpQ
cs ->
     ExpQ -> VarEnv ExpQ
forall (m :: * -> *) a. Monad m => a -> m a
return [| $(el'WithAttr tag attr tDynAttrs) $(cs) |]
cnode (CText String
"") = ExpQ -> VarEnv ExpQ
forall (m :: * -> *) a. Monad m => a -> m a
return (ExpQ -> VarEnv ExpQ) -> ExpQ -> VarEnv ExpQ
forall a b. (a -> b) -> a -> b
$ [| blank |]
cnode (CText String
txt) = ExpQ -> VarEnv ExpQ
forall (m :: * -> *) a. Monad m => a -> m a
return (ExpQ -> VarEnv ExpQ) -> ExpQ -> VarEnv ExpQ
forall a b. (a -> b) -> a -> b
$ [| text txt |]
cnode (CWidget String
x Maybe Int
_) = ExpQ -> VarEnv ExpQ
forall (m :: * -> *) a. Monad m => a -> m a
return (ExpQ -> VarEnv ExpQ) -> ExpQ -> VarEnv ExpQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
unboundVarE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
x
cnode (CComment String
txt) = ExpQ -> VarEnv ExpQ
forall (m :: * -> *) a. Monad m => a -> m a
return [| 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
    VarEnv ExpQ -> (Int -> Name) -> ExpQ
forall r a. Reader r a -> r -> a
runReader (Chain -> VarEnv ExpQ
cchain Chain
refchain) (Array Int Name
varNames Array Int Name -> Int -> Name
forall i e. Ix i => Array i e -> i -> e
!)

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