Input.hs

{-|
Module      : Functions for Parsing Hasklepias populations 
Description : Defines FromJSON instances for Hasklepias populations .
Copyright   : (c) NoviSci, Inc 2020
License     : BSD3
Maintainer  : bsaul@novisci.com
-}
{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TupleSections #-}

module Cohort.Input(
      parsePopulationLines
    , parsePopulationIntLines
    , parsePopulationDayLines
    , ParseError(..)
) where

import Control.Applicative                  ( Applicative((<*>)), (<$>) )
import Data.Aeson                           ( FromJSON(..)
                                            , ToJSON(..)
                                            , eitherDecode
                                            , Value(Array))
import qualified Data.ByteString.Lazy as B  ( fromStrict
                                            , toStrict
                                            , ByteString)
import qualified Data.ByteString.Char8 as C ( lines )
import Prelude                              (
                                             String)
import Data.Bifunctor                       ( Bifunctor(first) )
import Data.Either                          ( Either(..)
                                            , partitionEithers )
import Data.Eq                              ( Eq )
import Data.Function                        ( ($), id )                                        
import Data.Functor                         ( Functor(fmap) )
import Data.List                            ( sort, (++), zipWith )
import qualified Data.Map.Strict as M       ( toList, fromListWith)
import Data.Ord                             ( Ord )
import Data.Text                            (Text, pack)
import Data.Time.Calendar                   ( Day )
import Data.Vector                          ( (!) )
import EventData                            ( Events, event, Event )
import EventData.Aeson                      ()
import Cohort.Core                          ( Population(..)
                                            , ID
                                            , Subject(MkSubject) )
import GHC.Int                              ( Int )
import GHC.Num                              ( Natural )
import GHC.Show                             ( Show )
import IntervalAlgebra                      ( IntervalSizeable )


newtype SubjectEvent a = MkSubjectEvent (ID, Event a)

subjectEvent :: ID -> Event a -> SubjectEvent a
subjectEvent x y = MkSubjectEvent (x, y)

instance (FromJSON a, Show a, IntervalSizeable a b) => FromJSON (SubjectEvent a) where
    parseJSON (Array v) = subjectEvent <$>
        parseJSON (v ! 0) <*> (event <$> parseJSON (v ! 5) <*> parseJSON (Array v))

mapIntoPop :: (Ord a) => [SubjectEvent a] -> Population (Events a)
mapIntoPop l = MkPopulation $
    fmap (\(id, es) -> MkSubject (id, sort es)) -- TODO: is there a way to avoid the sort?
        (M.toList $ M.fromListWith (++) 
        (fmap (\(MkSubjectEvent (id, e)) -> (id, [e])) l ))

decodeIntoSubj :: (FromJSON a, Show a, IntervalSizeable a b) => 
        B.ByteString  -> Either Text (SubjectEvent a)
decodeIntoSubj x = first pack $ eitherDecode x 

-- | Contains the line number and error message.
newtype ParseError = MkParseError (Natural, Text) deriving (Eq, Show)

-- |  Parse @Event Int@ from json lines.
parseSubjectLines ::
    (FromJSON a, Show a, IntervalSizeable a b) =>
        B.ByteString -> ( [ParseError], [SubjectEvent a] )
parseSubjectLines l =
    partitionEithers $ zipWith
      (\x i -> first (\t -> MkParseError (i,t)) (decodeIntoSubj $ B.fromStrict x) )
      (C.lines $ B.toStrict l)
      [1..]

-- |  Parse @Event Int@ from json lines.
parsePopulationLines :: (FromJSON a, Show a, IntervalSizeable a b) => 
    B.ByteString -> ([ParseError], Population (Events a))
parsePopulationLines x = fmap mapIntoPop (parseSubjectLines x)

-- |  Parse @Event Int@ from json lines.
parsePopulationIntLines :: B.ByteString -> ([ParseError], Population (Events Int))
parsePopulationIntLines x = fmap mapIntoPop (parseSubjectLines x)

-- |  Parse @Event Day@ from json lines.
parsePopulationDayLines :: B.ByteString -> ([ParseError], Population (Events Day))
parsePopulationDayLines x = fmap mapIntoPop (parseSubjectLines x)