Skip to content
This repository
Browse code

Partial switch to text labels for choice (WIP)

See #38
  • Loading branch information...
commit 5e325af248b4951949aba758dd3caadf581e9ab0 1 parent 7242c85
Jasper Van der Jeugt authored June 10, 2012
3  digestive-functors/src/Text/Digestive.hs
... ...
@@ -1,3 +1,4 @@
  1
+--------------------------------------------------------------------------------
1 2
 -- | Tutorial:
2 3
 -- <http://github.com/jaspervdj/digestive-functors/blob/master/examples/tutorial.lhs>
3 4
 module Text.Digestive
@@ -8,6 +9,8 @@ module Text.Digestive
8 9
     , module Text.Digestive.View
9 10
     ) where
10 11
 
  12
+
  13
+--------------------------------------------------------------------------------
11 14
 import           Text.Digestive.Form
12 15
 import           Text.Digestive.Form.Encoding
13 16
 import           Text.Digestive.Ref
57  digestive-functors/src/Text/Digestive/Field.hs
... ...
@@ -1,4 +1,8 @@
1  
-{-# LANGUAGE ExistentialQuantification, GADTs, OverloadedStrings #-}
  1
+--------------------------------------------------------------------------------
  2
+{-# LANGUAGE BangPatterns              #-}
  3
+{-# LANGUAGE ExistentialQuantification #-}
  4
+{-# LANGUAGE GADTs                     #-}
  5
+{-# LANGUAGE OverloadedStrings         #-}
2 6
 module Text.Digestive.Field
3 7
     ( Field (..)
4 8
     , SomeField (..)
@@ -6,23 +10,31 @@ module Text.Digestive.Field
6 10
     , fieldMapView
7 11
     ) where
8 12
 
9  
-import Control.Arrow (second)
10  
-import Data.Maybe (fromMaybe, listToMaybe)
11 13
 
12  
-import Data.Text (Text)
13  
-import qualified Data.Text as T
  14
+--------------------------------------------------------------------------------
  15
+import           Control.Arrow        (second)
  16
+import           Data.Maybe           (fromMaybe, listToMaybe)
  17
+import           Data.Text            (Text)
14 18
 
15  
-import Text.Digestive.Types
16  
-import Text.Digestive.Util
17 19
 
  20
+--------------------------------------------------------------------------------
  21
+import           Text.Digestive.Types
  22
+
  23
+
  24
+--------------------------------------------------------------------------------
18 25
 -- | A single input field. This usually maps to a single HTML @<input>@ element.
19 26
 data Field v a where
20 27
     Singleton :: a -> Field v a
21 28
     Text      :: Text -> Field v Text
22  
-    Choice    :: [(a, v)] -> Int -> Field v (a, Int)
  29
+    -- | A list of identifier, value, view. Then we have the default index in
  30
+    -- the list. The return value has the actual value as well as the index in
  31
+    -- the list.
  32
+    Choice    :: [(Text, (a, v))] -> Int -> Field v (a, Int)
23 33
     Bool      :: Bool -> Field v Bool
24 34
     File      :: Field v (Maybe FilePath)
25 35
 
  36
+
  37
+--------------------------------------------------------------------------------
26 38
 instance Show (Field v a) where
27 39
     show (Singleton _) = "Singleton _"
28 40
     show (Text t)      = "Text " ++ show t
@@ -30,8 +42,12 @@ instance Show (Field v a) where
30 42
     show (Bool b)      = "Bool " ++ show b
31 43
     show (File)        = "File"
32 44
 
  45
+
  46
+--------------------------------------------------------------------------------
33 47
 data SomeField v = forall a. SomeField (Field v a)
34 48
 
  49
+
  50
+--------------------------------------------------------------------------------
35 51
 evalField :: Method       -- ^ Get/Post
36 52
           -> [FormInput]  -- ^ Given input
37 53
           -> Field v a    -- ^ Field
@@ -40,21 +56,34 @@ evalField _    _                 (Singleton x) = x
40 56
 evalField _    (TextInput x : _) (Text _)      = x
41 57
 evalField _    _                 (Text x)      = x
42 58
 evalField _    (TextInput x : _) (Choice ls y) =
43  
-    fromMaybe (fst (ls !! y), y) $ do
  59
+    fromMaybe (fst (snd (ls !! y)), y) $ do
44 60
         -- Expects input in the form of @foo.bar.2@
45  
-        t <- listToMaybe $ reverse $ toPath x
46  
-        i <- readMaybe $ T.unpack t
47  
-        return $ (fst (ls !! i), i)
48  
-evalField _    _                 (Choice ls x) = (fst (ls !! x), x)
  61
+        -- TODO: Do we really need that?
  62
+        t      <- listToMaybe $ reverse $ toPath x
  63
+        (c, i) <- lookupIdx t ls
  64
+        return (fst c, i)
  65
+evalField _    _                 (Choice ls x) = (fst (snd (ls !! x)), x)
49 66
 evalField Get  _                 (Bool x)      = x
50 67
 evalField Post (TextInput x : _) (Bool _)      = x == "on"
51 68
 evalField Post _                 (Bool _)      = False
52 69
 evalField Post (FileInput x : _) File          = Just x
53 70
 evalField _    _                 File          = Nothing
54 71
 
  72
+
  73
+--------------------------------------------------------------------------------
55 74
 fieldMapView :: (v -> w) -> Field v a -> Field w a
56 75
 fieldMapView _ (Singleton x)   = Singleton x
57 76
 fieldMapView _ (Text x)        = Text x
58  
-fieldMapView f (Choice xs i)   = Choice (map (second f) xs) i
  77
+fieldMapView f (Choice xs i)   = Choice (map (second (second f)) xs) i
59 78
 fieldMapView _ (Bool x)        = Bool x
60 79
 fieldMapView _ File            = File
  80
+
  81
+
  82
+--------------------------------------------------------------------------------
  83
+lookupIdx :: Eq k => k -> [(k, v)] -> Maybe (v, Int)
  84
+lookupIdx key = go 0
  85
+  where
  86
+    go _  []        = Nothing
  87
+    go !i ((k, v) : xs)
  88
+        | key == k  = Just (v, i)
  89
+        | otherwise = go (i + 1) xs
65  digestive-functors/src/Text/Digestive/Form.hs
... ...
@@ -1,4 +1,8 @@
1  
-{-# LANGUAGE ExistentialQuantification, GADTs, OverloadedStrings, Rank2Types #-}
  1
+--------------------------------------------------------------------------------
  2
+{-# LANGUAGE ExistentialQuantification #-}
  3
+{-# LANGUAGE GADTs                     #-}
  4
+{-# LANGUAGE OverloadedStrings         #-}
  5
+{-# LANGUAGE Rank2Types                #-}
2 6
 module Text.Digestive.Form
3 7
     ( Formlet
4 8
     , Form
@@ -29,44 +33,69 @@ module Text.Digestive.Form
29 33
     , monadic
30 34
     ) where
31 35
 
32  
-import Control.Monad (liftM)
33  
-import Data.List (findIndex)
34  
-import Data.Maybe (fromMaybe)
35 36
 
36  
-import Data.Text (Text)
37  
-import qualified Data.Text as T
  37
+--------------------------------------------------------------------------------
  38
+import           Control.Monad                (liftM)
  39
+import           Data.List                    (findIndex)
  40
+import           Data.Maybe                   (fromMaybe)
  41
+import           Data.Text                    (Text)
  42
+import qualified Data.Text                    as T
38 43
 
39  
-import Text.Digestive.Field
40  
-import Text.Digestive.Form.Internal
41  
-import Text.Digestive.Types
42  
-import Text.Digestive.Util
43 44
 
  45
+--------------------------------------------------------------------------------
  46
+import           Text.Digestive.Field
  47
+import           Text.Digestive.Form.Internal
  48
+import           Text.Digestive.Ref
  49
+import           Text.Digestive.Types
  50
+import           Text.Digestive.Util
  51
+
  52
+
  53
+--------------------------------------------------------------------------------
44 54
 type Formlet m v a = Maybe a -> Form m v a
45 55
 
  56
+
  57
+--------------------------------------------------------------------------------
46 58
 text :: Formlet v m Text
47 59
 text def = Pure Nothing $ Text $ fromMaybe "" def
48 60
 
  61
+
  62
+--------------------------------------------------------------------------------
49 63
 string :: Monad m => Formlet v m String
50 64
 string = fmap T.unpack . text . fmap T.pack
51 65
 
  66
+
  67
+--------------------------------------------------------------------------------
52 68
 stringRead :: (Monad m, Read a, Show a) => v -> Formlet v m a
53 69
 stringRead err = transform (readTransform err) . string . fmap show
54 70
 
  71
+
  72
+--------------------------------------------------------------------------------
55 73
 choice :: (Eq a, Monad m) => [(a, v)] -> Formlet v m a
56 74
 choice items def = choice' items $
57 75
     maybe Nothing (\d -> findIndex ((== d) . fst) items) def
58 76
 
  77
+
  78
+--------------------------------------------------------------------------------
59 79
 -- | Sometimes there is no good 'Eq' instance for 'choice'. In this case, you
60 80
 -- can use this function, which takes an index in the list as default.
61 81
 choice' :: Monad m => [(a, v)] -> Maybe Int -> Form v m a
62  
-choice' items def = fmap fst $ Pure Nothing $ Choice items $ fromMaybe 0 def
  82
+choice' items def = fmap fst $ Pure Nothing $ Choice items' def'
  83
+  where
  84
+    items' = zip makeRefs items
  85
+    def'   = fromMaybe 0 def
  86
+
63 87
 
  88
+--------------------------------------------------------------------------------
64 89
 bool :: Formlet v m Bool
65 90
 bool = Pure Nothing . Bool . fromMaybe False
66 91
 
  92
+
  93
+--------------------------------------------------------------------------------
67 94
 file :: Form v m (Maybe FilePath)
68 95
 file = Pure Nothing File
69 96
 
  97
+
  98
+--------------------------------------------------------------------------------
70 99
 -- | Validate the results of a form with a simple predicate
71 100
 --
72 101
 -- Example:
@@ -79,6 +108,8 @@ check :: Monad m
79 108
       -> Form v m a   -- ^ Resulting form
80 109
 check err = checkM err . (return .)
81 110
 
  111
+
  112
+--------------------------------------------------------------------------------
82 113
 -- | Version of 'check' which allows monadic validations
83 114
 checkM :: Monad m => v -> (a -> m Bool) -> Form v m a -> Form v m a
84 115
 checkM err predicate form = validateM f form
@@ -87,6 +118,8 @@ checkM err predicate form = validateM f form
87 118
         r <- predicate x
88 119
         return $ if r then return x else Error err
89 120
 
  121
+
  122
+--------------------------------------------------------------------------------
90 123
 -- | This is an extension of 'check' that can be used to apply transformations
91 124
 -- that optionally fail
92 125
 --
@@ -102,10 +135,14 @@ checkM err predicate form = validateM f form
102 135
 validate :: Monad m => (a -> Result v b) -> Form v m a -> Form v m b
103 136
 validate = validateM . (return .)
104 137
 
  138
+
  139
+--------------------------------------------------------------------------------
105 140
 -- | Version of 'validate' which allows monadic validations
106 141
 validateM :: Monad m => (a -> m (Result v b)) -> Form v m a -> Form v m b
107 142
 validateM = transform
108 143
 
  144
+
  145
+--------------------------------------------------------------------------------
109 146
 optionalText :: Monad m => Maybe Text -> Form v m (Maybe Text)
110 147
 optionalText def = validate optional (text def)
111 148
   where
@@ -113,9 +150,13 @@ optionalText def = validate optional (text def)
113 150
         | T.null t  = return Nothing
114 151
         | otherwise = return $ Just t
115 152
 
  153
+
  154
+--------------------------------------------------------------------------------
116 155
 optionalString :: Monad m => Maybe String -> Form v m (Maybe String)
117 156
 optionalString = fmap (fmap T.unpack) . optionalText . fmap T.pack
118 157
 
  158
+
  159
+--------------------------------------------------------------------------------
119 160
 optionalStringRead :: (Monad m, Read a, Show a)
120 161
                    => v -> Maybe a -> Form v m (Maybe a)
121 162
 optionalStringRead err = transform readTransform' . optionalString . fmap show
@@ -123,5 +164,7 @@ optionalStringRead err = transform readTransform' . optionalString . fmap show
123 164
     readTransform' (Just s) = liftM (fmap Just) $ readTransform err s
124 165
     readTransform' Nothing  = return (return Nothing)
125 166
 
  167
+
  168
+--------------------------------------------------------------------------------
126 169
 readTransform :: (Monad m, Read a) => v -> String -> m (Result v a)
127 170
 readTransform err = return . maybe (Error err) return . readMaybe
2  digestive-functors/src/Text/Digestive/Ref.hs
@@ -28,4 +28,4 @@ makeRef =
28 28
 --------------------------------------------------------------------------------
29 29
 -- | Create an infinite list of refs.
30 30
 makeRefs :: [Text]
31  
-makeRefs = ["df-" `T.append` T.pack (show i) | i <- [0 :: Int ..]]
  31
+makeRefs = map (T.pack . show) [0 :: Int ..]
70  digestive-functors/src/Text/Digestive/View.hs
... ...
@@ -1,5 +1,8 @@
1  
-{-# LANGUAGE ExistentialQuantification, GADTs, OverloadedStrings,
2  
-        ScopedTypeVariables #-}
  1
+--------------------------------------------------------------------------------
  2
+{-# LANGUAGE ExistentialQuantification #-}
  3
+{-# LANGUAGE GADTs                     #-}
  4
+{-# LANGUAGE OverloadedStrings         #-}
  5
+{-# LANGUAGE ScopedTypeVariables       #-}
3 6
 module Text.Digestive.View
4 7
     ( View (..)
5 8
 
@@ -30,18 +33,23 @@ module Text.Digestive.View
30 33
     , childErrors
31 34
     ) where
32 35
 
33  
-import Control.Arrow (second)
34  
-import Control.Monad.Identity (Identity)
35  
-import Data.List (isPrefixOf)
36 36
 
37  
-import Data.Text (Text)
38  
-import qualified Data.Text as T
  37
+--------------------------------------------------------------------------------
  38
+import           Control.Arrow                (second)
  39
+import           Control.Monad.Identity       (Identity)
  40
+import           Data.List                    (isPrefixOf)
  41
+import           Data.Text                    (Text)
  42
+import qualified Data.Text                    as T
39 43
 
40  
-import Text.Digestive.Field
41  
-import Text.Digestive.Form.Encoding
42  
-import Text.Digestive.Form.Internal
43  
-import Text.Digestive.Types
44 44
 
  45
+--------------------------------------------------------------------------------
  46
+import           Text.Digestive.Field
  47
+import           Text.Digestive.Form.Encoding
  48
+import           Text.Digestive.Form.Internal
  49
+import           Text.Digestive.Types
  50
+
  51
+
  52
+--------------------------------------------------------------------------------
45 53
 data View v = forall a m. Monad m => View
46 54
     { viewName    :: Text
47 55
     , viewContext :: Path
@@ -51,20 +59,28 @@ data View v = forall a m. Monad m => View
51 59
     , viewMethod  :: Method
52 60
     }
53 61
 
  62
+
  63
+--------------------------------------------------------------------------------
54 64
 instance Functor View where
55 65
     fmap f (View name ctx form input errs method) = View
56 66
         name ctx (formMapView f form) input (map (second f) errs) method
57 67
 
  68
+
  69
+--------------------------------------------------------------------------------
58 70
 instance Show v => Show (View v) where
59 71
     show (View name ctx form input errs method) =
60 72
         "View " ++ show name ++ " " ++ show ctx ++ " " ++ show form ++ " " ++
61 73
         show input ++ " " ++ show errs ++ " " ++ show method
62 74
 
  75
+
  76
+--------------------------------------------------------------------------------
63 77
 getForm :: Monad m => Text -> Form v m a -> m (View v)
64 78
 getForm name form = do
65 79
     form' <- toFormTree form
66 80
     return $ View name [] form' [] [] Get
67 81
 
  82
+
  83
+--------------------------------------------------------------------------------
68 84
 postForm :: Monad m => Text -> Form v m a -> Env m -> m (View v, Maybe a)
69 85
 postForm name form env = do
70 86
     form' <- toFormTree form
@@ -74,12 +90,16 @@ postForm name form env = do
74 90
   where
75 91
     env' = env . (name :)
76 92
 
  93
+
  94
+--------------------------------------------------------------------------------
77 95
 subView :: Text -> View v -> View v
78 96
 subView ref (View name ctx form input errs method) =
79 97
     View name (ctx ++ path) form input errs method
80 98
   where
81 99
     path = toPath ref
82 100
 
  101
+
  102
+--------------------------------------------------------------------------------
83 103
 -- | Returns all immediate subviews of a view
84 104
 subViews :: View v -> [View v]
85 105
 subViews view@(View _ _ form _ _ _) =
@@ -89,26 +109,38 @@ subViews view@(View _ _ form _ _ _) =
89 109
         Nothing -> [r | c <- children f, r <- go c]
90 110
         Just r  -> [r]
91 111
 
  112
+
  113
+--------------------------------------------------------------------------------
92 114
 -- | Determine an absolute 'Path' for a field in the form
93 115
 absolutePath :: Text -> View v -> Path
94 116
 absolutePath ref view@(View name _ _ _ _ _) = name : viewPath ref view
95 117
 
  118
+
  119
+--------------------------------------------------------------------------------
96 120
 -- | Determine an absolute path and call 'fromPath' on it. Useful if you're
97 121
 -- writing a view library...
98 122
 absoluteRef :: Text -> View v -> Text
99 123
 absoluteRef ref view = fromPath $ absolutePath ref view
100 124
 
  125
+
  126
+--------------------------------------------------------------------------------
101 127
 -- | Internal version of 'absolutePath' which does not take the form name into
102 128
 -- account
103 129
 viewPath :: Text -> View v -> Path
104 130
 viewPath ref (View _ ctx _ _ _ _) = ctx ++ toPath ref
105 131
 
  132
+
  133
+--------------------------------------------------------------------------------
106 134
 viewEncType :: View v -> FormEncType
107 135
 viewEncType (View _ _ form _ _ _) = formTreeEncType form
108 136
 
  137
+
  138
+--------------------------------------------------------------------------------
109 139
 lookupInput :: Path -> [(Path, FormInput)] -> [FormInput]
110 140
 lookupInput path = map snd . filter ((== path) . fst)
111 141
 
  142
+
  143
+--------------------------------------------------------------------------------
112 144
 fieldInputText :: forall v. Text -> View v -> Text
113 145
 fieldInputText ref view@(View _ _ form input _ method) =
114 146
     queryField path form eval'
@@ -122,21 +154,25 @@ fieldInputText ref view@(View _ _ form input _ method) =
122 154
         f      -> error $ T.unpack ref ++ ": expected (Text _), " ++
123 155
             "but got: (" ++ show f ++ ")"
124 156
 
125  
-fieldInputChoice :: forall v. Text -> View v -> ([v], Int)
  157
+
  158
+--------------------------------------------------------------------------------
  159
+fieldInputChoice :: forall v. Text -> View v -> ([(Text, v)], Int)
126 160
 fieldInputChoice ref view@(View _ _ form input _ method) =
127 161
     queryField path form eval'
128 162
   where
129 163
     path       = viewPath ref view
130 164
     givenInput = lookupInput path input
131 165
 
132  
-    eval' :: Field v b -> ([v], Int)
  166
+    eval' :: Field v b -> ([(Text, v)], Int)
133 167
     eval' field = case field of
134 168
         Choice xs i ->
135 169
             let idx = snd $ evalField method givenInput (Choice xs i)
136  
-            in (map snd xs, idx)
  170
+            in (map (\(k, (_, v)) -> (k, v)) xs, idx)
137 171
         f           -> error $ T.unpack ref ++ ": expected (Choice _ _), " ++
138 172
             "but got: (" ++ show f ++ ")"
139 173
 
  174
+
  175
+--------------------------------------------------------------------------------
140 176
 fieldInputBool :: forall v. Text -> View v -> Bool
141 177
 fieldInputBool ref view@(View _ _ form input _ method) =
142 178
     queryField path form eval'
@@ -150,6 +186,8 @@ fieldInputBool ref view@(View _ _ form input _ method) =
150 186
         f      -> error $ T.unpack ref ++ ": expected (Bool _), " ++
151 187
             "but got: (" ++ show f ++ ")"
152 188
 
  189
+
  190
+--------------------------------------------------------------------------------
153 191
 fieldInputFile :: forall v. Text -> View v -> Maybe FilePath
154 192
 fieldInputFile ref view@(View _ _ form input _ method) =
155 193
     queryField path form eval'
@@ -163,10 +201,14 @@ fieldInputFile ref view@(View _ _ form input _ method) =
163 201
         f    -> error $ T.unpack ref ++ ": expected (File), " ++
164 202
             "but got: (" ++ show f ++ ")"
165 203
 
  204
+
  205
+--------------------------------------------------------------------------------
166 206
 errors :: Text -> View v -> [v]
167 207
 errors ref view = map snd $ filter ((== viewPath ref view) . fst) $
168 208
     viewErrors view
169 209
 
  210
+
  211
+--------------------------------------------------------------------------------
170 212
 childErrors :: Text -> View v -> [v]
171 213
 childErrors ref view = map snd $
172 214
     filter ((viewPath ref view `isPrefixOf`) . fst) $ viewErrors view

0 notes on commit 5e325af

Please sign in to comment.
Something went wrong with that request. Please try again.