{-|
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 DeriveDataTypeable #-}

module Hasklepias.MakeApp
  ( makeCohortApp
  ) where

import           Control.Applicative            ( Applicative )
import           Control.Monad                  ( Functor(fmap)
                                                , Monad(return)
                                                )
import           Data.Aeson                     ( FromJSON
                                                , ToJSON(..)
                                                , encode
                                                )
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.Map.Strict                ( fromList
                                                , toList
                                                )
import           Data.Maybe                     ( Maybe )
import           Data.Monoid                    ( Monoid(mconcat) )
import           Data.String                    ( String )
import           Data.Text                      ( Text
                                                , pack
                                                )
import           Data.Tuple                     ( fst
                                                , snd
                                                )
import           GHC.IO                         ( IO )
import           GHC.Show                       ( Show(show) )

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

import           Colog                          ( (<&)
                                                , (>$)
                                                , HasLog(..)
                                                , LogAction(..)
                                                , Message
                                                , WithLog
                                                , log
                                                , logError
                                                , logInfo
                                                , logPrint
                                                , logPrintStderr
                                                , logStringStderr
                                                , logStringStdout
                                                , logText
                                                , richMessageAction
                                                , withLog
                                                )
import           System.Console.CmdArgs         ( (&=)
                                                , Data
                                                , Typeable
                                                , cmdArgs
                                                , help
                                                , summary
                                                )

-- 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
     )
  => CohortSetSpec (Events a) d0
  -> m (B.ByteString -> m ([ParseError], CohortSet d0))
makeCohortBuilder :: CohortSetSpec (Events a) d0
-> m (ByteString -> m ([ParseError], CohortSet d0))
makeCohortBuilder CohortSetSpec (Events a) d0
specs =
  (ByteString -> m ([ParseError], CohortSet d0))
-> m (ByteString -> m ([ParseError], CohortSet d0))
forall (m :: * -> *) a. Monad m => a -> m a
return (([ParseError], CohortSet d0) -> m ([ParseError], CohortSet d0)
forall (m :: * -> *) a. Monad m => a -> m a
return (([ParseError], CohortSet d0) -> m ([ParseError], CohortSet d0))
-> (ByteString -> ([ParseError], CohortSet d0))
-> ByteString
-> m ([ParseError], CohortSet d0)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Population (Events a) -> CohortSet d0)
-> ([ParseError], Population (Events a))
-> ([ParseError], CohortSet d0)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (CohortSetSpec (Events a) d0
-> Population (Events a) -> CohortSet d0
forall d1 d0. CohortSetSpec d1 d0 -> Population d1 -> CohortSet d0
evalCohortSet CohortSetSpec (Events a) d0
specs) (([ParseError], Population (Events a))
 -> ([ParseError], CohortSet d0))
-> (ByteString -> ([ParseError], Population (Events a)))
-> ByteString
-> ([ParseError], CohortSet 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)

reshapeCohortSet :: (Cohort d0 -> CohortJSON) -> CohortSet d0 -> CohortSetJSON
reshapeCohortSet :: (Cohort d0 -> CohortJSON) -> CohortSet d0 -> CohortSetJSON
reshapeCohortSet Cohort d0 -> CohortJSON
g CohortSet d0
x =
  Map Text CohortJSON -> CohortSetJSON
MkCohortSetJSON (Map Text CohortJSON -> CohortSetJSON)
-> Map Text CohortJSON -> CohortSetJSON
forall a b. (a -> b) -> a -> b
$ [(Text, CohortJSON)] -> Map Text CohortJSON
forall k a. Ord k => [(k, a)] -> Map k a
fromList ([(Text, CohortJSON)] -> Map Text CohortJSON)
-> [(Text, CohortJSON)] -> Map Text CohortJSON
forall a b. (a -> b) -> a -> b
$ ((Text, Cohort d0) -> (Text, CohortJSON))
-> [(Text, Cohort d0)] -> [(Text, CohortJSON)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Cohort d0 -> CohortJSON)
-> (Text, Cohort d0) -> (Text, CohortJSON)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Cohort d0 -> CohortJSON
g) (Map Text (Cohort d0) -> [(Text, Cohort d0)]
forall k a. Map k a -> [(k, a)]
toList (Map Text (Cohort d0) -> [(Text, Cohort d0)])
-> Map Text (Cohort d0) -> [(Text, Cohort d0)]
forall a b. (a -> b) -> a -> b
$ CohortSet d0 -> Map Text (Cohort d0)
forall d. CohortSet d -> Map Text (Cohort d)
getCohortSet CohortSet d0
x)

shapeOutput
  :: (Monad m, ShapeCohort d0)
  => (Cohort d0 -> CohortJSON)
  -> m ([ParseError], CohortSet d0)
  -> m ([ParseError], CohortSetJSON)
shapeOutput :: (Cohort d0 -> CohortJSON)
-> m ([ParseError], CohortSet d0)
-> m ([ParseError], CohortSetJSON)
shapeOutput Cohort d0 -> CohortJSON
shape = (([ParseError], CohortSet d0) -> ([ParseError], CohortSetJSON))
-> m ([ParseError], CohortSet d0)
-> m ([ParseError], CohortSetJSON)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CohortSet d0 -> CohortSetJSON)
-> ([ParseError], CohortSet d0) -> ([ParseError], CohortSetJSON)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Cohort d0 -> CohortJSON) -> CohortSet d0 -> CohortSetJSON
forall d0.
(Cohort d0 -> CohortJSON) -> CohortSet d0 -> CohortSetJSON
reshapeCohortSet Cohort d0 -> CohortJSON
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 -> CohortJSON) -- ^ a function which specifies the output shape
  -> CohortSetSpec (Events a) d0  -- ^ a list of cohort specifications
  -> IO ()
makeCohortApp :: String
-> String
-> (Cohort d0 -> CohortJSON)
-> CohortSetSpec (Events a) d0
-> IO ()
makeCohortApp String
name String
version Cohort d0 -> CohortJSON
shape CohortSetSpec (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 = logStringStdout
  let errLog :: LogAction IO String
errLog = LogAction IO String
forall (m :: * -> *). MonadIO m => LogAction m String
logStringStderr

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

  LogAction IO String
errLog 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
errLog LogAction IO String -> String -> IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& String
"Bulding cohort..."
  ([ParseError], CohortSetJSON)
res <- (Cohort d0 -> CohortJSON)
-> IO ([ParseError], CohortSet d0)
-> IO ([ParseError], CohortSetJSON)
forall (m :: * -> *) d0.
(Monad m, ShapeCohort d0) =>
(Cohort d0 -> CohortJSON)
-> m ([ParseError], CohortSet d0)
-> m ([ParseError], CohortSetJSON)
shapeOutput Cohort d0 -> CohortJSON
shape (ByteString -> IO ([ParseError], CohortSet d0)
app ByteString
dat)

  [ParseError] -> IO ()
logParseErrors (([ParseError], CohortSetJSON) -> [ParseError]
forall a b. (a, b) -> a
fst ([ParseError], CohortSetJSON)
res)

  LogAction IO String
errLog 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 (Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode (CohortSetJSON -> Value
forall a. ToJSON a => a -> Value
toJSON (([ParseError], CohortSetJSON) -> CohortSetJSON
forall a b. (a, b) -> b
snd ([ParseError], CohortSetJSON)
res)))

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