{-|
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           Cohort.Core                    ( ID
                                                , Population(..)
                                                , Subject(MkSubject)
                                                )
import           Control.Applicative            ( (<$>)
                                                , Applicative((<*>))
                                                )
import           Data.Aeson                     ( FromJSON(..)
                                                , ToJSON(..)
                                                , Value(Array)
                                                , eitherDecode
                                                )
import           Data.Bifunctor                 ( Bifunctor(first) )
import qualified Data.ByteString.Char8         as C
                                                ( lines )
import qualified Data.ByteString.Lazy          as B
                                                ( ByteString
                                                , fromStrict
                                                , toStrict
                                                )
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
                                                ( fromListWith
                                                , toList
                                                )
import           Data.Ord                       ( Ord )
import           Data.Text                      ( Text
                                                , pack
                                                )
import           Data.Time.Calendar             ( Day )
import           Data.Vector                    ( (!) )
import           EventData                      ( Event
                                                , Events
                                                , event
                                                )
import           EventData.Aeson                ( )
import           GHC.Int                        ( Int )
import           GHC.Num                        ( Natural )
import           GHC.Show                       ( Show )
import           IntervalAlgebra                ( IntervalSizeable )
import           Prelude                        ( String )


newtype SubjectEvent a = MkSubjectEvent (ID, Event a)

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

instance (FromJSON a, Show a, IntervalSizeable a b) => FromJSON (SubjectEvent a) where
  parseJSON :: Value -> Parser (SubjectEvent a)
parseJSON (Array Array
v) =
    ID -> Event a -> SubjectEvent a
forall a. ID -> Event a -> SubjectEvent a
subjectEvent
      (ID -> Event a -> SubjectEvent a)
-> Parser ID -> Parser (Event a -> SubjectEvent a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser ID
forall a. FromJSON a => Value -> Parser a
parseJSON (Array
v Array -> Int -> Value
forall a. Vector a -> Int -> a
! Int
0)
      Parser (Event a -> SubjectEvent a)
-> Parser (Event a) -> Parser (SubjectEvent a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Interval a -> Context -> Event a
forall a. Interval a -> Context -> Event a
event (Interval a -> Context -> Event a)
-> Parser (Interval a) -> Parser (Context -> Event a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser (Interval a)
forall a. FromJSON a => Value -> Parser a
parseJSON (Array
v Array -> Int -> Value
forall a. Vector a -> Int -> a
! Int
5) Parser (Context -> Event a) -> Parser Context -> Parser (Event a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Parser Context
forall a. FromJSON a => Value -> Parser a
parseJSON (Array -> Value
Array Array
v))

mapIntoPop :: (Ord a) => [SubjectEvent a] -> Population (Events a)
mapIntoPop :: [SubjectEvent a] -> Population (Events a)
mapIntoPop [SubjectEvent a]
l = [Subject (Events a)] -> Population (Events a)
forall d. [Subject d] -> Population d
MkPopulation ([Subject (Events a)] -> Population (Events a))
-> [Subject (Events a)] -> Population (Events a)
forall a b. (a -> b) -> a -> b
$ ((ID, Events a) -> Subject (Events a))
-> [(ID, Events a)] -> [Subject (Events a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
  (\(ID
id, Events a
es) -> (ID, Events a) -> Subject (Events a)
forall d. (ID, d) -> Subject d
MkSubject (ID
id, Events a -> Events a
forall a. Ord a => [a] -> [a]
sort Events a
es)) -- TODO: is there a way to avoid the sort?
  ( Map ID (Events a) -> [(ID, Events a)]
forall k a. Map k a -> [(k, a)]
M.toList
  (Map ID (Events a) -> [(ID, Events a)])
-> Map ID (Events a) -> [(ID, Events a)]
forall a b. (a -> b) -> a -> b
$ (Events a -> Events a -> Events a)
-> [(ID, Events a)] -> Map ID (Events a)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith Events a -> Events a -> Events a
forall a. [a] -> [a] -> [a]
(++) ((SubjectEvent a -> (ID, Events a))
-> [SubjectEvent a] -> [(ID, Events a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(MkSubjectEvent (ID
id, Event a
e)) -> (ID
id, [Event a
e])) [SubjectEvent a]
l)
  )

decodeIntoSubj
  :: (FromJSON a, Show a, IntervalSizeable a b)
  => B.ByteString
  -> Either Text (SubjectEvent a)
decodeIntoSubj :: ByteString -> Either ID (SubjectEvent a)
decodeIntoSubj ByteString
x = (String -> ID)
-> Either String (SubjectEvent a) -> Either ID (SubjectEvent a)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> ID
pack (Either String (SubjectEvent a) -> Either ID (SubjectEvent a))
-> Either String (SubjectEvent a) -> Either ID (SubjectEvent a)
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String (SubjectEvent a)
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
x

-- | Contains the line number and error message.
newtype ParseError = MkParseError (Natural, Text) deriving (ParseError -> ParseError -> Bool
(ParseError -> ParseError -> Bool)
-> (ParseError -> ParseError -> Bool) -> Eq ParseError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ParseError -> ParseError -> Bool
$c/= :: ParseError -> ParseError -> Bool
== :: ParseError -> ParseError -> Bool
$c== :: ParseError -> ParseError -> Bool
Eq, Int -> ParseError -> ShowS
[ParseError] -> ShowS
ParseError -> String
(Int -> ParseError -> ShowS)
-> (ParseError -> String)
-> ([ParseError] -> ShowS)
-> Show ParseError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ParseError] -> ShowS
$cshowList :: [ParseError] -> ShowS
show :: ParseError -> String
$cshow :: ParseError -> String
showsPrec :: Int -> ParseError -> ShowS
$cshowsPrec :: Int -> ParseError -> ShowS
Show)

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

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

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

-- |  Parse @Event Day@ from json lines.
parsePopulationDayLines
  :: B.ByteString -> ([ParseError], Population (Events Day))
parsePopulationDayLines :: ByteString -> ([ParseError], Population (Events Day))
parsePopulationDayLines ByteString
x = ([SubjectEvent Day] -> Population (Events Day))
-> ([ParseError], [SubjectEvent Day])
-> ([ParseError], Population (Events Day))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [SubjectEvent Day] -> Population (Events Day)
forall a. Ord a => [SubjectEvent a] -> Population (Events a)
mapIntoPop (ByteString -> ([ParseError], [SubjectEvent Day])
forall a b.
(FromJSON a, Show a, IntervalSizeable a b) =>
ByteString -> ([ParseError], [SubjectEvent a])
parseSubjectLines ByteString
x)