Shpadoinkle-html-0.2.0.0: Shpadoinkle/Html/TH.hs

{-# LANGUAGE QuasiQuotes     #-}
{-# LANGUAGE TemplateHaskell #-}


module Shpadoinkle.Html.TH where


import qualified Data.Char           as Char
import qualified Data.Text
import           Language.Haskell.TH


import           Shpadoinkle         hiding (h, name)


capitalized :: String -> String
capitalized (c:cs) = Char.toUpper c : fmap Char.toLower cs
capitalized []     = []


mkEventDSL :: String -> Q [Dec]
mkEventDSL evt = let

    onevt = "on" ++ capitalized evt
    name   = mkName onevt
    nameC  = mkName $ onevt ++ "C"
    nameM  = mkName $ onevt ++ "M"
    nameM_ = mkName $ onevt ++ "M_"
    l   = mkName "listen"
    lC  = mkName "listenC"
    lM  = mkName "listenM"
    lM_ = mkName "listenM_"
    m   = VarT $ mkName "m"
    a   = VarT $ mkName "a"

  in return

    [ SigD nameM (ForallT [] [ AppT (ConT ''Prelude.Monad) m ]
      (AppT (AppT ArrowT (AppT m ((AppT (AppT ArrowT a) a))))
        (AppT (AppT (TupleT 2) (ConT ''Data.Text.Text))
         (AppT (AppT (ConT ''Shpadoinkle.Prop) m) a))))

    , FunD nameM  [Clause [] (NormalB $ AppE (VarE lM)  (LitE $ StringL evt)) []]


    , SigD nameM_ (ForallT [] [ AppT (ConT ''Prelude.Monad) m ]
      (AppT (AppT ArrowT (AppT m (ConT ''())))
       (AppT (AppT (TupleT 2) (ConT ''Data.Text.Text))
         (AppT (AppT (ConT ''Shpadoinkle.Prop) m) a))))

    , FunD nameM_ [Clause [] (NormalB $ AppE (VarE lM_) (LitE $ StringL evt)) []]


    , SigD nameC
      (ForallT [] [ ]
        (AppT (AppT ArrowT (AppT (AppT (ConT ''Shpadoinkle.Continuation) m) a))
         (AppT (AppT (TupleT 2) (ConT ''Data.Text.Text))
           (AppT (AppT (ConT ''Shpadoinkle.Prop) m) a))))

    , FunD nameC [Clause [] (NormalB $ AppE (VarE lC) (LitE $ StringL evt)) []]

    , SigD name
      (ForallT []
        []
        (AppT (AppT ArrowT a)
          (AppT (AppT (TupleT 2) (ConT ''Data.Text.Text))
           (AppT (AppT (ConT ''Shpadoinkle.Prop) m) a))))

    , FunD name [Clause [] (NormalB $ AppE (VarE l) (LitE $ StringL evt)) []]
    ]


mkProp :: Name -> String -> String -> Q [Dec]
mkProp typ lStr name' = let

    name = reverse $ case reverse name' of
             '\'':rs -> rs
             rs      -> rs
    a = VarT $ mkName "a"
    m = VarT $ mkName "m"
    l = mkName lStr
    n = mkName name'

  in return

    [ SigD n (ForallT [] []
      (AppT (AppT ArrowT (ConT typ))
       (AppT (AppT (TupleT 2) (ConT ''Data.Text.Text))
        (AppT (AppT (ConT ''Shpadoinkle.Prop) m) a))))

    , ValD (VarP n) (NormalB (AppE (VarE l) (LitE (StringL name)))) []
    ]


mkTextProp :: String -> Q [Dec]
mkTextProp = mkProp ''Data.Text.Text "textProperty"


mkBoolProp :: String -> Q [Dec]
mkBoolProp = mkProp ''Bool "flagProperty"


mkIntProp :: String -> Q [Dec]
mkIntProp = mkProp ''Int "textProperty"


mkElement :: String -> Q [Dec]
mkElement name = let

    raw = filter (not . (== '\'')) name
    n   = mkName name
    n'  = mkName $ name ++ "'"
    n_  = mkName $ name ++  "_"
    n'_ = mkName $ name ++ "'_"
    m   = VarT $ mkName "m"
    a   = VarT $ mkName "a"
    l   = mkName "h"

  in return

    [ SigD n
      (AppT (AppT ArrowT (AppT ListT (AppT (AppT (TupleT 2) (ConT ''Data.Text.Text))
                                      (AppT (AppT (ConT ''Shpadoinkle.Prop) m) a))))
        (AppT (AppT ArrowT (AppT ListT (AppT (AppT (ConT ''Shpadoinkle.Html) m) a)))
                (AppT (AppT (ConT ''Shpadoinkle.Html) m) a)))

    , ValD (VarP n) (NormalB (AppE (VarE l) (LitE (StringL raw)))) []


    , SigD n_
      (AppT (AppT ArrowT (AppT ListT (AppT (AppT (ConT ''Shpadoinkle.Html) m) a)))
       (AppT (AppT (ConT ''Shpadoinkle.Html) m) a))

    , ValD (VarP n_) (NormalB (AppE (VarE n) (ListE []))) []


    , SigD n'
      (AppT (AppT ArrowT (AppT ListT (AppT (AppT (TupleT 2) (ConT ''Data.Text.Text)) (AppT (AppT (ConT ''Shpadoinkle.Prop) m) a))))
       (AppT (AppT (ConT ''Shpadoinkle.Html) m) a))

    , ValD (VarP n') (NormalB (AppE (AppE (VarE (mkName "flip")) (VarE n)) (ListE []))) []


    , SigD n'_ (AppT (AppT (ConT ''Shpadoinkle.Html) m) a)

    , ValD (VarP n'_) (NormalB (AppE (AppE (VarE n) (ListE [])) (ListE []))) []

    ]