I18N.hs

{-# LANGUAGE OverloadedStrings, FlexibleInstances, MultiParamTypeClasses #-}
{-# LANGUAGE DeriveDataTypeable #-}


module Snap.Snaplet.I18N where

import           Control.Monad
import           Data.Lens.Common
import           Data.Maybe
import           System.Directory
import           System.FilePath.Posix
import           Text.Templating.Heist
import           Text.XmlHtml hiding (render)
import qualified Data.Configurator as Config
import qualified Data.Configurator.Types as Config
import qualified Data.Text as T
import qualified Text.XmlHtml as X

import Snap
import Snap.Snaplet.Heist
-------------------------------------------------------
-- 
--
-- 
-- 
-------------------------------------------------------

type Locale      = String
type MessageFile = String

defaultLocale :: Locale
defaultLocale = "en_US"

defaultMessageFilePrefix :: MessageFile
defaultMessageFilePrefix = "data/message"

data I18NConfig  = I18NConfig { _getLocale      :: Locale       -- ^ locale, default "en"
                              , _getMessageFile :: MessageFile  -- ^ message file name, default to "message"
                              } deriving (Show)

-- | A simple mapping to hold i18n messages
-- 
data I18NMessage = I18NMessage Config.Config

-- | data type
-- 
data I18NSnaplet = I18NSnaplet
                    { _getI18NConfig  :: I18NConfig
                    , _getI18NMessage :: I18NMessage
                    } 


-- | Compose App with a I18N Snaplet.
-- 
class HasI18N b where
  i18nLens :: Lens b (Snaplet I18NSnaplet)
  
-- | Util functions
-- 
i18nLens' :: HasI18N b => Lens (Snaplet b) (Snaplet I18NSnaplet)
i18nLens' = subSnaplet i18nLens

getI18NSnaplet :: HasI18N b => Handler b b I18NSnaplet
getI18NSnaplet = with i18nLens Snap.get

getI18NMessages :: HasI18N b => Handler b b I18NMessage
getI18NMessages = liftM _getI18NMessage getI18NSnaplet

-------------------------------------------------------

-- | Default I18N snaplet
-- 
defaultI18NSnaplet :: (HasHeist b, HasI18N b) => SnapletInit b I18NSnaplet
defaultI18NSnaplet = initI18NSnaplet Nothing Nothing

-- | Init this I18NSnaplet snaplet.
-- 
initI18NSnaplet :: (HasHeist b, HasI18N b)
                => Maybe Locale              -- ^ Locale, default to @defaultLocale@
                -> Maybe MessageFile         -- ^ Message file prefix, default to @defaultMessageFilePrefix@
                -> SnapletInit b I18NSnaplet
initI18NSnaplet l m = makeSnaplet "I18NSnaplet" "" Nothing $ do
    i18nConfig <- return $ I18NConfig (fromMaybe defaultLocale l) (fromMaybe defaultMessageFilePrefix m)
    config <- liftIO $ readMessageFile i18nConfig
    defaultSplices
    return $ I18NSnaplet i18nConfig $ I18NMessage config
  where defaultSplices = addSplices [(i18nSpliceName, liftHeist i18nSplice)]

-------------------------------------------------------
-- 

-- | Load file
--   server will not be able to start up if dir doesnt exists.
--   Thus, no additional validation check so far.
-- 
readMessageFile :: I18NConfig -> IO Config.Config
readMessageFile config = do
    base     <- getCurrentDirectory
    fullname <- return $ base </> (file config)
    Config.load [Config.Required fullname]
  where 
    -- file fullname will be like message-en_US.cfg
    file c = _getMessageFile c ++ "-" ++ _getLocale c ++ ".cfg"


-------------------------------------------------------

-- | Splice name used in Heist template.
--   e.g. <i18n name="hello" />
-- 
i18nSpliceName :: T.Text
i18nSpliceName = "i18n"

-- | Output as `span` HTML element for i18n message.
--   e.g. <span>Shanghai</span>
-- 
i18nSpliceElement :: T.Text
i18nSpliceElement = "span"

-- | element attribute used for looking up i18n value.
--   e.g. <i18n name="hello" />
-- 
i18nSpliceAttr :: T.Text
i18nSpliceAttr = "name"

-- | Splices
-- 
i18nSplice :: HasI18N b => Splice (Handler b b)
i18nSplice = do
    input <- getParamNode
    (I18NMessage messages) <- lift getI18NMessages
    value <- liftIO $ getValue messages input
    -- FIXME: Turns out that it is not possible to fail at compilation if value is Nothing but runtime.
    return [X.Element i18nSpliceElement [] [X.TextNode $ T.pack value]]
    where getValue :: Config.Config -> Node -> IO String
          getValue m i = Config.lookupDefault "Error: no value found." m (getAttr' i)
          getAttr' i = case getAttribute i18nSpliceAttr i of
            Just x -> x
            _      -> ""