{-# LANGUAGE BlockArguments #-}
{-|
Module      : Hasklepias.MakeApp
Description : Functions for creating a cohort application
Copyright   : (c) NoviSci, Inc 2020
License     : BSD3
Maintainer  : bsaul@novisci.com
-}
{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE DeriveDataTypeable #-}
module Hasklepias.MakeApp (
   makeCohortApp
) where

import Control.Monad                        ( Monad(return), Functor(fmap) )
import Control.Applicative                  ( Applicative )
import Data.Aeson                           ( encode, FromJSON, ToJSON(..) )
import Data.Bifunctor                       ( Bifunctor(second) )
import qualified Data.ByteString.Lazy as B
import Data.ByteString.Lazy.Char8 as C      ( putStrLn )
import Data.Function                        ( ($), (.) )
import Data.List                            ( (++) )
import Data.Maybe                           ( Maybe )
import Data.Monoid                          ( Monoid(mconcat) )
import Data.String                          ( String )
import Data.Text                            ( pack, Text )
import Data.Tuple                           ( fst, snd )
import GHC.Show                             ( Show(show) )
import GHC.IO                               ( IO )

import EventData                            ( Events )
import Cohort
import IntervalAlgebra                      ( IntervalSizeable )

import Control.Monad.IO.Class               (MonadIO, liftIO)
import Control.Monad.Reader                 (MonadReader (..), ReaderT (..))
import Colog                                ( Message
                                            , HasLog(..)
                                            , WithLog
                                            , LogAction(..)
                                            , richMessageAction
                                            , logInfo
                                            , logError
                                            , logStringStdout
                                            , logStringStderr
                                            , logText
                                            , withLog
                                            , logPrint
                                            , logPrintStderr
                                            , (<&)
                                            , (>$)
                                            , log )
import System.Console.CmdArgs               ( Data, Typeable
                                            , cmdArgs, summary, help, (&=) )
import System.Environment                   (getArgs)

-- a stub to add more arguments to later
data MakeCohort = MakeCohort deriving (Int -> MakeCohort -> ShowS
[MakeCohort] -> ShowS
MakeCohort -> String
(Int -> MakeCohort -> ShowS)
-> (MakeCohort -> String)
-> ([MakeCohort] -> ShowS)
-> Show MakeCohort
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MakeCohort] -> ShowS
$cshowList :: [MakeCohort] -> ShowS
show :: MakeCohort -> String
$cshow :: MakeCohort -> String
showsPrec :: Int -> MakeCohort -> ShowS
$cshowsPrec :: Int -> MakeCohort -> ShowS
Show, Typeable MakeCohort
DataType
Constr
Typeable MakeCohort
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> MakeCohort -> c MakeCohort)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c MakeCohort)
-> (MakeCohort -> Constr)
-> (MakeCohort -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c MakeCohort))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c MakeCohort))
-> ((forall b. Data b => b -> b) -> MakeCohort -> MakeCohort)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> MakeCohort -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> MakeCohort -> r)
-> (forall u. (forall d. Data d => d -> u) -> MakeCohort -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> MakeCohort -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> MakeCohort -> m MakeCohort)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> MakeCohort -> m MakeCohort)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> MakeCohort -> m MakeCohort)
-> Data MakeCohort
MakeCohort -> DataType
MakeCohort -> Constr
(forall b. Data b => b -> b) -> MakeCohort -> MakeCohort
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> MakeCohort -> c MakeCohort
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c MakeCohort
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> MakeCohort -> u
forall u. (forall d. Data d => d -> u) -> MakeCohort -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> MakeCohort -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> MakeCohort -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> MakeCohort -> m MakeCohort
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> MakeCohort -> m MakeCohort
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c MakeCohort
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> MakeCohort -> c MakeCohort
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c MakeCohort)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c MakeCohort)
$cMakeCohort :: Constr
$tMakeCohort :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> MakeCohort -> m MakeCohort
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> MakeCohort -> m MakeCohort
gmapMp :: (forall d. Data d => d -> m d) -> MakeCohort -> m MakeCohort
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> MakeCohort -> m MakeCohort
gmapM :: (forall d. Data d => d -> m d) -> MakeCohort -> m MakeCohort
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> MakeCohort -> m MakeCohort
gmapQi :: Int -> (forall d. Data d => d -> u) -> MakeCohort -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> MakeCohort -> u
gmapQ :: (forall d. Data d => d -> u) -> MakeCohort -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> MakeCohort -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> MakeCohort -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> MakeCohort -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> MakeCohort -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> MakeCohort -> r
gmapT :: (forall b. Data b => b -> b) -> MakeCohort -> MakeCohort
$cgmapT :: (forall b. Data b => b -> b) -> MakeCohort -> MakeCohort
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c MakeCohort)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c MakeCohort)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c MakeCohort)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c MakeCohort)
dataTypeOf :: MakeCohort -> DataType
$cdataTypeOf :: MakeCohort -> DataType
toConstr :: MakeCohort -> Constr
$ctoConstr :: MakeCohort -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c MakeCohort
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c MakeCohort
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> MakeCohort -> c MakeCohort
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> MakeCohort -> c MakeCohort
$cp1Data :: Typeable MakeCohort
Data, Typeable)

