{-# 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
)
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
-> String
-> 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))
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
makeCohortApp
:: (FromJSON a, Show a, IntervalSizeable a b, ToJSON d0, ShapeCohort d0)
=> String
-> String
-> (Cohort d0 -> CohortJSON)
-> CohortSetSpec (Events a) d0
-> 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 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..."
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!"