Re-namespacing

Moving away from the DNS-driven namespacing toward more condensed names,
mostly because I don't like typing so much.

1 files changed, 123 insertions, 0 deletions

diff --git a/Biz/Ibb/Keep.hs b/Biz/Ibb/Keep.hs
new file mode 100644
index 0000000..ad6dc5c
--- /dev/null
+++ b/Biz/Ibb/Keep.hs
@@ -0,0 +1,123 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# 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           Biz.Ibb.Core (Person(..), Book(..))
+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.
+data 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
+  k <- 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 = do
+  keep <- ask
+  return $ take n $ IxSet.toList $ _people keep
+
+-- * 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