makeAppArgs ::
     String  -- ^ name of the application
  -> String  -- ^ version of the application 
  -> MakeCohort
makeAppArgs :: String -> String -> MakeCohort
makeAppArgs String
name String
version = MakeCohort :: MakeCohort
MakeCohort
    {
    } MakeCohort -> Ann -> MakeCohort
forall val. Data val => val -> Ann -> val
&= String -> Ann
help String
"Pass event data via stdin."
      MakeCohort -> Ann -> MakeCohort
forall val. Data val => val -> Ann -> val
&= String -> Ann
summary (String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
version)

makeCohortBuilder :: (FromJSON a, Show a, IntervalSizeable a b, ToJSON d0, ShapeCohort d0, Monad m) =>
     [CohortSpec (Events a) d0]
  -> m (B.ByteString -> m ([ParseError], [Cohort d0]))
makeCohortBuilder :: [CohortSpec (Events a) d0]
-> m (ByteString -> m ([ParseError], [Cohort d0]))
makeCohortBuilder [CohortSpec (Events a) d0]
specs =
  (ByteString -> m ([ParseError], [Cohort d0]))
-> m (ByteString -> m ([ParseError], [Cohort d0]))
forall (m :: * -> *) a. Monad m => a -> m a
return (([ParseError], [Cohort d0]) -> m ([ParseError], [Cohort d0])
forall (m :: * -> *) a. Monad m => a -> m a
return (([ParseError], [Cohort d0]) -> m ([ParseError], [Cohort d0]))
-> (ByteString -> ([ParseError], [Cohort d0]))
-> ByteString
-> m ([ParseError], [Cohort d0])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Population (Events a) -> [Cohort d0])
-> ([ParseError], Population (Events a))
-> ([ParseError], [Cohort d0])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (\Population (Events a)
pop -> (CohortSpec (Events a) d0 -> Cohort d0)
-> [CohortSpec (Events a) d0] -> [Cohort d0]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CohortSpec (Events a) d0 -> Population (Events a) -> Cohort d0
forall d1 d0. CohortSpec d1 d0 -> Population d1 -> Cohort d0
`evalCohort` Population (Events a)
pop) [CohortSpec (Events a) d0]
specs) (([ParseError], Population (Events a))
 -> ([ParseError], [Cohort d0]))
-> (ByteString -> ([ParseError], Population (Events a)))
-> ByteString
-> ([ParseError], [Cohort d0])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ([ParseError], Population (Events a))
forall a b.
(FromJSON a, Show a, IntervalSizeable a b) =>
ByteString -> ([ParseError], Population (Events a))
parsePopulationLines)

reshapeWith :: (Cohort d -> CohortShape shape) 
        -> Cohort d 
        -> (Maybe AttritionInfo, CohortShape shape)
reshapeWith :: (Cohort d -> CohortShape shape)
-> Cohort d -> (Maybe AttritionInfo, CohortShape shape)
reshapeWith Cohort d -> CohortShape shape
s Cohort d
x = (Cohort d -> Maybe AttritionInfo
forall d. Cohort d -> Maybe AttritionInfo
getAttritionInfo Cohort d
x, Cohort d -> CohortShape shape
s Cohort d
x)

shapeOutput ::  (Monad m, ShapeCohort d0) => (Cohort d0 -> CohortShape shape) 
      -> m ([ParseError], [Cohort d0]) 
      -> m ([ParseError], [(Maybe AttritionInfo, CohortShape shape)]) 
shapeOutput :: (Cohort d0 -> CohortShape shape)
-> m ([ParseError], [Cohort d0])
-> m ([ParseError], [(Maybe AttritionInfo, CohortShape shape)])
shapeOutput Cohort d0 -> CohortShape shape
shape = (([ParseError], [Cohort d0])
 -> ([ParseError], [(Maybe AttritionInfo, CohortShape shape)]))
-> m ([ParseError], [Cohort d0])
-> m ([ParseError], [(Maybe AttritionInfo, CohortShape shape)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Cohort d0] -> [(Maybe AttritionInfo, CohortShape shape)])
-> ([ParseError], [Cohort d0])
-> ([ParseError], [(Maybe AttritionInfo, CohortShape shape)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Cohort d0 -> (Maybe AttritionInfo, CohortShape shape))
-> [Cohort d0] -> [(Maybe AttritionInfo, CohortShape shape)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Cohort d0 -> CohortShape shape)
-> Cohort d0 -> (Maybe AttritionInfo, CohortShape shape)
forall d shape.
(Cohort d -> CohortShape shape)
-> Cohort d -> (Maybe AttritionInfo, CohortShape shape)
reshapeWith Cohort d0 -> CohortShape shape
shape)))
  -- fmap (fmap (fmap shape))

