-- | This module uses Template Haskell to declare reactive fields for
--   a given model field and type that access the ProtectedModel in
--   the IO Monad and the reactive model.
--
-- Copyright   : (C) Keera Studios Ltd, 2013
-- License     : BSD3
-- Maintainer  : support@keera.co.uk
module Hails.MVC.Model.THFields where

-- External imports
import Data.Char
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Lib

-- | Creates a setter and a getter that works at ProtectedModel level
-- inside the IO Monad
protectedField :: String -> Q Type -> String -> String -> Q [Dec]
protectedField :: String -> Q Type -> String -> String -> Q [Dec]
protectedField String
fname Q Type
ftype String
pmodel String
event = [Q Dec] -> Q [Dec]
forall a. [Q a] -> Q [a]
sequenceQ
  -- Declare plain field
  [ Name -> Q Type -> Q Dec
sigD Name
setterName Q Type
setterType
  , Name -> [ClauseQ] -> Q Dec
funD Name
setterName [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause []
                     -- Main result: setter field
                     (ExpQ -> BodyQ
normalB (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE (String -> Name
mkName String
"reSetter"))
                                    (Name -> ExpQ
varE Name
fieldName)
                              )
                     )
                     -- where
                     []
                    ]
  -- Declare plain getter
  , Name -> Q Type -> Q Dec
sigD Name
getterName Q Type
getterType
  , Name -> [ClauseQ] -> Q Dec
funD Name
getterName [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause []
                     -- Main result: getter field
                     (ExpQ -> BodyQ
normalB (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE (String -> Name
mkName String
"reGetter"))
                                    (Name -> ExpQ
varE Name
fieldName)
                              )
                     )
                     []
                     ]
  -- Declare protected field
  , Name -> Q Type -> Q Dec
sigD Name
fieldName Q Type
fieldType
  , Name -> [ClauseQ] -> Q Dec
