diff --git a/colonnade/colonnade.cabal b/colonnade/colonnade.cabal index ebfb761..0fd7222 100644 --- a/colonnade/colonnade.cabal +++ b/colonnade/colonnade.cabal @@ -1,5 +1,5 @@ name: colonnade -version: 0.1 +version: 0.3 synopsis: Generic types and functions for columnar encoding and decoding description: Please see README.md homepage: https://github.com/andrewthad/colonnade#readme diff --git a/colonnade/src/Colonnade/Decoding.hs b/colonnade/src/Colonnade/Decoding.hs index 06b3ded..973b516 100644 --- a/colonnade/src/Colonnade/Decoding.hs +++ b/colonnade/src/Colonnade/Decoding.hs @@ -62,7 +62,7 @@ uncheckedRun dc v = getEitherWrap (go dc) rcurrent = mapLeft (DecodingCellErrors . Vector.singleton . DecodingCellError content ixed) (decode content) in rnext <*> (EitherWrap rcurrent) -headlessToIndexed :: forall c a. +headlessToIndexed :: forall c a. Decoding Headless c a -> Decoding (Indexed Headless) c a headlessToIndexed = go 0 where go :: forall b. Int -> Decoding Headless c b -> Decoding (Indexed Headless) c b @@ -71,7 +71,7 @@ headlessToIndexed = go 0 where DecodingAp (Indexed ix Headless) decode (go (ix + 1) apNext) length :: forall f c a. Decoding f c a -> Int -length = go 0 where +length = go 0 where go :: forall b. Int -> Decoding f c b -> Int go !a (DecodingPure _) = a go !a (DecodingAp _ _ apNext) = go (a + 1) apNext diff --git a/colonnade/src/Colonnade/Encoding.hs b/colonnade/src/Colonnade/Encoding.hs index d5aa667..3a53ab7 100644 --- a/colonnade/src/Colonnade/Encoding.hs +++ b/colonnade/src/Colonnade/Encoding.hs @@ -21,27 +21,27 @@ headed h f = Encoding (Vector.singleton (OneEncoding (Headed h) f)) -- instead. It may allow more things to get inlined -- in to a loop. runRow :: (c1 -> c2) -> Encoding f c1 a -> a -> Vector c2 -runRow g (Encoding v) a = flip Vector.map v $ +runRow g (Encoding v) a = flip Vector.map v $ \(OneEncoding _ encode) -> g (encode a) -runRowMonadic :: Monad m - => Encoding f content a - -> (content -> m ()) - -> a - -> m () -runRowMonadic (Encoding v) g a = Vector.forM_ v $ \e -> +runRowMonadic :: (Monad m, Monoid b) + => Encoding f content a + -> (content -> m b) + -> a + -> m b +runRowMonadic (Encoding v) g a = fmap (mconcat . Vector.toList) $ Vector.forM v $ \e -> g (oneEncodingEncode e a) runHeader :: (c1 -> c2) -> Encoding Headed c1 a -> Vector c2 -runHeader g (Encoding v) = +runHeader g (Encoding v) = Vector.map (g . getHeaded . oneEncodingHead) v -runHeaderMonadic :: Monad m - => Encoding Headed content a - -> (content -> m ()) - -> m () -runHeaderMonadic (Encoding v) g = - Vector.mapM_ (g . getHeaded . oneEncodingHead) v +runHeaderMonadic :: (Monad m, Monoid b) + => Encoding Headed content a + -> (content -> m b) + -> m b +runHeaderMonadic (Encoding v) g = + fmap (mconcat . Vector.toList) $ Vector.mapM (g . getHeaded . oneEncodingHead) v diff --git a/colonnade/src/Colonnade/Types.hs b/colonnade/src/Colonnade/Types.hs index ee0b477..99443e4 100644 --- a/colonnade/src/Colonnade/Types.hs +++ b/colonnade/src/Colonnade/Types.hs @@ -107,7 +107,7 @@ instance Contravariant (OneEncoding f content) where contramap f (OneEncoding h e) = OneEncoding h (e . f) newtype Encoding f content a = Encoding - { getEncoding :: Vector (OneEncoding f content a) + { getEncoding :: Vector (OneEncoding f content a) } deriving (Monoid) instance Contravariant (Encoding f content) where diff --git a/reflex-dom-colonnade/reflex-dom-colonnade.cabal b/reflex-dom-colonnade/reflex-dom-colonnade.cabal index 7a96cef..a5d83f1 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.2 +version: 0.3 synopsis: Use colonnade with reflex-dom description: Please see README.md homepage: https://github.com/andrewthad/colonnade#readme @@ -18,12 +18,13 @@ library Reflex.Dom.Colonnade build-depends: base >= 4.7 && < 5 - , colonnade + , colonnade >= 0.3 , contravariant , vector , reflex , reflex-dom , containers + , semigroups default-language: Haskell2010 ghc-options: -Wall diff --git a/reflex-dom-colonnade/src/Reflex/Dom/Colonnade.hs b/reflex-dom-colonnade/src/Reflex/Dom/Colonnade.hs index 397e658..86c2634 100644 --- a/reflex-dom-colonnade/src/Reflex/Dom/Colonnade.hs +++ b/reflex-dom-colonnade/src/Reflex/Dom/Colonnade.hs @@ -2,26 +2,28 @@ module Reflex.Dom.Colonnade where import Colonnade.Types import Control.Monad -import Reflex (Dynamic) +import Data.Foldable +import Reflex (Dynamic,Event,switchPromptly,never) import Reflex.Dynamic (mapDyn) import Reflex.Dom (MonadWidget) import Reflex.Dom.Widget.Basic import Data.Map (Map) +import Data.Semigroup (Semigroup) import qualified Colonnade.Encoding as Encoding import qualified Data.Map as Map -cell :: m () -> Cell m +cell :: m b -> Cell m b cell = Cell Map.empty -data Cell m = Cell - { cellAttrs :: Map String String - , cellContents :: m () +data Cell m b = Cell + { cellAttrs :: !(Map String String) + , cellContents :: !(m b) } basic :: (MonadWidget t m, Foldable f) => Map String String -- ^ Table element attributes -> f a -- ^ Values - -> Encoding Headed (Cell m) a -- ^ Encoding of a value into cells + -> Encoding Headed (Cell m ()) a -- ^ Encoding of a value into cells -> m () basic tableAttrs as encoding = do elAttr "table" tableAttrs $ do @@ -29,17 +31,17 @@ basic tableAttrs as encoding = do el "tbody" $ forM_ as $ \a -> do el "tr" $ mapM_ (Encoding.runRowMonadic encoding (elFromCell "td")) as -elFromCell :: MonadWidget t m => String -> Cell m -> m () +elFromCell :: MonadWidget t m => String -> Cell m b -> m b elFromCell name (Cell attrs contents) = elAttr name attrs contents -theadBuild :: MonadWidget t m => Encoding Headed (Cell m) a -> m () -theadBuild encoding = el "thead" . el "tr" +theadBuild :: (MonadWidget t m, Monoid b) => Encoding Headed (Cell m b) a -> m b +theadBuild encoding = el "thead" . el "tr" $ Encoding.runHeaderMonadic encoding (elFromCell "th") dynamic :: (MonadWidget t m, Foldable f) => Map String String -- ^ Table element attributes -> f (Dynamic t a) -- ^ Dynamic values - -> Encoding Headed (Cell m) a -- ^ Encoding of a value into cells + -> Encoding Headed (Cell m ()) a -- ^ Encoding of a value into cells -> m () dynamic tableAttrs as encoding@(Encoding v) = do elAttr "table" tableAttrs $ do @@ -52,3 +54,21 @@ dynamic tableAttrs as encoding@(Encoding v) = do _ <- elDynAttr "td" dynAttrs $ dyn dynContent return () +dynamicEventful :: (MonadWidget t m, Traversable f, Semigroup e) + => Map String String -- ^ Table element attributes + -> f (Dynamic t a) -- ^ Dynamic values + -> Encoding Headed (Cell m (Event t e)) a -- ^ Encoding of a value into cells + -> m (Event t e) +dynamicEventful tableAttrs as encoding@(Encoding v) = do + elAttr "table" tableAttrs $ do + b1 <- theadBuild encoding + b2 <- el "tbody" $ forM as $ \a -> do + el "tr" $ forM v $ \(OneEncoding _ encode) -> do + dynPair <- mapDyn encode a + dynAttrs <- mapDyn cellAttrs dynPair + dynContent <- mapDyn cellContents dynPair + e <- elDynAttr "td" dynAttrs $ dyn dynContent + -- TODO: This might actually be wrong. Revisit this. + switchPromptly never e + return (mappend b1 (mconcat $ toList $ mconcat $ toList b2)) + diff --git a/siphon/src/Siphon.hs b/siphon/src/Siphon.hs index 945ce35..5c6b00a 100644 --- a/siphon/src/Siphon.hs +++ b/siphon/src/Siphon.hs @@ -4,7 +4,7 @@ module Siphon where -- encode -- decode :: Pipe (Vector c) a m x --- encode :: +-- encode :: -- row :: Vector (Escaped Text) -> Text -- row = Vector. diff --git a/siphon/src/Siphon/Content.hs b/siphon/src/Siphon/Content.hs index 03f21bf..26e1f79 100644 --- a/siphon/src/Siphon/Content.hs +++ b/siphon/src/Siphon/Content.hs @@ -1,4 +1,4 @@ -module Siphon.Content +module Siphon.Content ( byteStringChar8 ) where diff --git a/siphon/src/Siphon/Decoding.hs b/siphon/src/Siphon/Decoding.hs index 0f06f2e..bc6b938 100644 --- a/siphon/src/Siphon/Decoding.hs +++ b/siphon/src/Siphon/Decoding.hs @@ -17,7 +17,7 @@ import qualified Data.ByteString.Char8 as ByteString import qualified Data.Attoparsec.Types as Atto -- unrow :: c1 -> (Vector c2,c1) --- +-- -- row :: _ -- -> Decoding (Indexed f) c a -- -> Vector c @@ -27,7 +27,7 @@ import qualified Data.Attoparsec.Types as Atto -- Monad m -- => Decoding (Indexed f) c a -- -> Pipe (Vector c) a m () --- decodeVectorPipe +-- decodeVectorPipe mkParseError :: Int -> [String] -> String -> DecodingRowError f content mkParseError i ctxs msg = id @@ -55,7 +55,7 @@ indexedPipe :: Monad m -> Decoding (Indexed Headless) c a -> Pipe c a m (DecodingRowError Headless c) indexedPipe sd decoding = do - (firstRow, mleftovers) <- consumeGeneral sd mkParseError + (firstRow, mleftovers) <- consumeGeneral sd mkParseError let req = Decoding.maxIndex decoding vlen = Vector.length firstRow if vlen < req @@ -72,28 +72,28 @@ headedPipe :: (Monad m, Eq c) -> Decoding Headed c a -> Pipe c a m (DecodingRowError Headed c) headedPipe sd decoding = do - (headers, mleftovers) <- consumeGeneral sd mkParseError + (headers, mleftovers) <- consumeGeneral sd mkParseError case Decoding.headedToIndexed headers decoding of Left headingErrs -> return (DecodingRowError 0 (RowErrorHeading headingErrs)) - Right indexedDecoding -> + Right indexedDecoding -> let requiredLength = Vector.length headers in uncheckedPipe requiredLength 1 sd indexedDecoding mleftovers - + uncheckedPipe :: Monad m => Int -- ^ expected length of each row -> Int -- ^ index of first row, usually zero or one - -> Siphon c + -> Siphon c -> Decoding (Indexed f) c a -> Maybe c -> Pipe c a m (DecodingRowError f c) -uncheckedPipe requiredLength ix sd d mleftovers = +uncheckedPipe requiredLength ix sd d mleftovers = pipeGeneral ix sd mkParseError checkedRunWithRow mleftovers where - checkedRunWithRow rowIx v = + checkedRunWithRow rowIx v = let vlen = Vector.length v in if vlen /= requiredLength - then Left $ DecodingRowError rowIx + then Left $ DecodingRowError rowIx $ RowErrorSize requiredLength vlen else Decoding.uncheckedRunWithRow rowIx d v @@ -110,7 +110,7 @@ pipeGeneral :: Monad m -> (Int -> Vector c -> Either e a) -> Maybe c -- ^ leftovers that should be handled first -> Pipe c a m e -pipeGeneral initIx (Siphon _ _ parse isNull) wrapParseError decodeRow mleftovers = +pipeGeneral initIx (Siphon _ _ parse isNull) wrapParseError decodeRow mleftovers = case mleftovers of Nothing -> go1 initIx Just leftovers -> handleResult initIx (parse leftovers) @@ -138,6 +138,6 @@ awaitSkip :: Monad m awaitSkip f = go where go = do a <- await - if f a then go else return a + if f a then go else return a diff --git a/siphon/src/Siphon/Encoding.hs b/siphon/src/Siphon/Encoding.hs index d02d6c6..a55fa99 100644 --- a/siphon/src/Siphon/Encoding.hs +++ b/siphon/src/Siphon/Encoding.hs @@ -7,27 +7,27 @@ import qualified Pipes.Prelude as Pipes import qualified Colonnade.Encoding as Encoding row :: Siphon c - -> Encoding f c a - -> a + -> Encoding f c a + -> a -> c row (Siphon escape intercalate _ _) e = intercalate . Encoding.runRow escape e header :: Siphon c - -> Encoding Headed c a + -> Encoding Headed c a -> c header (Siphon escape intercalate _ _) e = intercalate (Encoding.runHeader escape e) -pipe :: Monad m +pipe :: Monad m => Siphon c - -> Encoding f c a + -> Encoding f c a -> Pipe a c m x pipe siphon encoding = Pipes.map (row siphon encoding) -headedPipe :: Monad m - => Siphon c - -> Encoding Headed c a +headedPipe :: Monad m + => Siphon c + -> Encoding Headed c a -> Pipe a c m x headedPipe siphon encoding = do yield (header siphon encoding) diff --git a/siphon/src/Siphon/Internal.hs b/siphon/src/Siphon/Internal.hs index 8a203b4..3f3832a 100644 --- a/siphon/src/Siphon/Internal.hs +++ b/siphon/src/Siphon/Internal.hs @@ -40,8 +40,8 @@ import Control.Applicative import Data.Monoid byteStringChar8 :: Siphon ByteString -byteStringChar8 = Siphon - escape +byteStringChar8 = Siphon + escape encodeRow (A.parse (row comma)) B.null @@ -54,7 +54,7 @@ encodeRow = id . coerce escape :: ByteString -> Escaped ByteString -escape t = case B.find (\c -> c == newline || c == comma || c == doubleQuote) t of +escape t = case B.find (\c -> c == newline || c == cr || c == comma || c == doubleQuote) t of Nothing -> Escaped t Just _ -> escapeAlways t diff --git a/siphon/src/Siphon/Types.hs b/siphon/src/Siphon/Types.hs index 110beeb..6a6b0e3 100644 --- a/siphon/src/Siphon/Types.hs +++ b/siphon/src/Siphon/Types.hs @@ -31,6 +31,6 @@ data SiphonDecoding c1 c2 = SiphonDecoding -- } -- data SiphonDecodingError --- { clarify +-- { clarify -- } diff --git a/siphon/test/Test.hs b/siphon/test/Test.hs index 9b5db1a..0cc00ba 100644 --- a/siphon/test/Test.hs +++ b/siphon/test/Test.hs @@ -32,9 +32,9 @@ main = defaultMain tests tests :: [Test] tests = - [ testGroup "ByteString encode/decode" + [ testGroup "ByteString encode/decode" [ testCase "Headless Encoding (int,char,bool)" testEncodingA - , testProperty "Headless Isomorphism (int,char,bool)" + , testProperty "Headless Isomorphism (int,char,bool)" $ propIsoPipe $ (SE.pipe SC.byteStringChar8 encodingA) >-> @@ -42,7 +42,6 @@ tests = ] ] - decodingA :: Decoding Headless ByteString (Int,Char,Bool) decodingA = (,,) <$> Decoding.headless CDB.int @@ -63,8 +62,8 @@ propIsoPipe :: Eq a => Pipe a a Identity () -> [a] -> Bool propIsoPipe p as = (Pipes.toList $ each as >-> p) == as testEncodingA :: Assertion -testEncodingA = - ( ByteString.concat $ Pipes.toList $ +testEncodingA = + ( ByteString.concat $ Pipes.toList $ Pipes.yield (4,'c',False) >-> SE.pipe SC.byteStringChar8 encodingA ) @?= "4,c,false\n"