{-# LANGUAGE DeriveGeneric #-}

-- |
-- Module      :  ELynx.Tree.Import.Newick
-- Description :  Import Newick trees
-- Copyright   :  (c) Dominik Schrempf 2021
-- License     :  GPL-3.0-or-later
--
-- Maintainer  :  dominik.schrempf@gmail.com
-- Stability   :  unstable
-- Portability :  portable
--
-- Creation date: Thu Jan 17 14:56:27 2019.
--
-- Some functions are inspired by
-- [Biobase.Newick.Import](https://hackage.haskell.org/package/BiobaseNewick).
--
-- [Specifications](http://evolution.genetics.washington.edu/phylip/newicktree.html)
--
-- In particular, no conversion from _ to (space) is done right now.
--
-- For a description of rooted 'Tree's, please see the 'ELynx.Tree.Rooted'
module ELynx.Tree.Import.Newick
  ( NewickFormat (..),
    newick,
    oneNewick,
    parseOneNewick,
    readOneNewick,
    someNewick,
    parseSomeNewick,
    readSomeNewick,
  )
where

import Control.Applicative
import Data.Aeson (FromJSON, ToJSON)
import Data.Attoparsec.ByteString.Char8
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as BL
import ELynx.Tree.Length
import ELynx.Tree.Name
import ELynx.Tree.Phylogeny
import ELynx.Tree.Rooted hiding (forest, label)
import ELynx.Tree.Support
import GHC.Generics
import Prelude hiding (takeWhile)

-- IDEA: Key-value pairs in Newick files.
--
-- After some thinking I believe the best way to go is RevBayes-like key-value
-- pairs after branch lengths and node labels by default and the option to
-- import IqTree-like trees.
--
-- I can not really provide a general parser for key-value pairs, but I can
-- provide appropriate export functions for reasonably general key-value pairs
-- such as branch support values. This could look like so:
--
-- @
-- fromNewickG :: Parser (Tree (Maybe Length, BL.ByteString) (Name, BL.ByteString))
--
-- fromNewick :: Parser (Tree (Maybe Length) Name)
--
-- toNewickG :: Tree BL.ByteString BL.ByteString -> BL.ByteString
--
-- toNewick :: (HasMaybeLength e, HasMaybeSupport e, HasName a) => Tree e a -> BL.ByteString
-- @
--
-- In this case, I would also rename RevBayes to KeyVal (or provide a separate
-- function for IqTree-like trees). I would not ignore the key values but just
-- provide the whole string to be parsed by the user.

-- | Newick tree format.
--
-- - Standard: Branch support values are stored in square brackets after branch
--   lengths.
--
-- - IqTree: Branch support values are stored as node names after the closing
--   bracket of forests.
--
-- - RevBayes: Key-value pairs are provided in square brackets after node names
--   as well as branch lengths. NOTE: Key value pairs are ignored.
data NewickFormat = Standard | IqTree | RevBayes
  deriving (NewickFormat -> NewickFormat -> Bool
(NewickFormat -> NewickFormat -> Bool)
-> (NewickFormat -> NewickFormat -> Bool) -> Eq NewickFormat
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NewickFormat -> NewickFormat -> Bool
$c/= :: NewickFormat -> NewickFormat -> Bool
== :: NewickFormat -> NewickFormat -> Bool
$c== :: NewickFormat -> NewickFormat -> Bool
Eq, Int -> NewickFormat -> ShowS
[NewickFormat] -> ShowS
NewickFormat -> String
(Int -> NewickFormat -> ShowS)
-> (NewickFormat -> String)
-> ([NewickFormat] -> ShowS)
-> Show NewickFormat
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NewickFormat] -> ShowS
$cshowList :: [NewickFormat] -> ShowS
show :: NewickFormat -> String
$cshow :: NewickFormat -> String
showsPrec :: Int -> NewickFormat -> ShowS
$cshowsPrec :: Int -> NewickFormat -> ShowS
Show, ReadPrec [NewickFormat]
ReadPrec NewickFormat
Int -> ReadS NewickFormat
ReadS [NewickFormat]
(Int -> ReadS NewickFormat)
-> ReadS [NewickFormat]
-> ReadPrec NewickFormat
-> ReadPrec [NewickFormat]
-> Read NewickFormat
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [NewickFormat]
$creadListPrec :: ReadPrec [NewickFormat]
readPrec :: ReadPrec NewickFormat
$creadPrec :: ReadPrec NewickFormat
readList :: ReadS [NewickFormat]
$creadList :: ReadS [NewickFormat]
readsPrec :: Int -> ReadS NewickFormat
$creadsPrec :: Int -> ReadS NewickFormat
Read, NewickFormat
NewickFormat -> NewickFormat -> Bounded NewickFormat
forall a. a -> a -> Bounded a
maxBound :: NewickFormat
$cmaxBound :: NewickFormat
minBound :: NewickFormat
$cminBound :: NewickFormat
Bounded, Int -> NewickFormat
NewickFormat -> Int
NewickFormat -> [NewickFormat]
NewickFormat -> NewickFormat
NewickFormat -> NewickFormat -> [NewickFormat]
NewickFormat -> NewickFormat -> NewickFormat -> [NewickFormat]
(NewickFormat -> NewickFormat)
-> (NewickFormat -> NewickFormat)
-> (Int -> NewickFormat)
-> (NewickFormat -> Int)
-> (NewickFormat -> [NewickFormat])
-> (NewickFormat -> NewickFormat -> [NewickFormat])
-> (NewickFormat -> NewickFormat -> [NewickFormat])
-> (NewickFormat -> NewickFormat -> NewickFormat -> [NewickFormat])
-> Enum NewickFormat
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: NewickFormat -> NewickFormat -> NewickFormat -> [NewickFormat]
$cenumFromThenTo :: NewickFormat -> NewickFormat -> NewickFormat -> [NewickFormat]
enumFromTo :: NewickFormat -> NewickFormat -> [NewickFormat]
$cenumFromTo :: NewickFormat -> NewickFormat -> [NewickFormat]
enumFromThen :: NewickFormat -> NewickFormat -> [NewickFormat]
$cenumFromThen :: NewickFormat -> NewickFormat -> [NewickFormat]
enumFrom :: NewickFormat -> [NewickFormat]
$cenumFrom :: NewickFormat -> [NewickFormat]
fromEnum :: NewickFormat -> Int
$cfromEnum :: NewickFormat -> Int
toEnum :: Int -> NewickFormat
$ctoEnum :: Int -> NewickFormat
pred :: NewickFormat -> NewickFormat
$cpred :: NewickFormat -> NewickFormat
succ :: NewickFormat -> NewickFormat
$csucc :: NewickFormat -> NewickFormat
Enum, (forall x. NewickFormat -> Rep NewickFormat x)
-> (forall x. Rep NewickFormat x -> NewickFormat)
-> Generic NewickFormat
forall x. Rep NewickFormat x -> NewickFormat
forall x. NewickFormat -> Rep NewickFormat x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep NewickFormat x -> NewickFormat
$cfrom :: forall x. NewickFormat -> Rep NewickFormat x
Generic)

instance FromJSON NewickFormat

instance ToJSON NewickFormat

-- | Newick tree parser. Also succeeds when more trees follow.
newick :: NewickFormat -> Parser (Tree Phylo Name)
newick :: NewickFormat -> Parser (Tree Phylo Name)
newick NewickFormat
f = case NewickFormat
f of
  NewickFormat
Standard -> Parser (Tree Phylo Name) -> Parser (Tree Phylo Name)
forall a. Parser ByteString a -> Parser ByteString a
p Parser (Tree Phylo Name)
tree
  NewickFormat
IqTree -> Parser (Tree Phylo Name) -> Parser (Tree Phylo Name)
forall a. Parser ByteString a -> Parser ByteString a
p Parser (Tree Phylo Name)
treeIqTree
  NewickFormat
RevBayes -> Parser (Tree Phylo Name)
newickRevBayes
  where
    p :: Parser ByteString a -> Parser ByteString a
p Parser ByteString a
t = (Char -> Bool) -> Parser ()
skipWhile Char -> Bool
isSpace Parser () -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString a
t Parser ByteString a
-> Parser ByteString Char -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ByteString Char
char Char
';' Parser ByteString a -> Parser () -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (Char -> Bool) -> Parser ()
skipWhile Char -> Bool
isSpace Parser ByteString a -> String -> Parser ByteString a
forall i a. Parser i a -> String -> Parser i a
<?> String
"newick"

-- | One Newick tree parser. Fails when end of input is not reached.
oneNewick :: NewickFormat -> Parser (Tree Phylo Name)
oneNewick :: NewickFormat -> Parser (Tree Phylo Name)
oneNewick NewickFormat
f = NewickFormat -> Parser (Tree Phylo Name)
newick NewickFormat
f Parser (Tree Phylo Name) -> Parser () -> Parser (Tree Phylo Name)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
forall t. Chunk t => Parser t ()
endOfInput Parser (Tree Phylo Name) -> String -> Parser (Tree Phylo Name)
forall i a. Parser i a -> String -> Parser i a
<?> String
"oneNewick"

-- | See 'oneNewick'.
parseOneNewick :: NewickFormat -> BS.ByteString -> Either String (Tree Phylo Name)
parseOneNewick :: NewickFormat -> ByteString -> Either String (Tree Phylo Name)
parseOneNewick NewickFormat
f = Parser (Tree Phylo Name)
-> ByteString -> Either String (Tree Phylo Name)
forall a. Parser a -> ByteString -> Either String a
parseOnly (NewickFormat -> Parser (Tree Phylo Name)
oneNewick NewickFormat
f)

-- | See 'oneNewick'; may fail with 'error'.
readOneNewick :: NewickFormat -> FilePath -> IO (Tree Phylo Name)
readOneNewick :: NewickFormat -> String -> IO (Tree Phylo Name)
readOneNewick NewickFormat
f String
fn = String -> IO ByteString
BS.readFile String
fn IO ByteString
-> (ByteString -> IO (Tree Phylo Name)) -> IO (Tree Phylo Name)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((String -> IO (Tree Phylo Name))
-> (Tree Phylo Name -> IO (Tree Phylo Name))
-> Either String (Tree Phylo Name)
-> IO (Tree Phylo Name)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> IO (Tree Phylo Name)
forall a. HasCallStack => String -> a
error Tree Phylo Name -> IO (Tree Phylo Name)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String (Tree Phylo Name) -> IO (Tree Phylo Name))
-> (ByteString -> Either String (Tree Phylo Name))
-> ByteString
-> IO (Tree Phylo Name)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NewickFormat -> ByteString -> Either String (Tree Phylo Name)
parseOneNewick NewickFormat
f)

-- | One or more Newick trees parser.
someNewick :: NewickFormat -> Parser (Forest Phylo Name)
someNewick :: NewickFormat -> Parser (Forest Phylo Name)
someNewick NewickFormat
f = Parser (Tree Phylo Name) -> Parser (Forest Phylo Name)
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (NewickFormat -> Parser (Tree Phylo Name)
newick NewickFormat
f) Parser (Forest Phylo Name)
-> Parser () -> Parser (Forest Phylo Name)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
forall t. Chunk t => Parser t ()
endOfInput Parser (Forest Phylo Name) -> String -> Parser (Forest Phylo Name)
forall i a. Parser i a -> String -> Parser i a
<?> String
"someNewick"

-- | See 'someNewick'.
parseSomeNewick :: NewickFormat -> BS.ByteString -> Either String [Tree Phylo Name]
parseSomeNewick :: NewickFormat -> ByteString -> Either String (Forest Phylo Name)
parseSomeNewick NewickFormat
f = Parser (Forest Phylo Name)
-> ByteString -> Either String (Forest Phylo Name)
forall a. Parser a -> ByteString -> Either String a
parseOnly (NewickFormat -> Parser (Forest Phylo Name)
someNewick NewickFormat
f)

-- | See 'someNewick'; may fail with 'error'.
readSomeNewick :: NewickFormat -> FilePath -> IO [Tree Phylo Name]
readSomeNewick :: NewickFormat -> String -> IO (Forest Phylo Name)
readSomeNewick NewickFormat
f String
fn = String -> IO ByteString
BS.readFile String
fn IO ByteString
-> (ByteString -> IO (Forest Phylo Name)) -> IO (Forest Phylo Name)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((String -> IO (Forest Phylo Name))
-> (Forest Phylo Name -> IO (Forest Phylo Name))
-> Either String (Forest Phylo Name)
-> IO (Forest Phylo Name)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> IO (Forest Phylo Name)
forall a. HasCallStack => String -> a
error Forest Phylo Name -> IO (Forest Phylo Name)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String (Forest Phylo Name) -> IO (Forest Phylo Name))
-> (ByteString -> Either String (Forest Phylo Name))
-> ByteString
-> IO (Forest Phylo Name)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NewickFormat -> ByteString -> Either String (Forest Phylo Name)
parseSomeNewick NewickFormat
f)

