packages feed

sv-core 0.1 → 0.2

raw patch · 6 files changed

+155/−45 lines, 6 files

Files

changelog.md view
@@ -1,5 +1,11 @@ # Revision history for sv-core -## 0.1 -- 2018-03-06+## 0.2 -- 2018-07-25++* Add column-name-based decoding NameDecode, NameDecode', and associated+  functions such as 'column'.+* Add some extra constructors to DecodeError for new errors++## 0.1 -- 2018-07-19  * Split off from sv-0.1
src/Data/Sv/Decode/Core.hs view
@@ -47,6 +47,9 @@ , alterInput  -- * Primitive Decodes+-- ** Name-based+, column+, (.:) -- ** Field-based , contents , char@@ -111,15 +114,19 @@ , mkDecode , promote , promote'+, runNamed+, anonymous+, makePositional ) where  import Prelude hiding (either) import qualified Prelude -import Control.Lens (alaf, view)+import Control.Lens (alaf) import Control.Monad (unless)-import Control.Monad.Reader (ReaderT (ReaderT))+import Control.Monad.Reader (ReaderT (ReaderT, runReaderT)) import Control.Monad.State (state)+import Control.Monad.Writer.Strict (runWriter) import qualified Data.Attoparsec.ByteString as A import Data.Bifunctor (first, second) import Data.ByteString (ByteString)@@ -129,7 +136,9 @@ import Data.Functor.Alt (Alt ((<!>))) import Data.Functor.Compose (Compose (Compose, getCompose)) import Data.List.NonEmpty (NonEmpty ((:|)))-import Data.Monoid (First (First))+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+import Data.Monoid (First (First), Last) import Data.Profunctor (lmap) import Data.Readable (Readable (fromBS)) import Data.Semigroup (Semigroup ((<>)), sconcat)@@ -139,7 +148,6 @@ import Data.Text (Text) import Data.Text.Encoding (decodeUtf8') import qualified Data.Text.Lazy as LT-import Data.Validation (_Validation) import Data.Vector (Vector, (!)) import qualified Data.Vector as V import Text.Parsec (Parsec)@@ -369,7 +377,8 @@ -- -- To map over the other two parameters, use the 'Data.Profunctor.Profunctor' instance. mapErrors :: (e -> x) -> Decode e s a -> Decode x s a-mapErrors f (Decode (Compose r)) = Decode (Compose (fmap (first (fmap f)) r))+mapErrors f (Decode (Compose r)) =+  Decode (Compose (fmap (rnat (first (fmap f))) r))  -- | This transforms a @Decode' s a@ into a @Decode' t a@. It needs -- functions in both directions because the errors can include fragments of the@@ -416,11 +425,6 @@   in  byteString >>== (err . run p') {-# INLINE mkParserFunction #-} --- | Convenience to get the underlying function out of a Decode in a useful form-runDecode :: Decode e s a -> Vector s -> Ind -> (DecodeValidation e a, Ind)-runDecode = runDecodeState . getCompose . unwrapDecode-{-# INLINE runDecode #-}- -- | This can be used to build a 'Decode' whose value depends on the -- result of another 'Decode'. This is especially useful since 'Decode' is not -- a 'Monad'.@@ -433,10 +437,10 @@  -- | flipped '>>==' (==<<) :: (a -> DecodeValidation e b) -> Decode e s a -> Decode e s b-(==<<) f (Decode c) =-  Decode (rmapC (`bindValidation` (view _Validation . f)) c)-    where-      rmapC g (Compose fga) = Compose (fmap g fga)+(==<<) f d =+  buildDecode $ \vec i ->+    case runDecode d vec i of+      (v, l, i') -> (bindValidation v f, l, i') infixr 1 ==<<  -- | Bind through a 'Decode'.@@ -451,27 +455,28 @@ bindDecode d f =   buildDecode $ \v i ->     case runDecode d v i of-      (Failure e, i') -> (Failure e, i')-      (Success a, i') -> runDecode (f a) v i'+      (Failure e, l, i') -> (Failure e, l, i')+      (Success a, l, i') ->+        case runDecode (f a) v i' of+          (v', l', i'') -> (v', l <> l', i'')  -- | Run a 'Decode', and based on its errors build a new 'Decode'. onError :: Decode e s a -> (DecodeErrors e -> Decode e s a) -> Decode e s a onError d f =   buildDecode $ \v i ->     case runDecode d v i of-      (Failure e, i') -> runDecode (f e) v i'-      (Success a, i') -> (Success a, i')+      (Success a, l, i') -> (Success a, l, i')+      (Failure e, l, i') ->+        case runDecode (f e) v i' of+          (v',l',i'') -> (v',l <> l',i'')  -- | Build a 'Decode' from a function.------ This version gives you just the contents of the field, with no information--- about the spacing or quoting around that field. mkDecode :: (s -> DecodeValidation e a) -> Decode e s a mkDecode f =   Decode . Compose . DecodeState . ReaderT $ \v -> state $ \(Ind i) ->     if i >= length v-    then (unexpectedEndOfRow, Ind i)-    else (f (v ! i), Ind (i+1))+    then (Compose (pure unexpectedEndOfRow), Ind i)+    else (Compose (pure (f (v ! i))), Ind (i+1))  -- | Promotes a 'Decode' to work on a whole 'Record' at once. -- This does not need to be called by the user. Instead use 'decode'.@@ -488,7 +493,50 @@ promote' se dec vecField =   let len = length vecField   in  case runDecode dec vecField (Ind 0) of-    (d, Ind i) ->-      if i >= len-      then d-      else d *> expectedEndOfRow (V.force (fmap se (V.drop i vecField)))+    (d, l, Ind i) ->+      if i < len && and l+      then d *> expectedEndOfRow (V.force (fmap se (V.drop i vecField)))+      else d++-- | Convenience to get the underlying function out of a 'Decode' in a useful form+runDecode :: Decode e s a -> Vector s -> Ind -> (DecodeValidation e a, Last Bool, Ind)+runDecode = fmap (fmap z) . runDecodeState . getCompose . unwrapDecode+  where+    z (Compose wv, i) = case runWriter wv of+      (v,l) ->(v,l,i)+{-# INLINE runDecode #-}++-- | Convenience to get the underlying function out of a 'NameDecode' in a useful form+runNamed :: NameDecode e s a -> Map s Ind -> DecodeValidation e (Decode e s a)+runNamed = fmap getCompose . runReaderT . unNamed++-- | Promote a 'Decode' to a 'NameDecode' that doesn't look for any names+anonymous :: Decode e s a -> NameDecode e s a+anonymous = Named . ReaderT . pure . Compose . pure++-- | Given a header and a 'NameDecode', resolve header names to positions and+-- return a 'Decode'+makePositional :: Ord s => Vector s -> NameDecode e s a -> DecodeValidation e (Decode e s a)+makePositional names d =+  runNamed d . M.fromList $ zip (V.toList names) (Ind <$> [0..])++-- | This is the primitive for building decoders that work with columns+--+-- Look for the column with the given name and run the given decoder on it++column :: Ord s => s -> Decode' s a -> NameDecode' s a+column s d =+  Named . ReaderT $ \m -> case M.lookup s m of+    Nothing -> Compose (missingColumn s)+    Just i -> Compose . pure . buildDecode $ \vec _ ->+      case runDecode d vec i of+        (v, l, i') -> (v, l <> pure False, i')++-- | Infix alias for 'column'+(.:) :: Ord s => s -> Decode' s a -> NameDecode' s a+(.:) = column+{-# INLINE (.:) #-}+infixl 5 .:++rnat :: Functor f => (g a -> h a) -> Compose f g a -> Compose f h a+rnat gh (Compose fga) = Compose (fmap gh fga)
src/Data/Sv/Decode/Error.hs view
@@ -16,6 +16,9 @@ , unexpectedEndOfRow , expectedEndOfRow , unknownCategoricalValue+, missingColumn+, missingHeader+, badConfig , badParse , badDecode @@ -55,6 +58,23 @@ unknownCategoricalValue :: e -> [[e]] -> DecodeValidation e a unknownCategoricalValue unknown valids =   decodeError (UnknownCategoricalValue unknown valids)++-- | Fail with 'MissingColumn' with the given column name. This is for when a+-- 'NameDecode' looks for a column that doesn't exist.+missingColumn :: e -> DecodeValidation e a+missingColumn = decodeError . MissingColumn++-- | Fail with 'MissingHeader'. This is for when the user asks for a header but+-- the input document is completely empty (that is, it has nothing that could be+-- considered a header).+missingHeader :: DecodeValidation e a+missingHeader = decodeError MissingHeader++-- | Fail with 'badConfig'. This is for when the user has asked for something+-- impossible, like to decode a CSV by column name while asserting there's no+-- header.+badConfig :: e -> DecodeValidation e a+badConfig = decodeError . BadConfig  -- | Fail with 'BadParse' with the given message. This is for when the parse -- step fails, and decoding does not even begin.
src/Data/Sv/Decode/Type.hs view
@@ -15,6 +15,8 @@   Decode (..) , Decode' , buildDecode+, NameDecode (..)+, NameDecode' , DecodeState (..) , runDecodeState , Ind (..)@@ -24,15 +26,19 @@ , Validation (..) ) where +import Control.Applicative (liftA2) import Control.DeepSeq (NFData) import Control.Monad.Reader (ReaderT (ReaderT, runReaderT), MonadReader, withReaderT) import Control.Monad.State (State, runState, state, MonadState)+import Control.Monad.Writer.Strict (Writer, writer, runWriter) import Data.Functor.Alt (Alt ((<!>))) import Data.Functor.Apply (Apply) import Data.Functor.Bind (Bind ((>>-)))-import Data.Functor.Compose (Compose (Compose))-import Data.List.NonEmpty-import Data.Semigroup (Semigroup)+import Data.Functor.Compose (Compose (Compose, getCompose))+import Data.List.NonEmpty (NonEmpty)+import Data.Map.Strict (Map)+import Data.Monoid (Last)+import Data.Semigroup (Semigroup ((<>))) import Data.Semigroupoid (Semigroupoid (o)) import Data.Profunctor (Profunctor (lmap, rmap)) import Data.Validation (Validation (Success, Failure))@@ -56,7 +62,7 @@ -- 'Decode' is not a 'Monad', but we can perform monad-like operations on -- it with 'Data.Sv.Decode.>>==' or 'Data.Sv.Decode.bindDecode' newtype Decode e s a =-  Decode { unwrapDecode :: Compose (DecodeState s) (DecodeValidation e) a }+  Decode { unwrapDecode :: Compose (DecodeState s) (Compose (Writer (Last Bool)) (DecodeValidation e)) a }   deriving (Functor, Apply, Applicative)  -- | 'Decode'' is 'Decode' with the input and error types the same. You usually@@ -71,9 +77,9 @@           (b, k) ->             let a' = fmap (,j) a                 b' = fmap (,k) b-            in  case a' <!> b' of-                  Failure e -> (Failure e, k)-                  Success (z, m) -> (Success z, m)+            in  case runWriter $ liftA2 (<!>) (getCompose a') (getCompose b') of+                  (Failure e, l) -> (Failure e, l, k)+                  (Success (z, m), l) -> (Success z, l, m)  instance Profunctor (Decode e) where   lmap f (Decode (Compose dec)) = Decode (Compose (lmap f dec))@@ -84,10 +90,11 @@     Decode (Compose (DecodeState (ReaderT r'))) -> case s of       Decode (Compose (DecodeState (ReaderT s'))) ->         buildDecode $ \vec ind -> case runState (s' vec) ind of-            (v,ind') -> case v of-              Failure e -> (Failure e, ind')-              Success x ->-                (fst (runState (r' (pure x)) (Ind 0)), ind')+            (v,ind') -> case runWriter (getCompose v) of+              (Failure e, l) -> (Failure e, l, ind')+              (Success x, l) ->+                case runWriter $ getCompose $ fst (runState (r' (pure x)) (Ind 0)) of+                  (y, l') -> (y, l <> l', ind')  -- | As we decode a row of data, we walk through its fields. This 'Monad' -- keeps track of our position.@@ -103,8 +110,11 @@   rmap = fmap  -- | Convenient constructor for 'Decode' that handles all the newtype noise for you.-buildDecode :: (Vector s -> Ind -> (DecodeValidation e a, Ind)) -> Decode e s a-buildDecode f = Decode . Compose . DecodeState . ReaderT $ \v -> state $ \i -> f v i+buildDecode :: (Vector s -> Ind -> (DecodeValidation e a, Last Bool, Ind)) -> Decode e s a+buildDecode f =+  Decode . Compose . DecodeState . ReaderT $ \v -> state $ \i ->+    case f v i of+      (va, l, i') -> (Compose (writer (va, l)), i')  -- | Convenient function to run a DecodeState runDecodeState :: DecodeState s a -> Vector s -> Ind -> (a, Ind)@@ -123,6 +133,12 @@   | ExpectedEndOfRow (Vector e)   -- | This decoder was built using the 'categorical' primitive for categorical data   | UnknownCategoricalValue e [[e]]+  -- | Looked for a column with this name, but could not find it+  | MissingColumn e+  -- | There should have been a header but there was nothing+  | MissingHeader+  -- | sv is misconfigured+  | BadConfig e   -- | The parser failed, meaning decoding proper didn't even begin   | BadParse e   -- | Some other kind of decoding failure occured@@ -134,6 +150,9 @@     UnexpectedEndOfRow -> UnexpectedEndOfRow     ExpectedEndOfRow v -> ExpectedEndOfRow (fmap f v)     UnknownCategoricalValue e ess -> UnknownCategoricalValue (f e) (fmap (fmap f) ess)+    MissingColumn e -> MissingColumn (f e)+    MissingHeader -> MissingHeader+    BadConfig e -> BadConfig (f e)     BadParse e -> BadParse (f e)     BadDecode e -> BadDecode (f e) @@ -154,3 +173,18 @@ -- | 'DecodeValidation' is the error-accumulating 'Applicative' underlying -- 'Decode' type DecodeValidation e = Validation (DecodeErrors e)++-- | 'NameDecode' is a decoder that looks for a column by name rather than+-- by position.+newtype NameDecode e s a =+  Named {+    unNamed :: ReaderT (Map s Ind) (Compose (DecodeValidation e) (Decode e s)) a+  }+  deriving (Functor, Applicative)++-- | 'NameDecode'' is 'NameDecode' with both type parameters the same, as+-- should usually be the case+type NameDecode' s = NameDecode s s++instance Alt (NameDecode e s) where+  Named f <!> Named g = Named (f <!> g)
sv-core.cabal view
@@ -1,5 +1,5 @@ name:                sv-core-version:             0.1+version:             0.2 license:             BSD3 license-file:        LICENCE author:              George Wilson
test/Data/Sv/Core/Laws.hs view
@@ -8,6 +8,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.List.NonEmpty (NonEmpty ((:|)))+import Data.Monoid (Last) import Data.Profunctor (Profunctor (dimap)) import Data.Semigroupoid (Semigroupoid (o)) import qualified Data.Validation as V@@ -46,11 +47,11 @@ decodeGen =   buildDecode <$> (unwrap <$> arbitrary) -unwrap :: (Input s -> Output e a) -> Vector s -> Ind -> (Validation e a, Ind)+unwrap :: (Input s -> Output e a) -> Vector s -> Ind -> (Validation e a, Last Bool, Ind) unwrap = curry . dimap Input unwrapO  newtype Output e a =-  Output { unwrapO :: (Validation e a, Ind) }+  Output { unwrapO :: (Validation e a, Last Bool, Ind) }  newtype Input s = Input (Vector s, Ind) @@ -66,7 +67,8 @@ instance (Arbitrary (Out e), Arbitrary (Out a)) => Arbitrary (Output e a) where   arbitrary =     Output <$>-      ((,) <$> oneof [V.Failure <$> arbOut, V.Success <$> arbOut]+      ((,,) <$> oneof [V.Failure <$> arbOut, V.Success <$> arbOut]+          <*> arbitrary           <*> (Ind <$> arbOut))  instance (CoArbitrary (In (Vector s)), CoArbitrary (In Ind)) => CoArbitrary (Input s) where