-- | This module uses Template Haskell to declare getters and setters
--   for a given 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.THAccessors where

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

-- Creates a setter and a getter at ProtectedModel level that works in the IO Monad
protectedModelAccessors :: String -> String -> Q [Dec]
protectedModelAccessors :: String -> String -> Q [Dec]
protectedModelAccessors String
fname String
ftype = [Q Dec] -> Q [Dec]
forall a. [Q a] -> Q [a]
sequenceQ
  -- Declare plain setter
  [ Name -> TypeQ -> Q Dec
sigD Name
setterName TypeQ
setterType
  , Name -> [ClauseQ] -> Q Dec
funD Name
setterName [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP (String -> Name
mkName String
"pm"), Name -> PatQ
varP (String -> Name
mkName String
"n")]
                     (ExpQ -> BodyQ
normalB (ExpQ -> ExpQ -> ExpQ
appE (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE (String -> Name
mkName String
"applyToReactiveModel"))
                                          (Name -> ExpQ
varE (String -> Name
mkName String
"pm"))
                                    )
                                    (Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ
infixE Maybe ExpQ
forall a. Maybe a
Nothing
                                            (Name -> ExpQ
varE (String -> Name
mkName (String
"RM.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
"n")))
                                    )
                              )
                     )
                     []
                     ]
  -- Declare plain getter
  , Name -> TypeQ -> Q Dec
sigD Name
getterName TypeQ
getterType
  , Name -> [ClauseQ] -> Q Dec
funD Name
getterName [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause []
                     (ExpQ -> BodyQ
normalB (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.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)
       setterType :: TypeQ
setterType = TypeQ -> TypeQ -> TypeQ
appT TypeQ
pmTo TypeQ
typeToIO
       getterType :: TypeQ
getterType = TypeQ -> TypeQ -> TypeQ
appT TypeQ
pmTo TypeQ
ioType
       pmTo :: TypeQ
pmTo       = TypeQ -> TypeQ -> TypeQ
appT TypeQ
arrowT (Name -> TypeQ
conT (String -> Name
mkName String
"ProtectedModel"))
       typeToIO :: TypeQ
typeToIO   = TypeQ -> TypeQ -> TypeQ
appT (TypeQ -> TypeQ -> TypeQ
appT TypeQ
arrowT (Name -> TypeQ
conT (String -> Name
mkName String
ftype))) TypeQ
ioNil
       ioNil :: TypeQ
ioNil      = TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT (String -> Name
mkName String
"IO")) (Name -> TypeQ
conT (String -> Name
mkName String
"()"))
       ioType :: TypeQ
ioType     = TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT (String -> Name
mkName String
"IO")) (Name -> TypeQ
conT (String -> Name
mkName String
ftype))

-- | Creates a setter and a getter that works at ReactiveModel level.
reactiveModelAccessors :: String -> String -> Q [Dec]
reactiveModelAccessors :: String -> String -> Q [Dec]
reactiveModelAccessors String
fname String
ftype = [Q Dec] -> Q [Dec]
forall a. [Q a] -> Q [a]
sequenceQ
  -- Declare plain setter
  [ Name -> TypeQ -> Q Dec
sigD Name
setterName TypeQ
setterType
  , Name -> [ClauseQ] -> Q Dec
funD Name
setterName
                    [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause
                     -- Setter args: rm (reactive model), n (value)
                     [Name -> PatQ
varP (String -> Name
mkName String
"rm"), Name -> PatQ
varP (String -> Name
mkName String
"n")]
                     -- Main result: triggerEvent rm' ev
                     (ExpQ -> BodyQ
normalB (ExpQ -> ExpQ -> ExpQ
appE (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE (String -> Name
mkName String
"triggerEvent"))
                                          (Name -> ExpQ
varE (String -> Name
mkName String
"rm'"))
                                    )
                                    (Name -> ExpQ
varE (String -> Name
mkName String
"ev"))
                              )
                     )
                     -- Where rm' = updated rm
                     [PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP (String -> Name
mkName String
"rm'"))
                           (ExpQ -> BodyQ
normalB (Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ
infixE (ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just (Name -> ExpQ
varE (String -> Name
mkName String
"rm")))
                                            (Name -> ExpQ
varE (String -> Name
mkName String
"onBasicModel"))
                                            (ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just ([PatQ] -> ExpQ -> ExpQ
lamE [Name -> PatQ
varP (String -> Name
mkName String
"b")]
                                                        (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
"n"))
                                                                 ]
                                                        )
                                                  )
                                            )
                                    )
                           )
                           []
                      -- Where ev = Corresponding Event
                      , PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP (String -> Name
mkName String
"ev"))
                             (ExpQ -> BodyQ
normalB (Name -> ExpQ
conE (String -> Name
mkName (String
fname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Changed"))))
                             []
                      ]
                    ]
  -- Declare plain getter
  , Name -> TypeQ -> Q Dec
sigD Name
getterName TypeQ
getterType
  , Name -> [ClauseQ] -> Q Dec
funD Name
getterName [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause []
                     -- recordField . basicModel
                     (ExpQ -> BodyQ
normalB (Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ
infixE (ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just (Name -> ExpQ
varE (String -> Name
mkName String
fnamelc)))
                                      (Name -> ExpQ
varE (String -> Name
mkName String
"."))
                                      (ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just (Name -> ExpQ
varE (String -> Name
mkName String
"basicModel")))
                              )
                     )
                     []
                     ]
  ]
 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)
       setterType :: TypeQ
