diff --git a/colonnade/src/Colonnade/Decoding.hs b/colonnade/src/Colonnade/Decoding.hs index 408e0f2..5934db5 100644 --- a/colonnade/src/Colonnade/Decoding.hs +++ b/colonnade/src/Colonnade/Decoding.hs @@ -23,18 +23,34 @@ 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) +uncheckedRun :: forall content a. + Vector content + -> Decoding Indexed content a + -> Either (DecodingErrors Indexed content) a +uncheckedRun v = go + where + go :: forall b. + Decoding Indexed content b + -> Either (DecodingErrors Indexed content) b + go (DecodingPure b) = Right b + go (DecodingAp (Indexed ix) decode apNext) = + let rnext = go apNext + content = Vector.unsafeIndex v ix + rcurrent = mapLeft (DecodingErrors . Vector.singleton . DecodingError content (Indexed ix)) (decode content) + in eitherMonoidAp rnext rcurrent + -- | Maps over a 'Decoding' that expects headers, converting these -- expected headers into the indices of the columns that they -- correspond to. headedToIndexed :: forall content a. Eq content => Vector content -- ^ Headers in the source document -> Decoding Headed content a -- ^ Decoding that contains expected headers - -> Either (HeadingError content) (Decoding Indexed content a) + -> Either (HeadingErrors 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) + -> Either (HeadingErrors content) (Decoding Indexed content b) go (DecodingPure b) = Right (DecodingPure b) go (DecodingAp (Headed h) decode apNext) = let rnext = go apNext @@ -42,8 +58,8 @@ headedToIndexed v = go 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))) + | ixsLen == 0 = Left (HeadingErrors (Vector.singleton h) Vector.empty) + | otherwise = Left (HeadingErrors Vector.empty (Vector.singleton (h,ixsLen))) in case rcurrent of Right ix -> case rnext of Right apIx -> Right (DecodingAp (Indexed ix) decode apIx) @@ -52,4 +68,14 @@ headedToIndexed v = go Right _ -> Left err Left errNext -> Left (mappend err errNext) +eitherMonoidAp :: Monoid a => Either a (b -> c) -> Either a b -> Either a c +eitherMonoidAp = go where + go (Left a1) (Left a2) = Left (mappend a1 a2) + go (Left a1) (Right _) = Left a1 + go (Right _) (Left a2) = Left a2 + go (Right f) (Right b) = Right (f b) + +mapLeft :: (a -> b) -> Either a c -> Either b c +mapLeft _ (Right a) = Right a +mapLeft f (Left a) = Left (f a) diff --git a/colonnade/src/Colonnade/Types.hs b/colonnade/src/Colonnade/Types.hs index f9b05c1..10ec1b8 100644 --- a/colonnade/src/Colonnade/Types.hs +++ b/colonnade/src/Colonnade/Types.hs @@ -8,7 +8,9 @@ module Colonnade.Types , Headed(..) , Headless(..) , Indexed(..) - , HeadingError(..) + , HeadingErrors(..) + , DecodingError(..) + , DecodingErrors(..) ) where import Data.Vector (Vector) @@ -30,18 +32,33 @@ data Headless a = Headless 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 +data HeadingErrors content = HeadingErrors + { headingErrorsMissing :: Vector content -- ^ headers that were missing + , headingErrorsDuplicate :: Vector (content,Int) -- ^ headers that occurred more than once } deriving (Show,Read) -instance (Show content, Typeable content) => Exception (HeadingError content) +instance (Show content, Typeable content) => Exception (HeadingErrors content) -instance Monoid (HeadingError content) where - mempty = HeadingError Vector.empty Vector.empty - mappend (HeadingError a1 b1) (HeadingError a2 b2) = HeadingError +instance Monoid (HeadingErrors content) where + mempty = HeadingErrors Vector.empty Vector.empty + mappend (HeadingErrors a1 b1) (HeadingErrors a2 b2) = HeadingErrors (a1 Vector.++ a2) (b1 Vector.++ b2) + +data DecodingError f content = DecodingError + { decodingErrorContent :: content + , decodingErrorHeader :: f content + , decodingErrorMessage :: String + } -- deriving (Show,Read) + +-- instance (Show content, Typeable content) => Exception (DecodingError f content) + +newtype DecodingErrors f content = DecodingErrors + { getDecodingErrors :: Vector (DecodingError f content) + } deriving (Monoid) + +-- instance (Show content, Typeable content) => Exception (DecodingErrors f content) + instance Contravariant Headless where contramap _ Headless = Headless