-- logging based on example here:
-- https://github.com/kowainik/co-log/blob/main/co-log/tutorials/Main.hs
parseErrorL :: LogAction IO ParseError
parseErrorL :: LogAction IO ParseError
parseErrorL = LogAction IO ParseError
forall a (m :: * -> *). (Show a, MonadIO m) => LogAction m a
logPrintStderr

logParseErrors :: [ParseError] -> IO ()
logParseErrors :: [ParseError] -> IO ()
logParseErrors [ParseError]
x = [IO ()] -> IO ()
forall a. Monoid a => [a] -> a
mconcat ([IO ()] -> IO ()) -> [IO ()] -> IO ()
forall a b. (a -> b) -> a -> b
$ (ParseError -> IO ()) -> [ParseError] -> [IO ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (LogAction IO ParseError
parseErrorL LogAction IO ParseError -> ParseError -> IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<&) [ParseError]
x

-- | Make a command line cohort building application.
makeCohortApp :: (FromJSON a, Show a, IntervalSizeable a b
                  , ToJSON d0,
                   ShapeCohort d0) =>
       String  -- ^ cohort name
    -> String  -- ^ app version
    -> (Cohort d0 -> CohortShape shape) -- ^ a function which specifies the output shape
    -> [CohortSpec (Events a) d0]  -- ^ a list of cohort specifications
    -> IO ()
makeCohortApp :: String
-> String
-> (Cohort d0 -> CohortShape shape)
-> [CohortSpec (Events a) d0]
-> IO ()
makeCohortApp String
name String
version Cohort d0 -> CohortShape shape
shape [CohortSpec (Events a) d0]
spec =
    do
      MakeCohort
args <- MakeCohort -> IO MakeCohort
forall a. Data a => a -> IO a
cmdArgs ( String -> String -> MakeCohort
makeAppArgs String
name String
version )
      let logger :: LogAction IO String
logger = LogAction IO String
forall (m :: * -> *). MonadIO m => LogAction m String
logStringStdout

      LogAction IO String
logger LogAction IO String -> String -> IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& String
"Creating cohort builder..."
      ByteString -> IO ([ParseError], [Cohort d0])
app <- [CohortSpec (Events a) d0]
-> IO (ByteString -> IO ([ParseError], [Cohort d0]))
forall a b d0 (m :: * -> *).
(FromJSON a, Show a, IntervalSizeable a b, ToJSON d0,
 ShapeCohort d0, Monad m) =>
[CohortSpec (Events a) d0]
-> m (ByteString -> m ([ParseError], [Cohort d0]))
makeCohortBuilder [CohortSpec (Events a) d0]
spec

      LogAction IO String
logger LogAction IO String -> String -> IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& String
"Reading data from stdin..."
      -- TODO: give error if no contents within some amount of time
      ByteString
dat  <- IO ByteString
B.getContents

      LogAction IO String
logger LogAction IO String -> String -> IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& String
"Bulding cohort..."
      ([ParseError], [(Maybe AttritionInfo, CohortShape shape)])
res <- (Cohort d0 -> CohortShape shape)
-> IO ([ParseError], [Cohort d0])
-> IO ([ParseError], [(Maybe AttritionInfo, CohortShape shape)])
forall (m :: * -> *) d0 shape.
(Monad m, ShapeCohort d0) =>
(Cohort d0 -> CohortShape shape)
-> m ([ParseError], [Cohort d0])
-> m ([ParseError], [(Maybe AttritionInfo, CohortShape shape)])
shapeOutput Cohort d0 -> CohortShape shape
shape (ByteString -> IO ([ParseError], [Cohort d0])
app ByteString
dat)

      [ParseError] -> IO ()
logParseErrors (([ParseError], [(Maybe AttritionInfo, CohortShape shape)])
-> [ParseError]
forall a b. (a, b) -> a
fst ([ParseError], [(Maybe AttritionInfo, CohortShape shape)])
res)

      LogAction IO String
logger LogAction IO String -> String -> IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& String
"Encoding cohort(s) output and writing to stdout..."
      ByteString -> IO ()
C.putStrLn ([(Maybe AttritionInfo, Value)] -> ByteString
forall a. ToJSON a => a -> ByteString
encode (((Maybe AttritionInfo, CohortShape shape)
 -> (Maybe AttritionInfo, Value))
-> [(Maybe AttritionInfo, CohortShape shape)]
-> [(Maybe AttritionInfo, Value)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CohortShape shape -> Value)
-> (Maybe AttritionInfo, CohortShape shape)
-> (Maybe AttritionInfo, Value)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second CohortShape shape -> Value
forall shape. CohortShape shape -> Value
toJSONCohortShape) (([ParseError], [(Maybe AttritionInfo, CohortShape shape)])
-> [(Maybe AttritionInfo, CohortShape shape)]
forall a b. (a, b) -> b
snd ([ParseError], [(Maybe AttritionInfo, CohortShape shape)])
res) ))

      LogAction IO String
logger LogAction IO String -> String -> IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& String
"Cohort build complete!"