{-# LANGUAGE DeriveGeneric #-}
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)
data NewickFormat = Standard | IqTree | RevBayes
deriving (NewickFormat -> NewickFormat -> Bool
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
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]
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
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]
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. 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 :: NewickFormat -> Parser (Tree Phylo Name)
newick :: NewickFormat -> Parser (Tree Phylo Name)
newick NewickFormat
f = case NewickFormat
f of
NewickFormat
Standard -> forall {a}. Parser ByteString a -> Parser ByteString a
p Parser (Tree Phylo Name)
tree
NewickFormat
IqTree -> 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 forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString a
t forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
char Char
';' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (Char -> Bool) -> Parser ()
skipWhile Char -> Bool
isSpace forall i a. Parser i a -> String -> Parser i a
<?> String
"newick"
oneNewick :: NewickFormat -> Parser (Tree Phylo Name)
oneNewick :: NewickFormat -> Parser (Tree Phylo Name)
oneNewick NewickFormat
f = NewickFormat -> Parser (Tree Phylo Name)
newick NewickFormat
f forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall t. Chunk t => Parser t ()
endOfInput forall i a. Parser i a -> String -> Parser i a
<?> String
"oneNewick"
parseOneNewick :: NewickFormat -> BS.ByteString -> Either String (Tree Phylo Name)
parseOneNewick :: NewickFormat -> ByteString -> Either String (Tree Phylo Name)
parseOneNewick NewickFormat
f = forall a. Parser a -> ByteString -> Either String a
parseOnly (NewickFormat -> Parser (Tree Phylo Name)
oneNewick NewickFormat
f)
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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => String -> a
error forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. NewickFormat -> ByteString -> Either String (Tree Phylo Name)
parseOneNewick NewickFormat
f)
someNewick :: NewickFormat -> Parser (Forest Phylo Name)
someNewick :: NewickFormat -> Parser (Forest Phylo Name)
someNewick NewickFormat
f = forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (NewickFormat -> Parser (Tree Phylo Name)
newick NewickFormat
f) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall t. Chunk t => Parser t ()
endOfInput forall i a. Parser i a -> String -> Parser i a
<?> String
"someNewick"
parseSomeNewick :: NewickFormat -> BS.ByteString -> Either String [Tree Phylo Name]
parseSomeNewick :: NewickFormat -> ByteString -> Either String (Forest Phylo Name)
parseSomeNewick NewickFormat
f = forall a. Parser a -> ByteString -> Either String a
parseOnly (NewickFormat -> Parser (Forest Phylo Name)
someNewick NewickFormat
f)
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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => String -> a
error forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser (Tree Phylo Name)
leaf forall i a. Parser i a -> String -> Parser i a
<?> String
"tree"
branched :: Parser (Tree Phylo Name)
branched :: Parser (Tree Phylo Name)
branched = (forall i a. Parser i a -> String -> Parser i a
<?> String
"branched") 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
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall e a. e -> a -> Forest e a -> Tree e a
Node Phylo
p Name
n Forest Phylo Name
f
forestSep :: Parser ()
forestSep :: Parser ()
forestSep = Char -> Parser Char
char Char
',' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser ()
skipWhile Char -> Bool
isSpace
forest :: Parser (Forest Phylo Name)
forest :: Parser (Forest Phylo Name)
forest = Char -> Parser Char
char Char
'(' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Parser (Tree Phylo Name)
tree forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy1` Parser ()
forestSep) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
char Char
')' forall i a. Parser i a -> String -> Parser i a
<?> String
"forest"
leaf :: Parser (Tree Phylo Name)
leaf :: Parser (Tree Phylo Name)
leaf = (forall i a. Parser i a -> String -> Parser i a
<?> String
"leaf") forall a b. (a -> b) -> a -> b
$ do
Name
n <- Parser Name
name
Phylo
p <- Parser Phylo
phylo
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
" :;()[],"
nameNotQuoted :: Parser Name
nameNotQuoted :: Parser Name
nameNotQuoted = ByteString -> Name
Name forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.fromStrict forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser ByteString
takeWhile Char -> Bool
nameChar forall i a. Parser i a -> String -> Parser i a
<?> String
"nameNoQuotes"
noClosingQuote :: Char -> Bool
noClosingQuote :: Char -> Bool
noClosingQuote Char
c = Char
c forall a. Eq a => a -> a -> Bool
/= Char
'\''
nameQuoted :: Parser Name
nameQuoted :: Parser Name
nameQuoted = (forall i a. Parser i a -> String -> Parser i a
<?> String
"nameQuotes") forall a b. (a -> b) -> a -> b
$ do
Char
_ <- Char -> Parser Char
char Char
'\''
Name
n <- ByteString -> Name
Name forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.fromStrict forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser ByteString
takeWhile Char -> Bool
noClosingQuote forall i a. Parser i a -> String -> Parser i a
<?> String
"nameQuoted"
Char
_ <- Char -> Parser Char
char Char
'\''
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n
name :: Parser Name
name :: Parser Name
name = (Char -> Bool) -> Parser ()
skipWhile Char -> Bool
isSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Parser Name
nameQuoted forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Name
nameNotQuoted) 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser Length
branchLengthStandard forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser Support
branchSupportStandard forall i a. Parser i a -> String -> Parser i a
<?> String
"phylo"
branchLengthSimple :: Parser Length
branchLengthSimple :: Parser Length
branchLengthSimple = (forall i a. Parser i a -> String -> Parser i a
<?> String
"branchLengthSimple") forall a b. (a -> b) -> a -> b
$ do
Double
l <- Parser ByteString Double
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 -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
e
Right Length
pl -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Length
pl
branchLengthStandard :: Parser Length
branchLengthStandard :: Parser Length
branchLengthStandard = do
()
_ <- (Char -> Bool) -> Parser ()
skipWhile Char -> Bool
isSpace
Char
_ <- Char -> Parser Char
char Char
':' forall i a. Parser i a -> String -> Parser i a
<?> String
"branchLengthDelimiter"
()
_ <- (Char -> Bool) -> Parser ()
skipWhile Char -> Bool
isSpace
Parser Length
branchLengthSimple
branchSupportSimple :: Parser Support
branchSupportSimple :: Parser Support
branchSupportSimple = (forall i a. Parser i a -> String -> Parser i a
<?> String
"branchSupportSimple") forall a b. (a -> b) -> a -> b
$
do
Double
s <- Parser ByteString Double
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 -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
e
Right Support
ps -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Support
ps
branchSupportStandard :: Parser Support
branchSupportStandard :: Parser Support
branchSupportStandard = (forall i a. Parser i a -> String -> Parser i a
<?> String
"branchSupportStandard") forall a b. (a -> b) -> a -> b
$ do
Char
_ <- Char -> Parser Char
char Char
'[' forall i a. Parser i a -> String -> Parser i a
<?> String
"branchSupportBegin"
Support
s <- Parser Support
branchSupportSimple
Char
_ <- Char -> Parser Char
char Char
']' forall i a. Parser i a -> String -> Parser i a
<?> String
"branchSupportEnd"
forall (m :: * -> *) a. Monad m => a -> m a
return Support
s
treeIqTree :: Parser (Tree Phylo Name)
treeIqTree :: Parser (Tree Phylo Name)
treeIqTree = Parser (Tree Phylo Name)
branchedIqTree forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser (Tree Phylo Name)
leaf forall i a. Parser i a -> String -> Parser i a
<?> String
"treeIqTree"
branchedIqTree :: Parser (Tree Phylo Name)
branchedIqTree :: Parser (Tree Phylo Name)
branchedIqTree = (forall i a. Parser i a -> String -> Parser i a
<?> String
"branchedIqTree") forall a b. (a -> b) -> a -> b
$ do
Forest Phylo Name
f <- Parser (Forest Phylo Name)
forestIqTree
Maybe Support
ms <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser Support
branchSupportSimple
Name
n <- Parser Name
name
Maybe Length
mb <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser Length
branchLengthStandard
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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
forestIqTree :: Parser (Forest Phylo Name)
forestIqTree :: Parser (Forest Phylo Name)
forestIqTree = (forall i a. Parser i a -> String -> Parser i a
<?> String
"forestIqTree") forall a b. (a -> b) -> a -> b
$ do
Char
_ <- Char -> Parser Char
char Char
'('
Forest Phylo Name
f <- Parser (Tree Phylo Name)
treeIqTree forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy1` Parser ()
forestSep
Char
_ <- Char -> Parser Char
char Char
')'
forall (m :: * -> *) a. Monad m => a -> m a
return Forest Phylo Name
f
newickRevBayes :: Parser (Tree Phylo Name)
newickRevBayes :: Parser (Tree Phylo Name)
newickRevBayes =
(Char -> Bool) -> Parser ()
skipWhile Char -> Bool
isSpace
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser ()
brackets
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser (Tree Phylo Name)
treeRevBayes
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
char Char
';'
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (Char -> Bool) -> Parser ()
skipWhile Char -> Bool
isSpace
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 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser (Tree Phylo Name)
leafRevBayes forall i a. Parser i a -> String -> Parser i a
<?> String
"treeRevBayes"
branchedRevBayes :: Parser (Tree Phylo Name)
branchedRevBayes :: Parser (Tree Phylo Name)
branchedRevBayes = (forall i a. Parser i a -> String -> Parser i a
<?> String
"branchedRevgBayes") 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 <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser Length
branchLengthRevBayes
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall e a. e -> a -> Forest e a -> Tree e a
Node (Maybe Length -> Maybe Support -> Phylo
Phylo Maybe Length
b forall a. Maybe a
Nothing) Name
n Forest Phylo Name
f
forestRevBayes :: Parser (Forest Phylo Name)
forestRevBayes :: Parser (Forest Phylo Name)
forestRevBayes = (forall i a. Parser i a -> String -> Parser i a
<?> String
"forestRevBayes") forall a b. (a -> b) -> a -> b
$ do
Char
_ <- Char -> Parser Char
char Char
'('
Forest Phylo Name
f <- Parser (Tree Phylo Name)
treeRevBayes forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy1` Parser ()
forestSep
Char
_ <- Char -> Parser Char
char Char
')'
forall (m :: * -> *) a. Monad m => a -> m a
return Forest Phylo Name
f
nameRevBayes :: Parser Name
nameRevBayes :: Parser Name
nameRevBayes = Parser Name
name forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser ()
brackets forall i a. Parser i a -> String -> Parser i a
<?> String
"nameRevBayes"
branchLengthRevBayes :: Parser Length
branchLengthRevBayes :: Parser Length
branchLengthRevBayes = Parser Length
branchLengthStandard forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser ()
brackets forall i a. Parser i a -> String -> Parser i a
<?> String
"branchLengthRevBayes"
leafRevBayes :: Parser (Tree Phylo Name)
leafRevBayes :: Parser (Tree Phylo Name)
leafRevBayes = (forall i a. Parser i a -> String -> Parser i a
<?> String
"leafRevBayes") forall a b. (a -> b) -> a -> b
$ do
Name
n <- Parser Name
nameRevBayes
Maybe Length
b <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser Length
branchLengthRevBayes
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall e a. e -> a -> Forest e a -> Tree e a
Node (Maybe Length -> Maybe Support -> Phylo
Phylo Maybe Length
b forall a. Maybe a
Nothing) Name
n []
brackets :: Parser ()
brackets :: Parser ()
brackets = (forall i a. Parser i a -> String -> Parser i a
<?> String
"brackets") forall a b. (a -> b) -> a -> b
$ do
Char
_ <- Char -> Parser Char
char Char
'['
ByteString
_ <- (Char -> Bool) -> Parser ByteString
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
']')
Char
_ <- Char -> Parser Char
char Char
']'
forall (m :: * -> *) a. Monad m => a -> m a
return ()