family-tree 0.3.1.4 → 0.4.0.0

raw patch · 2 files changed

+31/−137 lines, 2 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• family-tree.cabal +1/−1
• src/Data/FamilyTree.hs +30/−136

@@ -10,7 +10,7 @@ -- PVP summary:      +-+------- breaking API changes --                   | | +----- non-breaking API additions --                   | | | +--- code changes with no API change-version:             0.3.1.4+version:             0.4.0.0  package-url:         https://github.com/Taneb/family-tree 

@@ -38,21 +38,15 @@  relationFrom,  relationTo,  relationship,- Event(..),- eventInfo,- eventDate,- eventAttendees,- +    FamilyTree(..),  treeName,  people,  families,- events,- -- ** ID types+  -- ** ID types  -- $ids  PersonID(..),  FamilyID(..),- EventID(..),  -- ** Other types  PartialDate,  Location(..),@@ -62,15 +56,11 @@  newTree,  addPerson,  addFamily,- addEvent,  -- ** Manipulation- traversePerson,- traverseFamily,- traverseEvent,+ FamilyTreePart (..),  -- ** Destruction  deletePerson,  deleteFamily,- deleteEvent,  -- * Utility functions  partialDateFromYear,  partialDateFromMonth,@@ -91,8 +81,9 @@ import Data.IntSet (IntSet) import qualified Data.IntSet as IS --import Data.Table+import Data.String import Data.Text (Text)-import qualified Data.Text as T+--import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Data.Time (Day(..), fromGregorian, gregorianMonthLength) @@ -114,14 +105,12 @@ instance Wrapped Int Int FamilyID FamilyID where   wrapped = iso FamilyID getFamilyID -newtype EventID = EventID {getEventID :: Int} deriving (Eq, Ord, Show, Read)--instance Wrapped Int Int EventID EventID where-  wrapped = iso EventID getEventID- -- | The Location type. Either a coordinate or a placename.   data Location = Coord Double Double | PlaceName Text deriving (Eq, Show) +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) @@ -165,29 +154,11 @@    makeLenses ''Family --- | The basic type for an event. For example:------ @---   Event {---     _eventInfo = \"Battle of Agincourt\"---     _eventDate = fromGregorianValid 1415 10 25---     _eventAttendees = IM.empty---         }--- @-data Event = Event -  {_eventInfo :: Text-  ,_eventDate :: Maybe PartialDate-  ,_eventAttendees :: IntSet-  } deriving (Eq, Show)--makeLenses ''Event- -- | The core structure of a family tree. data FamilyTree = FamilyTree   {_treeName :: Text   ,_people :: IntMap Person   ,_families :: IntMap Family-  ,_events :: IntMap Event   } deriving (Eq, Show)    makeLenses ''FamilyTree@@ -230,18 +201,6 @@     _children = (IS.union `on` _children) f1 f2     } -instance Monoid Event where-  mempty = Event {-    _eventInfo = T.empty,-    _eventDate = Nothing,-    _eventAttendees = IS.empty-    }-  e1 `mappend` e2 = Event {-    _eventInfo = (T.append `on` _eventInfo) e1 e2,-    _eventDate = getFirst $ (mappend `on` First . _eventDate) e1 e2,-    _eventAttendees = (IS.union `on` _eventAttendees) e1 e2-    }- instance Binary Location where   put (Coord x y) = do     put (0 :: Word8)@@ -331,87 +290,45 @@       ,_children = c       }       -instance Binary Event where-  put evnt = do-    put . encodeUtf8 $ _eventInfo evnt-    put $ toModifiedJulianDay . I.inf <$> _eventDate evnt-    put $ toModifiedJulianDay . I.sup <$> _eventDate evnt-    put $ _eventAttendees evnt-  get = do-    n <- get-    di <- get-    ds <- get-    a <- get-    return Event-      {_eventInfo = decodeUtf8 n-      ,_eventDate = I.I <$> fmap ModifiedJulianDay di <*> fmap ModifiedJulianDay ds-      ,_eventAttendees = a-      }- instance Binary FamilyTree where   put tree = do     put $ encodeUtf8 $ _treeName tree     put $ _people tree     put $ _families tree-    put $ _events tree   get = do     n <- get     p <- get     f <- get-    e <- get     return FamilyTree       {_treeName = decodeUtf8 n       ,_people = p       ,_families = f-      ,_events = e       } --- | Constructs a 'Traversal' for the manipulation of a person in a family tree, from--- that person's ID. -traversePerson :: PersonID -> IndexedTraversal' PersonID FamilyTree Person-traversePerson (PersonID n) f familyTree = case familyTree ^. people . at n of-  Nothing -> pure familyTree-  Just oldPerson -> -    let newPerson_ = indexed f (PersonID n) oldPerson-        newEvents_ = flip (IS.difference `on` _attendedEvents) oldPerson-          <$> newPerson_-        oldEvents_ =      (IS.difference `on` _attendedEvents) oldPerson-          <$> newPerson_-    in alterPerson <$> newPerson_ <*> newEvents_ <*> oldEvents_-  where-    alterPerson newPerson =-      IS.foldr (\i -> events . ix i . eventAttendees %~ IS.delete n) .-      IS.foldr (\i -> events . ix i . eventAttendees %~ IS.insert n) (-      people . ix n .~ newPerson $ familyTree)+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 --- | Constructs a 'Traversal' for the manipulation of a family in a family tree, from--- that family's ID.-traverseFamily :: FamilyID -> IndexedTraversal' FamilyID FamilyTree Family-traverseFamily (FamilyID n) f familyTree = case familyTree ^. families . at n of-  Nothing -> pure familyTree-  Just oldFamily -> let newFamily_ = indexed f (FamilyID n) oldFamily-                    in alterFamily <$> newFamily_-  where-    alterFamily newFamily =-      familyTree & families . ix n .~ newFamily+instance FamilyTreePart Person where+  type ID Person = PersonID+  accessFT (PersonID n) f familyTree = case familyTree ^. people . at n of+    Nothing -> pure familyTree+    Just oldPerson ->+      let newPerson_ = indexed f (PersonID n) oldPerson+      in alterPerson <$> newPerson_+    where+      alterPerson newPerson = people . ix n .~ newPerson $ familyTree --- | Constructs a 'Traversal' for the manipulation of an event in a family tree, from--- that event's ID.      -traverseEvent :: EventID -> IndexedTraversal' EventID FamilyTree Event-traverseEvent (EventID n) f familyTree = case familyTree ^. events . at n of+instance FamilyTreePart Family where+  type ID Family = FamilyID+  accessFT (FamilyID n) f familyTree = case familyTree ^. families . at n of     Nothing -> pure familyTree-    Just oldEvent ->-      let newEvent_  = indexed f (EventID n) oldEvent-          oldPeople_ =      (IS.difference `on` _eventAttendees) oldEvent-            <$> newEvent_-          newPeople_ = flip (IS.difference `on` _eventAttendees) oldEvent-             <$> newEvent_-      in alterEvent <$> newEvent_ <*> newPeople_ <*> oldPeople_-  where-    alterEvent newEvent =-      IS.foldr (\i -> people . ix i . attendedEvents %~ IS.delete n) .-      IS.foldr (\i -> people . ix i . attendedEvents %~ IS.insert n) (-      events . ix n .~ newEvent $ familyTree)+    Just oldFamily -> let newFamily_ = indexed f (FamilyID n) oldFamily+                      in alterFamily <$> newFamily_+    where+      alterFamily newFamily =+        familyTree & families . ix n .~ newFamily  -- | Adds a person with minimal information, returning the updated family tree -- and the ID of the new person.  @@ -433,16 +350,6 @@           zip [1 ..] $ IM.keys $ _families familyTree   in (FamilyID n, families . at n ?~ mempty $ familyTree) --- | Adds an event with minimal information, returning the updated family tree--- and the ID of the new event.-addEvent :: FamilyTree -> (EventID, FamilyTree)-addEvent familyTree =-  let n = maybe 0 fst $-          listToMaybe $-          dropWhile (uncurry (==)) $-          zip [1 ..] $ IM.keys $ _events familyTree-  in (EventID n, events . at n ?~ mempty $ familyTree)- -- | Deletes a person from the family tree, removing all references to them.   deletePerson :: PersonID -> FamilyTree -> FamilyTree deletePerson (PersonID n) familyTree =@@ -453,31 +360,18 @@             head1 %~ (id & ix (Just $ PersonID n) .~ Nothing) &             head2 %~ (id & ix (Just $ PersonID n) .~ Nothing) &             children . contains n .~ False-            ) &-  events %~ IM.map (eventAttendees . 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 --- | Deletes an event from the family tree, removing all references to it.-deleteEvent :: EventID -> FamilyTree -> FamilyTree-deleteEvent (EventID n) familyTree =-  let relevantPeople = _eventAttendees (_events familyTree IM.! n)-  in familyTree-       {_events = IM.delete n $ _events familyTree-       ,_people = IS.foldr (IM.adjust-         (\p -> p {_attendedEvents = IS.delete n $ _attendedEvents p}))-         (_people familyTree) relevantPeople-       }           - -- | Creates a new tree with a given name.        newTree :: Text -> FamilyTree newTree n = FamilyTree   {_treeName = n   ,_people = IM.empty   ,_families = IM.empty-  ,_events = IM.empty   }