mirror of
https://github.com/byteverse/colonnade.git
synced 2024-09-11 06:45:41 +03:00
Added functions for indexing headers
This commit is contained in:
parent
2ca732f4c9
commit
5325778502
@ -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)
|
||||
|
||||
|
||||
|
@ -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))
|
||||
|
||||
|
@ -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)
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user