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
|
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | Keep is a database built on Data.Acid.
--
-- If this proves useful, maybe we could make it a more general thing. Like
-- `Biz.Keep`. I could wrap all the safecopy stuff in my own template haskell
-- like `$(keep ''MyType)`.
module Biz.Ibb.Keep where
import Alpha
import Biz.Ibb.Core (Book (..), Person (..))
import qualified Biz.Ibb.Influencers as Influencers
import Control.Monad.Reader (ask)
import Control.Monad.State (get, put)
import Data.Acid (Update, makeAcidic)
import qualified Data.Acid as Acid
import Data.Data (Data, Typeable)
import Data.IxSet (Indexable (..), IxSet, ixFun, ixSet)
import qualified Data.IxSet as IxSet
import Data.SafeCopy
import Data.Text (Text)
import qualified Data.Text as Text
-- * Keep
-- | Main database. Need to think of a better name for this.
newtype IbbKeep = IbbKeep
{ _people :: IxSet Person
}
deriving (Data, Typeable)
$(deriveSafeCopy 0 'base ''IbbKeep)
-- * Index @Person@
$(deriveSafeCopy 0 'base ''Person)
newtype PersonName
= PersonName Text
deriving (Eq, Ord, Data, Typeable)
newtype PersonBlurb
= PersonBlurb Text
deriving (Eq, Ord, Data, Typeable)
instance Indexable Person where
empty =
ixSet
[ ixFun <| \p -> [PersonName <| _name p],
ixFun <| \p -> [_pic p],
ixFun <| \p -> [_twitter p],
ixFun <| \p -> [_website p],
ixFun <| \p -> [_books p],
ixFun <| \p -> [PersonBlurb <| _blurb p]
]
-- | updates the `IbbKeep` with a new `Person`
newPerson :: Text -> Text -> Update IbbKeep Person
newPerson name blurb = do
keep <- get
put
<| k
{ _people = IxSet.insert p (_people k)
}
return p
where
p =
Person
{ _name = name,
_pic = Text.empty,
_twitter = Text.empty,
_website = Text.empty,
_books = [],
_blurb = blurb
}
getPeople :: Int -> Acid.Query IbbKeep [Person]
getPeople n = ask /> _people /> IxSet.toList /> take n
-- * Index @Book@
$(deriveSafeCopy 0 'base ''Book)
newtype BookTitle
= BookTitle Text
deriving (Eq, Ord, Data, Typeable)
newtype BookAuthor
= BookAuthor Text
deriving (Eq, Ord, Data, Typeable)
instance Indexable Book where
empty =
ixSet
[ ixFun <| \b -> [BookTitle <| _title b],
ixFun <| \b -> [BookAuthor <| _author b],
ixFun <| \b -> [_amznref b]
]
-- | updates the `IbbKeep` with a new `Book`
-- newBook :: Text -> Text -> Text -> Update IbbKeep Book
-- newBook title author amznref = do
-- ibbKeep <- get
-- put <| ibbKeep { _books = IxSet.insert b (_books ibbKeep)
-- , _people = _people ibbKeep
-- }
-- return b
-- where
-- b = Book { _title = title
-- , _author = author
-- , _amznref = amznref
-- }
-- * Opening the keep
-- defines @NewPerson@ for us.
$(makeAcidic ''IbbKeep ['newPerson, 'getPeople])
initialIbbKeep :: IbbKeep
initialIbbKeep =
IbbKeep
{ _people = IxSet.fromList Influencers.allPeople
}
openLocal :: String -> IO (Acid.AcidState IbbKeep)
openLocal dir =
Acid.openLocalStateFrom dir initialIbbKeep
|
