git.iko.soy/project-m36
on YuMingLiao-feature/add_with_relvar_macro help sign in
project-m36/examples/Hospital.hs
63 lines 2.2 kB history raw
1{-# LANGUAGE DeriveAnyClass,DeriveGeneric #-}
2module Hospital where
4import ProjectM36.Client
5import ProjectM36.Atom
6import Data.Typeable
7import ProjectM36.Relation
8import Data.Binary
9import Control.DeepSeq
10import Data.Text
11import GHC.Generics
12import Data.Hashable
13import ProjectM36.Tuple
15data AgeType = PreciseAge Int |
16 ForgotToAsk |
17 RefusedToDisclose |
18 NotApplicable |
19 ApproximateAge Int Int
20 deriving (Eq,Show,Read,Hashable,Binary,Typeable,NFData,Generic)
22instance Atomable AgeType
24failFastMaybe :: (Show a) => Maybe a -> IO ()
25failFastMaybe (Just err) = error (show err)
26failFastMaybe Nothing = return ()
28failFastEither :: Show a => Either a b -> IO b
29failFastEither (Left err) = error (show err)
30failFastEither (Right val) = return val
32ageAtomType :: AtomType
33ageAtomType = atomTypeForProxy (Proxy :: Proxy AgeType)
35runExample :: IO ()
36runExample = do
37 let bob_relation_attrs = attributesFromList [Attribute "name" stringAtomType,
38 Attribute "age" ageAtomType]
39 relvar_name = "hospital_patient"
40 age_value_in = ApproximateAge 30 40
41 bob_relation_err = mkRelationFromList
42 bob_relation_attrs
43 [[Atom ("Bob"::Text), Atom age_value_in]]
45 connerr <- connectProjectM36 (InProcessConnectionInfo NoPersistence)
46 conn <- failFastEither connerr
47 bob_relation <- failFastEither bob_relation_err
48 merr <- executeDatabaseContextExpr conn (Assign relvar_name (ExistingRelation bob_relation))
49 failFastMaybe merr
50 result_err <- executeRelationalExpr conn (RelationVariable relvar_name)
51 result <- failFastEither result_err
52 case singletonTuple result of
53 Nothing -> error "not a singleton relation!"
54 Just tuple -> do
55 (Atom age_value_out) <- failFastEither $ atomForAttributeName "age" tuple
56 print age_value_in
57 print age_value_out
58 case cast age_value_out of
59 Nothing -> error "wrong datatype"
60 Just age_value_out' ->
61 print (age_value_in == age_value_out')