diff --git a/colonnade/src/Colonnade/Decoding.hs b/colonnade/src/Colonnade/Decoding.hs index d4c8f36..c698581 100644 --- a/colonnade/src/Colonnade/Decoding.hs +++ b/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) + diff --git a/colonnade/src/Colonnade/Encoding.hs b/colonnade/src/Colonnade/Encoding.hs index d62739f..e682b8d 100644 --- a/colonnade/src/Colonnade/Encoding.hs +++ b/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)) diff --git a/colonnade/src/Colonnade/Types.hs b/colonnade/src/Colonnade/Types.hs index 7d157d6..1f3e5d2 100644 --- a/colonnade/src/Colonnade/Types.hs +++ b/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 (\(h,c) -> (h,c . snd . f)) b) - + (Vector.map (contramap (fst . f)) a) + (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) diff --git a/reflex-dom-colonnade/reflex-dom-colonnade.cabal b/reflex-dom-colonnade/reflex-dom-colonnade.cabal index 2ba7853..52864d4 100644 --- a/reflex-dom-colonnade/reflex-dom-colonnade.cabal +++ 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 diff --git a/reflex-dom-colonnade/src/Reflex/Dom/Colonnade.hs b/reflex-dom-colonnade/src/Reflex/Dom/Colonnade.hs index 1d52dcc..5c49f39 100644 --- a/reflex-dom-colonnade/src/Reflex/Dom/Colonnade.hs +++ b/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),_) -> - elAttr "th" attrs contents + el "thead" $ el "tr" $ + 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),_) -> - elAttr "th" attrs contents + el "thead" $ el "tr" $ + 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