tree :: Parser (Tree Phylo Name)
tree :: Parser (Tree Phylo Name)
tree = Parser (Tree Phylo Name)
branched Parser (Tree Phylo Name)
-> Parser (Tree Phylo Name) -> Parser (Tree Phylo Name)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser (Tree Phylo Name)
leaf Parser (Tree Phylo Name) -> String -> Parser (Tree Phylo Name)
forall i a. Parser i a -> String -> Parser i a
<?> String
"tree"

branched :: Parser (Tree Phylo Name)
branched :: Parser (Tree Phylo Name)
branched = (Parser (Tree Phylo Name) -> String -> Parser (Tree Phylo Name)
forall i a. Parser i a -> String -> Parser i a
<?> String
"branched") (Parser (Tree Phylo Name) -> Parser (Tree Phylo Name))
-> Parser (Tree Phylo Name) -> Parser (Tree Phylo Name)
forall a b. (a -> b) -> a -> b
$ do
  Forest Phylo Name
f <- Parser (Forest Phylo Name)
forest
  Name
n <- Parser Name
name
  Phylo
p <- Parser Phylo
phylo
  Tree Phylo Name -> Parser (Tree Phylo Name)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree Phylo Name -> Parser (Tree Phylo Name))
-> Tree Phylo Name -> Parser (Tree Phylo Name)
forall a b. (a -> b) -> a -> b
$ Phylo -> Name -> Forest Phylo Name -> Tree Phylo Name
forall e a. e -> a -> Forest e a -> Tree e a
Node Phylo
p Name
n Forest Phylo Name
f

