gedcom (empty) → 0.1.0.0
raw patch · 14 files changed
+2619/−0 lines, 14 filesdep +arraydep +basedep +bytestringsetup-changed
Dependencies added: array, base, bytestring, containers, gedcom, megaparsec, monad-loops, mtl, text-all, time
Files
- LICENSE +30/−0
- README.md +6/−0
- Setup.hs +2/−0
- changelog.md +3/−0
- gedcom.cabal +52/−0
- src/Data/Gedcom.hs +102/−0
- src/Data/Gedcom/Common.hs +131/−0
- src/Data/Gedcom/Internal/Common.hs +132/−0
- src/Data/Gedcom/LineParser.hs +147/−0
- src/Data/Gedcom/ParseMonads.hs +120/−0
- src/Data/Gedcom/Parser.hs +1123/−0
- src/Data/Gedcom/Structure.hs +643/−0
- src/Data/Text/Encoding/ANSEL.hs +126/−0
- test/Spec.hs +2/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Callum Lowcay (c) 2017++All rights reserved.++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 Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++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 THE COPYRIGHT+OWNER OR CONTRIBUTORS 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.
+ README.md view
@@ -0,0 +1,6 @@+# gedcom++A parser for the GEDCOM genealogy file format. More information on+[https://en.wikipedia.org/wiki/GEDCOM](Wikipedia). The full specification is+[https://www.familysearch.org/developers/docs/gedcom/](here).+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ changelog.md view
@@ -0,0 +1,3 @@+0.1.0.0+ * Initial release+
+ gedcom.cabal view
@@ -0,0 +1,52 @@+name: gedcom+version: 0.1.0.0+synopsis: Parser for the GEDCOM genealogy file format.+description: A parser for the legacy GEDCOM 5.5 file format. GEDCOM is+ widely used by genealogy software, despite the limitations+ of the format.+homepage: https://github.com/CLowcay/hs-gedcom+license: BSD3+license-file: LICENSE+author: Callum Lowcay+maintainer: cwslowcay@gmail.com+copyright: 2017 Callum Lowcay+category: Genealogy+build-type: Simple+extra-source-files: README.md changelog.md+cabal-version: >=1.10++library+ hs-source-dirs: src+ ghc-options: -Wall+ exposed-modules: Data.Gedcom+ , Data.Text.Encoding.ANSEL+ other-modules: Data.Gedcom.Common+ , Data.Gedcom.Internal.Common+ , Data.Gedcom.LineParser+ , Data.Gedcom.ParseMonads+ , Data.Gedcom.Parser+ , Data.Gedcom.Structure+ build-depends: base >= 4.7 && < 5+ , array >= 0.5.1.1 && < 0.6+ , bytestring >= 0.10.8.1 && < 0.11+ , containers >= 0.5.7.1 && < 0.6+ , megaparsec >= 5.3.1 && < 5.4+ , monad-loops >= 0.4.3 && < 4.4+ , mtl >= 2.2.1 && < 2.3+ , text-all >= 0.4.1.1 && < 0.5+ , time >= 1.6.0.1 && < 1.7+ default-language: Haskell2010++test-suite gedcom-test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ build-depends: base+ , gedcom+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/CLowcay/hs-gedcom+
+ src/Data/Gedcom.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-|+Module: Data.Gedcom+Description: Parser for the GEDCOM genealogy format+Copyright: (c) Callum Lowcay, 2017+License: BSD3+Maintainer: cwslowcay@gmail.com+Stability: experimental+Portability: GHC+-}+module Data.Gedcom (+ -- * Functions+ parseGedcomString,+ parseGedcomFile,+ GDError (..),+ gdLookup,+ GDRef, XRefTable,+ GDRefError (..), GDXRefID,+ module Data.Gedcom.Structure+) where++import Control.Applicative+import Data.Dynamic+import Data.Either+import Data.Gedcom.Common+import Data.Gedcom.LineParser+import Data.Gedcom.ParseMonads+import Data.Gedcom.Parser+import Data.Gedcom.Structure+import Data.Maybe+import Data.Monoid+import Data.Text.Encoding.ANSEL+import qualified Data.ByteString as B+import qualified Data.Map as M+import qualified Data.Text.All as T+import Text.Megaparsec++-- | A table of cross references+newtype XRefTable = XRefTable (M.Map GDXRefID Dynamic) deriving Show++-- | Lookup up a reference in the cross reference table+gdLookup :: forall a. Typeable a+ => GDRef a -- ^ The reference to look up+ -> XRefTable -- ^ The table to look up in+ -> Either GDRefError a -- ^ The value or an error+gdLookup (GDStructure x) _ = Right x+gdLookup (GDXRef thisID) (XRefTable table) =+ case M.lookup thisID table of+ Nothing -> Left$ RefNotPresent thisID+ Just (dynamic) -> case fromDynamic dynamic of+ Nothing -> Left$+ WrongRefType (dynTypeRep dynamic) (typeRep (Proxy :: Proxy a))+ Just v -> Right v++-- | Parse Gedcom data from a ByteString+parseGedcomString ::+ Maybe String -- ^ The filename from which the string was read+ -> B.ByteString -- ^ The string to parse+ -> Either GDError (Gedcom, XRefTable) -- ^ The Gedcom data and cross reference table, or an error+parseGedcomString mfilename intext =+ let+ filename = fromMaybe "<<NO FILE>>" mfilename+ anselTree = runParser gdRoot filename . decodeANSEL$ intext+ utf8Tree = runParser gdRoot filename . T.decodeUtf8$ intext+ utf16LETree = runParser gdRoot filename . T.decodeUtf16LE$ intext+ utf16BETree = runParser gdRoot filename . T.decodeUtf16BE$ intext+ encodings = [anselTree, utf8Tree, utf16LETree, utf16BETree]+ charset = foldr (<|>) Nothing . fmap getCharset$ encodings+ trees = case charset of+ Nothing -> []+ Just (Charset "ANSEL" _) -> [anselTree]+ Just (Charset "UTF-8" _) -> [utf8Tree]+ Just (Charset "UNICODE" _) -> [utf8Tree, utf16LETree, utf16BETree]+ Just (Charset "ASCII" _) -> [utf8Tree, anselTree]+ Just (Charset _ _) -> [anselTree, utf8Tree]++ in case partitionEithers trees of+ ([], []) -> Left . LineFormatError$+ "Invalid format (is " <> (T.show filename) <> " really a gedcom file?)"+ (err:_, []) -> Left . LineFormatError . T.show$ err+ (_, dtrees) -> case partitionEithers.fmap doParseGedcom$ dtrees of+ ([], []) -> Left . LineFormatError$ "Unknown character encoding"+ (err:_, []) -> Left err+ (_, (gd, table):_) -> Right (gd, XRefTable table)+ where+ doParseGedcom tree = case parseGedcom tree of+ (Left err, _) -> Left err+ (Right v, table) -> Right (v, table)+ getCharset (Right (GDRoot (headTree:_))) =+ case runStructure$ parseHeader headTree of+ (Right (Right header), _) -> Just$ headerCharset header+ _ -> Nothing+ getCharset _ = Nothing++-- | Parse Gedcom data from a file+parseGedcomFile ::+ FilePath -- ^ The file to read+ -> IO (Either GDError (Gedcom, XRefTable)) -- ^ The Gedcom data and cross reference table, or an error+parseGedcomFile path = parseGedcomString (Just path) <$> B.readFile path+
+ src/Data/Gedcom/Common.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}++{-|+Module: Data.Gedcom.Common+Description: Common utility functions for parsing GEDCOM+Copyright: (c) Callum Lowcay, 2017+License: BSD3+Maintainer: cwslowcay@gmail.com+Stability: experimental+Portability: GHC+-}+module Data.Gedcom.Common (+ GDRefError (..),+ GDError (..),+ GDRef (..),+ GDRoot (..),+ GDTree (..),+ GDLine (..),+ GDLineValue (..),+ GDLineItem (..),+ GDEscape (..),+ GDXRefID (..),+ GDTag (..),+ GDLevel (..),++ gdLineData,+ gdTrimLineItem,+ gdIgnoreEscapes,+ gdFilterEscapes+) where++import Control.Arrow+import Data.Char+import Data.List+import Data.Monoid+import Data.Typeable+import qualified Data.Text.All as T++-- | An error arising from dereferencing a 'GDRef'+data GDRefError =+ RefNotPresent GDXRefID -- ^ The referred structure doesn't exist.+ | WrongRefType TypeRep TypeRep -- ^ Dereferenced structure had the wrong type++instance Show GDRefError where+ show (RefNotPresent thisID) = "Missing referenced structure " ++ (show thisID)+ show (WrongRefType got expected) = "Referenced value has wrong type, expected "+ ++ (show expected) ++ " but saw " ++ (show got)++-- | A parse error.+data GDError =+ LineFormatError T.Text -- ^ A badly formatted GEDCOM line+ | UnexpectedRef T.Text -- ^ A reference where a reference wasn't allowed+ | RequiredRef T.Text -- ^ Missing a reference where a reference was required+ | DuplicateRef T.Text -- ^ Two targets for the same reference+ | FormatError T.Text -- ^ A badly formatted field+ | TagError T.Text -- ^ The wrong tag+ deriving Show++-- | A reference to another structure+data GDRef a =+ GDStructure a -- ^ Already dereferenced.+ | GDXRef GDXRefID -- ^ The 'GDXRefID' to look up+ deriving Show++-- | A raw GEDCOM syntax tree+data GDRoot = GDRoot [GDTree] deriving Show++-- | A GEDCOM subtree+data GDTree = GDTree GDLine [GDTree] deriving Show++-- | A GEDCOM line+data GDLine = GDLine GDLevel (Maybe GDXRefID) GDTag (Maybe GDLineValue)+ deriving Show++-- | The value field+data GDLineValue =+ GDLineItemV GDLineItem | GDXRefIDV GDXRefID deriving (Show, Eq)++-- | Line text+newtype GDLineItem = GDLineItem [(Maybe GDEscape, T.Text)] deriving (Show, Eq)++-- | An escape sequence+newtype GDEscape = GDEscape T.Text deriving (Show, Eq)++-- | A cross reference ID+newtype GDXRefID = GDXRefID T.Text deriving (Show, Eq, Ord)++-- | The tag field+newtype GDTag = GDTag T.Text deriving (Show, Eq, Ord)++-- | The level field+newtype GDLevel = GDLevel Int deriving (Show, Eq, Ord, Num)++-- | Extract the line text+gdLineData :: GDLineItem -> [(Maybe GDEscape, T.Text)]+gdLineData (GDLineItem v) = v++instance Monoid GDLineItem where+ mempty = GDLineItem []+ mappend (GDLineItem l1) (GDLineItem l2) =+ GDLineItem . fmap coalease . groupBy canCoalease$ l1 <> l2+ where+ coalease [] = (Nothing, "") + coalease (l:ls) = foldl' (\(_, t1) (e, t2) -> (e, t1 <> t2)) l ls+ canCoalease (Nothing, _) (_, _) = True+ canCoalease _ _ = False++-- | Trim white space off the start an end of a GEDCOM line text.+gdTrimLineItem :: GDLineItem -> GDLineItem+gdTrimLineItem (GDLineItem []) = GDLineItem []+gdTrimLineItem (GDLineItem ((e, t):rst)) =+ let+ rst' = reverse$ case reverse rst of+ [] -> []+ ((e', t'):rst'') -> (e', T.dropWhile isSpace t'):rst''+ in GDLineItem$ (e, T.dropWhile isSpace t):rst'++-- | Ignore escape sequences+gdIgnoreEscapes :: [(Maybe GDEscape, T.Text)] -> T.Text+gdIgnoreEscapes = T.concat . fmap snd++-- | Ignore certain escape sequences+gdFilterEscapes ::+ [GDEscape] -> [(Maybe GDEscape, T.Text)] -> [(Maybe GDEscape, T.Text)]+gdFilterEscapes escapes =+ gdLineData . mconcat . fmap GDLineItem . fmap (:[]) . fmap (first f)+ where+ f (Just e) = if e `elem` escapes then Just e else Nothing+ f Nothing = Nothing+
+ src/Data/Gedcom/Internal/Common.hs view
@@ -0,0 +1,132 @@+{-|+Module: Data.Gedcom.Internal.Common+Description: Common utility functions for parsing+Copyright: (c) Callum Lowcay, 2017+License: BSD3+Maintainer: cwslowcay@gmail.com+Stability: experimental+Portability: GHC+-}+module Data.Gedcom.Internal.Common+ ((<&>), withDefault, trim, Parser, timeToPicos, timeValue,+ dateExact, month, monthFr, monthHeb, yearGreg+ )+where++import Control.Applicative+import Data.Char+import Data.Maybe+import Data.Time.Clock+import qualified Data.Text.All as T+import Text.Megaparsec++-- | Parsers from 'T.Text' using the default error component.+type Parser = Parsec Dec T.Text++infixl 1 <&>++-- | Flipped version of '<$>'+(<&>) :: Functor f => f a -> (a -> b) -> f b+as <&> f = f <$> as+{-# INLINE (<&>) #-}++-- | Replace failure with a default value+withDefault :: Alternative f => a -> f a -> f a+withDefault def = fmap (fromMaybe def).optional+{-# INLINE withDefault #-}++-- | Trim leading and trailing whitespace off a string+trim :: T.Text -> T.Text+trim = T.dropWhile isSpace . T.dropWhileEnd isSpace++-- | Convert h:m:s.fs time to 'DiffTime'+timeToPicos :: (Int, Int, Int, Double) -> DiffTime+timeToPicos (h, m, s, fs) =+ picosecondsToDiffTime$+ (fromIntegral h * hm)+ + (fromIntegral m * mm)+ + (fromIntegral s * sm)+ + (round$ fs * (fromIntegral sm))+ where+ hm = mm * 60+ mm = sm * 60+ sm = 1000000000++-- | Parse a GEDCOM exact time value into (h, m, s, fs) format+timeValue :: Parser (Maybe (Int, Int, Int, Double))+timeValue = optional$ (,,,)+ <$> (read <$> count' 1 2 digitChar)+ <*> (char ':' *> (read <$> count' 1 2 digitChar))+ <*> withDefault 0 (char ':' *> (read <$> count' 1 2 digitChar))+ <*> withDefault 0 (char '.' *> (read.("0." ++) <$> count' 1 3 digitChar))++-- | Parse a GEDCOM exact date into (day, month, year). Months are number from+-- 1 to 12.+dateExact :: Parser (Int, Word, Int)+dateExact = (,,)+ <$> (read <$> count' 1 2 digitChar)+ <*> (space *> month)+ <*> (space *> yearGreg)++-- | Parse a Gregorian/Julian month+month :: Parser Word+month =+ (string' "JAN" *> pure 1) <|>+ (string' "FEB" *> pure 2) <|>+ (string' "MAR" *> pure 3) <|>+ (string' "APR" *> pure 4) <|>+ (string' "MAY" *> pure 5) <|>+ (string' "JUN" *> pure 6) <|>+ (string' "JUL" *> pure 7) <|>+ (string' "AUG" *> pure 8) <|>+ (string' "SEP" *> pure 9) <|>+ (string' "OCT" *> pure 10) <|>+ (string' "NOV" *> pure 11) <|>+ (string' "DEC" *> pure 12)++-- | Parse a French calendar month+monthFr :: Parser Word+monthFr =+ (string' "VEND" *> pure 1) <|>+ (string' "BRUM" *> pure 2) <|>+ (string' "FRIM" *> pure 3) <|>+ (string' "NIVO" *> pure 4) <|>+ (string' "PLUV" *> pure 5) <|>+ (string' "VENT" *> pure 6) <|>+ (string' "GERM" *> pure 7) <|>+ (string' "FLOR" *> pure 8) <|>+ (string' "PRAI" *> pure 9) <|>+ (string' "MESS" *> pure 10) <|>+ (string' "THER" *> pure 11) <|>+ (string' "FRUC" *> pure 12) <|>+ (string' "COMP" *> pure 13)++-- | Parse a Hebrew calendar month+monthHeb :: Parser Word+monthHeb =+ (string' "TSH" *> pure 1) <|>+ (string' "CSH" *> pure 2) <|>+ (string' "KSL" *> pure 3) <|>+ (string' "TVT" *> pure 4) <|>+ (string' "SHV" *> pure 5) <|>+ (string' "ADR" *> pure 6) <|>+ (string' "ADS" *> pure 7) <|>+ (string' "NSN" *> pure 8) <|>+ (string' "IYR" *> pure 9) <|>+ (string' "SVN" *> pure 10) <|>+ (string' "TMZ" *> pure 11) <|>+ (string' "AAV" *> pure 12) <|>+ (string' "ELL" *> pure 13)++-- | Parse a Gregorian year. GEDCOM allows one to specify two versions of the+-- same year for cases where the historical year started in March instead of+-- January. This function attempts to return the modern year number (assuming+-- the year starts in January.+yearGreg :: Parser Int+yearGreg = do+ y <- read <$> count' 1 4 digitChar+ malt <- optional$ char '/' *> (read <$> count 2 digitChar)+ case malt of+ Just alt -> return$ if (y + 1) `mod` 100 == alt then y + 1 else y+ Nothing -> return y+
+ src/Data/Gedcom/LineParser.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++{-|+Module: Data.Gedcom.LineParser+Description: Low-level GEDCOM parser+Copyright: (c) Callum Lowcay, 2017+License: BSD3+Maintainer: cwslowcay@gmail.com+Stability: experimental+Portability: GHC++This module parses a Text string into a GEDCOM syntax tree.++-}+module Data.Gedcom.LineParser (+ gdRoot, gdDelim+) where++import Control.Monad+import Data.Char+import Data.Gedcom.Common+import Data.Gedcom.Internal.Common+import Data.Maybe+import Data.Monoid+import qualified Data.Text.All as T+import Text.Megaparsec++-- | Parse any_char.+gdAnyChar :: Parser String+gdAnyChar = (fmap (:[]) gdNonAt) <|> string "@@"++-- | Parse non_at.+gdNonAt :: Parser Char+gdNonAt = satisfy (\c -> (not.isControl) c && c /= '@' && c /= '\x7F')++-- | Parse alphanum.+gdAlphaNum :: Parser Char+gdAlphaNum = alphaNumChar <|> char '_'++-- | Parse delim.+gdDelim :: Parser (Maybe Char)+gdDelim = optional$ char '\x20'++-- | Parse escape.+gdEscape :: Parser GDEscape+gdEscape = GDEscape . T.pack <$>+ (string "@#" *> gdEscapeText <* char '@' <* (optional$ char ' '))++-- | Parse escape_text.+gdEscapeText :: Parser String+gdEscapeText = concat <$> many gdAnyChar++-- | Parse level.+gdLevel :: Parser GDLevel+gdLevel = GDLevel . read <$> count' 1 2 digitChar <* gdDelim++-- | Parse line_item.+gdLineItem :: Parser GDLineItem+gdLineItem = fmap GDLineItem . some$+ (,) <$> optional gdEscape <*> (T.pack . concat <$> some gdAnyChar)++-- | Parse pointer.+gdPointer :: Parser GDXRefID+gdPointer = char '@' *> plabel <* char '@'+ where plabel = fmap (GDXRefID . T.pack)$+ (:) <$> gdAlphaNum <*> (many gdNonAt)++-- | Parse line_value+gdLineValue :: Parser GDLineValue+gdLineValue = eitherP gdPointer gdLineItem <&> \x -> case x of+ Left v -> GDXRefIDV v+ Right v -> GDLineItemV v++-- | Parse optional_line_value.+gdOptionalLineValue :: Parser GDLineValue+gdOptionalLineValue = gdDelim *> gdLineValue++-- | Parse optional_xref_ID.+gdOptionalXRefID :: Parser (Maybe GDXRefID)+gdOptionalXRefID = gdXRefID <* gdDelim++-- | Parse tag.+gdTag :: Parser GDTag+gdTag = GDTag . T.toUpper . T.pack <$> many gdAlphaNum++-- | parse terminator.+gdTerminator :: Parser String+gdTerminator = string "\n" <|> string "\r" <|> string "\r\n" <|> string "\n\r"++-- | Parse xref_ID.+gdXRefID :: Parser (Maybe GDXRefID)+gdXRefID = optional $ fmap (\(GDXRefID t) -> GDXRefID t) gdPointer++-- | Parse gedcom_line.+gdLine :: Parser GDLine+gdLine = GDLine <$>+ gdLevel <*>+ gdOptionalXRefID <*>+ gdTag <*>+ (optional gdOptionalLineValue) <* gdTerminator++-- | Convert local ids to global ids.+gdExpandID ::+ GDXRefID -- ^ The parent structure's ID+ -> GDXRefID -- ^ The local ID.+ -> GDXRefID -- ^ A global ID.+gdExpandID (GDXRefID pid) s@(GDXRefID sub) =+ case T.uncons sub of+ Nothing -> s+ Just ('!', _) -> GDXRefID$ pid <> sub+ _ -> s++-- | Convert local ids to global ids.+gdExpandPointer ::+ GDXRefID -- ^ The parent structure's ID.+ -> GDLineValue -- ^ The line to update.+ -> GDLineValue -- ^ An updated line where local ID's have been made global.+gdExpandPointer pid v = case v of+ GDLineItemV _ -> v+ GDXRefIDV p -> GDXRefIDV$ gdExpandID pid p++-- | Parse a line at a fixed level+gdLineLevel ::+ GDXRefID -- ^ The parent ID + -> GDLevel -- ^ The level to parse the line at+ -> Parser GDLine+gdLineLevel pid n = do+ (GDLine n' xrid tag v) <- gdLine+ when (n' /= n)$ fail$ "Saw a " ++ (show tag) +++ " tag at level " ++ (show n') +++ " but expected level was " ++ (show n)+ return$ GDLine n' (fmap (gdExpandID pid) xrid) tag (fmap (gdExpandPointer pid) v)++-- | Parse a GEDCOM subtree+gdTree ::+ GDXRefID -- ^ The parent ID+ -> GDLevel -- ^ The level where the subtree is rooted+ -> Parser GDTree+gdTree pid n = try$ do+ line@(GDLine _ pid' _ _) <- gdLineLevel pid n+ GDTree line <$> many (gdTree (fromMaybe pid pid') (n + 1))++-- | Parse the raw GEDCOM syntax tree.+gdRoot :: Parser GDRoot+gdRoot = GDRoot <$> (many$ gdTree (GDXRefID "") 0)+
+ src/Data/Gedcom/ParseMonads.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}++{-|+Module: Data.Gedcom.ParseMonads+Description: Monads for parsing GEDCOM records+Copyright: (c) Callum Lowcay, 2017+License: BSD3+Maintainer: cwslowcay@gmail.com+Stability: experimental+Portability: GHC++This module contains monads and utility functions for extracting GEDCOM records+from the raw syntax tree.++-}+module Data.Gedcom.ParseMonads (+ StructureParser,+ MultiMonad,+ runMultiMonad,+ parseMulti,+ parseOptional,+ parseRequired,+ StructureMonad,+ addReference,+ runStructure+) where++import Control.Monad+import Control.Monad.Except+import Control.Monad.State+import Data.Dynamic+import Data.Either+import Data.Foldable+import Data.Gedcom.Common+import Data.Maybe+import Data.Monoid+import qualified Data.Map as M+import qualified Data.Text.All as T++-- | A parser that extracts a GEDCOM structure from a GEDCOM subtree.+type StructureParser a =+ GDTree -- ^ The subtree to parse.+ -> StructureMonad (Either GDTree a) -- ^ Either parsed structure, or the subtree itself if the subtree doesn't contain the expected GEDCOM structure.++-- | A Monad for parsing GEDCOM structures out of a list of GEDCOM subtrees.+newtype MultiMonad a =+ MultiMonad (ExceptT GDError (StateT [GDTree] StructureMonad) a)+ deriving (Monad, Functor, Applicative, MonadError GDError)++-- | Run a 'MultiMonad' into a 'StructureMonad'.+runMultiMonad ::+ [GDTree] -- ^ The subtrees to parse the structure from.+ -> MultiMonad a -- ^ The MultiMonad that does the parsing.+ -> StructureMonad a+runMultiMonad children (MultiMonad m) =+ ((flip evalStateT) children.runExceptT$ m) >>= rethrowError+ where rethrowError x = case x of+ Left e -> throwError e+ Right v -> return v++-- | Parse multiple instances of a structure+parseMulti :: StructureParser a -> MultiMonad [a]+parseMulti p = MultiMonad$ do+ ls <- lift$ get+ (others, vs) <- lift$ lift$ partitionEithers <$> p `traverse` ls+ lift$ put others+ return vs++-- | Parse an optional instance of a structure+parseOptional :: StructureParser a -> MultiMonad (Maybe a)+parseOptional p = MultiMonad$ do+ ls <- lift$ get+ (mr, leftover) <-+ lift$ lift$ foldrM (\v (r, rest) ->+ if isJust r then return (r, v:rest)+ else pick v rest.toMaybe <$> p v) (Nothing, []) ls+ lift$ put leftover+ return mr+ where+ toMaybe (Left _) = Nothing+ toMaybe (Right v) = Just v+ pick v rest Nothing = (Nothing, v:rest)+ pick _ rest x = (x, rest)++-- | Parse a required instance of a structure+parseRequired ::+ GDTag -- ^ The tag that identifies the required structure.+ -> StructureParser a+ -> MultiMonad a+parseRequired tag p = do+ r <- parseOptional p+ case r of+ Just v -> return v+ Nothing -> throwError.TagError$+ "Could not find required " <> (T.show tag) <> " tag"++-- | A monad for parsing an instance of a GEDCOM structure from a GEDCOM+-- subtree.+newtype StructureMonad a =+ StructureMonad (ExceptT GDError (State (M.Map GDXRefID Dynamic)) a)+ deriving (Monad, Functor, Applicative, MonadError GDError)++-- | Add a reference to the cross reference table.+addReference :: Typeable a+ => GDXRefID -- ^ The cross reference to add.+ -> a -- ^ The value the reference will resolve to.+ -> StructureMonad ()+addReference thisID value = StructureMonad$ do+ alreadySeen <- M.member thisID <$> lift get+ when alreadySeen$+ throwError.DuplicateRef$ "Duplicate definition of " <> (T.show thisID)+ lift.modify$ M.insert thisID (toDyn value)+ return ()++-- | Run a 'StructureMonad', returning either an error or a value, and the+-- cross reference table.+runStructure :: StructureMonad a -> (Either GDError a, M.Map GDXRefID Dynamic)+runStructure (StructureMonad m) = (flip runState) M.empty . runExceptT$ m+
+ src/Data/Gedcom/Parser.hs view
@@ -0,0 +1,1123 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE TupleSections #-}++{-|+Module: Data.Gedcom.Parser+Description: GEDCOM high level parsers+Copyright: (c) Callum Lowcay, 2017+License: BSD3+Maintainer: cwslowcay@gmail.com+Stability: experimental+Portability: GHC++These parsers extract the GEDCOM records from the raw syntax tree.++-}+module Data.Gedcom.Parser (+ parseGedcom,+ parseHeader+) where++import Control.Applicative+import Control.Monad.Except+import Data.Bifunctor+import Data.Dynamic+import Data.Gedcom.Common+import Data.Gedcom.Internal.Common+import Data.Gedcom.LineParser+import Data.Gedcom.ParseMonads+import Data.Gedcom.Structure+import Data.Maybe+import Data.Monoid+import Data.Time.Calendar+import Data.Time.Clock+import qualified Data.Map.Lazy as M+import qualified Data.Text.All as T+import Text.Megaparsec++-- | Parse a 'Gedcom' value from the raw GEDCOM syntax tree.+parseGedcom :: GDRoot -> (Either GDError Gedcom, M.Map GDXRefID Dynamic)+parseGedcom (GDRoot children) =+ runStructure.runMultiMonad children$ Gedcom+ <$> parseRequired (GDTag "HEAD") parseHeader+ <*> parseMulti parseFamily+ <*> parseMulti (parseIndividual (GDTag "INDI"))+ <*> parseMulti parseMultimediaRecord+ <*> parseMulti parseNote+ <*> parseMulti parseRepository+ <*> parseMulti parseSource+ <*> parseMulti (parseSubmitter (GDTag "SUBM"))++-- | Parse a 'Header'.+parseHeader :: StructureParser Header+parseHeader = parseNoLinkTag (GDTag "HEAD")$ \(_, children) ->+ runMultiMonad children$ Header+ <$> parseRequired (GDTag "SOUR") parseHeaderSource+ <*> parseOptional (parseTextTag (GDTag "DEST"))+ <*> parseOptional parseExactDateTime+ <*> parseRequired (GDTag "SUBM") (parseSubmitter (GDTag "SUBM"))+ <*> parseOptional parseSubmission+ <*> parseOptional parseFile+ <*> parseOptional parseCopyright+ <*> parseRequired (GDTag "GEDC") parseGedcomFormat+ <*> parseRequired (GDTag "CHAR") parseCharset+ <*> parseOptional parseLanguage+ <*> parseOptional parsePlaceForm+ <*> parseOptional (parseTextTag (GDTag "NOTE"))++-- | Parse a 'HeaderSource'.+parseHeaderSource :: StructureParser HeaderSource+parseHeaderSource = parseNoLinkTag (GDTag "SOUR")$ \(sid, children) ->+ runMultiMonad children$ HeaderSource (gdIgnoreEscapes sid)+ <$> parseOptional parseVersion+ <*> parseOptional parseName+ <*> parseOptional parseCorp+ <*> parseOptional parseHeaderSourceData++-- | Parse a 'Corp'.+parseCorp :: StructureParser Corp+parseCorp = parseNoLinkTag (GDTag "COPR")$ \(name, children) ->+ runMultiMonad children$ Corp (gdIgnoreEscapes name)+ <$> (parseContactDetails >>= (parseOptional.parseAddress))++-- | Parse a 'HeaderSourceData'.+parseHeaderSourceData :: StructureParser HeaderSourceData+parseHeaderSourceData = parseNoLinkTag (GDTag "DATA")$ \(name, children) ->+ runMultiMonad children$ HeaderSourceData (gdIgnoreEscapes name)+ <$> parseOptional parseExactDate+ <*> parseOptional parseCopyright++-- | Parse a 'Family'.+parseFamily :: StructureParser (GDRef Family)+parseFamily = parseTag (GDTag "FAM")$ \(_, children) ->+ runMultiMonad children$ Family+ <$> parseOptional parseRestrictionNotice+ <*> parseFamilyEvent+ <*> parseOptional (parseIndividual (GDTag "HUSB"))+ <*> parseOptional (parseIndividual (GDTag "WIFE"))+ <*> parseMulti (parseIndividual (GDTag "CHIL"))+ <*> parseOptional (parseWordTag (GDTag "NCHI"))+ <*> parseMulti (parseSubmitter (GDTag "SUBM"))+ <*> parseMulti parseUserReference+ <*> parseOptional parseRIN+ <*> parseOptional parseChangeDate+ <*> parseMulti parseNote+ <*> parseMulti parseSourceCitation+ <*> parseMulti parseMultimedia++-- | Parse an 'Individual'.+parseIndividual :: GDTag -> StructureParser (GDRef Individual)+parseIndividual tag = parseTag tag$ \(_, children) ->+ runMultiMonad children$ Individual+ <$> parseOptional parseRestrictionNotice+ <*> parseOptional parsePersonalName+ <*> parseOptional parseSex+ <*> parseIndividualEvent+ <*> parseIndividualAttribute+ <*> parseMulti parseChildToFamilyLink+ <*> parseMulti parseSpouseToFamilyLink+ <*> parseMulti (parseSubmitter (GDTag "SUBM"))+ <*> parseMulti parseAssociation+ <*> parseMulti (parseIndividual (GDTag "ALIA"))+ <*> parseMulti (parseSubmitter (GDTag "ANCI"))+ <*> parseMulti (parseSubmitter (GDTag "DECI"))+ <*> parseOptional parseRFN+ <*> parseOptional parseAFN+ <*> parseMulti parseUserReference+ <*> parseOptional parseRIN+ <*> parseOptional parseChangeDate+ <*> parseMulti parseNote+ <*> parseMulti parseSourceCitation+ <*> parseMulti parseMultimedia++-- | Parse a 'Node'.+parseNote :: StructureParser (GDRef Note)+parseNote = parseTag (GDTag "NOTE")$ \(t, children) ->+ runMultiMonad children$ Note (gdIgnoreEscapes t)+ <$> parseMulti parseUserReference+ <*> parseOptional parseRIN+ <*> parseMulti parseSourceCitation+ <*> parseOptional parseChangeDate++-- | Parse a 'Repository'.+parseRepository :: StructureParser (GDRef Repository)+parseRepository = parseTag (GDTag "REPO")$ \(_, children) ->+ runMultiMonad children$ Repository+ <$> parseRequired (GDTag "NAME") parseName+ <*> (parseContactDetails >>= (parseOptional.parseAddress))+ <*> parseMulti parseNote+ <*> parseMulti parseUserReference+ <*> parseOptional parseRIN+ <*> parseOptional parseChangeDate++-- | Parse a 'Source'.+parseSource :: StructureParser (GDRef Source)+parseSource = parseTag (GDTag "SOUR")$ \(_, children) ->+ runMultiMonad children$ Source+ <$> parseOptional parseSourceData+ <*> parseOptional (parseTextTag (GDTag "AUTH"))+ <*> parseOptional (parseTextTag (GDTag "TITL"))+ <*> parseOptional (parseTextTag (GDTag "ABBR"))+ <*> parseOptional (parseTextTag (GDTag "PUBL"))+ <*> parseOptional (parseTextTag (GDTag "TEXT"))+ <*> parseMulti parseRepositoryCitation+ <*> parseMulti parseUserReference+ <*> parseOptional parseRIN+ <*> parseOptional parseChangeDate+ <*> parseMulti parseNote+ <*> parseMulti parseMultimedia++-- | Parse a 'Submitter'.+parseSubmitter :: GDTag -> StructureParser (GDRef Submitter)+parseSubmitter tag = parseTag tag$ \(_, children) ->+ runMultiMonad children$ Submitter+ <$> parseRequired (GDTag "NAME")+ ((fmap.fmap.fmap) getPersonalName parseName)+ <*> (parseContactDetails >>= (parseOptional.parseAddress))+ <*> parseOptional parseMultimedia+ <*> parseMulti parseLanguage+ <*> parseOptional parseRFN+ <*> parseOptional parseRIN+ <*> parseMulti parseNote+ <*> parseOptional parseChangeDate++-- | Parse a 'Submission'.+parseSubmission :: StructureParser (GDRef Submission)+parseSubmission = parseTag (GDTag "SUBN")$ \(_, children) ->+ runMultiMonad children$ Submission+ <$> parseOptional (parseSubmitter (GDTag "SUBM"))+ <*> parseOptional (parseTextTag (GDTag "FAMF"))+ <*> parseOptional (parseTextTag (GDTag "TEMP"))+ <*> parseOptional (parseWordTag (GDTag "ANCE"))+ <*> parseOptional (parseWordTag (GDTag "DESC"))+ <*> parseOptional (parseBoolTag (GDTag "ORDI"))+ <*> parseOptional parseRIN+ <*> parseMulti parseNote+ <*> parseOptional parseChangeDate++-- | Parse a 'RestrictionNotice'.+parseRestrictionNotice :: StructureParser RestrictionNotice+parseRestrictionNotice = parseNoLinkTag (GDTag "RESN")$ \(t, _) ->+ case parseMaybe parser (gdIgnoreEscapes t) of+ Nothing -> throwError.FormatError$+ "Bad restriction notice " <> (T.show t)+ Just r -> return r+ where parser :: Parser RestrictionNotice+ parser = (Confidential <$ string' "confidential")+ <|> (Locked <$ string' "locked")+ <|> (Privacy <$ string' "privacy")++-- | Parse a list of 'FamilyEvent's.+parseFamilyEvent :: MultiMonad [FamilyEvent]+parseFamilyEvent = do+ concat <$> mapM (parseMulti.familyEventTag) [+ (GDTag "ANUL", const Annuled),+ (GDTag "CENS", const FamCensus),+ (GDTag "DIV", const Divorce),+ (GDTag "DIVF", const DivorceFiled),+ (GDTag "ENGA", const Engagement),+ (GDTag "MARB", const MarriageBann),+ (GDTag "MARC", const MarriageContract),+ (GDTag "MARR", const Marriage),+ (GDTag "MARL", const MarriageLicense),+ (GDTag "MARS", const MarriageSettlement),+ (GDTag "RESI", const Residence),+ (GDTag "EVEN", FamilyEventType)]+ where+ familyEventTag (tag, mkType) = parseNoLinkTag tag$ \(t, children) ->+ runMultiMonad children$ FamilyEvent (mkType$ gdIgnoreEscapes t)+ <$> parseFamilyEventDetail++-- | Parse a 'FamiltyEventDetail'.+parseFamilyEventDetail :: MultiMonad FamilyEventDetail+parseFamilyEventDetail = FamilyEventDetail+ <$> parseOptional (parseAge (GDTag "HUSB"))+ <*> parseOptional (parseAge (GDTag "WIFE"))+ <*> parseEventDetail++-- | Parse an 'EventDetail'.+parseEventDetail :: MultiMonad EventDetail+parseEventDetail = EventDetail+ <$> parseOptional (parseTextTag (GDTag "TYPE"))+ <*> parseOptional parseDateValue+ <*> parseOptional parsePlace+ <*> (parseContactDetails >>= (parseOptional.parseAddress))+ <*> parseOptional (parseTextTag (GDTag "AGNC"))+ <*> parseOptional (parseTextTag (GDTag "RELI"))+ <*> parseOptional (parseTextTag (GDTag "CAUS"))+ <*> parseOptional parseRestrictionNotice+ <*> parseMulti parseNote+ <*> parseMulti parseSourceCitation+ <*> parseMulti parseMultimedia++-- | Parse an AGE tag.+parseAge :: GDTag -> StructureParser Word+parseAge tag = parseNoLinkTag tag$ \(_, children) ->+ runMultiMonad children$+ parseRequired (GDTag "AGE") (parseWordTag (GDTag "AGE"))++-- | Parse a 'SourceData'.+parseSourceData :: StructureParser SourceData+parseSourceData = parseNoLinkTag (GDTag "DATA")$ \(_, children) ->+ runMultiMonad children$ SourceData+ <$> parseMulti parseSourceRecordedEvent+ <*> parseOptional (parseTextTag (GDTag "AGNC"))+ <*> parseMulti parseNote++-- | Parse a 'Place'.+parsePlace :: StructureParser Place+parsePlace = parseNoLinkTag (GDTag "PLAC")$ \(t, children) ->+ runMultiMonad children$ Place+ <$> (pure$ T.splitOn "," . gdIgnoreEscapes$ t)+ <*> parseOptional (parseListTag (GDTag "FORM"))+ <*> parseOptional parsePhoneticPlaceName+ <*> parseOptional parseRomanPlaceName+ <*> parseOptional parseMapCoord+ <*> parseMulti parseNote++-- | Parse a 'PhoneticPlaceName'.+parsePhoneticPlaceName :: StructureParser PhoneticPlaceName+parsePhoneticPlaceName = parseNoLinkTag (GDTag "FONE")$ \(t, children) ->+ runMultiMonad children$ PhoneticPlaceName+ <$> parseRequired (GDTag "TYPE") parsePhoneticType+ <*> (pure . T.splitOn "," . gdIgnoreEscapes$ t)++-- | Parse a 'RomanPlaceName'.+parseRomanPlaceName :: StructureParser RomanPlaceName+parseRomanPlaceName = parseNoLinkTag (GDTag "ROMN")$ \(t, children) ->+ runMultiMonad children$ RomanPlaceName+ <$> parseRequired (GDTag "TYPE") parseRomanType+ <*> (pure . T.splitOn "," . gdIgnoreEscapes$ t)++-- | Parse a 'PhoneticType'.+parsePhoneticType :: StructureParser PhoneticType+parsePhoneticType = parseNoLinkTag (GDTag "TYPE")$ \(t, _) ->+ return$ case trim . T.toUpper . gdIgnoreEscapes$ t of+ "HANGUL" -> Hangul+ "KANA" -> Kana+ v -> PhoneticType v++-- | Parse a 'RomanType'.+parseRomanType :: StructureParser RomanType+parseRomanType = parseNoLinkTag (GDTag "TYPE")$ \(t, _) ->+ return$ case trim . T.toUpper . gdIgnoreEscapes$ t of+ "PINYIN" -> Pinyin+ "ROMAJI" -> Romaji+ "WADEGILES" -> WadeGiles+ v -> RomanType v++-- | Parse a 'MapCoord'.+parseMapCoord :: StructureParser MapCoord+parseMapCoord = parseNoLinkTag (GDTag "MAP")$ \(_, children) ->+ runMultiMonad children$ MapCoord+ <$> parseRequired (GDTag "LATI") ((fmap.fmap.fmap) Longitude$+ parseLongLat (GDTag "LATI") 'N' 'S')+ <*> parseRequired (GDTag "LONG") ((fmap.fmap.fmap) Latitude$+ parseLongLat (GDTag "LONG") 'E' 'W')++-- | Parse a 'Longitude' or 'Latitude' value.+parseLongLat ::+ GDTag -- ^ The tag to parse+ -> Char -- ^ The single character prefix that indicates a positive value. + -> Char -- ^ The single character prefix that indicates a negative value.+ -> StructureParser Double+parseLongLat tag p n = parseNoLinkTag tag$ \(t, _) ->+ case T.uncons . T.toUpper . gdIgnoreEscapes$ t of+ Nothing -> throwError.FormatError$+ "Badly formatted longitude/latitude " <> (T.show t)+ Just (i, r) ->+ if i == p then return$ read . T.unpack$ r+ else if i == n then return$ negate . read . T.unpack$ r+ else throwError.FormatError$+ "Badly formatted longitude/latitude" <> (T.show t)++-- | Parse a 'PersonalName'.+parsePersonalName :: StructureParser PersonalName+parsePersonalName = parseNoLinkTag (GDTag "NAME")$ \(n, children) ->+ runMultiMonad children$ PersonalName+ <$> (pure.getPersonalName.gdIgnoreEscapes$ n)+ <*> parseOptional parseNameType+ <*> parseNamePieces+ <*> parseMulti parsePhoneticName+ <*> parseMulti parseRomanName+ +-- | Extract a 'Name' from a string.+getPersonalName :: T.Text -> Name+getPersonalName = Name <$> reformat <*> (getMiddle . T.splitOn "/")+ where+ reformat = T.unwords . T.words . T.map (\c -> if c == '/' then ' ' else c)+ getMiddle [_, m, _] = Just$ trim m+ getMiddle _ = Nothing++-- | Parse a 'NameType'.+parseNameType :: StructureParser NameType+parseNameType = parseNoLinkTag (GDTag "TYPE")$ \(t', _) ->+ let t = gdIgnoreEscapes t'+ in return . fromMaybe (NameType t) . parseMaybe parser $ t+ where parser :: Parser NameType+ parser = (AKA <$ string' "aka")+ <|> (BirthName <$ string' "birth")+ <|> (Immigrant <$ string' "immigrant")+ <|> (Maiden <$ string' "maiden")+ <|> (Married <$ string' "married")++-- | Parse a 'PersonalNamePieces' structure.+parseNamePieces :: MultiMonad PersonalNamePieces+parseNamePieces = PersonalNamePieces+ <$> (fromMaybe [] <$> parseOptional (parseListTag (GDTag "NPFX")))+ <*> (fromMaybe [] <$> parseOptional (parseListTag (GDTag "GIVN")))+ <*> (fromMaybe [] <$> parseOptional (parseListTag (GDTag "NICK")))+ <*> (fromMaybe [] <$> parseOptional (parseListTag (GDTag "SPFX")))+ <*> (fromMaybe [] <$> parseOptional (parseListTag (GDTag "SURN")))+ <*> (fromMaybe [] <$> parseOptional (parseListTag (GDTag "NSFX")))+ <*> parseMulti parseNote+ <*> parseMulti parseSourceCitation++-- | Parse a 'PhoneticName'.+parsePhoneticName :: StructureParser PhoneticName+parsePhoneticName = parseNoLinkTag (GDTag "FONE")$ \(t, children) ->+ runMultiMonad children$ PhoneticName+ <$> (pure.getPersonalName.gdIgnoreEscapes$ t)+ <*> parseRequired (GDTag "TYPE") parsePhoneticType+ <*> parseNamePieces++-- | Parse a 'RomanizedName'.+parseRomanName :: StructureParser RomanizedName+parseRomanName = parseNoLinkTag (GDTag "FONE")$ \(t, children) ->+ runMultiMonad children$ RomanizedName+ <$> (pure.getPersonalName.gdIgnoreEscapes$ t)+ <*> parseRequired (GDTag "TYPE") parseRomanType+ <*> parseNamePieces++-- | Parse a 'Sex'.+parseSex :: StructureParser Sex+parseSex = parseNoLinkTag (GDTag "SEX")$ \(t, _) ->+ case trim . T.toUpper . gdIgnoreEscapes $ t of+ "M" -> return Male+ "F" -> return Female+ "U" -> return Undetermined+ _ -> throwError.FormatError$ "Unknown sex code " <> (T.show t)+ +-- | Parse a list of 'IndividualAttribute's.+parseIndividualAttribute :: MultiMonad [IndividualAttribute]+parseIndividualAttribute = do+ concat <$> mapM (parseMulti.attributeTag) [+ (GDTag "CAST", Caste),+ (GDTag "DSCR", PhysicalDescription),+ (GDTag "EDUC", Education),+ (GDTag "IPNO", NationalID),+ (GDTag "NATI", NationalOrigin),+ (GDTag "NCHI", NChildren . read . T.unpack),+ (GDTag "NMR", NMarriages . read . T.unpack),+ (GDTag "OCCU", Occupation),+ (GDTag "PROP", Possessions),+ (GDTag "RELI", Religion),+ (GDTag "RESI", const ResidesAt),+ (GDTag "SSN", SocialSecurity),+ (GDTag "TITL", Title),+ (GDTag "FACT", Fact)]+ where+ attributeTag (tag, mkType) = parseNoLinkTag tag$ \(t, children) ->+ runMultiMonad children$ IndividualAttribute (mkType$ gdIgnoreEscapes t)+ <$> parseIndividualEventDetail++-- | Parse a list of 'IndividualEvent's+parseIndividualEvent :: MultiMonad [IndividualEvent]+parseIndividualEvent = do+ famc <- concat <$> mapM (parseMulti.famcTag)+ [(GDTag "BIRT", Birth), (GDTag "CHR", Christening)]+ adop <- parseMulti.parseNoLinkTag (GDTag "ADOP")$ \(_, children) ->+ runMultiMonad children$ IndividualEvent+ <$> (Adoption <$> parseOptional parseAdopFamilyRef)+ <*> parseIndividualEventDetail+ simple <- concat <$> mapM (parseMulti.eventTag) [+ (GDTag "DEAT", const Death),+ (GDTag "BURI", const Burial),+ (GDTag "CREM", const Cremation),+ (GDTag "BAPM", const Baptism),+ (GDTag "BARM", const BarMitzvah),+ (GDTag "BASM", const BasMitzvah),+ (GDTag "BLES", const Blessing),+ (GDTag "CHRA", const ChristeningAdult),+ (GDTag "CONF", const Confirmation),+ (GDTag "FCOM", const FirstCommunion),+ (GDTag "ORDN", const Ordination),+ (GDTag "NATU", const Naturalization),+ (GDTag "EMIG", const Emigration),+ (GDTag "IMMI", const Immigration),+ (GDTag "CENS", const IndvCensus),+ (GDTag "PROB", const Probate),+ (GDTag "WILL", const Will),+ (GDTag "GRAD", const Graduation),+ (GDTag "RETI", const Retirement),+ (GDTag "EVEN", IndividualEventType)]+ return$ famc ++ adop ++ simple+ where+ eventTag (tag, mkType) = parseNoLinkTag tag$ \(t, children) ->+ runMultiMonad children$ IndividualEvent (mkType$ gdIgnoreEscapes t)+ <$> parseIndividualEventDetail+ famcTag (tag, mkType) = parseNoLinkTag tag$ \(_, children) ->+ runMultiMonad children$ IndividualEvent+ <$> (mkType <$> parseOptional parseFamilyRef)+ <*> parseIndividualEventDetail+ parseFamilyRef = parseLinkTag (GDTag "FAMC") + parseAdopFamilyRef = parseTagFull (GDTag "FAMC") nullrref$ \(lb, children) ->+ case lb of+ Right _ -> throwError.RequiredRef$ "Missing link in FAMC"+ Left f -> runMultiMonad children$+ AdoptionDetail f <$> parseOptional parseParent+ parseParent = parseNoLinkTag (GDTag "ADOP")$ \(t, _) ->+ case trim . T.toUpper . gdIgnoreEscapes $ t of+ "HUSB" -> return Husband+ "WIFE" -> return Wife+ "BOTH" -> return BothParents+ _ -> throwError.FormatError$ "Invalid parent " <> (T.show t)++-- | Parse an 'IndividualEventDetail'.+parseIndividualEventDetail :: MultiMonad IndividualEventDetail+parseIndividualEventDetail = IndividualEventDetail+ <$> parseEventDetail+ <*> parseOptional (parseWordTag (GDTag "AGE"))++-- | Parse a 'ChildToFamilyLink'.+parseChildToFamilyLink :: StructureParser ChildToFamilyLink+parseChildToFamilyLink = parseTagFull (GDTag "FAMC") nullrref$ \(lb, children) ->+ case lb of+ Right _ -> throwError.RequiredRef$ "Missing link in FAMC"+ Left f -> runMultiMonad children$ ChildToFamilyLink f+ <$> parseOptional parsePedigree+ <*> parseOptional parseChildLinkStatus+ <*> parseMulti parseNote++-- | Parse a 'Pedigree'.+parsePedigree :: StructureParser Pedigree+parsePedigree = parseNoLinkTag (GDTag "PEDI")$ \(t, _) ->+ case trim . T.toUpper . gdIgnoreEscapes$ t of+ "ADOPTED" -> return Adopted+ "BIRTH" -> return ByBirth+ "FOSTER" -> return Foster+ "SEALING" -> return Sealing+ _ -> throwError.FormatError$ "Invalid pedigree code " <> (T.show t)++-- | Parse a 'ChildLinkStatus'.+parseChildLinkStatus :: StructureParser ChildLinkStatus+parseChildLinkStatus = parseNoLinkTag (GDTag "STAT")$ \(t, _) ->+ case trim . T.toUpper . gdIgnoreEscapes$ t of+ "CHALLENGED" -> return Challenged+ "DISPROVEN" -> return Disproved+ "PROVEN" -> return Proven+ _ -> throwError.FormatError$ "Invalid child link status " <> (T.show t)++-- | Parse a 'SpouseToFamilyLink'.+parseSpouseToFamilyLink :: StructureParser SpouseToFamilyLink+parseSpouseToFamilyLink = parseTagFull (GDTag "FAMS") nullrref$+ \(lb, children) ->+ case lb of+ Right _ -> throwError.RequiredRef$ "Missing link in FAMS"+ Left f -> runMultiMonad children$ SpouseToFamilyLink f+ <$> parseMulti parseNote++-- | Parse an 'Association'.+parseAssociation :: StructureParser Association+parseAssociation = parseTagFull (GDTag "ASSO") nullrref$ \(lb, children) ->+ case lb of+ Right _ -> throwError.RequiredRef$ "Missing link in ASSO"+ Left i -> runMultiMonad children$ Association i+ <$> parseRequired (GDTag "RELA") (parseTextTag (GDTag "RELA"))+ <*> parseMulti parseSourceCitation+ <*> parseMulti parseNote++-- | Parse a 'SourceRecordedEvent'.+parseSourceRecordedEvent :: StructureParser SourceRecordedEvent+parseSourceRecordedEvent = parseNoLinkTag (GDTag "EVEN")$+ \(recorded, children) ->+ runMultiMonad children$ SourceRecordedEvent+ <$> (pure . catMaybes . fmap getEventType+ . T.splitOn "," . gdIgnoreEscapes$ recorded)+ <*> parseOptional fullParseDatePeriod+ <*> parseOptional (parseListTag (GDTag "PLAC"))+ where+ fullParseDatePeriod = parseNoLinkTag (GDTag "DATE")$ \(date, _) ->+ case parseDatePeriod date of+ Just v -> return v+ Nothing -> throwError.FormatError$+ "Badly formatted date period: " <> (T.show date)++-- | Parse a 'RepositoryCitation'.+parseRepositoryCitation :: StructureParser RepositoryCitation+parseRepositoryCitation = parseTagFull (GDTag "REPO") nullrref$+ \(lb, children) ->+ let repo = case lb of+ Left v -> Just v+ Right _ -> Nothing+ in runMultiMonad children$ RepositoryCitation repo+ <$> parseMulti parseNote+ <*> parseOptional parseCallNumber++-- | Parse a 'CallNumber'.+parseCallNumber :: StructureParser CallNumber+parseCallNumber = parseNoLinkTag (GDTag "CALN")$ \(n, children) ->+ runMultiMonad children$ CallNumber (gdIgnoreEscapes n)+ <$> parseOptional (parseMultimediaType (GDTag "MEDI"))++-- | Parse a 'SourceCitation'.+parseSourceCitation :: StructureParser SourceCitation+parseSourceCitation = parseTagFull (GDTag "SOUR") nullrref$+ \(lb, children) ->+ case lb of+ Left source ->+ runMultiMonad children$ SourceCitation (Right source)+ <$> parseOptional (parseTextTag (GDTag "PAGE"))+ <*> parseMulti parseMultimedia+ <*> parseMulti parseNote+ <*> parseOptional parseQuality+ Right description ->+ runMultiMonad children$ SourceCitation+ <$> (Left . SourceDescription (gdIgnoreEscapes description)+ <$> parseMulti (parseTextTag (GDTag "TEXT")))+ <*> pure Nothing+ <*> parseMulti parseMultimedia+ <*> parseMulti parseNote+ <*> parseOptional parseQuality++-- | Parse a 'GedcomFormat'.+parseGedcomFormat :: StructureParser GedcomFormat+parseGedcomFormat = parseNoLinkTag (GDTag "GEDC")$ \(_, children) ->+ runMultiMonad children$ GedcomFormat+ <$> parseRequired (GDTag "VERS") parseVersion+ <*> parseRequired (GDTag "FORM") parseGedcomForm++-- | Parse a 'GedcomForm'.+parseGedcomForm :: StructureParser GedcomForm+parseGedcomForm = parseNoLinkTag (GDTag "FORM")$ \(t, _) ->+ return$ if (T.toUpper . gdIgnoreEscapes$ t) == "LINEAGE-LINKED"+ then GedcomLineageLinked+ else GedcomUnsupported (gdIgnoreEscapes t)++-- | Parse a 'Charset'.+parseCharset :: StructureParser Charset+parseCharset = parseNoLinkTag (GDTag "CHAR")$ \(cs, children) ->+ runMultiMonad children$ Charset (gdIgnoreEscapes cs)+ <$> parseOptional parseVersion++-- | Parse a 'ChangeDate'.+parseChangeDate :: StructureParser ChangeDate+parseChangeDate = parseNoLinkTag (GDTag "CHAN")$ \(_, children) ->+ runMultiMonad children$ ChangeDate+ <$> parseRequired (GDTag "DATE") parseExactDateTime+ <*> parseOptional parseNote++-- | Parse 'ContactDetails'.+parseContactDetails :: MultiMonad ContactDetails+parseContactDetails = ContactDetails+ <$> parseMulti (parseTextTag (GDTag "PHON"))+ <*> parseMulti (parseTextTag (GDTag "EMAIL"))+ <*> parseMulti (parseTextTag (GDTag "FAX"))+ <*> parseMulti (parseTextTag (GDTag "WWW"))++-- | Parse an 'Address'.+parseAddress :: ContactDetails -> StructureParser Address+parseAddress contacts = parseNoLinkTag (GDTag "ADDR")$ \(addr, children) ->+ runMultiMonad children$ Address (gdIgnoreEscapes addr)+ <$> parseOptional (parseTextTag (GDTag "CITY"))+ <*> parseOptional (parseTextTag (GDTag "STAE"))+ <*> parseOptional (parseTextTag (GDTag "POS"))+ <*> parseOptional (parseTextTag (GDTag "CTRY"))+ <*> pure contacts++-- | Parse a 'DateValue'.+parseDateValue :: StructureParser DateValue+parseDateValue = parseNoLinkTag (GDTag "DATE")$ \(t, _) ->+ let date = (DateApproxV <$> parseDateApprox t)+ <|> (DateRangeV <$> parseDateRange t)+ <|> (DatePeriodV <$> parseDatePeriod t)+ <|> (parseDatePhrase t)+ <|> (DateV <$> parseDate t)+ in case date of+ Just x -> return x+ Nothing -> throwError.FormatError$ "Invalid date format " <> (T.show t)++-- | Decode a calendar escape sequence to a 'Calendar'.+decodeCalendarEscape :: Maybe GDEscape -> Calendar+decodeCalendarEscape Nothing = Gregorian+decodeCalendarEscape (Just (GDEscape c)) = case T.toUpper c of+ "DGREGORIAN" -> Gregorian+ "DJULIAN" -> Julian+ "DHEBREW" -> Hebrew+ "DFRENCH" -> French+ "DROMAN" -> Julian+ "DUNKNOWN" -> Gregorian+ _ -> Gregorian++-- | Prepare text for parsing a 'DateValue'.+prepareDateText :: [(Maybe GDEscape, T.Text)] -> [(Maybe GDEscape, T.Text)]+prepareDateText = gdFilterEscapes [+ GDEscape "DGREGORIAN",+ GDEscape "DJULIAN",+ GDEscape "DHEBREW",+ GDEscape "DFRENCH",+ GDEscape "DROMAN",+ GDEscape "DUNKNOWN"]++-- | Attempt to extract a 'DatePeriod' from a string with escape sequences.+parseDatePeriod :: [(Maybe GDEscape, T.Text)] -> Maybe DatePeriod+parseDatePeriod t = case prepareDateText t of+ ((mCalendarEscape1, t1'):rest) ->+ let+ calendar1 = decodeCalendarEscape mCalendarEscape1+ t1 = trim$ T.toUpper t1'+ from = trim <$> T.stripPrefix "FROM" t1+ to = trim <$> T.stripPrefix "TO" t1+ in case to of+ Just r -> DateTo <$> getDate calendar1 r+ Nothing -> case from of+ Nothing -> Nothing+ Just r ->+ let topcs = T.splitOn "TO"$ r+ in case topcs of+ [mfdate, mto] -> DateFrom+ <$> getDate calendar1 (trim mfdate)+ <*> (pure$ getDate calendar1 (trim mto))+ [mfdate] -> case rest of+ [] -> DateFrom+ <$> getDate calendar1 (trim mfdate) <*> (pure Nothing)+ ((mCalendarEscape2, t2'):_) ->+ let+ calendar2 = decodeCalendarEscape mCalendarEscape2+ t2 = trim$ T.toUpper t2'+ to2 = trim <$> T.stripPrefix "TO" t2+ in case to2 of+ Nothing -> Nothing+ Just r2 -> DateFrom+ <$> getDate calendar1 (trim mfdate)+ <*> (pure$ getDate calendar2 (trim r2))+ _ -> Nothing+ _ -> Nothing++-- | Attempt to extract a 'DateRange' from a string with escape sequences.+parseDateRange :: [(Maybe GDEscape, T.Text)] -> Maybe DateRange+parseDateRange t = case prepareDateText t of+ ((mCalendarEscape1, t1):rest) ->+ let+ calendar1 = decodeCalendarEscape mCalendarEscape1+ (pref, date1) = second trim . T.splitAt 3 . T.toUpper . trim $ t1+ in case pref of+ "BEF" -> DateBefore <$> getDate calendar1 date1+ "AFT" -> DateAfter <$> getDate calendar1 date1+ "BET" -> case T.splitOn "AND" date1 of+ [d1, date2'] -> DateBetween+ <$> getDate calendar1 d1+ <*> getDate calendar1 (trim date2')+ [d1] -> case rest of+ [] -> Nothing+ ((mCalendarEscape2, t2):_) ->+ let calendar2 = decodeCalendarEscape mCalendarEscape2+ in DateBetween+ <$> getDate calendar1 d1+ <*> getDate calendar2 (trim t2)+ _ -> Nothing+ _ -> Nothing+ _ -> Nothing++-- | Attempt to extract a 'DateApprox' from a string with escape sequences.+parseDateApprox :: [(Maybe GDEscape, T.Text)] -> Maybe DateApprox+parseDateApprox t = case prepareDateText t of+ ((mCalendarEscape1, t1):_) ->+ let+ calendar1 = decodeCalendarEscape mCalendarEscape1+ (pref, date) = second trim . T.splitAt 3 . T.toUpper . trim $ t1+ cons = case pref of+ "ABT" -> Just DateAbout+ "CAL" -> Just DateCalculated+ "EST" -> Just DateEstimated+ _ -> Nothing+ in cons <*> getDate calendar1 date+ _ -> Nothing++-- | Attempt to extract a 'DatePhrase' from a string with escape sequences.+parseDatePhrase :: [(Maybe GDEscape, T.Text)] -> Maybe DateValue+parseDatePhrase t = case prepareDateText t of+ ((mCalendarEscape1, t1):_) ->+ let+ calendar1 = decodeCalendarEscape mCalendarEscape1+ int = trim <$> T.stripPrefix "INT" t1+ opp = trim <$> T.stripPrefix "(" t1+ in case int of+ Nothing -> case opp of+ Nothing -> Nothing+ Just phrase -> Just$+ DatePhrase Nothing (trim . T.dropEnd 1$ phrase)+ Just rest -> case trim <$> T.splitOn "(" rest of+ [date, phrase] -> Just$ + DatePhrase (getDate calendar1 date) (trim . T.dropEnd 1$ phrase)+ _ -> Nothing+ _ -> Nothing++-- | Attempt to extract a 'Date' from a string with escape sequences.+parseDate :: [(Maybe GDEscape, T.Text)] -> Maybe Date+parseDate t = case prepareDateText t of+ ((mCalendarEscape, cal):rest) ->+ let calendar = decodeCalendarEscape mCalendarEscape+ in getDate calendar (cal <> gdIgnoreEscapes rest)+ _ -> Nothing++-- | Parse a 'Date' from a given string assuming the given 'Calendar'.+getDate :: Calendar -> T.Text -> Maybe Date+getDate calendar = parseMaybe parser+ where+ yearParser = case calendar of+ Gregorian -> yearGreg+ _ -> read <$> count' 1 4 digitChar+ parseYear = (\y bc -> Year$ if bc then (0 - y) else y)+ <$> yearParser <*> ((True <$ string' "B.C.") <|> pure False)+ parser :: Parser Date+ parser =+ (try$ Date calendar+ <$> (Just . read <$> count' 1 2 digitChar)+ <*> (gdDelim >> (Just <$> parseMonth))+ <*> (gdDelim >> parseYear))+ <|> (try$ Date calendar Nothing+ <$> (gdDelim >> (Just <$> parseMonth))+ <*> (gdDelim >> parseYear))+ <|> (Date calendar Nothing Nothing+ <$> (gdDelim >> parseYear))+ parseMonth = case calendar of+ Gregorian -> month+ Julian -> month+ Hebrew -> monthHeb+ French -> monthFr+ +-- | Parse an exact date.+parseExactDate :: StructureParser UTCTime+parseExactDate = parseNoLinkTag (GDTag "DATE")$ \(date, _) ->+ case parseMaybe dateExact (gdIgnoreEscapes date) of+ Nothing -> throwError.FormatError$ "Bad date \"" <> (T.show date) <> "\""+ Just (d, m, y) ->+ return$ UTCTime+ (fromGregorian (fromIntegral y) (fromIntegral m) d)+ (secondsToDiffTime 0)++-- | Parse an exact date and time.+parseExactDateTime :: StructureParser UTCTime+parseExactDateTime = parseNoLinkTag (GDTag "DATE")$ \(date, children) -> do+ mtime <- runMultiMonad children$ parseOptional (parseTextTag (GDTag "TIME"))++ dt <- case mtime of+ Nothing -> return$ secondsToDiffTime 0+ Just t -> case parseMaybe timeValue t of+ Nothing -> throwError.FormatError$ "Bad time \"" <> (T.show t) <> "\""+ Just Nothing -> return$ secondsToDiffTime 0+ Just (Just time) -> return$ timeToPicos time++ case parseMaybe dateExact (gdIgnoreEscapes date) of+ Nothing -> throwError.FormatError$ "Bad date \"" <> (T.show date) <> "\""+ Just (d, m, y) -> return$ UTCTime+ (fromGregorian (fromIntegral y) (fromIntegral m) d) dt++-- | Parse a 'Multimedia' record.+parseMultimediaRecord :: StructureParser (GDRef Multimedia)+parseMultimediaRecord = parseMultimediaRaw (GDTag "TYPE")++-- | Parse a 'Multimedia' link.+parseMultimedia :: StructureParser (GDRef Multimedia)+parseMultimedia = parseMultimediaRaw (GDTag "MEDI")++-- | Actual parser for 'Multimedia' values.+parseMultimediaRaw :: GDTag -> StructureParser (GDRef Multimedia)+parseMultimediaRaw typeTag = parseTag (GDTag "OBJE")$ \(_, children) ->+ runMultiMonad children$ Multimedia+ <$> ((parseOptional (parseMultimediaFormat typeTag)) >>=+ (parseMulti.(parseMultimediaFile typeTag)))+ <*> parseOptional (parseTextTag (GDTag "TITL"))+ <*> parseMulti parseUserReference+ <*> parseOptional parseRIN+ <*> parseMulti parseNote+ <*> parseMulti parseSourceCitation+ <*> parseOptional parseChangeDate++-- | Parse a 'MultimediaFile'.+parseMultimediaFile ::+ GDTag -> Maybe MultimediaFormat ->+ StructureParser MultimediaFile+parseMultimediaFile typeTag mf = parseNoLinkTag (GDTag "FILE")$+ \(name, children) -> do+ (mc, title) <- runMultiMonad children$ (,)+ <$> parseOptional (parseMultimediaFormat typeTag)+ <*> parseOptional (parseTextTag (GDTag "TITL"))+ case mc <|> mf of+ Nothing -> throwError.TagError$ "Missing FORM tag for file format"+ Just c -> return$ MultimediaFile (gdIgnoreEscapes name) c title++-- | Parse a 'MultimediaFormat'.+parseMultimediaFormat :: GDTag -> StructureParser MultimediaFormat+parseMultimediaFormat tag = parseNoLinkTag (GDTag "FORM")$ \(v', children) ->+ let v = gdIgnoreEscapes v'+ in runMultiMonad children$ MultimediaFormat+ (fromMaybe (MF_OTHER v)$ parseMaybe parser v)+ <$> parseOptional (parseMultimediaType tag)++ where+ parser :: Parser MultimediaFileFormat+ parser = (MF_BMP <$ string' "bmp")+ <|> (MF_GIF <$ string' "gif")+ <|> (MF_JPG <$ string' "jpg")+ <|> (MF_OLE <$ string' "ole")+ <|> (MF_PCX <$ string' "pcx")+ <|> (MF_TIF <$ string' "tif")+ <|> (MF_WAV <$ string' "wav")++-- | Parse a 'MultimediaType'.+parseMultimediaType :: GDTag -> StructureParser MultimediaType+parseMultimediaType tag = parseNoLinkTag tag$ \(v', _) ->+ let v = gdIgnoreEscapes v'+ in return.fromMaybe (MT_OTHER v)$ parseMaybe parser v+ where+ parser :: Parser MultimediaType+ parser = (MT_AUDIO <$ string' "audio")+ <|> (MT_BOOK <$ string' "book")+ <|> (MT_CARD <$ string' "card")+ <|> (MT_ELECTRONIC <$ string' "electronic")+ <|> (MT_FICHE <$ string' "fiche")+ <|> (MT_FILM <$ string' "film")+ <|> (MT_MAGAZINE <$ string' "magazine")+ <|> (MT_MANUSCRIPT <$ string' "manuscript")+ <|> (MT_MAP <$ string' "map")+ <|> (MT_NEWSPAPER <$ string' "newspaper")+ <|> (MT_PHOTO <$ string' "photo")+ <|> (MT_TOMBSTONE <$ string' "tombstone")+ <|> (MT_VIDEO <$ string' "video")++-- | Parse a 'FamilyEventType'.+getFamilyEventType :: T.Text -> Maybe FamilyEventType+getFamilyEventType = parseMaybe parser+ where+ parser :: Parser FamilyEventType+ parser = (Annuled <$ string' "ANUL")+ <|> (FamCensus <$ string' "CENS")+ <|> (Divorce <$ string' "DIV")+ <|> (DivorceFiled <$ string' "DIVF")+ <|> (Engagement <$ string' "ENGA")+ <|> (MarriageBann <$ string' "MARB")+ <|> (MarriageContract <$ string' "MARC")+ <|> (Marriage <$ string' "MARR")+ <|> (MarriageLicense <$ string' "MARL")+ <|> (MarriageSettlement <$ string' "MARS")+ <|> (Residence <$ string' "RESI")+ <|> (FamilyEventType . T.pack <$>+ (string' "EVEN" *> gdDelim *> many anyChar))++-- | Parse an 'IndividualEventType'.+getIndividualEventType :: T.Text -> Maybe IndividualEventType+getIndividualEventType = parseMaybe parser+ where+ parser :: Parser IndividualEventType+ parser = (Birth Nothing <$ (string' "BIRTH"+ *> optional (gdDelim >> string' "Y")))+ <|> (Christening Nothing <$ (string' "CHR"+ *> optional (gdDelim >> string' "Y")))+ <|> (Death <$ (string' "DEAT"+ *> optional (gdDelim >> string' "Y")))+ <|> (Burial <$ string' "BURI")+ <|> (Cremation <$ string' "CREM")+ <|> (Adoption Nothing <$ string' "ADOP")+ <|> (Baptism <$ string' "BAPM")+ <|> (BarMitzvah <$ string' "BARM")+ <|> (BasMitzvah <$ string' "BASM")+ <|> (Blessing <$ string' "BLES")+ <|> (ChristeningAdult <$ string' "CHRA")+ <|> (Confirmation <$ string' "CONF")+ <|> (FirstCommunion <$ string' "FCOM")+ <|> (Ordination <$ string' "ORDN")+ <|> (Naturalization <$ string' "NATU")+ <|> (Emigration <$ string' "EMIG")+ <|> (Immigration <$ string' "IMMI")+ <|> (IndvCensus <$ string' "CENS")+ <|> (Probate <$ string' "PROB")+ <|> (Will <$ string' "WILL")+ <|> (Graduation <$ string' "GRAD")+ <|> (Retirement <$ string' "RETI")+ <|> (IndividualEventType . T.pack <$>+ (string' "EVEN" *> gdDelim *> many anyChar))++-- | Parse an 'EventType'.+getEventType :: T.Text -> Maybe EventType+getEventType et =+ let+ t = trim$ T.toUpper et+ fam = getFamilyEventType et+ indv = getIndividualEventType et+ in+ if t == "CENS" then Just Census+ else if (T.take 4 t) == "EVEN" then+ Just . EventType . trim . T.drop 4$ et+ else fmap FamilyEventTypeV fam <|> fmap IndividualEventTypeV indv++-- | Parse a place form structure.+parsePlaceForm :: StructureParser [T.Text]+parsePlaceForm = parseNoLinkTag (GDTag "PLAC")$ \(_, children) ->+ runMultiMonad children$ fromMaybe [].(fmap$ T.splitOn ",") <$>+ parseOptional (parseTextTag (GDTag "FORM"))++-- | Parse a 'UserReference'.+parseUserReference :: StructureParser UserReference+parseUserReference = parseNoLinkTag (GDTag "REFN")$ \(i, children) ->+ runMultiMonad children$ UserReference (gdIgnoreEscapes i)+ <$> parseOptional (parseTextTag (GDTag "TYPE"))++-- | Parse a version structure.+parseVersion :: StructureParser T.Text+parseVersion = parseTextTag (GDTag "VERS")++-- | Parse a NAME tag.+parseName :: StructureParser T.Text+parseName = parseTextTag (GDTag "NAME")++-- | Parse a copyright tag.+parseCopyright :: StructureParser T.Text+parseCopyright = parseTextTag (GDTag "COPR")++-- | Parse a file name.+parseFile :: StructureParser FilePath+parseFile = (fmap.fmap.fmap) T.unpack$ parseTextTag (GDTag "FILE")++-- | Parse an 'AFN'.+parseAFN :: StructureParser AFN+parseAFN = (fmap.fmap.fmap) AFN$ parseTextTag (GDTag "AFN")++-- | Parse a 'RFN'.+parseRFN :: StructureParser RFN+parseRFN = (fmap.fmap.fmap) RFN$ parseTextTag (GDTag "RFN")++-- | Parse a 'RIN'.+parseRIN :: StructureParser RIN+parseRIN = (fmap.fmap.fmap) RIN$ parseTextTag (GDTag "RIN")++-- | Parse a 'Language'.+parseLanguage :: StructureParser Language+parseLanguage = (fmap.fmap.fmap) (Language) $ parseTextTag (GDTag "LANG")++-- | Parse a 'QualityAssessment'.+parseQuality :: StructureParser QualityAssessment+parseQuality = (fmap.fmap.fmap) QualityAssessment $ parseWordTag (GDTag "QUAY")++-- | Parse a boolean value.+parseBoolTag :: GDTag -> StructureParser Bool+parseBoolTag tag = parseNoLinkTag tag$ \(v, _) ->+ case parseMaybe ynParser (gdIgnoreEscapes v) of+ Nothing -> throwError.FormatError$ "Expected boolean, saw " <> (T.show v)+ Just yn -> return yn+ where+ ynParser :: Parser Bool+ ynParser = (True <$ string' "yes") <|> (False <$ string' "no")++-- | Parse a Word value.+parseWordTag :: GDTag -> StructureParser Word+parseWordTag tag = parseNoLinkTag tag$ \(v, _) ->+ case parseMaybe parser (gdIgnoreEscapes v) of+ Nothing -> throwError.FormatError$ "Expected number, saw " <> (T.show v)+ Just n -> return . read $ n+ where+ parser :: Parser String+ parser = many digitChar++-- | Extract the text from a tag.+parseTextTag :: GDTag -> StructureParser T.Text+parseTextTag tag = parseNoLinkTag tag (return.gdIgnoreEscapes.fst)++-- | Extract a list of comma separated values from a tag.+parseListTag :: GDTag -> StructureParser [T.Text]+parseListTag tag =+ parseNoLinkTag tag (return . T.splitOn "," . gdIgnoreEscapes . fst)++-- | Handler for tags that cannot contain cross references.+type NoLinkHandler a =+ ([(Maybe GDEscape, T.Text)], [GDTree]) -> StructureMonad a++-- | Handler for general tags.+type TagHandler b a =+ (Either (GDRef b) [(Maybe GDEscape, T.Text)], [GDTree])+ -> StructureMonad a++-- | A function that adds references to the cross reference table.+type RegisterRef a = GDTag -> GDXRefID -> a -> StructureMonad ()++-- | Don't add any references.+nullrref :: Typeable a => RegisterRef a+nullrref _ _ _ = return ()++-- | Add direct references only.+defrref :: Typeable a => RegisterRef (GDRef a)+defrref _ thisID (GDStructure a) = addReference thisID a+defrref tag _ _ = throwError.UnexpectedRef$+ "Referenced structure references another structure " <> (T.show tag)++-- | Parse a tag which is either a GEDCOM structure, or a reference to the+-- expected GEDCOM structure.+parseTag :: Typeable a+ => GDTag -- ^ The tag to parse.+ -> NoLinkHandler a -- ^ A handler for the tag+ -> StructureParser (GDRef a)+parseTag tag handler = parseTagFull tag defrref$ \(lb, children) ->+ case lb of+ Left ref -> return ref+ Right text -> GDStructure <$> handler (text, children)++-- | Parse a tag which cannot contain a cross reference (i.e. the tag must+-- contain the structure itself, not a reference to another structure).+parseNoLinkTag :: Typeable a+ => GDTag -- ^ The tag to parse.+ -> NoLinkHandler a -- ^ A handler for the tag.+ -> StructureParser a+parseNoLinkTag tag handler = parseTagFull tag nullrref$ \(lb, children) ->+ case lb of+ Left _ -> throwError.UnexpectedRef$+ "Cannot follow cross references on " <> (T.show tag)+ Right text -> handler (text, children)++-- | Parse a tag which must contain a cross reference to another structure, not+-- the structure itself.+parseLinkTag :: Typeable a => GDTag -> StructureParser (GDRef a)+parseLinkTag tag = parseTagFull tag nullrref$ \(lb, _) ->+ case lb of+ Left ref -> return ref+ Right _ -> throwError.RequiredRef$+ "Expected cross reference was missing in " <> (T.show tag)++-- | The most general tag parsing function.+parseTagFull :: Typeable a+ => GDTag -- ^ The tag to parse.+ -> RegisterRef a -- ^ How to register cross references.+ -> TagHandler b a -- ^ How to convert the tag into a GEDCOM structure.+ -> StructureParser a+parseTagFull tag rref handler t@(GDTree (GDLine _ mthisID tag' v) children) =+ if tag /= tag' then return$ Left t else do+ r <- case v of+ Nothing -> Right <$> (handler.(first Right)$ parseCont mempty children)+ Just (GDXRefIDV xref) -> do+ Right <$> (handler (Left (GDXRef xref), children))+ Just (GDLineItemV l1) ->+ Right <$> (handler.(first Right)$ parseCont l1 children)+ case (mthisID, r) of+ (Just thisID, Right rv) -> rref tag thisID rv+ _ -> return ()+ return r++-- | Handle CONT and CONC tags.+parseCont ::+ GDLineItem -- ^ The value of the first line+ -> [GDTree] -- ^ The sub tree+ -> ([(Maybe GDEscape, T.Text)], [GDTree]) -- ^ The concatenation of the values of all the CONT and CONC tags, and the remaining tags.+parseCont l1 children =+ bimap assemble (fmap snd).span (isJust.fst)$+ zipWith (\l r -> (cont l <|> conc l, r)) children children+ where+ assemble = gdLineData . mconcat . (l1:) . catMaybes . fmap fst+ cont (GDTree (GDLine _ _ (GDTag "CONT") (Just (GDLineItemV l))) _) =+ Just$ GDLineItem [(Nothing, "\r\n")] <> l+ cont _ = Nothing+ conc (GDTree (GDLine _ _ (GDTag "CONC") (Just (GDLineItemV l))) _) =+ Just$ gdTrimLineItem l+ conc _ = Nothing+
+ src/Data/Gedcom/Structure.hs view
@@ -0,0 +1,643 @@+{-|+Module: Data.Gedcom.Structure+Description: GEDCOM data structures+Copyright: (c) Callum Lowcay, 2017+License: BSD3+Maintainer: cwslowcay@gmail.com+Stability: experimental+Portability: GHC++This module contains the GEDCOM records. Many fields contain references to+other records, which can be dereferenced by 'Data.Gedcom.gdLookup'++-}+module Data.Gedcom.Structure (+-- * Top level structures+Gedcom (..),+Header (..),+GedcomFormat (..),+GedcomForm (..),+HeaderSource (..),+Corp (..),+HeaderSourceData (..),++-- * Records+Family (..),+Individual (..),+Multimedia (..),+Note (..),+Repository (..),+Source (..),+Submission (..),+Submitter (..),++-- * Substructures+SourceData (..),+SourceRecordedEvent (..),+Association (..),+ChildToFamilyLink (..),+SpouseToFamilyLink (..),+EventDetail (..),+FamilyEventDetail (..),+FamilyEvent (..),+IndividualEventDetail (..),+IndividualEvent (..),+Place (..),+PersonalName (..),+PhoneticName (..),+RomanizedName (..),+PersonalNamePieces (..),+IndividualAttribute (..),+IndividualAttributeType (..),+SourceCitation (..),+RepositoryCitation (..),+Address (..),+ContactDetails (..),+MultimediaFile (..),++-- * Values+MultimediaFormat (..),+MultimediaFileFormat (..),+MultimediaType (..),+NameType (..),+DateValue (..),+DateApprox (..),+DateRange (..),+FamilyEventType (..),+IndividualEventType (..),+EventType (..),+AdoptionDetail (..),+Calendar (..),+CallNumber (..),+ChangeDate (..),+Charset (..),+ChildLinkStatus (..),+Date (..),+DatePeriod (..),+MapCoord (..),+Name (..),+Parent (..),+Pedigree (..),+PhoneticPlaceName (..),+PhoneticType (..),+RestrictionNotice (..),+RomanPlaceName (..),+RomanType (..),+Sex (..),+SourceDescription (..),+UserReference (..),+AFN (..),+Language (..),+Latitude (..),+Longitude (..),+QualityAssessment (..),+RFN (..),+RIN (..),+Year (..)+) where++import Data.Gedcom.Common+import Data.Time.Clock+import qualified Data.Text.All as T++-- | The root structure+data Gedcom = Gedcom {+ gedcomHeader :: Header,+ gedcomFamily :: [GDRef Family],+ gedcomIndividual :: [GDRef Individual],+ gedcomMultimedia :: [GDRef Multimedia],+ gedcomNote :: [GDRef Note],+ gedcomRepository :: [GDRef Repository],+ gedcomSource :: [GDRef Source],+ gedcomSubmitter :: [GDRef Submitter]+} deriving Show++-- | The header+data Header = Header {+ headerSource :: HeaderSource,+ headerDestination :: Maybe T.Text,+ headerDate :: Maybe UTCTime,+ headerSubmitter :: GDRef Submitter,+ headerSubmission :: Maybe (GDRef Submission),+ headerFile :: Maybe FilePath,+ headerCopyright :: Maybe T.Text,+ headerGedcomFormat :: GedcomFormat,+ headerCharset :: Charset,+ headerLang :: Maybe Language,+ headerPlaceForm :: Maybe [T.Text],+ headerNote :: Maybe T.Text+} deriving Show++-- | The database format and version number+data GedcomFormat = GedcomFormat {+ gedcomVersion :: T.Text,+ gedcomForm :: GedcomForm+} deriving Show++-- | The actual database format. Only the default LineageLinked is supported.+data GedcomForm =+ GedcomLineageLinked | GedcomUnsupported T.Text deriving (Show, Eq)++-- | Where the GEDCOM data is sourced from (e.g. the program that created the+-- file)+data HeaderSource = HeaderSource {+ headerSourceSystemID :: T.Text,+ headerSourceVersion :: Maybe T.Text,+ headerSourceName :: Maybe T.Text,+ headerSourceCorp :: Maybe Corp,+ headerSourceData :: Maybe HeaderSourceData+} deriving Show++-- | Information about a corporation+data Corp = Corp {+ corpName :: T.Text,+ corpAddress :: Maybe Address+} deriving Show++-- | Information about the source of this GEDCOM data+data HeaderSourceData = HeaderSourceData {+ headerSourceDataName :: T.Text,+ headerSourceDataDate :: Maybe UTCTime,+ headerSourceDataCopyright :: Maybe T.Text+} deriving Show++-- | The family record+data Family = Family {+ familyRestrictionNotice :: Maybe RestrictionNotice,+ familyEvent :: [FamilyEvent],+ familyHusband :: Maybe (GDRef Individual),+ familyWife :: Maybe (GDRef Individual),+ familyChildren :: [GDRef Individual],+ familyTotalChildren :: Maybe Word,+ familySubitter :: [GDRef Submitter],+ familyUserReference :: [UserReference],+ familyRIN :: Maybe RIN,+ familyChangeDate :: Maybe ChangeDate,+ familyNote :: [GDRef Note],+ familySourceCitation :: [SourceCitation],+ familyMultimedia :: [GDRef Multimedia]+} deriving Show++-- | The individual record+data Individual = Individual {+ individualRestrictionNotice :: Maybe RestrictionNotice,+ individualName :: Maybe PersonalName,+ individualSex :: Maybe Sex,+ individualEvent :: [IndividualEvent],+ individualAttribute :: [IndividualAttribute],+ individualChildToFamilyLink :: [ChildToFamilyLink],+ individualSpouseToFamilyLink :: [SpouseToFamilyLink],+ individualSubmitter :: [GDRef Submitter],+ individualAssociation :: [Association],+ individualAlias :: [GDRef Individual],+ individualAncestorInterest :: [GDRef Submitter],+ individualDescendantInterest :: [GDRef Submitter],+ individualRFN :: Maybe RFN,+ individualAFN :: Maybe AFN,+ individualUserReference :: [UserReference],+ individualRIN :: Maybe RIN,+ individualChangeDate :: Maybe ChangeDate,+ individualNote :: [GDRef Note],+ individualSourceCitation :: [SourceCitation],+ individualMultimedia :: [GDRef Multimedia]+} deriving Show++-- | The multimedia record (for linking multimedia files)+data Multimedia = Multimedia {+ multimediaFile :: [MultimediaFile],+ multimediaTitl :: Maybe T.Text,+ multimediaUserReference :: [UserReference],+ multimediaRIN :: Maybe RIN,+ multimediaNote :: [GDRef Note],+ multimediaSourceCitation :: [SourceCitation],+ multimediaChangeDate :: Maybe ChangeDate+} deriving Show++-- | The note record (for attaching notes to other records)+data Note = Note {+ noteText :: T.Text,+ noteUserReference :: [UserReference],+ noteRIN :: Maybe RIN,+ noteSourceCitation :: [SourceCitation],+ noteChangeDate :: Maybe ChangeDate+} deriving Show++-- | The repository record. Represents a repository of sources (for example a+-- collection of documents or a physical library)+data Repository = Repository {+ repositoryName :: T.Text,+ repositoryAddress :: Maybe Address,+ repositoryNote :: [GDRef Note],+ repositoryUserReference :: [UserReference],+ repositoryRIN :: Maybe RIN,+ repositoryChangeDate :: Maybe ChangeDate+} deriving Show++-- | The source record. A source of information that may be cited by other+-- records.+data Source = Source {+ sourceData :: Maybe SourceData,+ sourceAuthor :: Maybe T.Text,+ sourceTitle :: Maybe T.Text,+ sourceShortTitle :: Maybe T.Text,+ sourcePublicationFacts :: Maybe T.Text,+ sourceText :: Maybe T.Text,+ sourceRepositoryCitations :: [RepositoryCitation],+ sourceUserReference :: [UserReference],+ sourceRIN :: Maybe RIN,+ sourceChangeDate :: Maybe ChangeDate,+ sourceNote :: [GDRef Note],+ sourceMultimedia :: [GDRef Multimedia]+} deriving Show++-- | The submission record. Information about this file.+data Submission = Submission {+ submissionSubmitter :: Maybe (GDRef Submitter),+ submissionFamilyFile :: Maybe T.Text,+ submissionTempleCode :: Maybe T.Text,+ submissionAncestorGenerations :: Maybe Word,+ submissionDescendentGenerations :: Maybe Word,+ submissionOrdinanceProcessing :: Maybe Bool,+ submissionRIN :: Maybe RIN,+ submissionNote :: [GDRef Note],+ submissionChangeDate :: Maybe ChangeDate+} deriving Show++-- | The submitter record. Information about someone who submitted data to+-- this database.+data Submitter = Submitter {+ submitterName :: Name,+ submitterAddress :: Maybe Address,+ submitterMedia :: Maybe (GDRef Multimedia),+ submitterLang :: [Language],+ submitterRFN :: Maybe RFN,+ submitterRIN :: Maybe RIN,+ submitterNote :: [GDRef Note],+ submitterChangeDate :: Maybe ChangeDate+} deriving Show++-- | Extra data about a source.+data SourceData = SourceData {+ sourceDataEventsRecorded :: [SourceRecordedEvent],+ sourceDataAgency :: Maybe T.Text,+ sourceDataNote :: [GDRef Note]+} deriving Show++-- | Information about what events are recorded in a source.+data SourceRecordedEvent = SourceRecordedEvent {+ sourceRecordedEventType :: [EventType],+ sourceRecordedDate :: Maybe DatePeriod,+ sourceRecordedPlace :: Maybe [T.Text]+} deriving Show++-- | An association between individuals.+data Association = Association {+ associationIndividual :: GDRef Individual,+ associationRelation :: T.Text,+ associationCitation :: [SourceCitation],+ associationNote :: [GDRef Note]+} deriving Show++-- | A link from an individual to a family record where they are registered as+-- a child.+data ChildToFamilyLink = ChildToFamilyLink {+ childLinkFamily :: GDRef Family,+ childLinkPedigree :: Maybe Pedigree,+ childLinkStatus :: Maybe ChildLinkStatus,+ childLinkNote :: [GDRef Note]+} deriving Show++-- | A link from an individual to a family record where they are registered as+-- a spouse.+data SpouseToFamilyLink = SpouseToFamilyLink {+ spouseToFamilyLinkFamily :: GDRef Family,+ spouseToFamilyLinkNote :: [GDRef Note]+} deriving Show++-- | Details about an event.+data EventDetail = EventDetail {+ eventDetailType :: Maybe T.Text,+ eventDetailDate :: Maybe DateValue,+ eventDetailPlace :: Maybe Place,+ eventDetailAddress :: Maybe Address,+ eventDetailAgency :: Maybe T.Text,+ eventDetailReligion :: Maybe T.Text,+ eventDetailCause :: Maybe T.Text,+ eventDetailRestrictionNotice :: Maybe RestrictionNotice,+ eventDetailNote :: [GDRef Note],+ eventDetailSourceCitation :: [SourceCitation],+ eventDetailMultimedia :: [GDRef Multimedia]+} deriving Show++-- | Details about a family event.+data FamilyEventDetail = FamilyEventDetail {+ familyEventDetailAgeHusband :: Maybe Word,+ familyEventDetailAgeWife :: Maybe Word,+ familyEventDetailDetail :: EventDetail+} deriving Show++-- | An event concerning a family.+data FamilyEvent = FamilyEvent {+ familyEventType :: FamilyEventType,+ familyEventDetail :: FamilyEventDetail+} deriving Show++-- | Details about an individual event.+data IndividualEventDetail = IndividualEventDetail {+ individualEventDetailDetail :: EventDetail,+ individualEventDetailAge :: Maybe Word+} deriving Show++-- | An event concerning an individual.+data IndividualEvent = IndividualEvent {+ individualEventType :: IndividualEventType,+ individualEventDetail :: IndividualEventDetail+} deriving Show++-- | A physical place.+data Place = Place {+ placeName :: [T.Text],+ placeForm :: Maybe [T.Text],+ placePhonetic :: Maybe PhoneticPlaceName,+ placeRoman :: Maybe RomanPlaceName,+ placeMap :: Maybe MapCoord,+ placeNote :: [GDRef Note]+} deriving Show++-- | The name of a person.+data PersonalName = PersonalName {+ personalNameName :: Name,+ personalNameType :: Maybe NameType,+ personalNamePieces :: PersonalNamePieces,+ personalNamePhonetic :: [PhoneticName],+ personalNameRoman :: [RomanizedName]+} deriving Show++-- | A phonetic transcription of a person's name.+data PhoneticName = PhoneticName {+ phoneticName :: Name,+ phoneticType :: PhoneticType,+ phoneticPieces :: PersonalNamePieces+} deriving Show++-- | A Roman transliteration of a person's name.+data RomanizedName = RomanizedName {+ romanziedName :: Name,+ romanziedType :: RomanType,+ romanziedPieces :: PersonalNamePieces+} deriving Show++-- | Parts of a person's name.+data PersonalNamePieces = PersonalNamePieces {+ -- | Parts of the name that precede the other names. Example from the GEDCOM+ -- standard (prefix highlighted in bold):+ --+ -- __Lt. Cmndr.__ Joseph Allen jr.+ namePiecePrefix :: [T.Text],+ -- | Given names+ namePieceGiven :: [T.Text],+ -- | Nicknames+ namePieceNickname :: [T.Text],+ -- | Surname prefixes. Example from the GEDCOM standard (surname prefix+ -- highlighted in bold):+ --+ -- __de la__ Cruz+ namePieceSurnamePrefix :: [T.Text],+ -- | Surname or family names+ namePieceSurname :: [T.Text],+ -- | Parts of the name that come after all other names. Example from the+ -- GEDCOM standard (suffix highlighted in bold)+ --+ -- Lt. Cmndr. Joseph Allen __jr.__+ namePieceSuffix :: [T.Text],+ namePieceNameNote :: [GDRef Note],+ namePirceSourceCitation :: [SourceCitation]+} deriving Show++-- | Extra information about an individual.+data IndividualAttribute = IndividualAttribute+ IndividualAttributeType (IndividualEventDetail)+ deriving Show++-- | Classification of extra information about an individual.+data IndividualAttributeType =+ Caste T.Text -- ^ Caste.+ | PhysicalDescription T.Text -- ^ Physical description of the individual.+ | Education T.Text -- ^ Scholastic achievement.+ | NationalID T.Text -- ^ National id number.+ | NationalOrigin T.Text -- ^ National or tribal origin.+ | NChildren Word -- ^ Number of children.+ | NMarriages Word -- ^ Number of marriages.+ | Occupation T.Text -- ^ Occupation.+ | Possessions T.Text -- ^ Property the individual owned.+ | Religion T.Text -- ^ Religious affiliation.+ | ResidesAt -- ^ Place of residence.+ | SocialSecurity T.Text -- ^ Social security number.+ | Title T.Text -- ^ Title of nobility.+ | Fact T.Text -- ^ None of the above.+ deriving Show++-- | Citation of source material.+data SourceCitation = SourceCitation {+ -- | Either a description of the source, or a reference to a 'Source' record+ -- which describes the source in more detail.+ citeSource :: Either SourceDescription (GDRef Source),+ citePage :: Maybe T.Text,+ citeMultimedia :: [GDRef Multimedia],+ citeNote :: [GDRef Note],+ citeQuality :: Maybe QualityAssessment+} deriving Show++-- | Citation of a repository of source material.+data RepositoryCitation = RepositoryCitation {+ repoCiteRepository :: Maybe (GDRef Repository),+ repoCiteNote :: [GDRef Note],+ repoCiteCallNumber :: Maybe CallNumber+} deriving Show++-- | An address+data Address = Address {+ addressLines :: T.Text,+ addressCity :: Maybe T.Text,+ addressState :: Maybe T.Text,+ addressPostcode :: Maybe T.Text,+ addressCountry :: Maybe T.Text,+ addressContact :: ContactDetails+} deriving Show++-- | Contact details associated with an 'Address'+data ContactDetails = ContactDetails {+ addressPhone :: [T.Text],+ addressEmail :: [T.Text],+ addressFax :: [T.Text],+ addressWWW :: [T.Text]+} deriving Show++-- | Information about a multimedia file+data MultimediaFile = MultimediaFile {+ multimediaFileLink :: T.Text,+ multimediaFileFormat :: MultimediaFormat,+ multimediaTitle :: Maybe T.Text+} deriving Show++-- | Information about a multimedia format.+data MultimediaFormat =+ MultimediaFormat MultimediaFileFormat (Maybe MultimediaType) deriving Show++-- | Supported multimedia file formats.+data MultimediaFileFormat =+ MF_BMP+ | MF_GIF+ | MF_JPG+ | MF_OLE+ | MF_PCX+ | MF_TIF+ | MF_WAV+ | MF_OTHER T.Text -- ^ Any other file type.+ deriving Show++-- | The kind of multimedia (not necessarily a computer file).+data MultimediaType =+ MT_AUDIO | MT_BOOK | MT_CARD | MT_ELECTRONIC | MT_FICHE+ | MT_FILM | MT_MAGAZINE | MT_MANUSCRIPT | MT_MAP | MT_NEWSPAPER+ | MT_PHOTO | MT_TOMBSTONE | MT_VIDEO+ | MT_OTHER T.Text -- ^ Any other kind of multimedia.+ deriving Show++-- | Name types.+data NameType =+ AKA | BirthName | Immigrant | Maiden | Married+ | NameType T.Text -- ^ Any other kind of name.+ deriving Show++-- | Dates, including date ranges and approximate dates.+data DateValue = DateV Date+ | DateApproxV DateApprox+ | DatePeriodV DatePeriod+ | DateRangeV DateRange+ | DatePhrase (Maybe Date) T.Text -- ^ A date in a format that doesn't fit the other categories. May include an interpretation in the optional 'Date' field.+ deriving Show++-- | A date that is only approximately known.+data DateApprox = DateAbout Date+ | DateCalculated Date+ | DateEstimated Date deriving Show++-- | A range of dates.+data DateRange = DateBefore Date+ | DateAfter Date+ | DateBetween Date Date deriving Show++-- | Recognised types of events concerning families.+data FamilyEventType =+ Annuled | FamCensus | Divorce | DivorceFiled | Engagement+ | MarriageBann | MarriageContract | Marriage | MarriageLicense+ | MarriageSettlement | Residence+ | FamilyEventType T.Text -- ^ Any other kind of event.+ deriving Show++-- | Recognised types of events concerning individuals.+data IndividualEventType =+ Birth (Maybe (GDRef Family)) | Christening (Maybe (GDRef Family))+ | Death | Burial+ | Cremation | Adoption (Maybe AdoptionDetail)+ | Baptism | BarMitzvah+ | BasMitzvah | Blessing | ChristeningAdult | Confirmation | FirstCommunion+ | Ordination | Naturalization | Emigration | Immigration | IndvCensus+ | Probate | Will | Graduation | Retirement+ | IndividualEventType T.Text -- ^ Any other kind of event.+ deriving Show++-- | Recognised event types.+data EventType =+ Census -- ^ Family of individual census.+ | FamilyEventTypeV FamilyEventType -- ^ A family event+ | IndividualEventTypeV IndividualEventType -- ^ An individual event+ | EventType T.Text -- ^ Some other kind of event.+ deriving Show++-- | Information about an adoption, including the family the subject was+-- adopted into and which parent(s) adopted the child.+data AdoptionDetail =+ AdoptionDetail (GDRef Family) (Maybe Parent) deriving Show+-- | A calendar+data Calendar = Gregorian | Julian | Hebrew | French deriving Show+-- | A call number for citations+data CallNumber = CallNumber T.Text (Maybe MultimediaType) deriving Show+-- | The date a record was last changed+data ChangeDate = ChangeDate UTCTime (Maybe (GDRef Note)) deriving Show+-- | A character set and optional version (the version is unused so far as I am+-- aware)+data Charset = Charset T.Text (Maybe T.Text) deriving Show+-- | Metadata about a child link+data ChildLinkStatus = Challenged | Disproved | Proven deriving Show+-- | A date. The format is day \/ month \/ year and months are numbered 1 to+-- 12 (or 1 to 13 for certain calendars).+data Date = Date Calendar (Maybe Word) (Maybe Word) Year deriving Show+-- | A range of dates+data DatePeriod =+ DateFrom Date (Maybe Date) -- ^ A range of dates with a start date and optional end date.+ | DateTo Date -- ^ A range of dates with only the end date specified.+ deriving Show+-- | A global location in longitude and latitude.+data MapCoord = MapCoord Longitude Latitude deriving Show+-- | A personal name. The first field is the full name of the individual. The+-- second field contains just the surname of the individual (or Nothing if+-- unspecified)+data Name = Name T.Text (Maybe T.Text) deriving Show+-- | Which parent?+data Parent = Husband | Wife | BothParents deriving Show+-- | How a child is associated with his\/her family.+data Pedigree = Adopted | ByBirth | Foster | Sealing deriving Show+-- | A phonetic transcription of a place name.+data PhoneticPlaceName = PhoneticPlaceName PhoneticType [T.Text] deriving Show+-- | The type of phonetic transcription.+data PhoneticType =+ Kana -- ^ Japanese kana+ | Hangul -- ^ Korean hanguel+ | PhoneticType T.Text -- ^ Something else+ deriving Show+-- | Privacy restrictions associated with a record.+data RestrictionNotice = Confidential | Locked | Privacy deriving Show+-- | A Roman transliteration of a place name.+data RomanPlaceName = RomanPlaceName RomanType [T.Text] deriving Show+-- | The type of Roman transliteration.+data RomanType =+ Pinyin -- ^ Chinese Pinyin+ | Romaji -- ^ Japanese Romaji+ | WadeGiles -- ^ Chinese Wade-Giles+ | RomanType T.Text -- ^ Something else+ deriving Show+-- | Sex.+data Sex = Male | Female | Undetermined deriving Show+-- | Description of a source. The first field contains a description of the+-- source. The second field contains sections of text from the source.+data SourceDescription = SourceDescription T.Text [T.Text] deriving Show+-- | Custom reference added by the creator of this file. The format of this+-- reference is not standardized.+data UserReference = UserReference T.Text (Maybe T.Text) deriving Show++-- | A natural language.+newtype Language = Language T.Text deriving Show+-- | Latitude+newtype Latitude = Latitude Double deriving Show+-- | Longitude+newtype Longitude = Longitude Double deriving Show+-- | Assessment of the quality of a source. A number from 0 to 3 with 0+-- indicating unreliable information and 3 being direct primary evidence.+newtype QualityAssessment = QualityAssessment Word deriving Show+-- | A year in some calendar. May be negative.+newtype Year = Year Int deriving Show+-- | Automated Record ID. From the GEDCOM standard:+--+-- "This number is intended to serve as a more sure means of identification of+-- a record for reconciling differences in data between two interfacing+-- systems."+newtype RIN = RIN T.Text deriving Show++-- | Part of the GEDCOM standard, but only for LDS use so far as I am aware.+newtype AFN = AFN T.Text deriving Show++-- | Part of the GEDCOM standard, but only for LDS use so far as I am aware.+newtype RFN = RFN T.Text deriving Show+
+ src/Data/Text/Encoding/ANSEL.hs view
@@ -0,0 +1,126 @@+{-|+Module: Data.Text.Encoding.ANSEL+Description: Decoder for the ANSEL character encoding+Copyright: (c) Callum Lowcay, 2017+License: BSD3+Maintainer: cwslowcay@gmail.com+Stability: experimental+Portability: GHC++ANSEL <https://en.wikipedia.org/wiki/ANSEL> is a character set and associated+encodings intended for bibliographic purposes. GEDCOM files use the 8-bit+ANSEL encoding by default, so we need a way to decode it. ANSEL has combining+diacritics, but they precede the character that they modify (Unicode has it the+other way around). This means that the code points must be reordered when+converting to Unicode.++-}+module Data.Text.Encoding.ANSEL (+ decodeANSEL+) where++import Control.Monad.Loops (whileM)+import Control.Monad.State (State, evalState, get, put)+import Data.Array+import Data.Word+import qualified Data.ByteString as B+import qualified Data.Text.All as T++-- | Decode an ANSEL string to Unicode+decodeANSEL ::+ B.ByteString -- ^ The string to encode+ -> T.Text -- ^ Unicode text+decodeANSEL bs = T.pack . concat .+ evalState (whileM ((not.null) <$> get) decodeANSELChar)$ B.unpack bs++decodeANSELChar :: State [Word8] String+decodeANSELChar = do+ (dias', rest) <- span isDiacritic <$> get+ let dias = filter (/= '\xFFFD').fmap (combiningTable!)$ dias'+ case rest of+ [] -> put [] >> if null dias then return "" else return "\xFFFD"+ r:rs -> put rs >> let c = encode r in+ if c == '\xFFFD' then return "\xFFFD" else return$ c:dias+ where encode r = if isAscii r then toEnum (fromIntegral r) else composedTable!r++isAscii :: Word8 -> Bool+isAscii x = x < 0x80++isDiacritic :: Word8 -> Bool+isDiacritic x = x >= 0xE0++composedTable :: Array Word8 Char+composedTable = accumArray (flip const) '\xFFFD' (0x00, 0xFF) [+ (0xA1, 'Ł'),+ (0xA2, 'Ø'),+ (0xA3, 'Đ'),+ (0xA4, 'Þ'),+ (0xA5, 'Æ'),+ (0xA6, 'Œ'),+ (0xA7, 'ʹ'),+ (0xA8, '·'),+ (0xA9, '♭'),+ (0xAA, '®'),+ (0xAB, '±'),+ (0xAC, 'Ơ'),+ (0xAD, 'Ư'),+ (0xAE, 'ʼ'),+ (0xB0, 'ʻ'),+ (0xB1, 'ł'),+ (0xB2, 'ø'),+ (0xB3, 'đ'),+ (0xB4, 'þ'),+ (0xB5, 'æ'),+ (0xB6, 'œ'),+ (0xB7, 'ʺ'),+ (0xB8, 'ı'),+ (0xB9, '£'),+ (0xBA, 'ð'),+ (0xBC, 'ơ'),+ (0xBD, 'ư'),+ (0xBE, '□'),+ (0xBF, '■'),+ (0xC0, '°'),+ (0xC1, 'ℓ'),+ (0xC2, '℗'),+ (0xC3, '©'),+ (0xC4, '♯'),+ (0xC5, '¿'),+ (0xC6, '¡'),+ (0xCD, 'e'),+ (0xCE, 'o'),+ (0xCF, 'ß')]++combiningTable :: Array Word8 Char+combiningTable = accumArray (flip const) '\xFFFD' (0x00, 0xFF) [+ (0xE0, '\x0309'),+ (0xE1, '\x0300'),+ (0xE2, '\x0301'),+ (0xE3, '\x0302'),+ (0xE4, '\x0303'),+ (0xE5, '\x0304'),+ (0xE6, '\x0306'),+ (0xE7, '\x0307'),+ (0xE8, '\x0308'),+ (0xE9, '\x030C'),+ (0xEA, '\x030A'),+ (0xEB, '\xFE20'),+ (0xEC, '\xFE21'),+ (0xED, '\x0315'),+ (0xEE, '\x030B'),+ (0xEF, '\x0310'),+ (0xF0, '\x0327'),+ (0xF1, '\x0328'),+ (0xF2, '\x0323'),+ (0xF3, '\x0324'),+ (0xF4, '\x0325'),+ (0xF5, '\x0333'),+ (0xF6, '\x0332'),+ (0xF7, '\x0326'),+ (0xF8, '\x031C'),+ (0xF9, '\x032E'),+ (0xFA, '\xFE22'),+ (0xFB, '\xFE23'),+ (0xFE, '\x0313'),+ (0xFF, '\x0338')]+
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"