{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module Shpadoinkle.Html.TH where
import qualified Data.Char as Char
import qualified Data.Text
import Language.Haskell.TH (Body (NormalB), Clause (Clause),
Dec (FunD, SigD, ValD),
Exp (AppE, InfixE, ListE, LitE, UnboundVarE, VarE),
Lit (StringL), Name, Pat (VarP), Q,
Type (AppT, ArrowT, ConT, ForallT, ListT, TupleT, VarT),
mkName)
import Shpadoinkle (Continuation, Html, Prop, causes, impur,
pur)
{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
capitalized :: String -> String
capitalized (c:cs) = Char.toUpper c : 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 (AppT (AppT ArrowT a) 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)) []]
]
mkEventVariants :: String -> Q [Dec]
mkEventVariants evt = let
onevt = "on" ++ capitalized evt
name = mkName onevt
nameC = mkName $ onevt ++ "C"
nameM = mkName $ onevt ++ "M"
nameM_ = mkName $ onevt ++ "M_"
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 (AppE (VarE '(Prelude..)) (VarE nameC)) (VarE 'Shpadoinkle.impur)) []]
, 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 (AppE (VarE '(Prelude..)) (VarE nameC)) (VarE 'Shpadoinkle.causes)) []]
, SigD name
(ForallT []
[]
(AppT (AppT ArrowT (AppT (AppT ArrowT a) a))
(AppT (AppT (TupleT 2) (ConT ''Data.Text.Text))
(AppT (AppT (ConT ''Shpadoinkle.Prop) m) a))))
, FunD name [ Clause [] (NormalB $ AppE (AppE (VarE '(Prelude..)) (VarE nameC)) (VarE 'Shpadoinkle.pur)) []]
]
mkEventVariantsAfforded :: String -> Name -> Q [Dec]
mkEventVariantsAfforded evt afford = let
onevt = "on" ++ capitalized evt
name = mkName onevt
nameC = mkName $ onevt ++ "C"
nameM = mkName $ onevt ++ "M"
nameM_ = mkName $ onevt ++ "M_"
f = mkName "f"
m = VarT $ mkName "m"
a = VarT $ mkName "a"
in return
[ SigD nameM (ForallT [] [ AppT (ConT ''Prelude.Monad) m ]
(AppT (AppT ArrowT (AppT (AppT ArrowT (ConT afford)) (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 [VarP f] (NormalB (AppE (UnboundVarE nameC) (InfixE (Just (UnboundVarE 'Shpadoinkle.impur)) (VarE '(Prelude..)) (Just (VarE f))))) []]
, SigD nameM_ (ForallT [] [ AppT (ConT ''Prelude.Monad) m ]
(AppT (AppT ArrowT (AppT (AppT ArrowT (ConT afford)) (AppT m (ConT ''()))))
(AppT (AppT (TupleT 2) (ConT ''Data.Text.Text))
(AppT (AppT (ConT ''Shpadoinkle.Prop) m) a))))
, FunD nameM_ [Clause [VarP f] (NormalB (AppE (UnboundVarE nameC) (InfixE (Just (UnboundVarE 'Shpadoinkle.causes)) (VarE '(Prelude..)) (Just (VarE f))))) []]
, SigD name
(AppT (AppT ArrowT (AppT (AppT ArrowT (ConT afford)) (AppT (AppT ArrowT a) a)))
(AppT (AppT (TupleT 2) (ConT ''Data.Text.Text))
(AppT (AppT (ConT ''Shpadoinkle.Prop) m) a)))
, FunD name [Clause [VarP f] (NormalB (AppE (UnboundVarE nameC) (InfixE (Just (UnboundVarE 'Shpadoinkle.pur)) (VarE '(Prelude..)) (Just (VarE f))))) []]
]
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 (/= '\'') 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 []))) []
]