family-tree 0.1 → 0.1.1

raw patch · 3 files changed

+105/−58 lines, 3 filesdep −bytestringdep ~binarydep ~containersdep ~data-lensPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: bytestring

Dependency ranges changed: binary, containers, data-lens, text, time, unordered-containers

API changes (from Hackage documentation)

Files

• LICENSE +22/−5
• family-tree.cabal +9/−10
• src/Data/FamilyTree.hs +74/−43

@@ -1,7 +1,24 @@-Copyright (c) 2012 Nathan "Taneb" van Doorn--Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the Software), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:+Copyright (c) 2012, Nathan "Taneb" van Doorn+All rights reserved. -The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.+Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:+    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.+    * Redistributions in binary form must reproduce the above copyright+      notice, this list of conditions and the following disclaimer in the+      documentation and/or other materials provided with the distribution.+    * Neither the name of the <organization> nor the+      names of its contributors may be used to endorse or promote products+      derived from this software without specific prior written permission. -THE SOFTWARE IS PROVIDED AS IS, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL NATHAN "TANEB" VAN DOORN BE LIABLE FOR ANY+DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -1,5 +1,5 @@ name:           family-tree-version:        0.1+version:        0.1.1 cabal-version:  >= 1.2 build-type:     Simple author:         Nathan "Taneb" van Doorn@@ -12,20 +12,19 @@                 It also includes appropriate lenses! category:       Genealogy, Data copyright:      (c) 2012 Nathan "Taneb" van Doorn-license:        OtherLicense-license-file:  LICENSE+license:        BSD3+license-file:   LICENSE  library   hs-source-dirs:  src   build-depends:                       base >= 4 && < 5,-                   text,-                   containers,-                   unordered-containers,-                   bytestring,-                   time,-                   data-lens,-                   binary+                   text < 0.12,+                   containers >= 0.4.2 && < 0.6,+                   unordered-containers < 0.3,+                   time < 2,+                   data-lens < 3,+                   binary < 0.6   ghc-options:     -Wall   exposed-modules: Data.FamilyTree 

