diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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). + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,3 @@ +0.1.0.0 + * Initial release + diff --git a/gedcom.cabal b/gedcom.cabal new file mode 100644 --- /dev/null +++ b/gedcom.cabal @@ -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 + diff --git a/src/Data/Gedcom.hs b/src/Data/Gedcom.hs new file mode 100644 --- /dev/null +++ b/src/Data/Gedcom.hs @@ -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 "<>" 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 + diff --git a/src/Data/Gedcom/Common.hs b/src/Data/Gedcom/Common.hs new file mode 100644 --- /dev/null +++ b/src/Data/Gedcom/Common.hs @@ -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 + diff --git a/src/Data/Gedcom/Internal/Common.hs b/src/Data/Gedcom/Internal/Common.hs new file mode 100644 --- /dev/null +++ b/src/Data/Gedcom/Internal/Common.hs @@ -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 + diff --git a/src/Data/Gedcom/LineParser.hs b/src/Data/Gedcom/LineParser.hs new file mode 100644 --- /dev/null +++ b/src/Data/Gedcom/LineParser.hs @@ -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) + diff --git a/src/Data/Gedcom/ParseMonads.hs b/src/Data/Gedcom/ParseMonads.hs new file mode 100644 --- /dev/null +++ b/src/Data/Gedcom/ParseMonads.hs @@ -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 + diff --git a/src/Data/Gedcom/Parser.hs b/src/Data/Gedcom/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Data/Gedcom/Parser.hs @@ -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 + diff --git a/src/Data/Gedcom/Structure.hs b/src/Data/Gedcom/Structure.hs new file mode 100644 --- /dev/null +++ b/src/Data/Gedcom/Structure.hs @@ -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 + diff --git a/src/Data/Text/Encoding/ANSEL.hs b/src/Data/Text/Encoding/ANSEL.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Encoding/ANSEL.hs @@ -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 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')] + diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"