1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194

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