-- | Forms that configure themselves based on type
--
-- This module is for constructing forms that only output to 'Html'.
-- For forms that also parse input, see SimpleForm.Combined
module SimpleForm (
	Widget,
	DefaultWidget(..),
	Input(..),
	-- * Options
	InputOptions(..),
	Label(..),
	-- * Wrappers
	ShowRead(..),
	unShowRead,
	SelectEnum(..),
	unSelectEnum,
	-- * Widgets
	button,
	hidden,
	checkbox,
	file,
	-- ** Text-like
	text,
	textarea,
	password,
	search,
	email,
	uri,
	tel,
	-- ** Numbers
	number,
	integral,
	boundedNumber,
	boundedIntegral,
	-- ** Dates and times
	date,
	time,
	datetime,
	datetime_local,
	-- ** Collections
	GroupedCollection,
	Collection,
	select,
	multi_select,
	radio_buttons,
	buttons,
	checkboxes,
	-- * Helpers
	input_tag,
	selectEnum,
	enum,
	group_,
	multiEnum,
	humanize,
	maybeCons,
	applyAttrs
) where

import Data.Maybe
import Data.Fixed (Fixed, HasResolution)
import Data.Char (isUpper)
import Data.Monoid
import Data.Ratio
import Data.Function (on)
import Data.Foldable (foldl', forM_)
import Data.List (nubBy)
import Control.Arrow (first)
import Control.Applicative ((<|>))
import Control.Monad (join)
import Data.Time (UTCTime, LocalTime, ZonedTime, Day, TimeOfDay, formatTime, FormatTime)
import System.Locale (defaultTimeLocale, iso8601DateFormat)
import Text.Blaze.XHtml5 (Html, (!), toValue)
import qualified Text.Blaze.XHtml5 as HTML
import qualified Text.Blaze.XHtml5.Attributes as HTML hiding (label, span)
import qualified Text.Blaze.XHtml5.Attributes as HTMLA
import Data.Text (Text)
import qualified Data.Text as T
import Data.String

-- | Representation of an input widget in HTML
data Input = Input Html | MultiInput [Html] | SelfLabelInput Html

instance Monoid Input where
	mempty = Input mempty
	(Input x) `mappend` (Input y) = MultiInput [x,y]
	(Input x) `mappend` (MultiInput y) = MultiInput (x:y)
	(MultiInput x) `mappend` (Input y) = MultiInput (x ++ [y])
	(MultiInput x) `mappend` (MultiInput y) = MultiInput (x ++ y)
	(SelfLabelInput x) `mappend` y = Input x `mappend` y
	x `mappend` (SelfLabelInput y) = x `mappend` Input y

-- | A block label, inline label, or implied value label
data Label = Label Text | InlineLabel Text | DefaultLabel
	deriving (Show, Eq)

instance IsString Label where
	fromString = Label . fromString

-- | The setup for rendering an input. Blank is 'Data.Monoid.mempty'
data InputOptions = InputOptions {
		label :: Maybe Label,
		hint :: Maybe Text,
		required :: Bool,
		disabled :: Bool,
		input_html :: [(Text,Text)],
		label_html :: [(Text,Text)],
		error_html :: [(Text,Text)],
		hint_html :: [(Text,Text)],
		wrapper_html :: [(Text,Text)]
	} deriving (Show, Eq)

instance Monoid InputOptions where
	mempty = InputOptions {
		label = Just DefaultLabel,
		hint = Nothing,
		required = True,
		disabled = False,
		input_html = [],
		label_html = [],
		error_html = [],
		hint_html = [],
		wrapper_html = []
	}

	mappend a b = InputOptions {
		label = label (if label b == Just DefaultLabel then a else b),
		hint = monoidOr (hint b) (hint a),
		required = required (if required b then a else b),
		disabled = disabled (if not (disabled b) then a else b),
		input_html = input_html a ++ input_html b,
		label_html = label_html a ++ label_html b,
		error_html = error_html a ++ error_html b,
		hint_html = hint_html a ++ hint_html b,
		wrapper_html = wrapper_html a ++ wrapper_html b
	}

monoidOr :: (Monoid a, Eq a) => a -> a -> a
monoidOr a b
	| a == mempty = b
	| otherwise = a

-- | Format identifiers nicely for humans to read
humanize :: Text -> Text
humanize =
	T.unwords . map titleWord . titleFirstWord . T.words . T.concatMap go
	where
	titlecase word = T.toUpper (T.singleton $ T.head word)
		`T.append` T.tail word
	titleFirstWord [] = []
	titleFirstWord (w:ws) = titlecase w : ws
	titleWord word
		| T.length word < 4 = word
		| otherwise = titlecase word
	go c
		| isUpper c = T.singleton ' ' `T.append` T.toLower (T.singleton c)
		| c == '_' = T.singleton ' '
		| otherwise = T.singleton c

-- | Infer a 'Widget' based on type
class DefaultWidget a where
	wdef :: Widget a
	wdefList :: Widget [a]
	wdefList _ _ _ _ =
		-- Some things just can't be multi-selected (like Text)
		Input $ HTML.p $ HTML.toHtml "No useful multi-select box for this type."

instance (DefaultWidget a) => DefaultWidget [a] where
	wdef = wdefList

instance DefaultWidget Bool where
	wdef = checkbox
	wdefList = wdefList . fmap (map SelectEnum)

instance DefaultWidget Text where
	wdef = text

instance DefaultWidget Char where
	wdef = text . fmap T.singleton
	wdefList = text . fmap T.pack -- Heh, hack for 'String'

instance DefaultWidget Integer where
	wdef = integral

instance DefaultWidget Int where
	wdef = boundedIntegral
	wdefList = wdefList . fmap (map SelectEnum)

instance DefaultWidget Float where
	wdef = number

instance DefaultWidget Double where
	wdef = number

instance (HasResolution a) => DefaultWidget (Fixed a) where
	wdef = number

instance DefaultWidget UTCTime where
	wdef = datetime

instance DefaultWidget ZonedTime where
	wdef = datetime

instance DefaultWidget LocalTime where
	wdef = datetime_local

instance DefaultWidget Day where
	wdef = date

instance DefaultWidget TimeOfDay where
	wdef = time

instance (Integral a, Show a) => DefaultWidget (Ratio a) where
	wdef = number . fmap (\x -> realToFrac x :: Double)

instance (DefaultWidget a, DefaultWidget b) => DefaultWidget (a, b) where
	wdef v u n opt = wdef (fmap fst v) u n opt `mappend` wdef (fmap snd v) u n opt

instance (DefaultWidget a) => DefaultWidget (Maybe a) where
	wdef = wdef . join

-- | Wrapper for types that should be rendered using 'show'
newtype ShowRead a = ShowRead a deriving (Eq, Ord)

unShowRead :: ShowRead a -> a
unShowRead (ShowRead x) = x

instance (Show a, Read a) => Show (ShowRead a) where
	show (ShowRead x) = show x

instance (Read a) => Read (ShowRead a) where
	readsPrec n s = map (first ShowRead) (readsPrec n s)

instance (Show a, Read a) => DefaultWidget (ShowRead a) where
	wdef = text . fmap (T.pack . show)

-- | Wrapper for select boxes on enumerable types
newtype SelectEnum a = SelectEnum a deriving (Eq, Ord)

unSelectEnum :: SelectEnum a -> a
unSelectEnum (SelectEnum x) = x

instance (Show a, Read a) => Show (SelectEnum a) where
	show (SelectEnum x) = show x

instance (Read a) => Read (SelectEnum a) where
	readsPrec n s = map (first SelectEnum) (readsPrec n s)

instance (Bounded a) => Bounded (SelectEnum a) where
	minBound = SelectEnum minBound
	maxBound = SelectEnum maxBound

instance (Enum a) => Enum (SelectEnum a) where
	toEnum = SelectEnum . toEnum
	fromEnum (SelectEnum x) = fromEnum x

-- | Collection of items for the user to choose from, with optional grouping
--
-- A trivial 'GroupedCollection' (with just one, blankly-named group)
-- should be treated by 'Widget's as if it were just a 'Collection'
type GroupedCollection = [(Text, [(Text, Text)])]

-- | Collection of items for the user to choose from
type Collection = [(Text, Text)]

-- | Derive a collection from an enumerable type
selectEnum :: (Show a, Read a, Bounded a, Enum a) => a -> Collection
selectEnum v = map (\x -> let x' = T.pack $ show x in (x', humanize x')) opts
	where
	opts = [minBound `asTypeOf` v .. maxBound `asTypeOf` v]

-- | Feed a collection 'Widget' from an enumerable type
enum :: (Show a, Read a, Bounded a, Enum a) => (GroupedCollection -> Widget Text) -> Widget a
enum w v = w (group_ $ selectEnum $ fromJust v) (fmap (T.pack . show) v)

-- | Feed a multi-select collection 'Widget' from an enumerable type
multiEnum :: (Show a, Read a, Bounded a, Enum a) => (GroupedCollection -> Widget [Text]) -> Widget [a]
multiEnum w v = w (group_ $ selectEnum $ head $ fromJust v) (fmap (fmap (T.pack . show)) v)

-- | Push any 'Collection' to a trivial 'GroupedCollection'
group_ :: Collection -> GroupedCollection
group_ c = [(mempty, c)]

instance (Show a, Read a, Bounded a, Enum a) => DefaultWidget (SelectEnum a) where
	wdef = enum select
	wdefList = multiEnum multi_select

-- | The type of a widget renderer
type Widget a = (Maybe a -> Maybe Text -> Text -> InputOptions -> Input)

text :: Widget Text
text v u n = Input . input_tag n (v <|> u) (T.pack "text") []

password :: Widget Text
password v u n = Input . input_tag n (v <|> u) (T.pack "password") []

search :: Widget Text
search v u n = Input . input_tag n (v <|> u) (T.pack "search") []

email :: Widget Text
email v u n = Input . input_tag n (v <|> u) (T.pack "email") []

uri :: Widget Text
uri v u n = Input . input_tag n (v <|> u) (T.pack "url") []

tel :: Widget Text
tel v u n = Input . input_tag n (v <|> u) (T.pack "tel") []

number :: (Num a, Show a) => Widget a
number v u n =
	Input . input_tag n (fmap (T.pack . show) v <|> u) (T.pack "number") [
		[(T.pack "step", T.pack "any")]
	]

integral :: (Integral a, Show a) => Widget a
integral v u n =
	Input . input_tag n (fmap (T.pack . show) v <|> u) (T.pack "number") [
		[(T.pack "step", T.pack "1")]
	]

boundedNumber :: (Bounded a, Num a, Show a) => Widget a
boundedNumber v u n =
	Input . input_tag n (fmap (T.pack . show) v <|> u) (T.pack "number") [
		[(T.pack "step", T.pack "any")],
		[(T.pack "min", T.pack $ show (minBound `asTypeOf` fromJust v))],
		[(T.pack "max", T.pack $ show (maxBound `asTypeOf` fromJust v))]
	]

boundedIntegral :: (Bounded a, Integral a, Show a) => Widget a
boundedIntegral v u n =
	Input . input_tag n (fmap (T.pack . show) v <|> u) (T.pack "number") [
		[(T.pack "step", T.pack "1")],
		[(T.pack "min", T.pack $ show (minBound `asTypeOf` fromJust v))],
		[(T.pack "max", T.pack $ show (maxBound `asTypeOf` fromJust v))]
	]

textarea :: Widget Text
textarea v u n (InputOptions {disabled = d, required = r, input_html =    iattrs}) = Input $
	applyAttrs (
		maybeCons d (T.pack "disabled", T.pack "disabled") $
		maybeCons r (T.pack "required", T.pack "required")
		[(T.pack "rows", T.pack "10"),(T.pack "cols", T.pack "55")]
	) iattrs (
		HTML.textarea ! HTML.name (toValue n) $
			maybe mempty HTML.toHtml (v <|> u)
	)

button :: Widget Text
button v _ n (InputOptions {label = l, disabled = d, input_html = iattrs}) = SelfLabelInput $
	applyAttrs (
		maybeCons d (T.pack "disabled", T.pack "disabled")
		[(T.pack "type", T.pack "submit")]
	) iattrs $ maybe id (\v' h -> h ! HTML.value (toValue v')) v (
		HTML.button ! HTML.name (toValue n) $
			maybe mempty (HTML.toHtml . getLabel) l
	)
	where
	getLabel (Label s) = s
	getLabel (InlineLabel s) = s
	getLabel DefaultLabel = humanize n

hidden :: Widget Text
hidden v u n = SelfLabelInput . input_tag n (v <|> u) (T.pack "hidden") []

file :: Widget Text
file v u n = Input . input_tag n (v <|> u) (T.pack "file") []

checkbox :: Widget Bool
checkbox v u n = Input . input_tag n Nothing (T.pack "checkbox") [
		[(T.pack "checked", T.pack "checked") | isChecked]
	]
	where
	isChecked = fromMaybe (maybe False (/=mempty) u) v

date :: (FormatTime a) => Widget a
date v u n = Input . input_tag n (fmap fmt v <|> u) (T.pack "date") []
	where
	fmt = T.pack . formatTime defaultTimeLocale format
	format = iso8601DateFormat Nothing

time :: (FormatTime a) => Widget a
time v u n = Input . input_tag n (fmap fmt v <|> u) (T.pack "time") []
	where
	fmt = T.pack . formatTime defaultTimeLocale format
	format = "%H:%M:%S%Q"

datetime :: (FormatTime a) => Widget a
datetime v u n = Input . input_tag n (fmap fmt v <|> u) (T.pack "datetime") []
	where
	fmt = T.pack . formatTime defaultTimeLocale format
	format = iso8601DateFormat $ Just "%H:%M:%S%Q%z"

datetime_local :: (FormatTime a) => Widget a
datetime_local v u n =
	Input . input_tag n (fmap fmt v <|> u) (T.pack "datetime-local") []
	where
	fmt = T.pack . formatTime defaultTimeLocale format
	format = iso8601DateFormat $ Just "%H:%M:%S%Q"

select :: GroupedCollection -> Widget Text
select collection v _ n (InputOptions {disabled = d, required = r, input_html = iattrs}) = Input $
	applyAttrs (
		maybeCons d (T.pack "disabled", T.pack "disabled") $
		maybeCons r (T.pack "required", T.pack "required")
		[]
	) iattrs (
		HTML.select ! HTML.name (toValue n) $
			formatCollection $ \subCollection ->
				forM_ subCollection $ \(value, label) ->
					mkSelected (Just value == v) $
					HTML.option ! HTML.value (toValue value) $
						HTML.toHtml label
	)
	where
	formatCollection f
		| length collection == 1 && fst (head collection) == mempty =
			f (snd $ head collection)
		| otherwise =
			forM_ collection $ \(group, subCollection) ->
				HTML.optgroup ! HTMLA.label (toValue group) $
					f subCollection

multi_select :: GroupedCollection -> Widget [Text]
multi_select collection v _ n (InputOptions {disabled = d, required = r, input_html = iattrs}) = Input $
	applyAttrs (
		maybeCons d (T.pack "disabled", T.pack "disabled") $
		maybeCons r (T.pack "required", T.pack "required")
		[]
	) iattrs (
		HTML.select ! HTML.name (toValue n) ! HTML.multiple (toValue "multiple") $
			formatCollection $ \subCollection ->
				forM_ subCollection $ \(value, label) ->
					mkSelected (value `elem` items) $
					HTML.option ! HTML.value (toValue value) $
						HTML.toHtml label
	)
	where
	items = fromMaybe [] v
	formatCollection f
		| length collection == 1 && fst (head collection) == mempty =
			f (snd $ head collection)
		| otherwise =
			forM_ collection $ \(group, subCollection) ->
				HTML.optgroup ! HTMLA.label (toValue group) $
					f subCollection

radio_buttons :: GroupedCollection -> Widget Text
radio_buttons collection v _ n opt =
	MultiInput $ formatCollection $ map radio
	where
	radio (value, label) = HTML.label $ do
		mkChecked (Just value == v) $
			input_tag n (Just value) (T.pack "radio") [] opt
		HTML.toHtml label
	formatCollection f
		| length collection == 1 && fst (head collection) == mempty =
			f (snd $ head collection)
		| otherwise =
			(`map` collection) $ \(group, subCollection) ->
				HTML.fieldset $ do
					HTML.legend $ HTML.toHtml group
					mconcat (f subCollection)

buttons :: GroupedCollection -> Widget Text
buttons collection _ u n opt =
	MultiInput $ formatCollection $ map go
	where
	go (value, label) =
		let SelfLabelInput html =
			button (Just value) u n (opt {label = Just $ Label label})
		in html
	formatCollection f
		| length collection == 1 && fst (head collection) == mempty =
			f (snd $ head collection)
		| otherwise =
			(`map` collection) $ \(group, subCollection) ->
				HTML.fieldset $ do
					HTML.legend $ HTML.toHtml group
					mconcat (f subCollection)

checkboxes :: GroupedCollection -> Widget [Text]
checkboxes collection v _ n opt =
	MultiInput $ formatCollection $ map check
	where
	items = fromMaybe [] v
	check (value, label) = HTML.label $ do
		mkChecked (value `elem` items) $
			input_tag n (Just value) (T.pack "checkbox") [] opt
		HTML.toHtml label
	formatCollection f
		| length collection == 1 && fst (head collection) == mempty =
			f (snd $ head collection)
		| otherwise =
			(`map` collection) $ \(group, subCollection) ->
				HTML.fieldset $ do
					HTML.legend $ HTML.toHtml group
					mconcat (f subCollection)

-- | \<input /\>
input_tag ::
	Text               -- ^ name
	-> Maybe Text      -- ^ textual value
	-> Text            -- ^ type
	-> [[(Text,Text)]] -- ^ Extra default attributes
	-> InputOptions    -- ^ Attributes from options override defaults
	-> Html
input_tag n v t dattr (InputOptions {disabled = d, required = r, input_html = iattrs}) =
	applyAttrs (
		maybeCons d (T.pack "disable", T.pack "disabled") $
		maybeCons r (T.pack "required", T.pack "required") $
		(T.pack "type", t) : concat dattr
	) iattrs $ maybe id (\v' h -> h ! HTML.value (toValue v')) v (
		HTML.input !
			HTML.name (toValue n)
	)

maybeCons :: Bool -> a -> [a] -> [a]
maybeCons True x = (x:)
maybeCons False _ = id

mkSelected :: Bool -> Html -> Html
mkSelected True = (! HTML.selected (toValue "selected"))
mkSelected False = id

mkChecked :: Bool -> Html -> Html
mkChecked True = (! HTML.checked (toValue "checked"))
mkChecked False = id

mkAttribute :: (Text,Text) -> HTML.Attribute
mkAttribute (k,v) = HTML.customAttribute (HTML.textTag k) (toValue v)

-- | Apply a list of default attributes and user overrides to some 'Html'
applyAttrs ::
	[(Text,Text)]  -- ^ Defaults
	-> [(Text,Text)] -- ^ User overrides
	-> Html          -- ^ Apply attributes to this 'Html'
	-> Html
applyAttrs dattr cattr html = foldl' (!) html (map mkAttribute attrs)
	where
	attrs = nubBy ((==) `on` fst) attrsWithClass
	attrsWithClass
		| null classes = attrs'
		| otherwise = (T.pack "class", T.unwords classes):attrs'
	classes = concatMap (T.words . snd) $ filter ((== T.pack "class") . fst) attrs'
	attrs' = cattr ++ dattr