@@ -1,9 +1,4 @@ {- |-Module      :  $Header$-Description :  Family trees with lenses-Copyright   :  (c) 2012 Nathan "Taneb" van Doorn-License     :  MIT License- Maintainer  :  nvd124@gmail.com Stability   :  unstable Portability :  portable@@ -14,24 +9,44 @@  Better description coming soon! -}-module Data.FamilyTree where+module Data.FamilyTree+ (Person(..)+ ,Family(..)+ ,Event(..)+ ,Location(..)+ ,Relationship(..)+ ,FamilyTree(..)+ ,ID+ ,newTree+ ,personLens+ ,familyLens+ ,eventLens+ ,addPerson+ ,addFamily+ ,addEvent+ ,deletePerson+ ,deleteFamily+ ,deleteEvent+) where +import Control.Applicative import Control.Arrow import Control.Monad  import Data.Binary import Data.Function-import Data.HashMap.Lazy (HashMap)-import qualified Data.HashMap.Lazy as HM+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HM import Data.Lens.Common+import Data.Maybe import Data.IntMap (IntMap) import qualified Data.IntMap as IM import Data.IntSet (IntSet) import qualified Data.IntSet as IS import Data.Text (Text)-import qualified Data.Text as T +import qualified Data.Text as T import Data.Text.Encoding-import Data.Time+import Data.Time (Day(..))  data Person = Person   {name :: Maybe Text@@ -84,7 +99,7 @@         x <- get         y <- get         return $ Coord x y-      1 -> fmap (PlaceName . decodeUtf8) get+      _ -> PlaceName . decodeUtf8 <$> get  instance Binary Relationship where   put (Other t) = do@@ -94,15 +109,15 @@   get = do     tag <- getWord8     case tag of-      0 -> fmap (Other . decodeUtf8) get-      1 -> return Marriage+      0 -> Other . decodeUtf8 <$> get+      _ -> return Marriage  instance Binary Person where   put person = do-    put (fmap encodeUtf8 $ name person)-    put (fmap toModifiedJulianDay $ birthdate person)+    put (encodeUtf8 <$> name person)+    put (toModifiedJulianDay <$> birthdate person)     put (birthplace person)-    put (fmap toModifiedJulianDay $ deathdate person)+    put (toModifiedJulianDay <$> deathdate person)     put (deathplace person)     put (map (join (***) encodeUtf8) . HM.toList $ attributes person)     put (attendedEvents person)@@ -129,8 +144,8 @@     put $ head1 fam     put $ head2 fam     put $ relationship fam-    put $ fmap toModifiedJulianDay $ relationFrom fam-    put $ fmap toModifiedJulianDay $ relationTo fam+    put $ toModifiedJulianDay <$> relationFrom fam+    put $ toModifiedJulianDay <$> relationTo fam     put $ children fam   get = do     h1 <- get@@ -151,7 +166,7 @@ instance Binary Event where   put evnt = do     put . encodeUtf8 $ eventInfo evnt-    put $ fmap toModifiedJulianDay $ eventDate evnt+    put $ toModifiedJulianDay <$> eventDate evnt     put $ eventAttendees evnt   get = do     n <- get@@ -181,8 +196,10 @@       ,events = e       } -personLens :: Int -> Lens FamilyTree Person-personLens n = lens ((IM.! n) . people) $+newtype ID = ID Int++personLens :: ID -> Lens FamilyTree Person+personLens (ID n) = lens ((IM.! n) . people) $   \person familyTree ->     let oldPerson = people familyTree IM.! n         newattended = (IS.difference `on` attendedEvents)@@ -200,15 +217,15 @@           (events familyTree) newattended) oldattended       }       -familyLens :: Int -> Lens FamilyTree Family-familyLens n = lens ((IM.! n) . families) $+familyLens :: ID -> Lens FamilyTree Family+familyLens (ID n) = lens ((IM.! n) . families) $   \family' familyTree ->     familyTree       {families = IM.insert n family' (families familyTree)       }       -eventLens :: Int -> Lens FamilyTree Event-eventLens n = lens ((IM.! n) . events) $+eventLens :: ID -> Lens FamilyTree Event+eventLens (ID n) = lens ((IM.! n) . events) $   \event familyTree ->     familyTree       {events = IM.insert n event (events familyTree)@@ -258,28 +275,34 @@   ,eventAttendees = IS.empty   }   -addPerson :: FamilyTree -> (FamilyTree, Int)+addPerson :: FamilyTree -> (FamilyTree, ID) addPerson familyTree =-  let ((n,_):_) = dropWhile (uncurry (==)) $-                    zip [1..] $ IM.keys $ people familyTree+  let n = maybe 0 fst $+          listToMaybe $+          dropWhile (uncurry (==)) $+          zip [1 ..] $ IM.keys $ people familyTree   in (familyTree-       {people = IM.insert n blankPerson $ people familyTree}, n)+       {people = IM.insert n blankPerson $ people familyTree}, ID n)   -addFamily :: FamilyTree -> (FamilyTree, Int)+addFamily :: FamilyTree -> (FamilyTree, ID) addFamily familyTree =-  let ((n,_):_) = dropWhile (uncurry (==)) $-                    zip [1..] $ IM.keys $ families familyTree+  let n = maybe 0 fst $+          listToMaybe $+          dropWhile (uncurry (==)) $+          zip [1 ..] $ IM.keys $ families familyTree   in (familyTree -       {families = IM.insert n blankFamily $ families familyTree}, n)+       {families = IM.insert n blankFamily $ families familyTree}, ID n) -addEvent :: FamilyTree -> (FamilyTree, Int)+addEvent :: FamilyTree -> (FamilyTree, ID) addEvent familyTree =-  let ((n,_):_) = dropWhile (uncurry (==)) $-                    zip [1..] $ IM.keys $ events familyTree-  in (familyTree {events = IM.insert n blankEvent $ events familyTree}, n)+  let n = maybe 0 fst $+          listToMaybe $+          dropWhile (uncurry (==)) $+          zip [1 ..] $ IM.keys $ events familyTree+  in (familyTree {events = IM.insert n blankEvent $ events familyTree}, ID n)   -deletePerson :: Int -> FamilyTree -> FamilyTree-deletePerson n familyTree =+deletePerson :: ID -> FamilyTree -> FamilyTree+deletePerson (ID n) familyTree =   familyTree      {people = IM.delete n $ people familyTree     ,families = IM.map@@ -297,13 +320,13 @@       (events familyTree)     }     -deleteFamily :: Int -> FamilyTree -> FamilyTree-deleteFamily n familyTree =+deleteFamily :: ID -> FamilyTree -> FamilyTree+deleteFamily (ID n) familyTree =   familyTree     {families = IM.delete n $ families familyTree} -deleteEvent :: Int -> FamilyTree -> FamilyTree-deleteEvent n familyTree =+deleteEvent :: ID -> FamilyTree -> FamilyTree+deleteEvent (ID n) familyTree =   let relevantPeople = eventAttendees (events familyTree IM.! n)   in familyTree        {events = IM.delete n $ events familyTree@@ -311,3 +334,11 @@          (\p -> p {attendedEvents = IS.delete n $ attendedEvents p}))          (people familyTree) relevantPeople        }           +       +newTree :: Text -> FamilyTree+newTree n = FamilyTree+  {treeName = n+  ,people = IM.empty+  ,families = IM.empty+  ,events = IM.empty+  }