project-m36-1.2.0: examples/Hospital.hs

{-# LANGUAGE DeriveGeneric, DerivingVia, TypeApplications #-}
import ProjectM36.Client
import Data.Typeable
import ProjectM36.Relation
import GHC.Generics
import ProjectM36.Tuple
import System.Random (initStdGen)

-- define a custom data type to use in both the client and database
data AgeType = PreciseAge Int |
               ForgotToAsk |
               RefusedToDisclose |
               NotApplicable |
               ApproximateAge Int Int
               deriving (Eq, Show, Generic)

-- define an automatically-derived Atomable instance
instance Atomable AgeType

failFast :: Show a => IO (Either a b) -> IO b
failFast m = do
  ret <- m
  case ret of
    Left err -> error (show err)
    Right val -> pure val

ageAtomType :: AtomType
ageAtomType = toAtomType (Proxy :: Proxy AgeType)
               
main :: IO ()
main = do
  let bob_relation_attrs = attributesFromList [Attribute "name" TextAtomType,
                                               Attribute "age" ageAtomType]
      relvar_name = "hospital_patient"
      age_value_in = ApproximateAge 30 40 
      mk_bob_relation = mkRelationFromList 
                     bob_relation_attrs 
                     [[TextAtom "Bob",
                       toAtom age_value_in]]

  rando <- initStdGen
  -- create the database
  conn <- failFast $ connectProjectM36 (InProcessConnectionInfo NoPersistence emptyNotificationCallback [] basicDatabaseContext rando "admin")

  -- create the session at the head of master branch
  sessionId <- failFast $ createSessionAtHead conn "master"

  -- create the data type in the database
  failFast $ executeDatabaseContextExpr sessionId conn (toAddTypeExpr (Proxy :: Proxy AgeType))
  
  -- create the patient data in a relation
  bob_relation <- failFast (pure mk_bob_relation)

  -- save the data to the database
  failFast $ executeDatabaseContextExpr sessionId conn (Assign relvar_name (ExistingRelation bob_relation))

  -- retrieve the data from the database
  result <- failFast $ executeRelationalExpr sessionId conn (RelationVariable relvar_name ())

  -- print the data
  case singletonTuple result of
    Nothing -> error "not a singleton relation!"
    Just tuple -> do
      case atomForAttributeName "age" tuple of
        Left err -> error (show err)
        Right age_value_out -> do
          print age_value_in
          print (fromAtom @AgeType age_value_out)