diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,8 @@ +0.2.0.0 + * Upgrade to stackage 9.6 and make ready for GHC 8.2 + * Add some test cases + * Expose internal modules + 0.1.0.0 * Initial release diff --git a/gedcom.cabal b/gedcom.cabal --- a/gedcom.cabal +++ b/gedcom.cabal @@ -1,15 +1,14 @@ name: gedcom -version: 0.1.0.0 +version: 0.2.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. + a widely used file format in genealogy. homepage: https://github.com/CLowcay/hs-gedcom license: BSD3 license-file: LICENSE author: Callum Lowcay maintainer: cwslowcay@gmail.com -copyright: 2017 Callum Lowcay +copyright: 2018 Callum Lowcay category: Genealogy build-type: Simple extra-source-files: README.md changelog.md @@ -19,22 +18,23 @@ 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.Internal.CoreTypes + , Data.Gedcom.Internal.LineParser + , Data.Gedcom.Internal.ParseMonads + , Data.Gedcom.Internal.Parser , Data.Gedcom.Structure - build-depends: base >= 4.7 && < 5 + , Data.Text.Encoding.ANSEL + other-modules: + build-depends: base >= 4.8 && < 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 + , megaparsec >= 6.3 && < 6.4 + , monad-loops >= 0.4.3 && < 0.5 , mtl >= 2.2.1 && < 2.3 , text-all >= 0.4.1.1 && < 0.5 - , time >= 1.6.0.1 && < 1.7 + , time >= 1.8 && < 1.9 default-language: Haskell2010 test-suite gedcom-test @@ -43,6 +43,9 @@ main-is: Spec.hs build-depends: base , gedcom + , hspec >= 2.4.4 && < 2.5 + , text-all >= 0.4.1.1 && < 0.5 + , megaparsec >= 5.3.1 && < 5.4 ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 diff --git a/src/Data/Gedcom.hs b/src/Data/Gedcom.hs --- a/src/Data/Gedcom.hs +++ b/src/Data/Gedcom.hs @@ -24,14 +24,15 @@ 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.Internal.CoreTypes +import Data.Gedcom.Internal.LineParser +import Data.Gedcom.Internal.ParseMonads +import Data.Gedcom.Internal.Parser import Data.Gedcom.Structure import Data.Maybe import Data.Monoid import Data.Text.Encoding.ANSEL +import Data.Typeable import qualified Data.ByteString as B import qualified Data.Map as M import qualified Data.Text.All as T diff --git a/src/Data/Gedcom/Common.hs b/src/Data/Gedcom/Common.hs deleted file mode 100644 --- a/src/Data/Gedcom/Common.hs +++ /dev/null @@ -1,131 +0,0 @@ -{-# 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 --- a/src/Data/Gedcom/Internal/Common.hs +++ b/src/Data/Gedcom/Internal/Common.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + {-| Module: Data.Gedcom.Internal.Common Description: Common utility functions for parsing @@ -17,11 +19,13 @@ import Data.Char import Data.Maybe import Data.Time.Clock +import Data.Void import qualified Data.Text.All as T import Text.Megaparsec +import Text.Megaparsec.Char -- | Parsers from 'T.Text' using the default error component. -type Parser = Parsec Dec T.Text +type Parser = Parsec Void T.Text infixl 1 <&> diff --git a/src/Data/Gedcom/Internal/CoreTypes.hs b/src/Data/Gedcom/Internal/CoreTypes.hs new file mode 100644 --- /dev/null +++ b/src/Data/Gedcom/Internal/CoreTypes.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.Internal.CoreTypes ( + 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, Eq) + +-- | A raw GEDCOM syntax tree +data GDRoot = GDRoot [GDTree] deriving (Show, Eq) + +-- | A GEDCOM subtree +data GDTree = GDTree GDLine [GDTree] deriving (Show, Eq) + +-- | A GEDCOM line +data GDLine = GDLine GDLevel (Maybe GDXRefID) GDTag (Maybe GDLineValue) + deriving (Show, Eq) + +-- | 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/LineParser.hs b/src/Data/Gedcom/Internal/LineParser.hs new file mode 100644 --- /dev/null +++ b/src/Data/Gedcom/Internal/LineParser.hs @@ -0,0 +1,148 @@ +{-# 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.Internal.LineParser ( + gdRoot, gdDelim +) where + +import Control.Monad +import Data.Char +import Data.Gedcom.Internal.Common +import Data.Gedcom.Internal.CoreTypes +import Data.Maybe +import Data.Monoid +import qualified Data.Text.All as T +import Text.Megaparsec +import Text.Megaparsec.Char + +-- | Parse any_char. +gdAnyChar :: Parser T.Text +gdAnyChar = (fmap T.singleton gdNonAt) <|> "@@" + +-- | 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 <$> + ("@#" *> gdEscapeText <* char '@' <* (optional$ char ' ')) + +-- | Parse escape_text. +gdEscapeText :: Parser T.Text +gdEscapeText = T.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.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 T.Text +gdTerminator = "\n" <|> "\r" <|> "\r\n" <|> "\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/Internal/ParseMonads.hs b/src/Data/Gedcom/Internal/ParseMonads.hs new file mode 100644 --- /dev/null +++ b/src/Data/Gedcom/Internal/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.Internal.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.Internal.CoreTypes +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/Internal/Parser.hs b/src/Data/Gedcom/Internal/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Data/Gedcom/Internal/Parser.hs @@ -0,0 +1,1135 @@ +{-# 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.Internal.Parser ( + parseGedcom, + parseHeader, + + parseBoolTag, + parseWordTag, + parseTextTag, + parseListTag, + parseTag, + parseLinkTag, + parseNoLinkTag +) where + +import Control.Applicative +import Control.Monad.Except +import Data.Bifunctor +import Data.Dynamic +import Data.Gedcom.Internal.Common +import Data.Gedcom.Internal.CoreTypes +import Data.Gedcom.Internal.LineParser +import Data.Gedcom.Internal.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 +import Text.Megaparsec.Char + +-- | 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 <$ "confidential") + <|> (Locked <$ "locked") + <|> (Privacy <$ "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 <$ "aka") + <|> (BirthName <$ "birth") + <|> (Immigrant <$ "immigrant") + <|> (Maiden <$ "maiden") + <|> (Married <$ "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 <$ "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 <$ "bmp") + <|> (MF_GIF <$ "gif") + <|> (MF_JPG <$ "jpg") + <|> (MF_OLE <$ "ole") + <|> (MF_PCX <$ "pcx") + <|> (MF_TIF <$ "tif") + <|> (MF_WAV <$ "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 <$ "audio") + <|> (MT_BOOK <$ "book") + <|> (MT_CARD <$ "card") + <|> (MT_ELECTRONIC <$ "electronic") + <|> (MT_FICHE <$ "fiche") + <|> (MT_FILM <$ "film") + <|> (MT_MAGAZINE <$ "magazine") + <|> (MT_MANUSCRIPT <$ "manuscript") + <|> (MT_MAP <$ "map") + <|> (MT_NEWSPAPER <$ "newspaper") + <|> (MT_PHOTO <$ "photo") + <|> (MT_TOMBSTONE <$ "tombstone") + <|> (MT_VIDEO <$ "video") + +-- | Parse a 'FamilyEventType'. +getFamilyEventType :: T.Text -> Maybe FamilyEventType +getFamilyEventType = parseMaybe parser + where + parser :: Parser FamilyEventType + parser = (Annuled <$ "ANUL") + <|> (FamCensus <$ "CENS") + <|> (Divorce <$ "DIV") + <|> (DivorceFiled <$ "DIVF") + <|> (Engagement <$ "ENGA") + <|> (MarriageBann <$ "MARB") + <|> (MarriageContract <$ "MARC") + <|> (Marriage <$ "MARR") + <|> (MarriageLicense <$ "MARL") + <|> (MarriageSettlement <$ "MARS") + <|> (Residence <$ "RESI") + <|> (FamilyEventType . T.pack <$> + ("EVEN" *> gdDelim *> many anyChar)) + +-- | Parse an 'IndividualEventType'. +getIndividualEventType :: T.Text -> Maybe IndividualEventType +getIndividualEventType = parseMaybe parser + where + parser :: Parser IndividualEventType + parser = (Birth Nothing <$ ("BIRTH" + *> optional (gdDelim >> "Y"))) + <|> (Christening Nothing <$ ("CHR" + *> optional (gdDelim >> "Y"))) + <|> (Death <$ ("DEAT" + *> optional (gdDelim >> "Y"))) + <|> (Burial <$ "BURI") + <|> (Cremation <$ "CREM") + <|> (Adoption Nothing <$ "ADOP") + <|> (Baptism <$ "BAPM") + <|> (BarMitzvah <$ "BARM") + <|> (BasMitzvah <$ "BASM") + <|> (Blessing <$ "BLES") + <|> (ChristeningAdult <$ "CHRA") + <|> (Confirmation <$ "CONF") + <|> (FirstCommunion <$ "FCOM") + <|> (Ordination <$ "ORDN") + <|> (Naturalization <$ "NATU") + <|> (Emigration <$ "EMIG") + <|> (Immigration <$ "IMMI") + <|> (IndvCensus <$ "CENS") + <|> (Probate <$ "PROB") + <|> (Will <$ "WILL") + <|> (Graduation <$ "GRAD") + <|> (Retirement <$ "RETI") + <|> (IndividualEventType . T.pack <$> + ("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 <$ "yes") <|> (False <$ "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 . split . trim . gdIgnoreEscapes . fst) + where + split "" = [] + split s = T.splitOn "," s + +-- | 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/LineParser.hs b/src/Data/Gedcom/LineParser.hs deleted file mode 100644 --- a/src/Data/Gedcom/LineParser.hs +++ /dev/null @@ -1,147 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Data/Gedcom/ParseMonads.hs +++ /dev/null @@ -1,120 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Data/Gedcom/Parser.hs +++ /dev/null @@ -1,1123 +0,0 @@ -{-# 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 --- a/src/Data/Gedcom/Structure.hs +++ b/src/Data/Gedcom/Structure.hs @@ -96,7 +96,7 @@ Year (..) ) where -import Data.Gedcom.Common +import Data.Gedcom.Internal.CoreTypes import Data.Time.Clock import qualified Data.Text.All as T diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,2 +1,153 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Data.Gedcom.Internal.CoreTypes +import Data.Gedcom.Internal.LineParser +import Data.Gedcom.Internal.ParseMonads +import Data.Gedcom.Internal.Parser +import Data.Monoid +import Data.Void +import qualified Data.Text.All as T +import Test.Hspec +import Text.Megaparsec + +testTagData :: T.Text +testTagData = "some test data" + +testTag :: T.Text -> Maybe GDLine +testTag d = do + (GDRoot [GDTree t []]) <- parseMaybe gdRoot$ "0 TEST " <> d <> "\n" + return t + +emptyTag :: Maybe GDLine +emptyTag = do + (GDRoot [GDTree t []]) <- parseMaybe gdRoot$ "0 TEST\n" + return t + +ref1 :: GDXRefID +ref1 = GDXRefID "1" + +linkTag :: Maybe GDLine +linkTag = do + (GDRoot [GDTree t []]) <- parseMaybe gdRoot$ "0 TEST @1@\n" + return t + +linkLinkTag :: Maybe GDLine +linkLinkTag = do + (GDRoot [GDTree t []]) <- parseMaybe gdRoot$ "0 @2@ TEST @1@\n" + return t + +crdTag :: Maybe GDLine +crdTag = do + (GDRoot [GDTree t []]) <- + parseMaybe gdRoot$ "0 @1@ TEST " <> testTagData <> "\n" + return t + +data ParseReturn a = + Error T.Text | NoMatch | Match a deriving (Show, Eq) + +isError :: ParseReturn a -> Bool +isError (Error _) = True +isError _ = False + +parseStructure :: Maybe GDTree -> StructureParser a -> ParseReturn a +parseStructure Nothing p = Error "Line parse error" +parseStructure (Just v) p = case runStructure (p v) of + (Right (Left _), _) -> NoMatch + (Right (Right m), _) -> Match m + (Left err, _) -> Error$ T.show err + +noEscapes :: T.Text -> [(Maybe GDEscape, T.Text)] +noEscapes v = [(Nothing, v)] + main :: IO () -main = putStrLn "Test suite not yet implemented" +main = hspec$ do + describe "gdRoot"$ do + it "parses a simple line with no children"$ + (testTag testTagData) `shouldBe` + (Just$ GDLine (GDLevel 0) Nothing (GDTag "TEST") + (Just . GDLineItemV . GDLineItem . noEscapes$ testTagData)) + it "parses a simple cross referenced line"$ + crdTag `shouldBe` (Just$ GDLine (GDLevel 0) (Just ref1) (GDTag "TEST") + (Just . GDLineItemV . GDLineItem . noEscapes$ testTagData)) + it "parses a simple line cross referencing line"$ + linkTag `shouldBe` (Just$ GDLine (GDLevel 0) Nothing (GDTag "TEST") + (Just . GDXRefIDV$ ref1)) + it "parses an empty tag with no children"$ + emptyTag `shouldBe` + (Just$ GDLine (GDLevel 0) Nothing (GDTag "TEST") Nothing) + + describe "parseNoLinkTag"$ do + it "matches the specified tag"$ + testLine (testTag testTagData) (parseNoLinkTag (GDTag "TEST") pure) + `shouldBe` (Match (noEscapes testTagData, [])) + it "matches the specified tag (with a cross reference)" $ + testLine crdTag (parseNoLinkTag (GDTag "TEST") pure) + `shouldBe` (Match (noEscapes testTagData, [])) + it "doesn't match other tags"$ + testLine (testTag testTagData) (parseNoLinkTag (GDTag "OTHER") pure) + `shouldBe` NoMatch + it "doesn't parse links"$ + isError$ testLine linkTag (parseNoLinkTag (GDTag "TEST") pure) + + describe "parseTag"$ do + it "matches the specified tag"$ + testLine (testTag testTagData) (parseTag (GDTag "TEST") pure) + `shouldBe` (Match . GDStructure$ (noEscapes testTagData, [])) + it "matches the specified tag (with a cross reference)" $ + testLine crdTag (parseTag (GDTag "TEST") pure) + `shouldBe` (Match . GDStructure$ (noEscapes testTagData, [])) + it "doesn't match other tags"$ + testLine (testTag testTagData) (parseTag (GDTag "OTHER") pure) + `shouldBe` NoMatch + it "parses links"$ + testLine linkTag (parseTag (GDTag "TEST") pure) + `shouldBe` (Match$ GDXRef ref1) + it "doesn't parse links to links"$ + isError$ testLine linkLinkTag (parseTag (GDTag "TEST") pure) + + describe "parseLinkTag"$ do + it "parses link tags"$ + testLine linkTag (parseLinkTag (GDTag "TEST")) `shouldBe` + (Match$ (GDXRef ref1 :: GDRef Void)) + it "doesn't parse other tags"$ + isError$ testLine (testTag testTagData) + (parseLinkTag (GDTag "TEST") :: StructureParser (GDRef Void)) + + describe "parseTextTag"$ do + it "matches the specified tag" $ + testLine (testTag testTagData) (parseTextTag (GDTag "TEST")) + `shouldBe` (Match testTagData) + + describe "parseListTag"$ do + it "splits lists"$ + testLine (testTag "one,,two,three,four") (parseListTag (GDTag "TEST")) + `shouldBe` (Match ["one", "", "two", "three", "four"]) + it "handles the empty list"$ + testLine emptyTag (parseListTag (GDTag "TEST")) `shouldBe` (Match []) + + describe "parseWordTag"$ do + it "parses numbers"$ + testLine (testTag "42") (parseWordTag (GDTag "TEST")) `shouldBe` (Match 42) + it "doesn't parse negative numbers"$ + isError$ testLine (testTag "-42") (parseWordTag (GDTag "TEST")) + it "doesn't parse empty strings"$ + isError$ testLine (testTag "") (parseWordTag (GDTag "TEST")) + + describe "parseBoolTag"$ do + it "parses yes and no"$ do + testLine (testTag "yes") (parseBoolTag (GDTag "TEST")) + `shouldBe` (Match True) + testLine (testTag "no") (parseBoolTag (GDTag "TEST")) + `shouldBe` (Match False) + it "parses case insensitive"$ do + testLine (testTag "Yes") (parseBoolTag (GDTag "TEST")) + `shouldBe` (Match True) + testLine (testTag "nO") (parseBoolTag (GDTag "TEST")) + `shouldBe` (Match False) + it "doesn't parse anything else"$ + (isError$ testLine (testTag "true") (parseBoolTag (GDTag "TEST"))) + && (isError$ testLine (testTag "false") (parseBoolTag (GDTag "TEST"))) + + where + testLine l = parseStructure (GDTree <$> l <*> pure []) +