-- A 'forest' is a set of trees separated by @,@ and enclosed by parentheses.
forest :: Parser (Forest Phylo Name)
forest :: Parser (Forest Phylo Name)
forest = Char -> Parser ByteString Char
char Char
'(' Parser ByteString Char
-> Parser (Forest Phylo Name) -> Parser (Forest Phylo Name)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Parser (Tree Phylo Name)
tree Parser (Tree Phylo Name)
-> Parser ByteString Char -> Parser (Forest Phylo Name)
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy1` Char -> Parser ByteString Char
char Char
',') Parser (Forest Phylo Name)
-> Parser ByteString Char -> Parser (Forest Phylo Name)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ByteString Char
char Char
')' Parser (Forest Phylo Name) -> String -> Parser (Forest Phylo Name)
forall i a. Parser i a -> String -> Parser i a
<?> String
"forest"

-- A 'leaf' has a 'name' and a 'phylo' branch.
leaf :: Parser (Tree Phylo Name)
leaf :: Parser (Tree Phylo Name)
leaf = (Parser (Tree Phylo Name) -> String -> Parser (Tree Phylo Name)
forall i a. Parser i a -> String -> Parser i a
<?> String
"leaf") (Parser (Tree Phylo Name) -> Parser (Tree Phylo Name))
-> Parser (Tree Phylo Name) -> Parser (Tree Phylo Name)
forall a b. (a -> b) -> a -> b
$ do
  Name
n <- Parser Name
name
  Phylo
p <- Parser Phylo
phylo
  Tree Phylo Name -> Parser (Tree Phylo Name)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree Phylo Name -> Parser (Tree Phylo Name))
-> Tree Phylo Name -> Parser (Tree Phylo Name)
forall a b. (a -> b) -> a -> b
$ Phylo -> Name -> Forest Phylo Name -> Tree Phylo Name
forall e a. e -> a -> Forest e a -> Tree e a
Node Phylo
p Name
n []

nameChar :: Char -> Bool
nameChar :: Char -> Bool
nameChar Char
c = Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
" :;()[],"

-- A name can be any string of printable characters except blanks, colons,
-- semicolons, parentheses, and square brackets (and commas).
name :: Parser Name
name :: Parser Name
name = ByteString -> Name
Name (ByteString -> Name)
-> (ByteString -> ByteString) -> ByteString -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.fromStrict (ByteString -> Name) -> Parser ByteString ByteString -> Parser Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser ByteString ByteString
takeWhile Char -> Bool
nameChar Parser Name -> String -> Parser Name
forall i a. Parser i a -> String -> Parser i a
<?> String
"name"

phylo :: Parser Phylo
phylo :: Parser Phylo
phylo = Maybe Length -> Maybe Support -> Phylo
Phylo (Maybe Length -> Maybe Support -> Phylo)
-> Parser ByteString (Maybe Length)
-> Parser ByteString (Maybe Support -> Phylo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Length -> Parser ByteString (Maybe Length)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser ByteString Length
branchLengthStandard Parser ByteString (Maybe Support -> Phylo)
-> Parser ByteString (Maybe Support) -> Parser Phylo
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString Support -> Parser ByteString (Maybe Support)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser ByteString Support
branchSupportStandard Parser Phylo -> String -> Parser Phylo
forall i a. Parser i a -> String -> Parser i a
<?> String
"phylo"

-- Branch length.
branchLengthSimple :: Parser Length
branchLengthSimple :: Parser ByteString Length
branchLengthSimple = (Parser ByteString Length -> String -> Parser ByteString Length
forall i a. Parser i a -> String -> Parser i a
<?> String
"branchLengthSimple") (Parser ByteString Length -> Parser ByteString Length)
-> Parser ByteString Length -> Parser ByteString Length
forall a b. (a -> b) -> a -> b
$ do
  Double
l <- Parser Double
double Parser Double -> String -> Parser Double
forall i a. Parser i a -> String -> Parser i a
<?> String
"branchLengthSimple; double"
  case Double -> Either String Length
toLength Double
l of
    Left String
e -> String -> Parser ByteString Length
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
e
    Right Length
pl -> Length -> Parser ByteString Length
forall (f :: * -> *) a. Applicative f => a -> f a
pure Length
pl

-- Branch length.
branchLengthStandard :: Parser Length
branchLengthStandard :: Parser ByteString Length
branchLengthStandard = do
  Char
_ <- Char -> Parser ByteString Char
char Char
':' Parser ByteString Char -> String -> Parser ByteString Char
forall i a. Parser i a -> String -> Parser i a
<?> String
"branchLengthDelimiter"
  Parser ByteString Length
branchLengthSimple

branchSupportSimple :: Parser Support
branchSupportSimple :: Parser ByteString Support
branchSupportSimple = (Parser ByteString Support -> String -> Parser ByteString Support
forall i a. Parser i a -> String -> Parser i a
<?> String
"branchSupportSimple") (Parser ByteString Support -> Parser ByteString Support)
-> Parser ByteString Support -> Parser ByteString Support
forall a b. (a -> b) -> a -> b
$
  do
    Double
s <- Parser Double
double Parser Double -> String -> Parser Double
forall i a. Parser i a -> String -> Parser i a
<?> String
"branchSupportSimple; double"
    case Double -> Either String Support
toSupport Double
s of
      Left String
e -> String -> Parser ByteString Support
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
e
      Right Support
ps -> Support -> Parser ByteString Support
forall (f :: * -> *) a. Applicative f => a -> f a
pure Support
ps

branchSupportStandard :: Parser Support
branchSupportStandard :: Parser ByteString Support
branchSupportStandard = (Parser ByteString Support -> String -> Parser ByteString Support
forall i a. Parser i a -> String -> Parser i a
<?> String
"branchSupportStandard") (Parser ByteString Support -> Parser ByteString Support)
-> Parser ByteString Support -> Parser ByteString Support
forall a b. (a -> b) -> a -> b
$ do
  Char
_ <- Char -> Parser ByteString Char
char Char
'[' Parser ByteString Char -> String -> Parser ByteString Char
forall i a. Parser i a -> String -> Parser i a
<?> String
"branchSupportBegin"
  Support
s <- Parser ByteString Support
branchSupportSimple
  Char
_ <- Char -> Parser ByteString Char
char Char
']' Parser ByteString Char -> String -> Parser ByteString Char
forall i a. Parser i a -> String -> Parser i a
<?> String
"branchSupportEnd"
  Support -> Parser ByteString Support
forall (m :: * -> *) a. Monad m => a -> m a
return Support
s

--------------------------------------------------------------------------------
-- IQ-TREE.
--
-- IQ-TREE stores the branch support as node names after the closing bracket of
-- a forest. Parse a single Newick tree. Also succeeds when more trees follow.

-- IQ-TREE stores the branch support as node names after the closing bracket of a forest.
treeIqTree :: Parser (Tree Phylo Name)
treeIqTree :: Parser (Tree Phylo Name)
treeIqTree = Parser (Tree Phylo Name)
branchedIqTree Parser (Tree Phylo Name)
-> Parser (Tree Phylo Name) -> Parser (Tree Phylo Name)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser (Tree Phylo Name)
leaf Parser (Tree Phylo Name) -> String -> Parser (Tree Phylo Name)
forall i a. Parser i a -> String -> Parser i a
<?> String
"treeIqTree"

-- IQ-TREE stores the branch support as node names after the closing bracket of a forest.
branchedIqTree :: Parser (Tree Phylo Name)
branchedIqTree :: Parser (Tree Phylo Name)
branchedIqTree = (Parser (Tree Phylo Name) -> String -> Parser (Tree Phylo Name)
forall i a. Parser i a -> String -> Parser i a
<?> String
"branchedIqTree") (Parser (Tree Phylo Name) -> Parser (Tree Phylo Name))
-> Parser (Tree Phylo Name) -> Parser (Tree Phylo Name)
forall a b. (a -> b) -> a -> b
$ do
  Forest Phylo Name
f <- Parser (Forest Phylo Name)
forestIqTree
  Maybe Support
ms <- Parser ByteString Support -> Parser ByteString (Maybe Support)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser ByteString Support
branchSupportSimple
  Name
n <- Parser Name
name
  Maybe Length
mb <- Parser ByteString Length -> Parser ByteString (Maybe Length)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser ByteString Length
branchLengthStandard
  Tree Phylo Name -> Parser (Tree Phylo Name)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree Phylo Name -> Parser (Tree Phylo Name))
-> Tree Phylo Name -> Parser (Tree Phylo Name)
forall a b. (a -> b) -> a -> b
$ Phylo -> Name -> Forest Phylo Name -> Tree Phylo Name
forall e a. e -> a -> Forest e a -> Tree e a
Node (Maybe Length -> Maybe Support -> Phylo
Phylo Maybe Length
mb Maybe Support
ms) Name
n Forest Phylo Name
f

-- IQ-TREE stores the branch support as node names after the closing bracket of a forest.
forestIqTree :: Parser (Forest Phylo Name)
forestIqTree :: Parser (Forest Phylo Name)
forestIqTree = (Parser (Forest Phylo Name) -> String -> Parser (Forest Phylo Name)
forall i a. Parser i a -> String -> Parser i a
<?> String
"forestIqTree") (Parser (Forest Phylo Name) -> Parser (Forest Phylo Name))
-> Parser (Forest Phylo Name) -> Parser (Forest Phylo Name)
forall a b. (a -> b) -> a -> b
$ do
  Char
_ <- Char -> Parser ByteString Char
char Char
'('
  Forest Phylo Name
f <- Parser (Tree Phylo Name)
treeIqTree Parser (Tree Phylo Name)
-> Parser ByteString Char -> Parser (Forest Phylo Name)
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy1` Char -> Parser ByteString Char
char Char
','
  Char