funD Name
fieldName [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause []
                     (ExpQ -> BodyQ
normalB
                      (Name -> [Q (Name, Exp)] -> ExpQ
recConE (String -> Name
mkName String
"ReactiveElement")
                               [Name -> ExpQ -> Q (Name, Exp)
fieldExp
                                 (String -> Name
mkName String
"reEvents")
                                 ([ExpQ] -> ExpQ
listE [Name -> ExpQ
conE (String -> Name
mkName
                                                (String
"RM." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Changed"))
                                        ]
                                 )
                               , Name -> ExpQ -> Q (Name, Exp)
fieldExp
                                 (String -> Name
mkName String
"reSetter")
                                 ([PatQ] -> ExpQ -> ExpQ
lamE [Name -> PatQ
varP (String -> Name
mkName String
"pm")
                                       , Name -> PatQ
varP (String -> Name
mkName String
"c")
                                       ]
                                    (Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ
infixE
                                     (ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just (Name -> ExpQ
varE (String -> Name
mkName String
"pm")))
                                     (Name -> ExpQ
varE (String -> Name
mkName String
"applyToReactiveModel"))
                                     (ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just (Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ
infixE Maybe ExpQ
forall a. Maybe a
Nothing
                                            (Name -> ExpQ
varE (String -> Name
mkName
                                                   (String
"RM." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"set" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fname)
                                                  )
                                            )
                                            (ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just (Name -> ExpQ
varE (String -> Name
mkName String
"c")))
                                           )
                                     )
                                    )
                                 )
                               , Name -> ExpQ -> Q (Name, Exp)
fieldExp (String -> Name
mkName String
"reGetter")
                                          (Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ
infixE
                                            Maybe ExpQ
forall a. Maybe a
Nothing
                                            (Name -> ExpQ
varE (String -> Name
mkName String
"onReactiveModel"))
                                            (ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just (Name -> ExpQ
varE (String -> Name
mkName
                                                          (String
"RM." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"get" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fname)))
                                            )
                                          )
                               ]
                      )
                     )
                    []
                   ]
  ]
 where setterName :: Name
setterName = String -> Name
mkName (String
"set" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fname)
       getterName :: Name
getterName = String -> Name
mkName (String
"get" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fname)
       fieldName :: Name
fieldName  = String -> Name
mkName (String
fnamelc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Field")
       setterType :: Q Type
setterType = Q Type -> Q Type -> Q Type
appT Q Type
pmTo Q Type
typeToIO
       getterType :: Q Type
getterType = Q Type -> Q Type -> Q Type
appT Q Type
pmTo Q Type
ioType
       fieldType :: Q Type
fieldType  = Q Type -> Q Type -> Q Type
appT
                     (Q Type -> Q Type -> Q Type
appT
                       (Q Type -> Q Type -> Q Type
appT (Name -> Q Type
conT (String -> Name
mkName String
"ReactiveElement"))
                             Q Type
ftype
                       )
                       (Name -> Q Type
conT (String -> Name
mkName String
pmodel))
                     )
                     (Name -> Q Type
conT (String -> Name
mkName String
event))
       pmTo :: Q Type
pmTo       = Q Type -> Q Type -> Q Type
appT Q Type
arrowT (Name -> Q Type
conT (String -> Name
mkName String
"ProtectedModel"))
       typeToIO :: Q Type
typeToIO   = Q Type -> Q Type -> Q Type
appT (Q Type -> Q Type -> Q Type
appT Q Type
arrowT Q Type
ftype) Q Type
ioNil
       ioNil :: Q Type
ioNil      = Q Type -> Q Type -> Q Type
appT (Name -> Q Type
conT (String -> Name
mkName String
"IO")) (Name -> Q Type
conT (String -> Name
mkName String
"()"))
       ioType :: Q Type
ioType     = Q Type -> Q Type -> Q Type
appT (Name -> Q Type
conT (String -> Name
mkName String
"IO")) Q Type
ftype

       fnamelc :: String
fnamelc    = String -> String
lcFst String
fname

-- | Creates a setter and a getter that works at ReactiveModel level.
reactiveField :: String -> Q Type -> Q [Dec]
reactiveField :: String -> Q Type -> Q [Dec]
reactiveField String
fname Q Type
ftype = [Q Dec] -> Q [Dec]
forall a. [Q a] -> Q [a]
sequenceQ
  -- Declare plain setter
  [ Name -> Q Type -> Q Dec
sigD Name
setterName Q Type
setterType
  , Name -> [ClauseQ] -> Q Dec
funD Name
setterName [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause []
                     -- Main result: just use the field's setter
                     (ExpQ -> BodyQ
normalB (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE (String -> Name
mkName String
"fieldSetter"))
                                    (Name -> ExpQ
varE Name
fieldName)
                              )
                     )
                     -- where
                     []
                    ]
  -- Declare plain getter
  , Name -> Q Type -> Q Dec
sigD Name
getterName Q Type
getterType
  , Name -> [ClauseQ] -> Q Dec
funD Name
getterName [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause []
                     -- Main result: just use the field's getter
                     (ExpQ -> BodyQ
normalB (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE (String -> Name
mkName String
"fieldGetter"))
                                    (Name -> ExpQ
varE Name
fieldName)
                              )
                     )
                     []
                     ]
  -- Declare field with 4 elements
  , Name -> Q Type -> Q Dec
sigD Name
fieldName Q Type
fieldType
  , Name -> [ClauseQ] -> Q Dec
funD Name
fieldName [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause []
                     (ExpQ -> BodyQ
normalB
                      ([ExpQ] -> ExpQ
tupE
                       [ Name -> ExpQ
varE (String -> Name
mkName String
fnamelc)                        -- function to read from model
                       , Name -> ExpQ
varE (String -> Name
mkName String
"preTrue")                      -- precondition to update model
                       , [PatQ] -> ExpQ -> ExpQ
lamE [Name -> PatQ
varP (String -> Name
mkName String
"v"), Name -> PatQ
varP (String -> Name
mkName String
"b")]  -- function to update model
                         (ExpQ -> [Q (Name, Exp)] -> ExpQ
recUpdE (Name -> ExpQ
varE (String -> Name
mkName String
"b"))
                          [Name -> ExpQ -> Q (Name, Exp)
fieldExp
                           (String -> Name
mkName String
fnamelc)
                           (Name -> ExpQ
varE (String -> Name
mkName String
"v"))
                          ]
                         )
                       , Name -> ExpQ
conE (String -> Name
mkName (String
fname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Changed"))           -- Event to trigger when changed
                       ]
                      )
                     )
                     []
                    ]
  ]
 where setterName :: Name
setterName = String -> Name
mkName (String
"set" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fname)
       getterName :: Name
getterName = String -> Name
mkName (String
"get" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fname)
       fieldName :: Name
fieldName  = String -> Name
mkName (String
fnamelc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Field")
       setterType :: Q Type
setterType = Q Type -> Q Type -> Q Type
appT Q Type
rmTo Q Type
typeToRM
       getterType :: Q Type
getterType = Q Type -> Q Type -> Q Type
appT Q Type
rmTo Q Type
ftype
       fieldType :: Q Type
fieldType  = Q Type -> Q Type -> Q Type
appT (Name -> Q Type
conT (String -> Name
mkName String
"Field")) Q Type
ftype
       rmTo :: Q Type
rmTo       = Q Type -> Q Type -> Q Type
appT Q Type
arrowT (Name -> Q Type
conT (String -> Name
mkName String
"ReactiveModel"))
       typeToRM :: Q Type
typeToRM   = Q Type -> Q Type -> Q Type
appT (Q Type -> Q Type -> Q Type
appT Q Type
arrowT Q Type
ftype)
                         (Name -> Q Type
conT (String -> Name
mkName String
"ReactiveModel"))
       fnamelc :: String
fnamelc    = String -> String
lcFst String
fname

lcFst :: String -> String
lcFst :: String -> String
lcFst []     = []
lcFst (Char
x:String
xs) = (Char -> Char
toLower Char
x) Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs