hasklepias 0.15.2 → 0.16.0
raw patch · 15 files changed
+441/−56 lines, 15 files
Files
- ChangeLog.md +11/−0
- examples/ExampleCohort1.hs +19/−49
- examples/ExampleFeatures4.hs +1/−1
- hasklepias.cabal +20/−1
- src/Cohort/Index.hs +10/−5
- src/EventData/Context/Domain.hs +4/−0
- src/EventData/Context/Domain/Enrollment.hs +39/−0
- src/Hasklepias.hs +4/−0
- src/Hasklepias/FeatureEvents.hs +6/−0
- src/Hasklepias/Templates.hs +16/−0
- src/Hasklepias/Templates/Features.hs +16/−0
- src/Hasklepias/Templates/Features/Enrollment.hs +216/−0
- src/Hasklepias/Templates/TestUtilities.hs +46/−0
- src/Hasklepias/Templates/Tests.hs +24/−0
- template-test/Main.hs +9/−0
ChangeLog.md view
@@ -1,5 +1,16 @@ # Changelog for hasklepias +## 0.16.0++* Adds a basic framework for `Feature` definition templates. Initially, this includes two templates for enrollment related features:+ * `defIsEnrolled` is a definition that maps an `Index` and a container of `Event`s to a `Status` (i.e. `Include` or `Exclude`). This template takes no arguments.+ * `defContinuousEnrollment` is a definition that maps an `Index`, a container of `Event`s, and a `Status` to a `Status`. This template takes two arguments: a function that creates the interval from the index during which enrollment is assessed and an allowable gap between any enrollment intervals. The input `Status` is used so that continuous enrollment may depend on other statuses. For example, you may want to have continuous enrollment depend on being enrolled.+* Adds a framework for testing the templates. E.g. templates can be tested using `cabal test templates`.+* Updates the `ExampleCohort1` to use the `defIsEnrolled` and `defContinuousEnrollment` templates.+* Makes the `Index i a` type an instance of `Intervallic`, so you can use methods like `begin`, `end`, and interval algebra functions directly on an `Index` without having to unpack the interval first.+* Adds stripped down `Enrollment` Domain. This does type is not faithful to the EDM, as it does not include the event data model's plan fact.+* Adds the `isEnrollment` predicate function for identifying `Domain`s that are Enrollment. This can be used with `filterByDomain` to filter a container of `Event`s to those that are enrollment events.+ ## 0.15.2 * Updates `viewBirthYears` utility to filter a list of events to those with `BirthYear` demographic facts. In this way, one doesn't need to prefilter the input list by, e.g., a concept.
examples/ExampleCohort1.hs view
@@ -40,22 +40,22 @@ -- | Creates a baseline interval from index baselineInterval :: Index Interval Day -> Interval Day-baselineInterval index = lookback baselineLookback (getIndex index)+baselineInterval = lookback baselineLookback -- | Shifts an interval by a calendar amount-shiftIntervalDay :: CalendarDiffDays -> Interval Day -> Interval Day+shiftIntervalDay :: (Intervallic i Day) => CalendarDiffDays -> i Day -> Interval Day shiftIntervalDay cd i = beginerval (duration i) (addGregorianDurationClip cd (begin i)) -- | Creates an interval *beginning the same day as the index* and -- ending 'followupDuration' days later. followupInterval :: Index Interval Day -> Interval Day-followupInterval index = beginerval (diff bi (end $ shiftIntervalDay followupDuration i)) bi- where i = getIndex index- bi = begin i+followupInterval index = + beginerval (diff (begin index) (end $ shiftIntervalDay followupDuration index)) (begin index) + -- | A predicate function that determines if some interval is before index beforeIndex :: Intervallic i Day => Index Interval Day -> i Day -> Bool-beforeIndex index = before (getIndex index)+beforeIndex = before -- | Creates a filter for events to those that 'concur' with the baseline interval. getBaselineConcur :: Index Interval Day -> Events Day -> [Event Day]@@ -126,21 +126,6 @@ featureIndex :: Index Interval Day -> Feature "calendarIndex" (Index Interval Day) featureIndex = pure ---- | Gets all enrollment intervals and combines them any place they concur. --- Returns an error if there are no enrollment intervals.-enrollmentIntervals :: Definition- ( Feature "allEvents" (Events Day)- -> Feature "enrollmentIntervals" [Interval Day])-enrollmentIntervals =- defineA- (\events ->- events- |> makeConceptsFilter ["enrollment"]- |> combineIntervals- |> (\x -> if null x then makeFeature $ missingBecause $ Other "no enrollment intervals"- else pure x)- )- -- | The subject's age at time of index. Returns an error if there no birth year -- records. age :: Definition@@ -155,7 +140,7 @@ |> viewBirthYears |> headMay |> fmap (\y -> fromGregorian y 1 7) -- Use July 1 YEAR as birthdate- |> fmap (\bday -> computeAgeAt bday (begin $ getIndex index) )+ |> fmap (\bday -> computeAgeAt bday (begin index) ) |> \case Nothing -> makeFeature $ featureDataL $ Other "No numeric birth year found" Just age -> pure age@@ -203,15 +188,9 @@ -- | Include the subject if she has an enrollment interval concurring with index. critEnrolled :: Definition ( Feature "calendarIndex" (Index Interval Day)- -> Feature "enrollmentIntervals" [Interval Day]+ -> Feature "allEvents" [Event Day] -> Feature "isEnrolled" Status )-critEnrolled =- define- (\index enrollmentIntervals ->- enrollmentIntervals- |> any (concur $ getIndex index)- |> includeIf- )+critEnrolled = defIsEnrolled -- | Include the subject if both: -- * she is enrolled on index ('critEnrolled')@@ -219,16 +198,10 @@ -- are less than 30 days critEnrolled455 :: Definition ( Feature "calendarIndex" (Index Interval Day)- -> Feature "enrollmentIntervals" [Interval Day]+ -> Feature "allEvents" [Event Day] -> Feature "isEnrolled" Status -> Feature "isContinuousEnrolled" Status )-critEnrolled455 =- define- (\index enrollIntrvls isEnrolled ->- case isEnrolled of- Exclude -> Exclude- Include -> includeIf ( allGapsWithinLessThanDuration 30 (baselineInterval index) enrollIntrvls)- )+critEnrolled455 = defContinuousEnrollment baselineInterval 30 -- | Exclude if the subject is dead before the time of index. critDead :: Definition@@ -298,8 +271,6 @@ [Covariate] ["baseline"] --- instance HasAttributes "" (*)- {------------------------------------------------------------------------------- Cohort Specifications and evaluation -------------------------------------------------------------------------------}@@ -315,11 +286,10 @@ , criterion crit5 ] where crit1 = eval critFemale featEvs crit2 = eval critOver50 agefeat- crit3 = eval critEnrolled (featInd, enrll)- crit4 = eval critEnrolled455 (featInd, enrll, crit3)+ crit3 = eval critEnrolled (featInd, featEvs)+ crit4 = eval critEnrolled455 (featInd, featEvs, crit3) crit5 = eval critDead (featInd, dead) agefeat = eval age (featInd, featEvs)- enrll = eval enrollmentIntervals featEvs dead = eval deathDay featEvs featInd = featureIndex index featEvs = featureEvents events@@ -360,9 +330,9 @@ testData1 = sort [ m 2010 1 1 1 ["is_female"] (Demographics (DemographicsFacts (DemographicsInfo Gender (Just "Female")) )) , m 2010 1 1 1 ["is_birth_year"] (Demographics (DemographicsFacts (DemographicsInfo BirthYear (Just "1960")) ))- , m 2016 1 1 699 ["enrollment"] ( UnimplementedDomain ())- , m 2018 1 1 30 ["enrollment"] ( UnimplementedDomain ())- , m 2018 2 1 30 ["enrollment"] ( UnimplementedDomain ())+ , m 2016 1 1 699 ["enrollment"] (Enrollment EnrollmentFacts)+ , m 2018 1 1 30 ["enrollment"] (Enrollment EnrollmentFacts)+ , m 2018 2 1 30 ["enrollment"] (Enrollment EnrollmentFacts) , m 2017 6 5 1 ["is_diabetes_inpatient"] (UnimplementedDomain ()) , m 2017 8 1 91 ["is_ppi"] (UnimplementedDomain ()) ]@@ -374,9 +344,9 @@ testData2 = sort [ m 2010 1 1 1 ["is_female"] (Demographics (DemographicsFacts (DemographicsInfo Gender (Just "Female")) )) , m 2010 1 1 1 ["is_birth_year"] (Demographics (DemographicsFacts (DemographicsInfo BirthYear (Just "1980")) ))- , m 2016 1 1 730 ["enrollment"] (UnimplementedDomain ())- , m 2018 1 1 30 ["enrollment"] (UnimplementedDomain ())- , m 2018 2 1 30 ["enrollment"] (UnimplementedDomain ())+ , m 2016 1 1 730 ["enrollment"] (Enrollment EnrollmentFacts)+ , m 2018 1 1 30 ["enrollment"] (Enrollment EnrollmentFacts)+ , m 2018 2 1 30 ["enrollment"] (Enrollment EnrollmentFacts) ] testSubject2 :: Subject (Events Day)
examples/ExampleFeatures4.hs view
@@ -168,7 +168,7 @@ , IntervalSizeable a b) => b -> Index i a -> Interval a makeFollowupInterval dur index = - beginerval dur (add washoutDuration (begin $ getIndex index))+ beginerval dur (add washoutDuration (begin index)) -- | Creates an interval *starting 7 days after the index* and -- ending 'followupDuration' days later.
hasklepias.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: hasklepias-version: 0.15.2+version: 0.16.0 description: Please see the README on GitHub at <https://github.com/novisci/asclepias#readme> homepage: https://github.com/novisci/asclepias/#readme bug-reports: https://github.com/novisci/asclepias/issues@@ -30,6 +30,7 @@ EventData.Context.Arbitrary EventData.Context.Domain EventData.Context.Domain.Demographics+ EventData.Context.Domain.Enrollment Features Features.Attributes Features.Compose@@ -48,6 +49,11 @@ Hasklepias.Misc Hasklepias.Reexports Hasklepias.ReexportsUnsafe+ Hasklepias.Templates+ Hasklepias.Templates.Features+ Hasklepias.Templates.Tests+ Hasklepias.Templates.TestUtilities+ Hasklepias.Templates.Features.Enrollment Stype Stype.Aeson Stype.Numeric@@ -128,6 +134,19 @@ , unordered-containers >=0.2.10 , vector >=0.12 , QuickCheck+ default-language: Haskell2010++test-suite templates+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs:+ template-test+ build-depends:+ hasklepias+ , base >=4.14 && <4.15+ , tasty == 1.4.1+ , tasty-hunit == 0.10.0.3+ , tasty-hspec == 1.2 default-language: Haskell2010 test-suite examples
src/Cohort/Index.hs view
@@ -9,19 +9,20 @@ {-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-} -- {-# LANGUAGE Safe #-} module Cohort.Index(- Index+ Index(..) , makeIndex- , getIndex ) where import GHC.Show ( Show )-import GHC.Generics+import GHC.Generics ( Generic ) import Data.Eq ( Eq )-import IntervalAlgebra ( Intervallic )-import Data.Aeson+import IntervalAlgebra ( Intervallic(..) )+import Data.Aeson ( ToJSON ) {-| An @Index@ is a wrapper for an @Intervallic@ used to indicate that a particular@@ -35,5 +36,9 @@ -- | Creates a new @'Index'@. makeIndex :: Intervallic i a => i a -> Index i a makeIndex = MkIndex++instance (Intervallic i a) => Intervallic (Index i) a where+ getInterval (MkIndex x) = getInterval x+ setInterval (MkIndex x) y = MkIndex (setInterval x y) instance (Intervallic i a, ToJSON (i a)) => ToJSON (Index i a)
src/EventData/Context/Domain.hs view
@@ -17,6 +17,8 @@ Domain(..) , _Demographics , module EventData.Context.Domain.Demographics+ , _Enrollment+ , module EventData.Context.Domain.Enrollment ) where import Control.Lens ( makePrisms )@@ -26,10 +28,12 @@ import GHC.Show ( Show ) import EventData.Context.Domain.Demographics+import EventData.Context.Domain.Enrollment -- | Defines the available domains. data Domain = Demographics DemographicsFacts+ | Enrollment EnrollmentFacts | UnimplementedDomain () deriving ( Eq, Show, Generic )
+ src/EventData/Context/Domain/Enrollment.hs view
@@ -0,0 +1,39 @@+{-|+Module : Event Data Model facts +Description : Defines the Context type and its component types, constructors, + and class instances+Copyright : (c) NoviSci, Inc 2020+License : BSD3+Maintainer : bsaul@novisci.com+-}+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TemplateHaskell #-}++module EventData.Context.Domain.Enrollment(+ EnrollmentFacts(..)+) where++import Control.Lens ( makeLenses )+import Data.Aeson ( FromJSON(..)+ , genericParseJSON+ , defaultOptions+ , fieldLabelModifier )+import Data.List ( drop )+import Data.Eq ( Eq )+import GHC.Generics ( Generic )+import GHC.Show ( Show )+++-- | An enrollment fact+data EnrollmentFacts = EnrollmentFacts { + -- TODO add plan fact+ } + deriving( Eq, Show, Generic )++makeLenses ''EnrollmentFacts++instance FromJSON EnrollmentFacts where+ parseJSON = genericParseJSON defaultOptions{fieldLabelModifier = drop 1}
src/Hasklepias.hs view
@@ -26,6 +26,9 @@ , module Hasklepias.FeatureEvents , module Hasklepias.Misc + -- ** Feature definition templates+ , module Hasklepias.Templates+ -- * Specifying and building cohorts , module Cohort @@ -55,5 +58,6 @@ import Hasklepias.Reexports import Hasklepias.ReexportsUnsafe import Hasklepias.MakeApp+import Hasklepias.Templates import Stype
src/Hasklepias/FeatureEvents.hs view
@@ -39,6 +39,7 @@ , isBirthYear , isGenderFact , isStateFact+ , isEnrollment , filterByDomain -- ** Manipulating Dates@@ -275,6 +276,11 @@ isStateFact :: Domain -> Bool isStateFact (Demographics (DemographicsFacts (DemographicsInfo State _))) = True isStateFact _ = False++-- | Predicate for State facts+isEnrollment :: Domain -> Bool +isEnrollment (Enrollment _) = True+isEnrollment _ = False -- | Filters a container of 'Event's by the 'Domain'. filterByDomain :: (Witherable f) => (Domain -> Bool) -> f (Event a) -> f (Event a)
+ src/Hasklepias/Templates.hs view
@@ -0,0 +1,16 @@+{-|+Module : Exports Hasklepias templates+Copyright : (c) NoviSci, Inc 2020+License : BSD3+Maintainer : bsaul@novisci.com++-}+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Hasklepias.Templates (+ module Hasklepias.Templates.Features++) where++import Hasklepias.Templates.Features
+ src/Hasklepias/Templates/Features.hs view
@@ -0,0 +1,16 @@+{-|+Module : Exports Hasklepias templates+Copyright : (c) NoviSci, Inc 2020+License : BSD3+Maintainer : bsaul@novisci.com++-}+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Hasklepias.Templates.Features (+ module Hasklepias.Templates.Features.Enrollment++) where++import Hasklepias.Templates.Features.Enrollment (defIsEnrolled, defContinuousEnrollment)
+ src/Hasklepias/Templates/Features/Enrollment.hs view
@@ -0,0 +1,216 @@+{-|+Module : Enrollment Features Templates +Description : Templates for Features pertaining to enrollment+Copyright : (c) NoviSci, Inc 2020+License : BSD3+Maintainer : bsaul@novisci.com++-}+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}++module Hasklepias.Templates.Features.Enrollment (+ defIsEnrolled + , defContinuousEnrollment+ , defEnrollmentTests+) where++import Control.Applicative ( Applicative(..) )+import GHC.Int ( Int )+import GHC.TypeLits ( KnownSymbol )+import GHC.Show ( Show )+import Flow ( (|>), (.>) )+import IntervalAlgebra+import IntervalAlgebra.IntervalUtilities ( combineIntervals )+import IntervalAlgebra.PairedInterval ( intervals )+import Witherable ( Witherable )+import Data.Eq ( Eq )+import Data.Foldable (Foldable(..), any)+import Data.Function ( ($), (.) )+import Data.Functor ( Functor(.. ) )+import Data.Maybe ( Maybe )+import Data.Monoid ( Monoid(..) )+import Data.Text ( Text )+import Data.Tuple ( uncurry ) +import Test.Tasty ( testGroup, TestName, TestTree )+import Test.Tasty.HUnit ( testCase )++import EventData ( Event+ , Domain(..)+ , EnrollmentFacts(..)+ , event+ , context+ )+import Features.Compose ( Feature+ , Definition(..)+ , Define(..)+ , Eval(..)+ , makeFeature )+import Hasklepias.FeatureEvents ( allGapsWithinLessThanDuration+ , makeConceptsFilter+ , filterByDomain+ , isEnrollment, lookback )+import Hasklepias.Templates.TestUtilities+ ( makeAssertion+ , TemplateTestCase(..) )+import Hasklepias.Misc ( F )+import Cohort.Index ( Index(..) )+import Cohort.Criteria ( Status(..), includeIf )+++{-| Is Enrolled++TODO: describe this++-}+defIsEnrolled ::+ ( Intervallic i0 a+ , Monoid (container (Interval a))+ , Applicative container+ , Witherable container) =>+ Definition+ ( Feature indexName (Index i0 a)+ -> Feature eventsName (container (Event a))+ -> Feature varName Status )+defIsEnrolled =+ define+ (\index ->+ filterByDomain isEnrollment+ .> combineIntervals+ .> any (concur index)+ .> includeIf+ )++makeIsEnrolledTestInputs :: (IntervalSizeable a b) =>+ TestName+ -> b + -> a+ -> [Event a]+ -> Status+ -> TemplateTestCase (F "index" (Index Interval a), F "events" [Event a]) Status+makeIsEnrolledTestInputs name dur bgn e s = + MkTemplateTestCase name (pure (MkIndex $ beginerval dur bgn), pure e) (pure s)++makeEnrollmentEvent :: (IntervalSizeable a b) => b -> a -> Event a+makeEnrollmentEvent dur bgn = + event (beginerval dur bgn) (context ( Enrollment EnrollmentFacts) mempty)++defIsEnrolledTestCases :: [TemplateTestCase+ (F "index" (Index Interval Int), F "events" [Event Int]) Status]+defIsEnrolledTestCases = [ + f "Exclude if no events" 1 (0::Int) [] Exclude+ , f "Exclude if only interval meets" 1 (0::Int) [g 5 1] Exclude+ , f "Include if concurring interval" 1 (0::Int) [g 5 (-1)] Include+ , f "Include if concurring interval" 1 (0::Int) [g 2 (-1), g 5 1] Include + ] where f = makeIsEnrolledTestInputs+ g = makeEnrollmentEvent++defIsEnrolledTests :: TestTree+defIsEnrolledTests = testGroup "Tests of isEnrolled template"+ ( fmap (\x -> testCase (getTestName x) (makeAssertion x defIsEnrolled) )+ defIsEnrolledTestCases )+++{-| Continuous Enrollment ++TODO: describe this+-}+defContinuousEnrollment ::+ ( Monoid (container (Interval a))+ , Monoid (container (Maybe (Interval a)))+ , Applicative container+ , Witherable container+ , IntervalCombinable i1 a+ , IntervalSizeable a b) =>+ (Index i0 a -> i1 a) -- ^ function which maps index interval to interval in which to assess enrollment+ -> b -- ^ duration of allowable gap between enrollment intervals+ -> Definition+ ( Feature indexName (Index i0 a)+ -> Feature eventsName (container (Event a))+ -> Feature prevName Status+ -> Feature varName Status )+defContinuousEnrollment formInterval allowableGap =+ define+ (\index events prevStatus ->+ case prevStatus of+ Exclude -> Exclude+ Include -> includeIf+ ( allGapsWithinLessThanDuration+ allowableGap+ (formInterval index)+ (combineIntervals $ filterByDomain isEnrollment events))+ )++makeContinuousEnrollmentTestInputs :: (IntervalSizeable a b) =>+ TestName+ -> b + -> a+ -> [Event a]+ -> Status+ -> Status+ -> TemplateTestCase (F "index" (Index Interval a), F "events" [Event a], F "prev" Status) Status+makeContinuousEnrollmentTestInputs name dur bgn e prev s = + MkTemplateTestCase name (pure (MkIndex $ beginerval dur bgn), pure e, pure prev) (pure s)++defContinuousEnrollmentTestCases :: [TemplateTestCase+ (F "index" (Index Interval Int), F "events" [Event Int], F "prev" Status) Status]+defContinuousEnrollmentTestCases = [ + f "Exclude if previously excluded" 1 (0::Int) [] Exclude Exclude+ , f "Exclude if no events" 1 (0::Int) [] Include Exclude+ {-+ - <- Index+ ---------- <- Baseline+ --- --- <- Enrollment+ |--------------|+ -}+ , f "Exclude if gap >= 3" 1 (10::Int) [g 3 1, g 3 9] Include Exclude+ {-+ - <- Index+ ---------- <- Baseline+ ------ <- Enrollment+ |--------------|+ -}+ , f "Exclude if gap >= 3" 1 (10::Int) [g 6 1] Include Exclude+ {-+ - <- Index+ ---------- <- Baseline+ ------- <- Enrollment+ |--------------|+ -}+ , f "Exclude if gap >= 3" 1 (10::Int) [g 7 6] Include Exclude+ {-+ - <- Index+ ---------- <- Baseline+ -- ------- <- Enrollment+ |--------------|+ -}+ , f "Include if gaps less than 3" 1 (10::Int) [g 2 1, g 7 5] Include Include+ {-+ - <- Index+ ---------- <- Baseline+ ------- <- Enrollment+ |--------------|+ -}+ , f "Include if gaps less than 3" 1 (10::Int) [g 7 2] Include Include+ {-+ - <- Index+ ---------- <- Baseline+ ----- <- Enrollment+ ----+ |--------------|+ -}+ , f "Include if gaps less than 3" 1 (10::Int) [g 5 1, g 4 4] Include Include+ ] where f = makeContinuousEnrollmentTestInputs+ g = makeEnrollmentEvent++defContinuousEnrollmentTests :: TestTree+defContinuousEnrollmentTests = testGroup "Tests of continuous enrollment template"+ ( fmap (\x -> testCase (getTestName x) + (makeAssertion x (defContinuousEnrollment (lookback 10) 3)) )+ defContinuousEnrollmentTestCases )++defEnrollmentTests :: TestTree+defEnrollmentTests = testGroup "" [defIsEnrolledTests, defContinuousEnrollmentTests]
+ src/Hasklepias/Templates/TestUtilities.hs view
@@ -0,0 +1,46 @@+{-|+Module : Functions and types for creating tests for templates +Description : Misc types and functions useful in Hasklepias.+Copyright : (c) NoviSci, Inc 2020+License : BSD3+Maintainer : bsaul@novisci.com++These functions may be moved to more appropriate modules in future versions.+-}+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}++module Hasklepias.Templates.TestUtilities (+ TemplateTestCase(..)+ , evalTestCase+ , makeAssertion+) where++import Data.Eq ( Eq )+import Data.Tuple ( uncurry )+import GHC.Show ( Show )+import Features.Compose ( Feature+ , Definition(..)+ , Define(..)+ , Eval(..) )+import Test.Tasty ( TestName )+import Test.Tasty.HUnit ( (@=?), Assertion )++data TemplateTestCase a b = MkTemplateTestCase {+ getTestName :: TestName+ , getInputs :: a+ , getTruth :: Feature "result" b+ } deriving (Eq, Show)++evalTestCase :: Eval def args return => + TemplateTestCase args b + -> Definition def + -> ( return, Feature "result" b )+evalTestCase (MkTemplateTestCase _ inputs truth) def = ( eval def inputs, truth )++makeAssertion :: (Eq b, Show b, Eval def args (Feature "result" b)) =>+ TemplateTestCase args b -> Definition def -> Assertion+makeAssertion x def = uncurry (@=?) (evalTestCase x def)
+ src/Hasklepias/Templates/Tests.hs view
@@ -0,0 +1,24 @@+{-|+Module : Functions and types for creating tests for templates +Description : Misc types and functions useful in Hasklepias.+Copyright : (c) NoviSci, Inc 2020+License : BSD3+Maintainer : bsaul@novisci.com++These functions may be moved to more appropriate modules in future versions.+-}+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}++module Hasklepias.Templates.Tests (+ templateTests+) where++import Test.Tasty ( testGroup, TestTree ) +import Hasklepias.Templates.Features.Enrollment ( defEnrollmentTests )++templateTests :: TestTree+templateTests = testGroup "tests of feature templates" [defEnrollmentTests]
+ template-test/Main.hs view
@@ -0,0 +1,9 @@+module Main(+ main+) where++import Test.Tasty ( defaultMain )+import Hasklepias.Templates.Tests ( templateTests )++main :: IO ()+main = defaultMain templateTests