_ <- Char -> Parser ByteString Char
char Char
')'
  Forest Phylo Name -> Parser (Forest Phylo Name)
forall (m :: * -> *) a. Monad m => a -> m a
return Forest Phylo Name
f

--------------------------------------------------------------------------------
-- RevBayes.

-- RevBayes uses square brackets and key-value pairs to define information
-- about nodes and branches.
--
-- Parse a single Newick tree. Also succeeds when more trees follow.
--
-- NOTE: Key value pairs are ignored. In my opinion, it is just not a good
-- option to import key values pairs in this form. Key value pairs can still be
-- exported by first converting them to a ByteString, and then performing a
-- normal export.
newickRevBayes :: Parser (Tree Phylo Name)
newickRevBayes :: Parser (Tree Phylo Name)
newickRevBayes =
  (Char -> Bool) -> Parser ()
skipWhile Char -> Bool
isSpace
    Parser ()
-> Parser ByteString (Maybe ()) -> Parser ByteString (Maybe ())
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser () -> Parser ByteString (Maybe ())
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser ()
brackets
    Parser ByteString (Maybe ())
-> Parser (Tree Phylo Name) -> Parser (Tree Phylo Name)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser (Tree Phylo Name)
treeRevBayes
    Parser (Tree Phylo Name)
