Added functions for indexing headers

colonnade/src/Colonnade/Decoding.hs

@@ -4,6 +4,8 @@ module Colonnade.Decoding where
 
 import Colonnade.Types
 import Data.Functor.Contravariant
+import Data.Vector (Vector)
+import qualified Data.Vector as Vector
 
 -- | Converts the content type of a 'Decoding'. The @'Contravariant' f@
 -- constraint means that @f@ can be 'Headless' but not 'Headed'.
@@ -21,4 +23,30 @@ headless f = DecodingAp Headless f (DecodingPure id)
 headed :: content -> (content -> Either String a) -> Decoding Headed content a
 headed h f = DecodingAp (Headed h) f (DecodingPure id)
 
+headedToIndexed :: forall content a. Eq content
+                => Vector content
+                -> Decoding Headed content a
+                -> Either (HeadingError content) (Decoding Indexed content a)
+headedToIndexed v = go
+  where
+  go :: forall b. Eq content
+     => Decoding Headed content b
+     -> Either (HeadingError content) (Decoding Indexed content b)
+  go (DecodingPure b) = Right (DecodingPure b)
+  go (DecodingAp (Headed h) decode apNext) =
+    let rnext = go apNext
+        ixs = Vector.elemIndices h v
+        ixsLen = Vector.length ixs
+        rcurrent
+          | ixsLen == 1 = Right (Vector.unsafeIndex ixs 0)
+          | ixsLen == 0 = Left (HeadingError (Vector.singleton h) Vector.empty)
+          | otherwise   = Left (HeadingError Vector.empty (Vector.singleton (h,ixsLen)))
+    in case rcurrent of
+         Right ix -> case rnext of
+           Right apIx -> Right (DecodingAp (Indexed ix) decode apIx)
+           Left errNext -> Left errNext
+         Left err -> case rnext of
+           Right _ -> Left err
+           Left errNext -> Left (mappend err errNext)
+
 

colonnade/src/Colonnade/Encoding.hs

@@ -5,11 +5,11 @@ import qualified Data.Vector as Vector
 
 mapContent :: Functor f => (c1 -> c2) -> Encoding f c1 a -> Encoding f c2 a
 mapContent f (Encoding v) = Encoding
-  $ Vector.map (\(h,c) -> (fmap f h,f . c)) v
+  $ Vector.map (\(OneEncoding h c) -> (OneEncoding (fmap f h) (f . c))) v
 
 headless :: (a -> content) -> Encoding Headless content a
-headless f = Encoding (Vector.singleton (Headless,f))
+headless f = Encoding (Vector.singleton (OneEncoding Headless f))
 
 headed :: content -> (a -> content) -> Encoding Headed content a
-headed h f = Encoding (Vector.singleton (Headed h,f))
+headed h f = Encoding (Vector.singleton (OneEncoding (Headed h) f))
 

colonnade/src/Colonnade/Types.hs

@@ -4,8 +4,11 @@
 module Colonnade.Types
   ( Encoding(..)
   , Decoding(..)
+  , OneEncoding(..)
   , Headed(..)
   , Headless(..)
+  , Indexed(..)
+  , HeadingError(..)
   ) where
 
 import Data.Vector (Vector)
@@ -21,6 +24,20 @@ newtype Headed a = Headed { getHeaded :: a }
 data Headless a = Headless
   deriving (Eq,Ord,Functor,Show,Read)
 
+-- | Isomorphic to @'Const' 'Int'@
+newtype Indexed a = Indexed { getIndexed :: Int }
+  deriving (Eq,Ord,Functor,Show,Read)
+
+data HeadingError content = HeadingError
+  { headingErrorMissing   :: Vector content -- ^ headers that were missing
+  , headingErrorDuplicate :: Vector (content,Int) -- ^ headers that occurred more than once
+  } deriving (Show,Read)
+
+instance Monoid (HeadingError content) where
+  mempty = HeadingError Vector.empty Vector.empty
+  mappend (HeadingError a1 b1) (HeadingError a2 b2) = HeadingError
+    (a1 Vector.++ a2) (b1 Vector.++ b2)
+
 instance Contravariant Headless where
   contramap _ Headless = Headless
 
