module Colonnade.Decoding where
import Colonnade.Internal (EitherWrap(..),mapLeft)
import Colonnade.Types
import Data.Functor.Contravariant
import Data.Vector (Vector)
import qualified Data.Vector as Vector
import Data.Char (chr)
contramapContent :: forall c1 c2 f a. Contravariant f => (c2 -> c1) -> Decoding f c1 a -> Decoding f c2 a
contramapContent f = go
where
go :: forall b. Decoding f c1 b -> Decoding f c2 b
go (DecodingPure x) = DecodingPure x
go (DecodingAp h decode apNext) =
DecodingAp (contramap f h) (decode . f) (go apNext)
headless :: (content -> Either String a) -> Decoding Headless content a
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)
indexed :: Int -> (content -> Either String a) -> Decoding (Indexed Headless) content a
indexed ix f = DecodingAp (Indexed ix Headless) f (DecodingPure id)
maxIndex :: forall f c a. Decoding (Indexed f) c a -> Int
maxIndex = go 0 where
go :: forall b. Int -> Decoding (Indexed f) c b -> Int
go !ix (DecodingPure _) = ix
go !ix1 (DecodingAp (Indexed ix2 _) decode apNext) =
go (max ix1 ix2) apNext
uncheckedRunWithRow ::
Int
-> Decoding (Indexed f) content a
-> Vector content
-> Either (DecodingRowError f content) a
uncheckedRunWithRow i d v = mapLeft (DecodingRowError i . RowErrorDecode) (uncheckedRun d v)
uncheckedRun :: forall content a f.
Decoding (Indexed f) content a
-> Vector content
-> Either (DecodingCellErrors f content) a
uncheckedRun dc v = getEitherWrap (go dc)
where
go :: forall b.
Decoding (Indexed f) content b
-> EitherWrap (DecodingCellErrors f content) b
go (DecodingPure b) = EitherWrap (Right b)
go (DecodingAp ixed@(Indexed ix h) decode apNext) =
let rnext = go apNext
content = Vector.unsafeIndex v ix
rcurrent = mapLeft (DecodingCellErrors . Vector.singleton . DecodingCellError content ixed) (decode content)
in rnext <*> (EitherWrap rcurrent)
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
go !ix (DecodingPure a) = DecodingPure a
go !ix (DecodingAp Headless decode apNext) =
DecodingAp (Indexed ix Headless) decode (go (ix + 1) apNext)
length :: forall f c a. Decoding f c a -> Int
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
headedToIndexed :: forall content a. Eq content
=> Vector content
-> Decoding Headed content a
-> Either (HeadingErrors content) (Decoding (Indexed Headed) content a)
headedToIndexed v = getEitherWrap . go
where
go :: forall b. Eq content
=> Decoding Headed content b
-> EitherWrap (HeadingErrors content) (Decoding (Indexed Headed) content b)
go (DecodingPure b) = EitherWrap (Right (DecodingPure b))
go (DecodingAp hd@(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 (HeadingErrors (Vector.singleton h) Vector.empty)
| otherwise = Left (HeadingErrors Vector.empty (Vector.singleton (h,ixsLen)))
in (\ix ap -> DecodingAp (Indexed ix hd) decode ap)
<$> EitherWrap rcurrent
<*> rnext
prettyError :: (c -> String) -> DecodingRowError f c -> String
prettyError toStr (DecodingRowError ix e) = unlines
$ ("Decoding error on line " ++ show (ix + 1) ++ " of file.")
: ("Error Category: " ++ descr)
: map (" " ++) errDescrs
where (descr,errDescrs) = prettyRowError toStr e
prettyRowError :: (content -> String) -> RowError f content -> (String, [String])
prettyRowError toStr x = case x of
RowErrorParse err -> (,) "CSV Parsing"
[ "The line could not be parsed into cells correctly."
, "Original parser error: " ++ err
]
RowErrorSize reqLen actualLen -> (,) "Row Length"
[ "Expected the row to have exactly " ++ show reqLen ++ " cells."
, "The row only has " ++ show actualLen ++ " cells."
]
RowErrorMinSize reqLen actualLen -> (,) "Row Min Length"
[ "Expected the row to have at least " ++ show reqLen ++ " cells."
, "The row only has " ++ show actualLen ++ " cells."
]
RowErrorMalformed enc -> (,) "Text Decoding"
[ "Tried to decode the input as " ++ enc ++ " text"
, "There is a mistake in the encoding of the text."
]
RowErrorHeading errs -> (,) "Header" (prettyHeadingErrors toStr errs)
RowErrorDecode errs -> (,) "Cell Decoding" (prettyCellErrors toStr errs)
prettyCellErrors :: (c -> String) -> DecodingCellErrors f c -> [String]
prettyCellErrors toStr (DecodingCellErrors errs) = drop 1 $
flip concatMap errs $ \(DecodingCellError content (Indexed ix _) msg) ->
let str = toStr content in
[ "-----------"
, "Column " ++ columnNumToLetters ix
, "Original parse error: " ++ msg
, "Cell Content Length: " ++ show (Prelude.length str)
, "Cell Content: " ++ if null str
then "[empty cell]"
else str
]
prettyHeadingErrors :: (c -> String) -> HeadingErrors c -> [String]
prettyHeadingErrors conv (HeadingErrors missing duplicates) = concat
[ concatMap (\h -> ["The header " ++ conv h ++ " was missing."]) missing
, concatMap (\(h,n) -> ["The header " ++ conv h ++ " occurred " ++ show n ++ " times."]) duplicates
]
columnNumToLetters :: Int -> String
columnNumToLetters i
| i >= 0 && i < 25 = [chr (i + 65)]
| otherwise = "Beyond Z. Fix this."