{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving #-} 
module RESTng.System.FormFields where

import RESTng.System.Proxy
import Control.Monad.Reader
import Control.Monad.Writer


type ValidationError = String

class (Show a, Read a) => Field a where

  showField :: a -> String
  showField = show

  readField :: String -> Maybe a
  readField s = case reads s of 
                   [(x,"")] -> Just x
                   _ -> Nothing

  defaultValue :: a

  defaultValidationError :: Proxy a -> String -> ValidationError
  defaultValidationError _ name = "The attribute '" ++ name ++ "' is invalid"

instance Field [Char] where 
 showField = id
 readField = Just
 defaultValue = ""

instance Field Bool where 
  defaultValue = True
  defaultValidationError _ name = "The attribute '" ++  name ++ "' must be False or True"


instance Field Integer where 
  defaultValue = 0
  defaultValidationError _ name = "The attribute '" ++  name ++ "' must be an integer"

instance Field Int where 
  defaultValue = 0
  defaultValidationError _ name = "The attribute '" ++  name ++ "' must be an integer"

instance Field Float where 
  defaultValue = 0
  defaultValidationError _ name = "The attribute '" ++  name ++ "' must be a number"




-----------------------------
----- Validator Monad -------
-----------------------------

type AssocList = [(String,String)]

newtype AssocListValidator a = ALV { runALV :: ReaderT AssocList (Writer [(String,ValidationError)]) a }
                               deriving (Monad, MonadReader AssocList, MonadWriter [(String,ValidationError)])

-- to run the monad
runParserAndValidator :: AssocListValidator a -> AssocList -> Either [(String,ValidationError)] a
runParserAndValidator m fields = 
            case (runWriter . ($ fields) . runReaderT . runALV) m of 
                          (x, []) -> Right x
                          (_, msgs) -> Left msgs


parseAndValidateValue :: String -> (String->Maybe a) -> (a->Bool) -> a -> ValidationError -> AssocListValidator a
parseAndValidateValue name parser validation returnIfInvalid msgIfInvalid = 
            do env <- ask
               case lookup name env >>= parser of
                 Nothing -> catchAndLog
                 Just val -> if validation val
                               then return val
                               else catchAndLog
             where
                catchAndLog = tell [(name,msgIfInvalid)] >> return returnIfInvalid



-------------------------------------------------
-- Field validation functions (not primitive) ---
-------------------------------------------------

parseAndValidateField :: Field a => String -> (a->Bool) -> ValidationError -> AssocListValidator a
parseAndValidateField name validation msgIfInvalid = 
            parseAndValidateValue name readField validation defaultValue msgIfInvalid


parseField :: Field a => String -> AssocListValidator a
--parseField name = parseAndValidateField name (\_->True) (defaultValidationError (proxyOf undefined))
-- had to comment last line and make a more complex definition to solve ambiguity type problem on the defaultValidationError argument
parseField name = let 
                      m = parseAndValidateField name (\_->True) (defaultValidationError' m (proxyOf undefined) name)
                      defaultValidationError' :: Field a => m a -> Proxy a -> String -> ValidationError
                      defaultValidationError' _ = defaultValidationError
                   in m


parseNotEmpty :: String -> AssocListValidator String
parseNotEmpty name = parseAndValidateField name (not . null) ("The attribute '" ++ name ++ "' can not be empty")