-> Parser ByteString Char -> Parser (Tree Phylo Name)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ByteString Char
char Char
';'
    Parser (Tree Phylo Name) -> Parser () -> Parser (Tree Phylo Name)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (Char -> Bool) -> Parser ()
skipWhile Char -> Bool
isSpace Parser (Tree Phylo Name) -> String -> Parser (Tree Phylo Name)
forall i a. Parser i a -> String -> Parser i a
<?> String
"newickRevBayes"

treeRevBayes :: Parser (Tree Phylo Name)
treeRevBayes :: Parser (Tree Phylo Name)
treeRevBayes = Parser (Tree Phylo Name)
branchedRevBayes Parser (Tree Phylo Name)
-> Parser (Tree Phylo Name) -> Parser (Tree Phylo Name)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser (Tree Phylo Name)
leafRevBayes Parser (Tree Phylo Name) -> String -> Parser (Tree Phylo Name)
forall i a. Parser i a -> String -> Parser i a
<?> String
"treeRevBayes"

branchedRevBayes :: Parser (Tree Phylo Name)
branchedRevBayes :: Parser (Tree Phylo Name)
branchedRevBayes = (Parser (Tree Phylo Name) -> String -> Parser (Tree Phylo Name)
forall i a. Parser i a -> String -> Parser i a
<?> String
"branchedRevgBayes") (Parser (Tree Phylo Name) -> Parser (Tree Phylo Name))
-> Parser (Tree Phylo Name) -> Parser (Tree Phylo Name)
forall a b. (a -> b) -> a -> b
$ do
  Forest Phylo Name
