formlets.hs

module Formlets where

import Control.Applicative
import Control.Monad
import Control.Monad.Reader
import Control.Monad.State
import Control.Arrow (first)
import Data.Monoid
import Data.Either
import Data.Maybe

--------------------------------------------------------------------------------
-- ABSTRACT TYPES AND FUNCTIONS                                               --
--------------------------------------------------------------------------------

data Result ok = Error [(IdRange, String)]
               | Ok ok
               deriving (Show)

newtype View v = View {unView :: [(IdRange, String)] -> v}

newtype Field m inp v a = Field {unField :: FieldState m inp (View v, Result a)}

newtype Validator m a = Validator {unValidator :: a -> m [String]}

-- | Environment is where you get your input
--
data Environment m inp = Environment {unEnvironment :: Integer -> m (Maybe inp)}

-- | Monad under which our applicative functors are composed
--
type FieldState m inp a = ReaderT (Environment m inp) (StateT IdRange m) a

data IdRange = IdRange Integer Integer
             deriving (Show)

getFieldId :: Monad m => FieldState m inp Integer
getFieldId = do
    IdRange x _ <- get
    return x

getFieldRange :: Monad m => FieldState m inp IdRange
getFieldRange = get

getFieldInput :: Monad m => FieldState m inp (Maybe inp)
getFieldInput = do
    id' <- getFieldId
    env <- ask
    lift $ lift $ unEnvironment env id'

mapView :: Monad m => (IdRange -> Maybe inp -> View v -> View v) -> Field m inp v a -> Field m inp v a
mapView f field = Field $ do
    (view, result) <- unField field
    range <- getFieldRange
    inp <- getFieldInput
    return (f range inp view, result)

--------------------------------------------------------------------------------
-- EXAMPLE                                                                    --
--------------------------------------------------------------------------------

showRange :: IdRange -> Maybe inp -> View String -> View String
showRange range _ view = View $ \err -> show range ++ ":\n" ++ unView view err ++ "\n"

addLabel :: String -> Maybe inp -> View String -> View String
addLabel id' _ view = View $ \err -> "Label (" ++ id' ++ ") " ++ unView view err

rangeErrors :: IdRange -> [(IdRange, String)] -> [String]
rangeErrors (IdRange min' max') = map snd . filter (inRange . fst)
  where
    inRange (IdRange a b) = a >= min' && b <= max'

percentage :: Field IO String String Int
percentage = Field $ do
    id' <- getFieldId
    range <- getFieldRange
    inp <- getFieldInput
    return (view id' range inp, reader range inp) 
  where
    view id' range inp = View $ \err -> "Enter percentage, given: (" ++ show inp ++
        "), ID: " ++ show id' ++ ", range: " ++ show range ++ ", errors: " ++
        show (rangeErrors range err) ++ "\n"

    reader range Nothing = Error [(range, "Must enter value")]
    reader _ (Just s) = Ok (read s)

inRange :: Monad m => Validator m Int
inRange = Validator $ \x -> return $ if x >= 0 && x <= 100 then [] else return "must be in [0, 100]"

prettySmall :: Monad m => Validator m Int
prettySmall = Validator $ \x -> return $ if x <= 50 then [] else return "must be <50"

validate :: Monad m => Field m inp v a -> Validator m a -> Field m inp v a
validate field validator = Field $ do
    (view, result) <- unField field
    range <- getFieldRange
    case result of
        Error e -> return (view, Error e)
        Ok x -> do
            r <- lift $ lift $ unValidator validator x
            return $ case r of
                [] -> (view, Ok x)
                e -> (view, Error $ map ((,) range) e)

addition :: Field IO String String Int
addition = (\x y z -> x + y + z) <$> validate percentage inRange
                                 <*> validate percentage prettySmall
                                 <*> percentage

--------------------------------------------------------------------------------
-- RUNNING STUFF                                                              --
--------------------------------------------------------------------------------

runFieldState :: Monad m => Environment m inp -> Field m inp v a -> m (View v, Result a)
runFieldState env field = evalStateT (runReaderT (unField field) env) $ IdRange 0 1

getField :: Field IO inp String a -> IO String
getField field = do
    (view, _) <- runFieldState env field
    return $ unView view []
  where
    env = Environment $ const $ return Nothing

printField :: Field IO inp String a -> IO ()
printField = putStrLn <=< getField

postField :: Field IO String String a -> [(Integer, String)] -> IO (Either String a)
postField field env = do
    (view, result) <- runFieldState (Environment $ return . flip lookup env) field
    return $ case result of Error err -> Left $ unView view err
                            Ok x -> Right x

--------------------------------------------------------------------------------
-- HERE BE MONADS, APPLICATIVE FUNCTORS AND DRAGONS                           --
--------------------------------------------------------------------------------

instance Functor Result where
    fmap f (Error x) = Error x
    fmap f (Ok x) = Ok (f x)

instance Monad Result where
    return = Ok
    Error x >>= _ = Error x
    Ok x >>= f = f x

instance Applicative Result where
    pure = Ok
    Error x <*> Error y = Error $ x ++ y
    Error x <*> Ok _ = Error x
    Ok _ <*> Error y = Error y
    Ok x <*> Ok y = Ok $ x y

instance Monoid v => Monoid (View v) where
    mempty = View $ const mempty
    mappend (View f) (View g) = View $ \err -> mappend (f err) (g err)

instance Monad m => Monoid (Validator m inp) where
    mempty = Validator $ const $ return mempty
    v1 `mappend` v2 = Validator $ \inp ->
        liftM2 mappend (unValidator v1 inp) (unValidator v2 inp)

instance Monad m => Functor (Field m inp v) where
    fmap f field = Field $ do
        (view, result) <- unField field
        return (view, fmap f result)

instance (Monad m, Monoid v) => Applicative (Field m inp v) where
    pure x = Field $ return (mempty, return x)
    f1 <*> f2 = Field $ do
        -- Assuming f1 already has a valid ID
        IdRange startF1 _ <- get
        (v1, r1) <- unField f1
        IdRange _ endF1 <- get

        -- Set a new, empty range
        put $ IdRange endF1 $ endF1 + 1
        (v2, r2) <- unField f2
        IdRange _ endF2 <- get

        put $ IdRange startF1 endF2
        return (v1 `mappend` v2, r1 <*> r2)