diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2012, Nathan "Taneb" van Doorn +Copyright (c) 2013, Nathan "Taneb" van Doorn All rights reserved. diff --git a/family-tree.cabal b/family-tree.cabal --- a/family-tree.cabal +++ b/family-tree.cabal @@ -1,63 +1,21 @@ --- Initial family-tree.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ - --- The name of the package. name: family-tree - --- The package version. See the Haskell package versioning policy (PVP) --- for standards guiding when and how versions should be incremented. --- http://www.haskell.org/haskellwiki/Package_versioning_policy --- PVP summary: +-+------- breaking API changes --- | | +----- non-breaking API additions --- | | | +--- code changes with no API change -version: 0.4.1.1 - +version: 0.5 package-url: https://github.com/Taneb/family-tree - --- A short (one-line) description of the package. synopsis: A family tree library for the Haskell programming language. - --- A longer description of the package. description: A family tree library for the Haskell programming language. Uses "Control.Lens" for modification and "Data.Binary" for serialization. - --- URL for the project homepage or repository. homepage: https://github.com/Taneb/family-tree - --- The license under which the package is released. license: BSD3 - --- The file containing the license text. license-file: LICENSE - --- The package author(s). author: Nathan "Taneb" van Doorn - --- An email address to which users can send suggestions, bug reports, and --- patches. maintainer: nvd1234@gmail.com - --- A copyright notice. --- copyright: - category: Data, Genealogy - build-type: Simple - --- Constraint on the version of Cabal needed to build this package. cabal-version: >=1.8 - - library - -- Modules exported by the library. exposed-modules: Data.FamilyTree - - -- Modules included in this library but not exported. - -- other-modules: - - -- Other library packages from which modules are imported. build-depends: base >= 4.3 && < 5, lens >= 3.8 && < 3.10, binary < 0.7, @@ -65,9 +23,9 @@ containers >=0.4.2 && < 0.6, text ==0.11.*, time < 1.5, - intervals < 0.3 - - -- Directories containing source files. + intervals < 0.3, + tables ==0.3.*, + hashable >= 1.1.1.0 && < 1.3 hs-source-dirs: src source-repository head diff --git a/src/Data/FamilyTree.hs b/src/Data/FamilyTree.hs --- a/src/Data/FamilyTree.hs +++ b/src/Data/FamilyTree.hs @@ -1,5 +1,5 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} @@ -16,8 +16,6 @@ "Control.Lens" It is reccomended to use "Data.Binary" to do saving and loading. - - -} module Data.FamilyTree ( @@ -37,15 +35,10 @@ relationFrom, relationTo, relationship, - FamilyTree(..), treeName, people, families, - -- ** ID types - -- $ids - PersonID(..), - FamilyID(..), -- ** Other types PartialDate, Location(..), @@ -66,52 +59,36 @@ partialDateFromDay ) where -import Control.Applicative (Applicative(..), (<$>), Alternative(..)) +import Control.Applicative (Applicative(..), (<$>), Alternative((<|>))) import Control.Lens hiding (children) -import Data.Binary (Word8, Binary(..), getWord8) +import Data.Binary (Binary(..), putWord8, getWord8) import Data.Function (on) +import Data.Hashable (Hashable(..)) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HM -import Data.Maybe (listToMaybe) import Data.Monoid (Monoid(..), First(..)) -import Data.IntMap (IntMap) -import qualified Data.IntMap as IM import Data.IntSet (IntSet) import qualified Data.IntSet as IS ---import Data.Table +import Data.Table import Data.String import Data.Text (Text) ---import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Data.Time (Day(..), fromGregorian, gregorianMonthLength) +import GHC.Generics (Generic) + import Numeric.Interval (Interval) import qualified Numeric.Interval as I --- $ids --- The various ID types represent an identifier for a person, family, or event. --- While the constructors are exported, it is probably better to use the --- various 'Traversal's for manipulation, as they echo the changes around the --- tree automatically. -newtype PersonID = PersonID {getPersonID :: Int} deriving (Eq, Ord, Show, Read) - -instance Wrapped Int Int PersonID PersonID where - wrapped = iso PersonID getPersonID - -newtype FamilyID = FamilyID {getFamilyID :: Int} deriving (Eq, Ord, Show, Read) - -instance Wrapped Int Int FamilyID FamilyID where - wrapped = iso FamilyID getFamilyID - -- | The Location type. Either a coordinate or a placename. -data Location = Coord Double Double | PlaceName Text deriving (Eq, Show) +data Location = Coord Double Double | PlaceName Text deriving (Eq, Show, Generic) instance IsString Location where fromString = PlaceName . fromString -- | The Relationship type. Marriage is the default for similarity to GEDCOM. -data Relationship = Marriage | Other Text deriving (Eq, Show) +data Relationship = Marriage | Other Text deriving (Eq, Show, Generic) type PartialDate = Interval Day @@ -129,40 +106,114 @@ -- non-existent, for intance a death date for someone still alive) is a -- convention used throughout this library. data Person = Person - {_name :: Maybe Text + {_personId :: Int + ,_name :: Maybe Text ,_birthdate :: Maybe PartialDate ,_birthplace :: Maybe Location ,_deathdate :: Maybe PartialDate ,_deathplace :: Maybe Location ,_attributes :: HashMap Text Text - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) makeLenses ''Person +instance Tabular Person where + type PKT Person = Int + data Tab Person i = PersonTab (i Primary Int) (i SupplementalHash (Maybe Text)) (i Supplemental (Maybe PartialDate)) + (i SupplementalHash (Maybe Location)) (i Supplemental (Maybe PartialDate)) + (i SupplementalHash (Maybe Location)) + data Key k Person t where + PersonID :: Key Primary Person Int + Name :: Key SupplementalHash Person (Maybe Text) + BirthDate :: Key Supplemental Person (Maybe PartialDate) + BirthPlace :: Key SupplementalHash Person (Maybe Location) + DeathDate :: Key Supplemental Person (Maybe PartialDate) + DeathPlace :: Key SupplementalHash Person (Maybe Location) + fetch PersonID = _personId + fetch Name = _name + fetch BirthDate = _birthdate + fetch BirthPlace = _birthplace + fetch DeathDate = _deathdate + fetch DeathPlace = _deathplace + primary = PersonID + primarily PersonID r = r + mkTab f = PersonTab <$> f PersonID <*> f Name <*> f BirthDate <*> f BirthPlace + <*> f DeathDate <*> f DeathPlace + ixTab (PersonTab i n bd bp dd dp) k = case k of + PersonID -> i + Name -> n + BirthDate -> bd + BirthPlace -> bp + DeathDate -> dd + DeathPlace -> dp + forTab (PersonTab i n bd bp dd dp) f = + PersonTab <$> f PersonID i <*> f Name n <*> f BirthDate bd <*> f BirthPlace bp + <*> f DeathDate dd <*> f DeathPlace dp + autoTab = autoIncrement personId + -- | The basic type for a family. Which person is head1 and which is head2 is -- arbitrary, but try to use a consistent rule data Family = Family - {_head1 :: Maybe PersonID - ,_head2 :: Maybe PersonID + {_familyId :: Int + ,_head1 :: Maybe Int + ,_head2 :: Maybe Int ,_relationship :: Maybe Relationship ,_relationFrom :: Maybe PartialDate ,_relationTo :: Maybe PartialDate ,_children :: IntSet - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) makeLenses ''Family +instance Tabular Family where + type PKT Family = Int + data Tab Family i = FamilyTab (i Primary Int) (i Supplemental (Maybe Int)) (i Supplemental (Maybe Int)) + (i SupplementalHash (Maybe Relationship)) (i Supplemental (Maybe PartialDate)) + (i Supplemental (Maybe PartialDate)) (i InvertedInt (IntSet)) + data Key k Family t where + FamilyID :: Key Primary Family Int + Head1 :: Key Supplemental Family (Maybe Int) + Head2 :: Key Supplemental Family (Maybe Int) + Relationship :: Key SupplementalHash Family (Maybe Relationship) + RelationFrom :: Key Supplemental Family (Maybe PartialDate) + RelationTo :: Key Supplemental Family (Maybe PartialDate) + Children :: Key InvertedInt Family IntSet + fetch FamilyID = _familyId + fetch Head1 = _head1 + fetch Head2 = _head2 + fetch Relationship = _relationship + fetch RelationFrom = _relationFrom + fetch RelationTo = _relationTo + fetch Children = _children + primary = FamilyID + primarily FamilyID r = r + mkTab f = FamilyTab <$> f FamilyID <*> f Head1 <*> f Head2 <*> f Relationship + <*> f RelationFrom <*> f RelationTo <*> f Children + ixTab (FamilyTab i h1 h2 r rf rt c) k = case k of + FamilyID -> i + Head1 -> h1 + Head2 -> h2 + Relationship -> r + RelationFrom -> rf + RelationTo -> rt + Children -> c + forTab (FamilyTab i h1 h2 r rf rt c) f = + FamilyTab <$> f FamilyID i <*> f Head1 h1 <*> f Head2 h2 <*> f Relationship r + <*> f RelationFrom rf <*> f RelationTo rt <*> f Children c + autoTab = autoIncrement familyId + -- | The core structure of a family tree. data FamilyTree = FamilyTree {_treeName :: Text - ,_people :: IntMap Person - ,_families :: IntMap Family - } deriving (Eq, Show) + ,_people :: Table Person + ,_families :: Table Family + } deriving (Eq, Show, Generic) makeLenses ''FamilyTree instance Monoid Person where mempty = Person { + _personId = 0, _name = Nothing, _birthdate = Nothing, _birthplace = Nothing, @@ -171,6 +222,7 @@ _attributes = HM.empty } p1 `mappend` p2 = Person { + _personId = _personId p1, _name = ((<|>) `on` _name) p1 p2, _birthdate = ((<|>) `on` _birthdate) p1 p2, _birthplace = ((<|>) `on` _birthplace) p1 p2, @@ -181,6 +233,7 @@ instance Monoid Family where mempty = Family { + _familyId = 0, _head1 = Nothing, _head2 = Nothing, _relationship = Nothing, @@ -189,6 +242,7 @@ _children = IS.empty } f1 `mappend` f2 = Family { + _familyId = _familyId f1, _head1 = getFirst $ (mappend `on` First . _head1) f1 f2, _head2 = getFirst $ (mappend `on` First . _head2) f1 f2, _relationship = getFirst $ (mappend `on` First . _relationship) f1 f2, @@ -199,11 +253,11 @@ instance Binary Location where put (Coord x y) = do - put (0 :: Word8) + putWord8 0 put x put y put (PlaceName t) = do - put (1 :: Word8) + putWord8 1 put (encodeUtf8 t) get = do tag <- getWord8 @@ -214,19 +268,24 @@ return $ Coord x y _ -> PlaceName . decodeUtf8 <$> get +instance Hashable Location + instance Binary Relationship where put (Other t) = do - put (0 :: Word8) + putWord8 0 put (encodeUtf8 t) - put Marriage = put (1 :: Word8) + put Marriage = putWord8 1 get = do tag <- getWord8 case tag of 0 -> Other . decodeUtf8 <$> get _ -> return Marriage +instance Hashable Relationship + instance Binary Person where put person = do + put (_personId person) put (encodeUtf8 <$> _name person) put (toModifiedJulianDay . I.inf <$> _birthdate person) put (toModifiedJulianDay . I.sup <$> _birthdate person) @@ -236,6 +295,7 @@ put (_deathplace person) put (map (both %~ encodeUtf8) . HM.toList $ _attributes person) get = do + i <- get n <- get bdi <- get bds <- get @@ -245,7 +305,8 @@ dp <- get a <- get return Person - {_name = fmap decodeUtf8 n + {_personId = i + ,_name = fmap decodeUtf8 n ,_birthdate = I.I <$> fmap ModifiedJulianDay bdi <*> fmap ModifiedJulianDay bds ,_birthplace = bp @@ -257,8 +318,9 @@ instance Binary Family where put fam = do - put $ getPersonID <$> _head1 fam - put $ getPersonID <$> _head2 fam + put $ _familyId fam + put $ _head1 fam + put $ _head2 fam put $ _relationship fam put $ toModifiedJulianDay . I.inf <$> _relationFrom fam put $ toModifiedJulianDay . I.sup <$> _relationFrom fam @@ -266,6 +328,7 @@ put $ toModifiedJulianDay . I.sup <$> _relationTo fam put $ _children fam get = do + f <- get h1 <- get h2 <- get r <- get @@ -275,8 +338,9 @@ rts <- get c <- get return Family - {_head1 = PersonID <$> h1 - ,_head2 = PersonID <$> h2 + {_familyId = f + ,_head1 = h1 + ,_head2 = h2 ,_relationship = r ,_relationFrom = I.I <$> fmap ModifiedJulianDay rfi <*> fmap ModifiedJulianDay rfs ,_relationTo = I.I <$> fmap ModifiedJulianDay rti <*> fmap ModifiedJulianDay rts @@ -299,25 +363,22 @@ } class FamilyTreePart part where - type ID part - -- | 'accessFT' is a 'Traversal' to the part of the family tree (either a 'Person' or a 'Family') with the given 'ID' - accessFT :: ID part -> IndexedTraversal' (ID part) FamilyTree part + -- | 'accessFT' is a 'Traversal' to the part of the family tree (either a 'Person' or a 'Family') + accessFT :: Int -> IndexedTraversal' Int FamilyTree part instance FamilyTreePart Person where - type ID Person = PersonID - accessFT (PersonID n) f familyTree = case familyTree ^. people . at n of + accessFT n f familyTree = case familyTree ^. people . at n of Nothing -> pure familyTree Just oldPerson -> - let newPerson_ = indexed f (PersonID n) oldPerson + let newPerson_ = indexed f n oldPerson in alterPerson <$> newPerson_ where alterPerson newPerson = people . ix n .~ newPerson $ familyTree instance FamilyTreePart Family where - type ID Family = FamilyID - accessFT (FamilyID n) f familyTree = case familyTree ^. families . at n of + accessFT n f familyTree = case familyTree ^. families . at n of Nothing -> pure familyTree - Just oldFamily -> let newFamily_ = indexed f (FamilyID n) oldFamily + Just oldFamily -> let newFamily_ = indexed f n oldFamily in alterFamily <$> newFamily_ where alterFamily newFamily = @@ -325,46 +386,35 @@ -- | Adds a person with minimal information, returning the updated family tree -- and the ID of the new person. -addPerson :: FamilyTree -> (PersonID, FamilyTree) -addPerson familyTree = - let n = maybe 0 fst $ - listToMaybe $ - dropWhile (uncurry (==)) $ - zip [1 ..] $ IM.keys $ _people familyTree - in (PersonID n, people . at n ?~ mempty $ familyTree) +addPerson :: FamilyTree -> (Int, FamilyTree) +addPerson = people %%~ (_1 %~ _personId) . insert' mempty -- | Adds a family with minimal information, returning the updated family tree -- and the ID of the new family. -addFamily :: FamilyTree -> (FamilyID, FamilyTree) -addFamily familyTree = - let n = maybe 0 fst $ - listToMaybe $ - dropWhile (uncurry (==)) $ - zip [1 ..] $ IM.keys $ _families familyTree - in (FamilyID n, families . at n ?~ mempty $ familyTree) +addFamily :: FamilyTree -> (Int, FamilyTree) +addFamily = families %%~ (_1 %~ _familyId) . insert' mempty -- | Deletes a person from the family tree, removing all references to them. -deletePerson :: PersonID -> FamilyTree -> FamilyTree -deletePerson (PersonID n) familyTree = +deletePerson :: Int -> FamilyTree -> FamilyTree +deletePerson n familyTree = familyTree & people . at n .~ Nothing & - families %~ IM.map ( + families . each %~ \fam -> fam & - head1 %~ (id & ix (Just $ PersonID n) .~ Nothing) & - head2 %~ (id & ix (Just $ PersonID n) .~ Nothing) & + head1 %~ set (ix $ Just n) Nothing id & + head2 %~ set (ix $ Just n) Nothing id & children . contains n .~ False - ) + -- | Deletes a family from the family tree, removing all references to it. -deleteFamily :: FamilyID -> FamilyTree -> FamilyTree -deleteFamily (FamilyID n) = families . at n .~ Nothing +deleteFamily :: Int -> FamilyTree -> FamilyTree +deleteFamily n = families . at n .~ Nothing -- | Creates a new tree with a given name. newTree :: Text -> FamilyTree newTree n = FamilyTree {_treeName = n - ,_people = IM.empty - ,_families = IM.empty + ,_people = empty + ,_families = empty } -