f <- Parser (Forest Phylo Name)
forestRevBayes
  Name
n <- Parser Name
nameRevBayes
  Maybe Length
b <- Parser ByteString Length -> Parser ByteString (Maybe Length)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser ByteString Length
branchLengthRevBayes
  Tree Phylo Name -> Parser (Tree Phylo Name)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree Phylo Name -> Parser (Tree Phylo Name))
-> Tree Phylo Name -> Parser (Tree Phylo Name)
forall a b. (a -> b) -> a -> b
$ Phylo -> Name -> Forest Phylo Name -> Tree Phylo Name
forall e a. e -> a -> Forest e a -> Tree e a
Node (Maybe Length -> Maybe Support -> Phylo
Phylo Maybe Length
b Maybe Support
forall a. Maybe a
Nothing) Name
n Forest Phylo Name
f

forestRevBayes :: Parser (Forest Phylo Name)
forestRevBayes :: Parser (Forest Phylo Name)
forestRevBayes = (Parser (Forest Phylo Name) -> String -> Parser (Forest Phylo Name)
forall i a. Parser i a -> String -> Parser i a
<?> String
"forestRevBayes") (Parser (Forest Phylo Name) -> Parser (Forest Phylo Name))
-> Parser (Forest Phylo Name) -> Parser (Forest Phylo Name)
forall a b. (a -> b) -> a -> b
$ do
  Char