@@ -44,19 +61,28 @@ instance Applicative (Decoding f content) where
   DecodingPure f <*> y = fmap f y
   DecodingAp h c y <*> z = DecodingAp h c (flip <$> y <*> z)
 
+data OneEncoding f content a = OneEncoding
+  { oneEncodingHead   :: !(f content)
+  , oneEncodingEncode :: !(a -> content)
+  }
+
+instance Contravariant (OneEncoding f content) where
+  contramap f (OneEncoding h e) = OneEncoding h (e . f)
+
 newtype Encoding f content a = Encoding
-  { getEncoding :: Vector (f content,a -> content) }
+  { getEncoding :: Vector (OneEncoding f content a) }
   deriving (Monoid)
 
 instance Contravariant (Encoding f content) where
   contramap f (Encoding v) = Encoding
-    (Vector.map (\(h,c) -> (h, c . f)) v)
+    (Vector.map (contramap f) v)
 
 instance Divisible (Encoding f content) where
   conquer = Encoding Vector.empty
   divide f (Encoding a) (Encoding b) =
     Encoding $ (Vector.++)
-      (Vector.map (\(h,c) -> (h,c . fst . f)) a)
+      (Vector.map (contramap (fst . f)) a)
-      (Vector.map (\(h,c) -> (h,c . snd . f)) b)
+      (Vector.map (contramap (snd . f)) b)
-
+      -- (Vector.map (\(OneEncoding h c) -> (h,c . fst . f)) a)
+      -- (Vector.map (\(OneEncoding h c) -> (h,c . snd . f)) b)
 

reflex-dom-colonnade/reflex-dom-colonnade.cabal

@@ -1,5 +1,5 @@
 name:                reflex-dom-colonnade
-version:             0.1
+version:             0.2
 synopsis:            Use colonnade with reflex-dom
 description:         Please see README.md
 homepage:            https://github.com/andrewthad/colonnade#readme

reflex-dom-colonnade/src/Reflex/Dom/Colonnade.hs

@@ -24,10 +24,11 @@ basic :: (MonadWidget t m, Foldable f)
       -> m ()
 basic tableAttrs as (Encoding v) = do
   elAttr "table" tableAttrs $ do
-    el "thead" $ el "tr" $ forM_ v $ \(Headed (Cell attrs contents),_) ->
+    el "thead" $ el "tr" $
-      elAttr "th" attrs contents
+      forM_ v $ \(OneEncoding (Headed (Cell attrs contents)) _) ->
+        elAttr "th" attrs contents
     el "tbody" $ forM_ as $ \a -> do
-      el "tr" $ forM_ v $ \(_,encode) -> do
+      el "tr" $ forM_ v $ \(OneEncoding _ encode) -> do
         let Cell attrs contents = encode a
         elAttr "td" attrs contents
 
@@ -38,10 +39,11 @@ dynamic :: (MonadWidget t m, Foldable f)
         -> m ()
 dynamic tableAttrs as (Encoding v) = do
   elAttr "table" tableAttrs $ do
-    el "thead" $ el "tr" $ forM_ v $ \(Headed (Cell attrs contents),_) ->
+    el "thead" $ el "tr" $
-      elAttr "th" attrs contents
+      forM_ v $ \(OneEncoding (Headed (Cell attrs contents)) _) ->
+        elAttr "th" attrs contents
     el "tbody" $ forM_ as $ \a -> do
-      el "tr" $ forM_ v $ \(_,encode) -> do
+      el "tr" $ forM_ v $ \(OneEncoding _ encode) -> do
         dynPair <- mapDyn encode a
         dynAttrs <- mapDyn cellAttrs dynPair
         dynContent <- mapDyn cellContents dynPair