Browse files

Style nazi strikes

  • Loading branch information...
1 parent 3e04633 commit 888fa113d0e0c45dc06845a9a692d6067247eed1 @jaspervdj committed Jun 11, 2012
View
31 digestive-functors/src/Text/Digestive/Form/Encoding.hs
@@ -1,47 +1,66 @@
+--------------------------------------------------------------------------------
{-# LANGUAGE GADTs #-}
module Text.Digestive.Form.Encoding
( FormEncType (..)
, formEncType
, formTreeEncType
) where
-import Control.Monad (liftM)
-import Control.Monad.Identity (Identity)
-import Data.Maybe (mapMaybe)
-import Data.Monoid (Monoid (..), mconcat)
-import Text.Digestive.Field
-import Text.Digestive.Form.Internal
+--------------------------------------------------------------------------------
+import Control.Monad (liftM)
+import Control.Monad.Identity (Identity)
+import Data.Maybe (mapMaybe)
+import Data.Monoid (Monoid(..), mconcat)
+
+--------------------------------------------------------------------------------
+import Text.Digestive.Field
+import Text.Digestive.Form.Internal
+
+
+--------------------------------------------------------------------------------
data FormEncType
= UrlEncoded
| MultiPart
deriving (Eq)
+
+--------------------------------------------------------------------------------
instance Show FormEncType where
show UrlEncoded = "application/x-www-form-urlencoded"
show MultiPart = "multipart/form-data"
+
+--------------------------------------------------------------------------------
-- Monoid instance for encoding types: prefer UrlEncoded, but fallback to
-- MultiPart when needed
instance Monoid FormEncType where
mempty = UrlEncoded
mappend UrlEncoded x = x
mappend MultiPart _ = MultiPart
+
+--------------------------------------------------------------------------------
fieldEncType :: Field v a -> FormEncType
fieldEncType File = MultiPart
fieldEncType _ = UrlEncoded
+
+--------------------------------------------------------------------------------
fieldList :: FormTree Identity v m a -> [SomeField v]
fieldList = mapMaybe toField' . fieldList' . SomeForm
where
fieldList' (SomeForm f) = SomeForm f : concatMap fieldList' (children f)
toField' (SomeForm f) = toField f
+
+--------------------------------------------------------------------------------
formEncType :: Monad m => Form v m a -> m FormEncType
formEncType form = liftM formTreeEncType $ toFormTree form
+
+--------------------------------------------------------------------------------
formTreeEncType :: FormTree Identity v m a -> FormEncType
formTreeEncType = mconcat . map fieldEncType' . fieldList
where
View
78 digestive-functors/src/Text/Digestive/Form/Internal.hs
@@ -1,7 +1,11 @@
+--------------------------------------------------------------------------------
-- | This module mostly meant for internal usage, and might change between minor
-- releases.
-{-# LANGUAGE ExistentialQuantification, FlexibleInstances,
- GADTs, OverloadedStrings, Rank2Types #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE Rank2Types #-}
module Text.Digestive.Form.Internal
( Form
, FormTree (..)
@@ -20,18 +24,26 @@ module Text.Digestive.Form.Internal
, formMapView
) where
-import Control.Applicative (Applicative (..))
-import Control.Monad (liftM, liftM2, (>=>))
-import Control.Monad.Identity (Identity (..))
-import Data.Maybe (maybeToList)
-import Data.Monoid (Monoid)
-import Data.Text (Text)
-import qualified Data.Text as T
+--------------------------------------------------------------------------------
+import Control.Applicative (Applicative(..))
+import Control.Monad (liftM, liftM2, (>=>))
+import Control.Monad.Identity (Identity(..))
+import Data.Maybe (maybeToList)
+import Data.Monoid (Monoid)
-import Text.Digestive.Types
-import Text.Digestive.Field
+--------------------------------------------------------------------------------
+import Data.Text (Text)
+import qualified Data.Text as T
+
+
+--------------------------------------------------------------------------------
+import Text.Digestive.Field
+import Text.Digestive.Types
+
+
+--------------------------------------------------------------------------------
-- | Base type for a form.
--
-- The three type parameters are:
@@ -48,6 +60,8 @@ import Text.Digestive.Field
--
type Form v m a = FormTree m v m a
+
+--------------------------------------------------------------------------------
data FormTree t v m a where
Pure :: Ref -> Field v a -> FormTree t v m a
App :: Ref
@@ -59,23 +73,37 @@ data FormTree t v m a where
Monadic :: t (FormTree t v m a) -> FormTree t v m a
+
+--------------------------------------------------------------------------------
instance Monad m => Functor (FormTree t v m) where
fmap = transform . (return .) . (return .)
+
+--------------------------------------------------------------------------------
instance (Monad m, Monoid v) => Applicative (FormTree t v m) where
pure x = Pure Nothing (Singleton x)
x <*> y = App Nothing x y
+
+--------------------------------------------------------------------------------
instance Show (FormTree Identity v m a) where
show = unlines . showForm
+
+--------------------------------------------------------------------------------
data SomeForm v m = forall a. SomeForm (FormTree Identity v m a)
+
+--------------------------------------------------------------------------------
instance Show (SomeForm v m) where
show (SomeForm f) = show f
+
+--------------------------------------------------------------------------------
type Ref = Maybe Text
+
+--------------------------------------------------------------------------------
showForm :: FormTree Identity v m a -> [String]
showForm form = case form of
(Pure r x) -> ["Pure (" ++ show r ++ ") (" ++ show x ++ ")"]
@@ -89,43 +117,59 @@ showForm form = case form of
where
indent = (" " ++)
+
+--------------------------------------------------------------------------------
transform :: Monad m
=> (a -> m (Result v b)) -> FormTree t v m a -> FormTree t v m b
transform f (Map g x) = flip Map x $ \y -> bindResult (g y) f
transform f x = Map f x
+
+--------------------------------------------------------------------------------
monadic :: m (Form v m a) -> Form v m a
monadic = Monadic
+
+--------------------------------------------------------------------------------
toFormTree :: Monad m => Form v m a -> m (FormTree Identity v m a)
toFormTree (Pure r x) = return $ Pure r x
toFormTree (App r x y) = liftM2 (App r) (toFormTree x) (toFormTree y)
toFormTree (Map f x) = liftM (Map f) (toFormTree x)
toFormTree (Monadic x) = x >>= toFormTree >>= return . Monadic . Identity
+
+--------------------------------------------------------------------------------
children :: FormTree Identity v m a -> [SomeForm v m]
children (Pure _ _) = []
children (App _ x y) = [SomeForm x, SomeForm y]
children (Map _ x) = children x
children (Monadic x) = children $ runIdentity x
+
+--------------------------------------------------------------------------------
setRef :: Monad t => Ref -> FormTree t v m a -> FormTree t v m a
setRef r (Pure _ x) = Pure r x
setRef r (App _ x y) = App r x y
setRef r (Map f x) = Map f (setRef r x)
setRef r (Monadic x) = Monadic $ liftM (setRef r) x
+
+--------------------------------------------------------------------------------
-- | Operator to set a name for a subform.
(.:) :: Monad m => Text -> Form v m a -> Form v m a
(.:) = setRef . Just
infixr 5 .:
+
+--------------------------------------------------------------------------------
getRef :: FormTree Identity v m a -> Ref
getRef (Pure r _) = r
getRef (App r _ _) = r
getRef (Map _ x) = getRef x
getRef (Monadic x) = getRef $ runIdentity x
+
+--------------------------------------------------------------------------------
lookupForm :: Path -> FormTree Identity v m a -> [SomeForm v m]
lookupForm path = go path . SomeForm
where
@@ -139,11 +183,15 @@ lookupForm path = go path . SomeForm
| otherwise -> []
Nothing -> children form >>= go (r : rs)
+
+--------------------------------------------------------------------------------
toField :: FormTree Identity v m a -> Maybe (SomeField v)
toField (Pure _ x) = Just (SomeField x)
toField (Map _ x) = toField x
toField _ = Nothing
+
+--------------------------------------------------------------------------------
queryField :: Path
-> FormTree Identity v m a
-> (forall b. Field v b -> c)
@@ -156,10 +204,14 @@ queryField path form f = case lookupForm path form of
where
ref = T.unpack $ fromPath path
+
+--------------------------------------------------------------------------------
ann :: Path -> Result v a -> Result [(Path, v)] a
ann _ (Success x) = Success x
ann path (Error x) = Error [(path, x)]
+
+--------------------------------------------------------------------------------
eval :: Monad m => Method -> Env m -> FormTree Identity v m a
-> m (Result [(Path, v)] a, [(Path, FormInput)])
eval = eval' []
@@ -194,13 +246,17 @@ eval' context method env form = case form of
where
path = context ++ maybeToList (getRef form)
+
+--------------------------------------------------------------------------------
formMapView :: Monad m
=> (v -> w) -> FormTree Identity v m a -> FormTree Identity w m a
formMapView f (Pure r x) = Pure r $ (fieldMapView f) x
formMapView f (App r x y) = App r (formMapView f x) (formMapView f y)
formMapView f (Map g x) = Map (g >=> return . resultMapError f) (formMapView f x)
formMapView f (Monadic x) = formMapView f $ runIdentity x
+
+--------------------------------------------------------------------------------
-- | Utility: bind for 'Result' inside another monad
bindResult :: Monad m
=> m (Result v a) -> (a -> m (Result v b)) -> m (Result v b)
View
35 digestive-functors/src/Text/Digestive/Types.hs
@@ -1,3 +1,4 @@
+--------------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
module Text.Digestive.Types
( Result (..)
@@ -10,61 +11,87 @@ module Text.Digestive.Types
, Env
) where
-import Control.Applicative (Applicative (..))
-import Data.Monoid (Monoid, mappend)
-import Data.Text (Text)
-import qualified Data.Text as T
+--------------------------------------------------------------------------------
+import Control.Applicative (Applicative(..))
+import Data.Monoid (Monoid, mappend)
+
+--------------------------------------------------------------------------------
+import Data.Text (Text)
+import qualified Data.Text as T
+
+
+--------------------------------------------------------------------------------
-- | A mostly internally used type for representing Success/Error, with a
-- special applicative instance
data Result v a
= Success a
| Error v
deriving (Show)
+
+--------------------------------------------------------------------------------
instance Functor (Result v) where
fmap f (Success x) = Success (f x)
fmap _ (Error x) = Error x
+
+--------------------------------------------------------------------------------
instance Monoid v => Applicative (Result v) where
pure x = Success x
Error x <*> Error y = Error $ mappend x y
Error x <*> Success _ = Error x
Success _ <*> Error y = Error y
Success x <*> Success y = Success (x y)
+
+--------------------------------------------------------------------------------
instance Monad (Result v) where
return x = Success x
(Error x) >>= _ = Error x
(Success x) >>= f = f x
+
+--------------------------------------------------------------------------------
-- | Map over the error type of a 'Result'
resultMapError :: (v -> w) -> Result v a -> Result w a
resultMapError f (Error x) = Error (f x)
resultMapError _ (Success x) = Success x
+
+--------------------------------------------------------------------------------
-- | Describes a path to a subform
type Path = [Text]
+
+--------------------------------------------------------------------------------
-- | Create a 'Path' from some text
toPath :: Text -> Path
toPath = filter (not . T.null) . T.split (== '.')
+
+--------------------------------------------------------------------------------
-- | Serialize a 'Path' to 'Text'
fromPath :: Path -> Text
fromPath = T.intercalate "."
+
+--------------------------------------------------------------------------------
-- | The HTTP methods
data Method = Get | Post
deriving (Eq, Ord, Show)
+
+--------------------------------------------------------------------------------
-- | The different input types sent by the browser
data FormInput
= TextInput Text
| FileInput FilePath
deriving (Show)
+
+--------------------------------------------------------------------------------
-- | An environment (e.g. a server) from which we can read input parameters. A
-- single key might be associated with multiple text values (multi-select).
type Env m = Path -> m [FormInput]
View
3 digestive-functors/src/Text/Digestive/Util.hs
@@ -1,7 +1,10 @@
+--------------------------------------------------------------------------------
module Text.Digestive.Util
( readMaybe
) where
+
+--------------------------------------------------------------------------------
-- | 'read' in the 'Maybe' monad.
readMaybe :: Read a => String -> Maybe a
readMaybe str = case readsPrec 1 str of
View
17 digestive-functors/tests/Text/Digestive/Field/Tests.hs
@@ -1,15 +1,22 @@
+--------------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
module Text.Digestive.Field.Tests
( tests
) where
-import Test.Framework (Test, testGroup)
-import Test.Framework.Providers.HUnit (testCase)
-import Test.HUnit ((@=?))
-import Text.Digestive.Field
-import Text.Digestive.Types
+--------------------------------------------------------------------------------
+import Test.Framework (Test, testGroup)
+import Test.Framework.Providers.HUnit (testCase)
+import Test.HUnit ((@=?))
+
+--------------------------------------------------------------------------------
+import Text.Digestive.Field
+import Text.Digestive.Types
+
+
+--------------------------------------------------------------------------------
tests :: Test
tests = testGroup "Text.Digestive.Field.Tests"
[ testCase "evalField singleton" $
View
23 digestive-functors/tests/Text/Digestive/Form/Encoding/Tests.hs
@@ -1,19 +1,25 @@
+--------------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
module Text.Digestive.Form.Encoding.Tests
( tests
) where
-import Control.Applicative ((<$>), (<*>))
-import Control.Monad.Identity (Identity (..))
-import Data.Text (Text)
-import Test.Framework (Test, testGroup)
-import Test.Framework.Providers.HUnit (testCase)
-import Test.HUnit ((@=?))
+--------------------------------------------------------------------------------
+import Control.Applicative ((<$>), (<*>))
+import Control.Monad.Identity (Identity(..))
+import Data.Text (Text)
+import Test.Framework (Test, testGroup)
+import Test.Framework.Providers.HUnit (testCase)
+import Test.HUnit ((@=?))
-import Text.Digestive.Form
-import Text.Digestive.Form.Encoding
+--------------------------------------------------------------------------------
+import Text.Digestive.Form
+import Text.Digestive.Form.Encoding
+
+
+--------------------------------------------------------------------------------
tests :: Test
tests = testGroup "Text.Digestive.Field.Tests"
[ testCase "formEncType url-encoded" $
@@ -23,7 +29,6 @@ tests = testGroup "Text.Digestive.Field.Tests"
, testCase "formEncType multipart" $
MultiPart @=? formEncType' ((,) <$> file <*> bool Nothing)
]
-
where
formEncType' :: Form Text Identity a -> FormEncType
formEncType' = runIdentity . formEncType
View
2 digestive-functors/tests/Text/Digestive/Tests/Fixtures.hs
@@ -151,7 +151,7 @@ data Product = Product
--------------------------------------------------------------------------------
productForm :: Form Text Database Product
-
+productForm = monadic $ do
products <- ask
return $ choiceWith (map makeChoice products) Nothing
where
View
33 digestive-functors/tests/Text/Digestive/View/Tests.hs
@@ -1,32 +1,31 @@
---------------------------------------------------------------------------------
-{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
+-------------------------------------------------------------------------------
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module Text.Digestive.View.Tests
( tests
) where
--------------------------------------------------------------------------------
-import Control.Monad.Identity (runIdentity)
-import Control.Exception (SomeException, handle)
-
-
---------------------------------------------------------------------------------
-import Data.Text (Text)
-import Test.Framework (Test, testGroup)
-import Test.Framework.Providers.HUnit (testCase)
-import Test.HUnit (Assertion, assert, assertFailure, (@=?))
+import Control.Exception (SomeException, handle)
+import Control.Monad.Identity (runIdentity)
+import Data.Text (Text)
+import Test.Framework (Test, testGroup)
+import Test.Framework.Providers.HUnit (testCase)
+import Test.HUnit ((@=?))
+import qualified Test.HUnit as H
--------------------------------------------------------------------------------
-import Text.Digestive.Tests.Fixtures
-import Text.Digestive.Types
-import Text.Digestive.View
+import Text.Digestive.Tests.Fixtures
+import Text.Digestive.Types
+import Text.Digestive.View
--------------------------------------------------------------------------------
-assertError :: Show a => a -> Assertion
-assertError x = handle (\(_ :: SomeException) -> assert True) $
- x `seq` assertFailure $ "Should throw an error but gave: " ++ show x
+assertError :: Show a => a -> H.Assertion
+assertError x = handle (\(_ :: SomeException) -> H.assert True) $
+ x `seq` H.assertFailure $ "Should throw an error but gave: " ++ show x
--------------------------------------------------------------------------------

0 comments on commit 888fa11

Please sign in to comment.