_ <- Char -> Parser ByteString Char
char Char
'('
  Forest Phylo Name
f <- Parser (Tree Phylo Name)
treeRevBayes Parser (Tree Phylo Name)
-> Parser ByteString Char -> Parser (Forest Phylo Name)
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy1` Char -> Parser ByteString Char
char Char
','
  Char
_ <- Char -> Parser ByteString Char
char Char
')'
  Forest Phylo Name -> Parser (Forest Phylo Name)
forall (m :: * -> *) a. Monad m => a -> m a
return Forest Phylo Name
f

nameRevBayes :: Parser Name
nameRevBayes :: Parser Name
nameRevBayes = Parser Name
name Parser Name -> Parser ByteString (Maybe ()) -> Parser Name
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser () -> Parser ByteString (Maybe ())
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser ()
brackets Parser Name -> String -> Parser Name
forall i a. Parser i a -> String -> Parser i a
<?> String
"nameRevBayes"

branchLengthRevBayes :: Parser Length
branchLengthRevBayes :: Parser ByteString Length
branchLengthRevBayes = Parser ByteString Length
branchLengthStandard Parser ByteString Length
-> Parser ByteString (Maybe ()) -> Parser ByteString Length
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser () -> Parser ByteString (Maybe ())
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser ()
brackets Parser ByteString Length -> String -> Parser ByteString Length
forall i a. Parser i a -> String -> Parser i a
<?> String
"branchLengthRevBayes"

leafRevBayes :: Parser (Tree Phylo Name)
leafRevBayes :: Parser (Tree Phylo Name)
leafRevBayes = (Parser (Tree Phylo Name) -> String -> Parser (Tree Phylo Name)
forall i a. Parser i a -> String -> Parser i a
<?> String
"leafRevBayes") (Parser (Tree Phylo Name) -> Parser (Tree Phylo Name))
-> Parser (Tree Phylo Name) -> Parser (Tree Phylo Name)
forall a b. (a -> b) -> a -> b
$ do
  Name
n <- Parser Name
nameRevBayes
  Maybe Length
b <- Parser ByteString Length -> Parser ByteString (Maybe Length)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser ByteString Length
branchLengthRevBayes
  Tree Phylo Name -> Parser (Tree Phylo Name)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree Phylo Name -> Parser (Tree Phylo Name))
-> Tree Phylo Name -> Parser (Tree Phylo Name)
forall a b. (a -> b) -> a -> b
$ Phylo -> Name -> Forest Phylo Name -> Tree Phylo Name
forall e a. e -> a -> Forest e a -> Tree e a
Node (Maybe Length -> Maybe Support -> Phylo
Phylo Maybe Length
b Maybe Support
forall a. Maybe a
Nothing) Name
n []

-- NOTE: Drop anything between brackets.
brackets :: Parser ()
brackets :: Parser ()
brackets = (Parser () -> String -> Parser ()
forall i a. Parser i a -> String -> Parser i a
<?> String
"brackets") (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ do
  Char
_ <- Char -> Parser ByteString Char
char Char
'['
  ByteString
_ <- (Char -> Bool) -> Parser ByteString ByteString
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
']')
  Char
_ <- Char -> Parser ByteString Char
char Char
']'
  () -> Parser ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()