setterType = TypeQ -> TypeQ -> TypeQ
appT TypeQ
rmTo TypeQ
typeToRM
       getterType :: TypeQ
getterType = TypeQ -> TypeQ -> TypeQ
appT TypeQ
rmTo (Name -> TypeQ
conT (String -> Name
mkName String
ftype))
       rmTo :: TypeQ
rmTo       = TypeQ -> TypeQ -> TypeQ
appT TypeQ
arrowT (Name -> TypeQ
conT (String -> Name
mkName String
"ReactiveModel"))
       typeToRM :: TypeQ
typeToRM   = TypeQ -> TypeQ -> TypeQ
appT (TypeQ -> TypeQ -> TypeQ
appT TypeQ
arrowT (Name -> TypeQ
conT (String -> Name
mkName String
ftype))) (Name -> TypeQ
conT (String -> Name
mkName String
"ReactiveModel"))
       fnamelc :: String
fnamelc    = String -> String
lcFst String
fname

-- | Creates a setter and a getter that works at ReactiveModel level.
nonReactiveModelAccessors :: String -> Q Type -> Q [Dec]
nonReactiveModelAccessors :: String -> TypeQ -> Q [Dec]
nonReactiveModelAccessors String
fname TypeQ
ftype = [Q Dec] -> Q [Dec]
forall a. [Q a] -> Q [a]
sequenceQ
  -- Declare plain setter
  [ Name -> TypeQ -> Q Dec
sigD Name
setterName TypeQ
setterType
  , Name -> [ClauseQ] -> Q Dec
funD Name
setterName
                    [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause
                     -- Setter args: rm (reactive model), n (value)
                     [Name -> PatQ
varP (String -> Name
mkName String
"rm"), Name -> PatQ
varP (String -> Name
mkName String
"n")]
                     -- Main result: triggerEvent rm' ev
                     (ExpQ -> BodyQ
normalB (Name -> ExpQ
varE (String -> Name
mkName String
"rm'")))
                     -- Where rm' = updated rm
                     [PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP (String -> Name
mkName String
"rm'"))
                           (ExpQ -> BodyQ
normalB (Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ
infixE (ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just (Name -> ExpQ
varE (String -> Name
mkName String
"rm")))
                                            (Name -> ExpQ
varE (String -> Name
mkName String
"onBasicModel"))
                                            (ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just ([PatQ] -> ExpQ -> ExpQ
lamE [Name -> PatQ
varP (String -> Name
mkName String
"b")]
                                                        (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
"n"))
                                                                 ]
                                                        )
                                                  )
                                            )
                                    )
                           )
                           []
                      ]
                    ]
  -- Declare plain getter
  , Name -> TypeQ -> Q Dec
sigD Name
getterName TypeQ
getterType
  , Name -> [ClauseQ] -> Q Dec
funD Name
getterName [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause []
                     -- recordField . basicModel
                     (ExpQ -> BodyQ
normalB (Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ
infixE (ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just (Name -> ExpQ
varE (String -> Name
mkName String
fnamelc)))
                                      (Name -> ExpQ
varE (String -> Name
mkName String
"."))
                                      (ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just (Name -> ExpQ
varE (String -> Name
mkName String
"basicModel")))
                              )
                     )
                     []
                     ]
  ]
 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)
       setterType :: TypeQ
setterType = TypeQ -> TypeQ -> TypeQ
appT TypeQ
rmTo TypeQ
typeToRM
       getterType :: TypeQ
getterType = TypeQ -> TypeQ -> TypeQ
appT TypeQ
rmTo TypeQ
ftype
       rmTo :: TypeQ
rmTo       = TypeQ -> TypeQ -> TypeQ
appT TypeQ
arrowT (Name -> TypeQ
conT (String -> Name
mkName String
"ReactiveModel"))
       typeToRM :: TypeQ
typeToRM   = TypeQ -> TypeQ -> TypeQ
appT (TypeQ -> TypeQ -> TypeQ
appT TypeQ
arrowT TypeQ
ftype) (Name -> TypeQ
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