@@ -0,0 +1,63 @@
1+{-# LANGUAGE OverloadedStrings,DeriveAnyClass,DeriveGeneric #-}
2+module Hospital where
3+
4+import ProjectM36.Client
5+import ProjectM36.Atom
6+import Data.Typeable
7+import ProjectM36.Relation
8+import Data.Binary
9+import Control.DeepSeq
10+import Data.Text
11+import GHC.Generics
12+import Data.Hashable
13+import ProjectM36.Tuple
14+
15+data AgeType = PreciseAge Int |
16+ ForgotToAsk |
17+ RefusedToDisclose |
18+ NotApplicable |
19+ ApproximateAge Int Int
20+ deriving (Eq,Show,Read,Hashable,Binary,Typeable,NFData,Generic)
21+
22+instance Atomable AgeType
23+
24+failFastMaybe :: (Show a) => Maybe a -> IO ()
25+failFastMaybe (Just err) = error (show err)
26+failFastMaybe Nothing = return ()
27+
28+failFastEither :: (Show a) => Either a b -> IO (b)
29+failFastEither (Left err) = error (show err)
30+failFastEither (Right val) = return val
31+
32+ageAtomType :: AtomType
33+ageAtomType = atomTypeForProxy (Proxy :: Proxy AgeType)
34+
35+runExample :: IO ()
36+runExample = 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]]
44+
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+ putStrLn (show age_value_in)
57+ putStrLn (show age_value_out)
58+ case cast age_value_out of
59+ Nothing -> error "wrong datatype"
60+ Just age_value_out' -> do
61+ putStrLn (show (age_value_in == age_value_out'))
62+
63+