-- | 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 fname ftype pmodel event = sequenceQ
  -- Declare plain field
  [ sigD setterName setterType
  , funD setterName [clause []
                     -- Main result: setter field
                     (normalB (appE (varE (mkName "reSetter"))
                                    (varE fieldName)
                              )
                     )
                     -- where
                     []
                    ]
  -- Declare plain getter
  , sigD getterName getterType
  , funD getterName [clause []
                     -- Main result: getter field
                     (normalB (appE (varE (mkName "reGetter"))
                                    (varE fieldName)
                              )
                     )
                     []
                     ]
  -- Declare protected field
  , sigD fieldName fieldType
  , funD fieldName [clause []
                     (normalB
                      (recConE (mkName "ReactiveElement")
                               [fieldExp
                                 (mkName "reEvents")
                                 (listE [conE (mkName
                                                ("RM." ++ fname ++ "Changed"))
                                        ]
                                 )
                               , fieldExp
                                 (mkName "reSetter")
                                 (lamE [varP (mkName "pm")
                                       , varP (mkName "c")
                                       ]
                                    (infixE
                                     (Just (varE (mkName "pm")))
                                     (varE (mkName "applyToReactiveModel"))
                                     (Just (infixE Nothing
                                            (varE (mkName
                                                   ("RM." ++ "set" ++ fname)
                                                  )
                                            )
                                            (Just (varE (mkName "c")))
                                           )
                                     )
                                    )
                                 )
                               , fieldExp (mkName "reGetter")
                                          (infixE
                                            Nothing
                                            (varE (mkName "onReactiveModel"))
                                            (Just (varE (mkName
                                                          ("RM." ++ "get" ++ fname)))
                                            )
                                          )
                               ]
                      )
                     )
                    []
                   ]
  ]
 where setterName = mkName ("set" ++ fname)
       getterName = mkName ("get" ++ fname)
       fieldName  = mkName (fnamelc ++ "Field")
       setterType = appT pmTo typeToIO
       getterType = appT pmTo ioType
       fieldType  = appT
                     (appT
                       (appT (conT (mkName "ReactiveElement"))
                             ftype
                       )
                       (conT (mkName pmodel))
                     )
                     (conT (mkName event))
       pmTo       = appT arrowT (conT (mkName "ProtectedModel"))
       typeToIO   = appT (appT arrowT ftype) ioNil
       ioNil      = appT (conT (mkName "IO")) (conT (mkName "()"))
       ioType     = appT (conT (mkName "IO")) ftype

       fnamelc    = lcFst fname

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

lcFst :: String -> String
lcFst []     = []
lcFst (x:xs) = (toLower x) : xs