gedcom 0.1.0.0 → 0.2.0.0

raw patch · 14 files changed

+1718/−1541 lines, 14 filesdep +hspecdep ~basedep ~megaparsecdep ~monad-loopsPVP ok

version bump matches the API change (PVP)

Dependencies added: hspec

Dependency ranges changed: base, megaparsec, monad-loops, time

API changes (from Hackage documentation)

Files

• changelog.md +5/−0
• gedcom.cabal +16/−13
• src/Data/Gedcom.hs +5/−4
• src/Data/Gedcom/Common.hs +0/−131
• src/Data/Gedcom/Internal/Common.hs +5/−1
• src/Data/Gedcom/Internal/CoreTypes.hs +131/−0
• src/Data/Gedcom/Internal/LineParser.hs +148/−0
• src/Data/Gedcom/Internal/ParseMonads.hs +120/−0
• src/Data/Gedcom/Internal/Parser.hs +1135/−0
• src/Data/Gedcom/LineParser.hs +0/−147
• src/Data/Gedcom/ParseMonads.hs +0/−120
• src/Data/Gedcom/Parser.hs +0/−1123
• src/Data/Gedcom/Structure.hs +1/−1
• test/Spec.hs +152/−1

@@ -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 

@@ -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 

@@ -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

@@ -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-

@@ -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 <&> 

@@ -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+

@@ -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)+

@@ -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+

@@ -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+

@@ -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)-

@@ -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-

@@ -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-

@@ -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 

@@ -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 [])+