diff --git a/ditto.cabal b/ditto.cabal --- a/ditto.cabal +++ b/ditto.cabal @@ -1,5 +1,5 @@ Name: ditto -Version: 0.1.0.0 +Version: 0.1.1.0 Synopsis: ditto is a type-safe HTML form generation and validation library Description: ditto follows in the footsteps of formlets and digestive-functors <= 0.2. It provides a @@ -18,7 +18,7 @@ source-repository head type: git - location: https://github.com/Happstack/ditto.git + location: https://github.com/goolord/ditto.git library ghc-options: -Wall diff --git a/src/Ditto.hs b/src/Ditto.hs --- a/src/Ditto.hs +++ b/src/Ditto.hs @@ -1,13 +1,11 @@ module Ditto - ( module Data.Monoid - , module Ditto.Backend + ( module Ditto.Backend , module Ditto.Core , module Ditto.Result , module Ditto.Proof ) where -import Data.Monoid import Ditto.Backend import Ditto.Core import Ditto.Result diff --git a/src/Ditto/Core.hs b/src/Ditto/Core.hs --- a/src/Ditto/Core.hs +++ b/src/Ditto/Core.hs @@ -11,10 +11,11 @@ import Control.Monad.State (MonadState (get, put), StateT, evalStateT) import Control.Monad.Trans (lift) import Data.Bifunctor (Bifunctor (..)) +import Data.List.NonEmpty (NonEmpty(..)) import Data.Monoid (Monoid (mappend, mempty)) -import qualified Data.Semigroup as SG import Data.Text.Lazy (Text, unpack) import Ditto.Result (FormId (..), FormRange (..), Result (..), unitRange, zeroId) +import qualified Data.Semigroup as SG ------------------------------------------------------------------------------ -- * Proved @@ -117,6 +118,13 @@ getFormId = do FormRange x _ <- get pure x + +getNamedFormId :: Monad m => String -> FormState m i FormId +getNamedFormId name = do + FormRange x _ <- get + pure $ case x of + FormIdCustom _ i -> FormIdCustom name i + FormId _ (i :| _) -> FormIdCustom name i -- | Utility function: increment the current 'FormId'. incFormId :: Monad m => FormState m i () diff --git a/src/Ditto/Generalized/Named.hs b/src/Ditto/Generalized/Named.hs --- a/src/Ditto/Generalized/Named.hs +++ b/src/Ditto/Generalized/Named.hs @@ -26,7 +26,7 @@ -> Form m input err view a input fromInput toView initialValue name = Form $ do - let i = FormIdCustom name + i <- getNamedFormId name v <- getFormInput' i case v of Default -> @@ -70,7 +70,7 @@ -> Form m input err view (Maybe a) inputMaybe fromInput toView initialValue name = Form $ do - let i = FormIdCustom name + i <- getNamedFormId name v <- getFormInput' i case v of Default -> pure @@ -118,7 +118,7 @@ -> Form m input err view () inputNoData toView a name = Form $ do - let i = FormIdCustom name + i <- getNamedFormId name pure ( View $ const $ toView i a , pure $ @@ -138,7 +138,7 @@ -> Form m input err view (FileType input) inputFile toView name = Form $ do - let i = FormIdCustom name + i <- getNamedFormId name v <- getFormInput' i case v of Default -> @@ -181,7 +181,7 @@ -> Form m input err view [a] inputMulti choices mkView isSelected name = Form $ do - let i = FormIdCustom name + i <- getNamedFormId name inp <- getFormInput' i case inp of Default -> @@ -225,7 +225,7 @@ augmentChoice (vl, (_, lbl, checked)) = do incFormId - let i = FormIdCustom name + i <- getNamedFormId name pure (i, vl, lbl, checked) -- | radio buttons, single @\@ boxes @@ -238,7 +238,7 @@ -> Form m input err view a inputChoice isDefault choices mkView name = Form $ do - let i = FormIdCustom name + i <- getNamedFormId name inp <- getFormInput' i case inp of Default -> @@ -300,7 +300,7 @@ augmentChoice (vl, (_a, lbl, selected)) = do incFormId - let i = FormIdCustom name + i <- getNamedFormId name pure (i, vl, lbl, selected) -- | radio buttons, single @\@ boxes @@ -313,7 +313,7 @@ -> Form m input err view a inputChoiceForms def choices mkView name = Form $ do - let i = FormIdCustom name -- id used for the 'name' attribute of the radio buttons + i <- getNamedFormId name -- id used for the 'name' attribute of the radio buttons inp <- getFormInput' i case inp of Default -> @@ -388,7 +388,7 @@ augmentChoice (vl, (frm, lbl, selected)) = do incFormId - let i = FormIdCustom name + i <- getNamedFormId name incFormId iview <- getFormId pure (i, vl, iview, frm, lbl, selected) @@ -415,10 +415,11 @@ label :: Monad m => (FormId -> view) + -> String -> Form m input err view () -label f = +label f name = Form $ do - id' <- getFormId + id' <- getNamedFormId name pure ( View (const $ f id') , pure diff --git a/src/Ditto/Result.hs b/src/Ditto/Result.hs --- a/src/Ditto/Result.hs +++ b/src/Ditto/Result.hs @@ -29,19 +29,16 @@ deriving (Show, Eq) instance Functor (Result e) where - fmap _ (Error x) = Error x fmap f (Ok x) = Ok (f x) instance Monad (Result e) where - return = Ok Error x >>= _ = Error x Ok x >>= f = f x instance Applicative (Result e) where - pure = Ok Error x <*> Error y = Error $ x ++ y @@ -61,9 +58,9 @@ { -- | Global prefix for the form formPrefix :: String , -- | Stack indicating field. Head is most specific to this item - formIdList :: NonEmpty Integer + formIdList :: NonEmpty Int } - | FormIdCustom String + | FormIdCustom String Int deriving (Eq, Ord) -- | The zero ID, i.e. the first ID that is usable @@ -74,20 +71,20 @@ , formIdList = pure 0 } --- | map a function over the @NonEmpty Integer@ inside a 'FormId' -mapId :: (NonEmpty Integer -> NonEmpty Integer) -> FormId -> FormId +-- | map a function over the @NonEmpty Int@ inside a 'FormId' +mapId :: (NonEmpty Int -> NonEmpty Int) -> FormId -> FormId mapId f (FormId p is) = FormId p $ f is mapId _ x = x instance Show FormId where show (FormId p xs) = - p ++ "-fval[" ++ (intercalate "." $ reverse $ map show $ NE.toList xs) ++ "]" - show (FormIdCustom x) = x + p ++ "-fval-" ++ (intercalate "." $ reverse $ map show $ NE.toList xs) + show (FormIdCustom x _) = x --- | get the head 'Integer' from a 'FormId' -formId :: FormId -> Integer +-- | get the head 'Int' from a 'FormId' +formId :: FormId -> Int formId (FormId _ (x :| _)) = x -formId (FormIdCustom x) = fromIntegral $ sum $ fromEnum <$> x +formId (FormIdCustom _ x) = x -- | A range of ID's to specify a group of forms --