Taking clinical trial description seriously.

monadicClinicalTrials.hs

{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Use newtype instead of data" #-}
{-# HLINT ignore "Use if" #-}
module ProtocolsRunOnTrials where

import Control.Monad.Free
import Control.Monad
import Control.Monad.Loops
import Data.List (isInfixOf)
import Data.Maybe (maybeToList)

-- Forms as a free monad.
type Form a = Free Question a
data Question y
  = Consent { consent :: Maybe Bool -> y }
  | DrugsTaken { nothing :: y , drug :: [Drug] -> y }
  | AdverseEffectClass { aeMinor :: y, aeMajor :: y, aeNo :: y }
  | AdverseEffectName { aeName :: AdverseEffect -> y }
  | AdverseEffectNarrative { aeNarrative :: String -> y }
  deriving (Functor)

data Drug = Loratadine | Montelukast | Cetirizine deriving Show
data AdverseEffectClass = AEMinor | AEMajor | AENone deriving Show
data AdverseEffect = Headache | Depression | Unclassified deriving Show

drugsForm :: Form [Drug]
drugsForm = ask $ DrugsTaken
  { drug = \d -> do
        rest <- drugsForm
        return (d ++ rest)
  , nothing = return [] }

inclusionForm :: Form (Bool, [Drug])
inclusionForm = do
  c <- askConsent
  case c of
    (Just True) -> do { d <- drugsForm ; return (True, d) }
    (Just False) -> do { return (False,[]) }
    Nothing -> do { return (False,[]) }

askAdverseEffectClass :: Form AdverseEffectClass
askAdverseEffectClass = liftF $ AdverseEffectClass AEMinor AEMajor AENone
askAdverseEffectName :: Form AdverseEffect
askAdverseEffectName = liftF $ AdverseEffectName id
askAdverseEffectNarrative :: Form String
askAdverseEffectNarrative = liftF $ AdverseEffectNarrative id

type Narrative = String
adverseEffectForm :: Form (AdverseEffectClass, Maybe (AdverseEffect, Narrative))
adverseEffectForm = do
  aeclass <- askAdverseEffectClass
  case aeclass of
    AEMajor -> pure (AEMajor, Nothing)
    AEMinor -> do
      aename <- askAdverseEffectName
      aenarrative <- askAdverseEffectNarrative
      return (aeclass, Just (aename, aenarrative))
    AENone -> pure (AENone, Nothing)


-- Clinical trial as a free monad
data Clinical y = InvalidBool (Bool -> y) | InvalidDrug ([Drug] -> y) | InvalidAdverseEffect (AdverseEffect -> y) | Concern String y | PutString String y | GetString (String -> y) deriving (Functor)
type ClinicalTrial a = Free Clinical a


-- Handling errors from the form during design of the clinical trial.
questionYesNo :: String -> ClinicalTrial (Maybe Bool)
questionYesNo questionString = do
  putString questionString
  s <- getString
  case s of
    "Yes" -> return (Just True)
    "No"  -> return (Just False)
    _ -> return Nothing

runsForm :: Form a -> ClinicalTrial a
runsForm (Pure a) = pure a

runsForm (Free (Consent cmaybebool)) = do
  b <- questionYesNo "Do you consent to participate in this study?"
  runsForm (cmaybebool b)

runsForm (Free (DrugsTaken dtno dtls)) = do
  putString "Are you taking any other drugs? If so, give the name."
  drug <- getString
  case drug of
    "No" -> runsForm dtno
    "Loratadine" -> runsForm (dtls [Loratadine])
    "Montelukast" -> runsForm (dtls [Montelukast])
    "Cetirizine" -> runsForm (dtls [Cetirizine])
    _ -> do
      d <- invalidDrug
      runsForm (dtls d)

runsForm (Free (AdverseEffectClass aeminor aemajor aeno)) = do
  b <- questionYesNo "Are you reporting an adverse event?"
  case b of
    Just True -> do
      b <- iterateWhile (== Nothing) $ questionYesNo "Are you reporting a MAJOR/unexpected adverse event?"
      case b of
        Just True -> runsForm aemajor
        Just False -> runsForm aeminor
        Nothing -> do
          concern "Possible adverse event was not reported. Question was not answered."
          runsForm aeno
    Just False -> runsForm aeno
    Nothing -> runsForm aeno

runsForm (Free (AdverseEffectName aename)) = do
  putString "What is the classification of the adverse event?"
  classification <- getString
  case classification of
    "Headache" -> runsForm (aename Headache)
    "Depression" -> runsForm (aename Depression)
    _ -> runsForm (aename Unclassified)

runsForm (Free (AdverseEffectNarrative aenarrative)) = do
  putString "Please describe the adverse event."
  narrative <- getString
  runsForm (aenarrative narrative)

exampleClinicalTrial :: ClinicalTrial (Bool, [Drug], [(AdverseEffect, String)])
exampleClinicalTrial = do
  (consent, concomitantMedication) <- runsForm inclusionForm
  if consent then do
    (aeclass, maybeAdverseEffectAndNarrative) <- runsForm adverseEffectForm
    aeList <- maybeToList <$> clinicalAdverseEventCollection
    return (consent, concomitantMedication, aeList)
  else
    return (False, [], [])

clinicalAdverseEventCollection :: ClinicalTrial (Maybe (AdverseEffect, String))
clinicalAdverseEventCollection = do
  (aeclass, maybeAdverseEffectAndNarrative) <- runsForm adverseEffectForm
  case (aeclass, maybeAdverseEffectAndNarrative) of
      (AEMajor, _) -> do
        concern "Major adverse effect has been raised"
        return $ Just (Unclassified, "")
      (AEMinor, Just (Unclassified, aenarrative)) ->
        if "Headache" `isInfixOf` aenarrative || "headache" `isInfixOf` aenarrative
          then return $ Just (Headache, aenarrative)
          else return $ Just (Unclassified, aenarrative)
      (AEMinor, Just (aename, aenarrative)) -> do
        return $ Just (aename, aenarrative)
      (AEMinor, Nothing) -> do
        return $ Just (Unclassified, "No description provided.")
      (AENone, _) -> return Nothing

-- Handling errors from the form on execution.
interpretTrial :: ClinicalTrial a -> IO a
interpretTrial (Free (PutString s y)) = do
  putStrLn s
  interpretTrial y
interpretTrial (Free (GetString f)) = do
  s <- getLine
  interpretTrial (f s)
interpretTrial (Free (InvalidBool g)) = do
  raise "missing boolean, set to False."
  interpretTrial (g True)
interpretTrial (Free (InvalidDrug d)) = do
  raise "missing drug, not registered in the list. Please ask the participant again."
  interpretTrial (d [])
interpretTrial (Free (InvalidAdverseEffect a)) = do
  raise "missing adverse effect. Recorded as unclassified. Please ask nurses for report."
  interpretTrial (a Unclassified)
interpretTrial (Free (Concern s y)) = do
  putStrLn $ "Clinical concern raised: " ++ s
  interpretTrial y
interpretTrial (Pure a) = pure a


--Boilerplate
putString :: String -> ClinicalTrial ()
putString xs = liftF $ PutString xs ()
getString :: ClinicalTrial String
getString = liftF $ GetString id
invalidBool :: ClinicalTrial Bool
invalidBool = liftF $ InvalidBool id
invalidAdverseEffect :: ClinicalTrial AdverseEffect
invalidAdverseEffect = liftF $ InvalidAdverseEffect id
invalidDrug :: ClinicalTrial [Drug]
invalidDrug = liftF $ InvalidDrug id
askConsent :: Form (Maybe Bool)
askConsent = liftF $ Consent id
concern :: String -> ClinicalTrial ()
concern s = liftF $ Concern s ()
ask :: f (Free f y) -> Free f y
ask = Free
end :: Free f ()
end = Pure ()


raise :: String -> IO ()
raise s = putStrLn $ "#WARNING RAISED: " ++ s
-------------