KeyValue.hs

{-|
Module      : Pipes.KeyValueCsv.KeyValue
Copyright   : (c) Marcin Mrotek, 2015
License     : BSD3
Maintainer  : marcin.jan.mrotek@gmail.com
Stability   : experimental

Parse key-value pairs.
-}

{-# LANGUAGE
    DataKinds
  , ExplicitForAll
  , FlexibleContexts
  , GADTs
  , PolyKinds
  , TypeOperators
  #-}

module Pipes.KeyValueCsv.KeyValue
  ( module Pipes.KeyValueCsv.KeyValue
  , Record
  , KeyValueError(..)
  ) where

import Pipes.KeyValueCsv.Internal.KeyValue
import Pipes.KeyValueCsv.Internal.Types
import Pipes.KeyValueCsv.Types.KeyValue

import Control.Lens
import Data.Reflection
import qualified Data.Set as Set
import Data.Validation
import Data.Vinyl
import Data.Vinyl.Functor
import Pipes
import qualified Pipes.Prelude as Pipes
import qualified Pipes.Group as Group

parseKeyValues
  :: forall (m :: * -> *) (f :: k -> *) (rs :: [k]) (r :: *)
   . ( Given Delimiter
     , Monad m
     , Record rs
     )
  => KeyValueOptions m f rs  -- ^Options
  -> Lines m r               -- ^Stream of lines
  -> m (Rec (WithKeyValueError :. f) rs, r)
-- ^Parse lines into a stream of records with at most one 'Success' field.
parseKeyValues options = 
    foldHeader
  . Group.concats 
  . Group.maps (parseKeyValue (options^.kvParser) names names'set)
  . unLines
 where
   names = options^.keyNames
   names'set = Set.fromList $ recordToList names

foldHeader 
  :: ( Monad m
     , Record rs
     )
  => Producer (Rec (WithKeyValueError :. f) rs) m r 
  -> m (Rec (WithKeyValueError :. f) rs, r)
-- ^Fold a stream of key-value records into a single record.
foldHeader = Pipes.fold' joinRecs missing id

joinRecs :: Rec (WithKeyValueError :. f) rs -> Rec (WithKeyValueError :. f) rs -> Rec (WithKeyValueError :. f) rs
-- ^Join two 'Rec's, replacing missing values with successes and accumulating failures.
joinRecs RNil RNil = RNil
joinRecs (Compose va :& as) (Compose vb :& bs) = Compose new :& joinRecs as bs
  where
    new = case (va, vb) of
           (Success              a, Failure [MissingValue]) -> Success a
           (Failure [MissingValue], Success              b) -> Success b 
           (Success              _, Success              _) -> Failure [MultipleValues] 
           (Success              _, Failure              f) -> Failure f
           (Failure              f, Success              _) -> Failure f 
           (Failure [MissingValue], Failure              f) -> Failure f
           (Failure              f, Failure [MissingValue]) -> Failure f
           (Failure             f1, Failure             f2) -> Failure $ MultipleValues : (f1++f2)