{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}

-- |
-- Module      :  TLynx.Connect.Connect
-- Description :  Connect two phylogenies
-- Copyright   :  (c) Dominik Schrempf 2020
-- License     :  GPL-3.0-or-later
--
-- Maintainer  :  dominik.schrempf@gmail.com
-- Stability   :  unstable
-- Portability :  portable
--
-- Creation date: Thu Sep 19 15:01:52 2019.
module TLynx.Connect.Connect
  ( connectCmd,
  )
where

import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Trans.Reader (ask)
import qualified Data.ByteString.Lazy.Char8 as BL
import qualified Data.Set as S
import ELynx.Tools
  ( Arguments (..),
    ELynx,
    fromBs,
    outHandle,
    tShow,
  )
import ELynx.Tree
import System.IO
import TLynx.Connect.Options
import TLynx.Parsers

-- Connect two trees with a branch in all possible ways.
--
-- Introduce a branch between two trees. If the trees have @n>2@, and @m>2@
-- nodes, respectively, there are (n-2)*(m-2) ways to connect them.
--
-- A base node label has to be given which will be used wherever the new node is
-- introduced.
--
-- Return 'Left' if one tree has a non-bifurcating root node.
connect :: (Semigroup e, Splittable e) => e -> a -> Tree e a -> Tree e a -> Either String (Forest e a)
connect :: e -> a -> Tree e a -> Tree e a -> Either String (Forest e a)
connect e
br a
lb Tree e a
l Tree e a
r = do
  Forest e a
ls <- Tree e a -> Either String (Forest e a)
forall e a.
(Semigroup e, Splittable e) =>
Tree e a -> Either String (Forest e a)
roots Tree e a
l
  Forest e a
rs <- Tree e a -> Either String (Forest e a)
forall e a.
(Semigroup e, Splittable e) =>
Tree e a -> Either String (Forest e a)
roots Tree e a
r
  Forest e a -> Either String (Forest e a)
forall (m :: * -> *) a. Monad m => a -> m a
return [e -> a -> Forest e a -> Tree e a
forall e a. e -> a -> Forest e a -> Tree e a
Node e
br a
lb [Tree e a
x, Tree e a
y] | Tree e a
x <- Forest e a
ls, Tree e a
y <- Forest e a
rs]

-- | Connect two trees honoring possible constraints.
--
-- Introduce a branch between two trees. If the trees have @n>2@, and @m>2@
-- nodes, respectively, there are (n-2)*(m-2) ways to connect them.
connectCmd :: ELynx ConnectArguments ()
connectCmd :: ELynx ConnectArguments ()
connectCmd = do
  ConnectArguments
lArgs <- Arguments ConnectArguments -> ConnectArguments
forall a. Arguments a -> a
local (Arguments ConnectArguments -> ConnectArguments)
-> ReaderT
     (Arguments ConnectArguments)
     (LoggingT IO)
     (Arguments ConnectArguments)
-> ReaderT
     (Arguments ConnectArguments) (LoggingT IO) ConnectArguments
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT
  (Arguments ConnectArguments)
  (LoggingT IO)
  (Arguments ConnectArguments)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  Handle
outH <- String -> String -> ELynx ConnectArguments Handle
forall a. Reproducible a => String -> String -> ELynx a Handle
outHandle String
"results" String
".out"
  -- Do we have constraints or not?
  let cs :: Maybe String
cs = ConnectArguments -> Maybe String
constraints ConnectArguments
lArgs
      l :: String
l = ConnectArguments -> String
inFileA ConnectArguments
lArgs
      r :: String
r = ConnectArguments -> String
inFileB ConnectArguments
lArgs
  case Maybe String
cs of
    Maybe String
Nothing -> Handle -> String -> String -> ELynx ConnectArguments ()
connectOnly Handle
outH String
l String
r
    Just String
c -> Handle -> String -> String -> String -> ELynx ConnectArguments ()
connectAndFilter Handle
outH String
c String
l String
r
  IO () -> ELynx ConnectArguments ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ELynx ConnectArguments ())
-> IO () -> ELynx ConnectArguments ()
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
hClose Handle
outH

connectTrees ::
  Tree Length Name ->
  Tree Length Name ->
  Forest Length Name
connectTrees :: Tree Length Name -> Tree Length Name -> Forest Length Name
connectTrees Tree Length Name
t = (String -> Forest Length Name)
-> (Forest Length Name -> Forest Length Name)
-> Either String (Forest Length Name)
-> Forest Length Name
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Forest Length Name
forall a. HasCallStack => String -> a
error Forest Length Name -> Forest Length Name
forall a. a -> a
id (Either String (Forest Length Name) -> Forest Length Name)
-> (Tree Length Name -> Either String (Forest Length Name))
-> Tree Length Name
-> Forest Length Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Length
-> Name
-> Tree Length Name
-> Tree Length Name
-> Either String (Forest Length Name)
forall e a.
(Semigroup e, Splittable e) =>
e -> a -> Tree e a -> Tree e a -> Either String (Forest e a)
connect Length
0 Name
"root" Tree Length Name
t

type Constraint a = S.Set a

-- Get groups induced by multifurcations. Collect the leaves of all trees
-- induced by multifurcations.
multifurcatingGroups :: Tree e a -> [[a]]
multifurcatingGroups :: Tree e a -> [[a]]
multifurcatingGroups (Node e
_ a
_ []) = []
multifurcatingGroups (Node e
_ a
_ [Tree e a
x]) = Tree e a -> [[a]]
forall e a. Tree e a -> [[a]]
multifurcatingGroups Tree e a
x
multifurcatingGroups (Node e
_ a
_ [Tree e a
x, Tree e a
y]) = Tree e a -> [[a]]
forall e a. Tree e a -> [[a]]
multifurcatingGroups Tree e a
x [[a]] -> [[a]] -> [[a]]
forall a. [a] -> [a] -> [a]
++ Tree e a -> [[a]]
forall e a. Tree e a -> [[a]]
multifurcatingGroups Tree e a
y
multifurcatingGroups Tree e a
t = Tree e a -> [a]
forall e a. Tree e a -> [a]
leaves Tree e a
t [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: (Tree e a -> [[a]]) -> [Tree e a] -> [[a]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Tree e a -> [[a]]
forall e a. Tree e a -> [[a]]
multifurcatingGroups (Tree e a -> [Tree e a]
forall e a. Tree e a -> Forest e a
forest Tree e a
t)

compatibleAll :: (Show a, Ord a) => Tree e a -> [Constraint a] -> Bool
compatibleAll :: Tree e a -> [Constraint a] -> Bool
compatibleAll t :: Tree e a
t@(Node e
_ a
_ [Tree e a
l, Tree e a
r]) [Constraint a]
cs =
  (Constraint a -> Bool) -> [Constraint a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Partition a -> Partition a -> Bool
forall a. (Show a, Ord a) => Partition a -> Partition a -> Bool
compatible Partition a
partitionLeft (Partition a -> Bool)
-> (Constraint a -> Partition a) -> Constraint a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Constraint a -> Partition a
getP) [Constraint a]
cs
    Bool -> Bool -> Bool
&& (Constraint a -> Bool) -> [Constraint a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Partition a -> Partition a -> Bool
forall a. (Show a, Ord a) => Partition a -> Partition a -> Bool
compatible Partition a
partitionRight (Partition a -> Bool)
-> (Constraint a -> Partition a) -> Constraint a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Constraint a -> Partition a
getP) [Constraint a]
cs
  where
    lvs :: Constraint a
lvs = [a] -> Constraint a
forall a. Ord a => [a] -> Set a
S.fromList ([a] -> Constraint a) -> [a] -> Constraint a
forall a b. (a -> b) -> a -> b
$ Tree e a -> [a]
forall e a. Tree e a -> [a]
leaves Tree e a
t
    getP :: Constraint a -> Partition a
getP Constraint a
x = (String -> Partition a)
-> (Partition a -> Partition a)
-> Either String (Partition a)
-> Partition a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Partition a
forall a. HasCallStack => String -> a
error Partition a -> Partition a
forall a. a -> a
id (Either String (Partition a) -> Partition a)
-> Either String (Partition a) -> Partition a
forall a b. (a -> b) -> a -> b
$ [Constraint a] -> Either String (Partition a)
forall a. Ord a => [Set a] -> Either String (Partition a)
pt [Constraint a
x, Constraint a
lvs Constraint a -> Constraint a -> Constraint a
forall a. Ord a => Set a -> Set a -> Set a
S.\\ Constraint a
x]
    partitionLeft :: Partition a
partitionLeft = (String -> Partition a)
-> (Partition a -> Partition a)
-> Either String (Partition a)
-> Partition a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Partition a
forall a. HasCallStack => String -> a
error Partition a -> Partition a
forall a. a -> a
id (Either String (Partition a) -> Partition a)
-> Either String (Partition a) -> Partition a
forall a b. (a -> b) -> a -> b
$ Tree e a -> Either String (Partition a)
forall a e. Ord a => Tree e a -> Either String (Partition a)
partition Tree e a
l
    partitionRight :: Partition a
partitionRight = (String -> Partition a)
-> (Partition a -> Partition a)
-> Either String (Partition a)
-> Partition a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Partition a
forall a. HasCallStack => String -> a
error Partition a -> Partition a
forall a. a -> a
id (Either String (Partition a) -> Partition a)
-> Either String (Partition a) -> Partition a
forall a b. (a -> b) -> a -> b
$ Tree e a -> Either String (Partition a)
forall a e. Ord a => Tree e a -> Either String (Partition a)
partition Tree e a
r
compatibleAll Tree e a
_ [Constraint a]
_ = String -> Bool
forall a. HasCallStack => String -> a
error String
"Tree is not bifurcating."

compatibleWith ::
  (Show b, Ord b) => (a -> b) -> [Constraint a] -> Tree e a -> Bool
compatibleWith :: (a -> b) -> [Constraint a] -> Tree e a -> Bool
compatibleWith a -> b
f [Constraint a]
cs Tree e a
t = Tree e b -> [Constraint b] -> Bool
forall a e. (Show a, Ord a) => Tree e a -> [Constraint a] -> Bool
compatibleAll ((a -> b) -> Tree e a -> Tree e b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Tree e a
t) ((Constraint a -> Constraint b) -> [Constraint a] -> [Constraint b]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> b) -> Constraint a -> Constraint b
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map a -> b
f) [Constraint a]
cs)

parseTreeTuple ::
  FilePath ->
  FilePath ->
  ELynx
    ConnectArguments
    (Tree Length Name, Tree Length Name)
parseTreeTuple :: String
-> String
-> ELynx ConnectArguments (Tree Length Name, Tree Length Name)
parseTreeTuple String
l String
r = do
  NewickFormat
nwF <- ConnectArguments -> NewickFormat
nwFormat (ConnectArguments -> NewickFormat)
-> (Arguments ConnectArguments -> ConnectArguments)
-> Arguments ConnectArguments
-> NewickFormat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arguments ConnectArguments -> ConnectArguments
forall a. Arguments a -> a
local (Arguments ConnectArguments -> NewickFormat)
-> ReaderT
     (Arguments ConnectArguments)
     (LoggingT IO)
     (Arguments ConnectArguments)
-> ReaderT (Arguments ConnectArguments) (LoggingT IO) NewickFormat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT
  (Arguments ConnectArguments)
  (LoggingT IO)
  (Arguments ConnectArguments)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  Tree Phylo Name
tl <- IO (Tree Phylo Name)
-> ReaderT
     (Arguments ConnectArguments) (LoggingT IO) (Tree Phylo Name)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Tree Phylo Name)
 -> ReaderT
      (Arguments ConnectArguments) (LoggingT IO) (Tree Phylo Name))
-> IO (Tree Phylo Name)
-> ReaderT
     (Arguments ConnectArguments) (LoggingT IO) (Tree Phylo Name)
forall a b. (a -> b) -> a -> b
$ NewickFormat -> String -> IO (Tree Phylo Name)
parseTree NewickFormat
nwF String
l
  Tree Phylo Name
tr <- IO (Tree Phylo Name)
-> ReaderT
     (Arguments ConnectArguments) (LoggingT IO) (Tree Phylo Name)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Tree Phylo Name)
 -> ReaderT
      (Arguments ConnectArguments) (LoggingT IO) (Tree Phylo Name))
-> IO (Tree Phylo Name)
-> ReaderT
     (Arguments ConnectArguments) (LoggingT IO) (Tree Phylo Name)
forall a b. (a -> b) -> a -> b
$ NewickFormat -> String -> IO (Tree Phylo Name)
parseTree NewickFormat
nwF String
r
  $(Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> ELynx ConnectArguments ()
(Text -> ELynx ConnectArguments ())
-> (Text -> Text) -> Text -> ELynx ConnectArguments ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
id :: forall a. a -> a
logInfo) Text
"Tree 1:"
  $(Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> ELynx ConnectArguments ()
(Text -> ELynx ConnectArguments ())
-> (Text -> Text) -> Text -> ELynx ConnectArguments ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
id :: forall a. a -> a
logInfo) (Text -> ELynx ConnectArguments ())
-> Text -> ELynx ConnectArguments ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
fromBs (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Tree Phylo Name -> ByteString
forall a. HasName a => Tree Phylo a -> ByteString
toNewick Tree Phylo Name
tl
  $(Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> ELynx ConnectArguments ()
(Text -> ELynx ConnectArguments ())
-> (Text -> Text) -> Text -> ELynx ConnectArguments ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
id :: forall a. a -> a
logInfo) Text
"Tree 2:"
  $(Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> ELynx ConnectArguments ()
(Text -> ELynx ConnectArguments ())
-> (Text -> Text) -> Text -> ELynx ConnectArguments ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
id :: forall a. a -> a
logInfo) (Text -> ELynx ConnectArguments ())
-> Text -> ELynx ConnectArguments ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
fromBs (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Tree Phylo Name -> ByteString
forall a. HasName a => Tree Phylo a -> ByteString
toNewick Tree Phylo Name
tr
  (Tree Length Name, Tree Length Name)
-> ELynx ConnectArguments (Tree Length Name, Tree Length Name)
forall (m :: * -> *) a. Monad m => a -> m a
return ((String -> Tree Length Name)
-> (Tree Length Name -> Tree Length Name)
-> Either String (Tree Length Name)
-> Tree Length Name
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Tree Length Name
forall a. HasCallStack => String -> a
error Tree Length Name -> Tree Length Name
forall a. a -> a
id (Either String (Tree Length Name) -> Tree Length Name)
-> Either String (Tree Length Name) -> Tree Length Name
forall a b. (a -> b) -> a -> b
$ Tree Phylo Name -> Either String (Tree Length Name)
forall a. Tree Phylo a -> Either String (Tree Length a)
phyloToLengthTree Tree Phylo Name
tl, (String -> Tree Length Name)
-> (Tree Length Name -> Tree Length Name)
-> Either String (Tree Length Name)
-> Tree Length Name
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Tree Length Name
forall a. HasCallStack => String -> a
error Tree Length Name -> Tree Length Name
forall a. a -> a
id (Either String (Tree Length Name) -> Tree Length Name)
-> Either String (Tree Length Name) -> Tree Length Name
forall a b. (a -> b) -> a -> b
$ Tree Phylo Name -> Either String (Tree Length Name)
forall a. Tree Phylo a -> Either String (Tree Length a)
phyloToLengthTree Tree Phylo Name
tr)

connectOnly :: Handle -> FilePath -> FilePath -> ELynx ConnectArguments ()
connectOnly :: Handle -> String -> String -> ELynx ConnectArguments ()
connectOnly Handle
h String
l String
r = do
  (Tree Length Name
tl, Tree Length Name
tr) <- String
-> String
-> ELynx ConnectArguments (Tree Length Name, Tree Length Name)
parseTreeTuple String
l String
r
  let ts :: Forest Length Name
ts = Tree Length Name -> Tree Length Name -> Forest Length Name
connectTrees Tree Length Name
tl Tree Length Name
tr
  $(Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> ELynx ConnectArguments ()
(Text -> ELynx ConnectArguments ())
-> (Text -> Text) -> Text -> ELynx ConnectArguments ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
id :: forall a. a -> a
logInfo) (Text -> ELynx ConnectArguments ())
-> Text -> ELynx ConnectArguments ()
forall a b. (a -> b) -> a -> b
$ Text
"Connected trees: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tShow (Forest Length Name -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Forest Length Name
ts)
  IO () -> ELynx ConnectArguments ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ELynx ConnectArguments ())
-> IO () -> ELynx ConnectArguments ()
forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
BL.hPutStr Handle
h (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
BL.unlines ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ (Tree Length Name -> ByteString)
-> Forest Length Name -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (Tree Phylo Name -> ByteString
forall a. HasName a => Tree Phylo a -> ByteString
toNewick (Tree Phylo Name -> ByteString)
-> (Tree Length Name -> Tree Phylo Name)
-> Tree Length Name
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree Length Name -> Tree Phylo Name
forall e a. HasLength e => Tree e a -> Tree Phylo a
measurableToPhyloTree) Forest Length Name
ts

connectAndFilter ::
  Handle -> FilePath -> FilePath -> FilePath -> ELynx ConnectArguments ()
connectAndFilter :: Handle -> String -> String -> String -> ELynx ConnectArguments ()
connectAndFilter Handle
h String
c String
l String
r = do
  NewickFormat
nwF <- ConnectArguments -> NewickFormat
nwFormat (ConnectArguments -> NewickFormat)
-> (Arguments ConnectArguments -> ConnectArguments)
-> Arguments ConnectArguments
-> NewickFormat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arguments ConnectArguments -> ConnectArguments
forall a. Arguments a -> a
local (Arguments ConnectArguments -> NewickFormat)
-> ReaderT
     (Arguments ConnectArguments)
     (LoggingT IO)
     (Arguments ConnectArguments)
-> ReaderT (Arguments ConnectArguments) (LoggingT IO) NewickFormat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT
  (Arguments ConnectArguments)
  (LoggingT IO)
  (Arguments ConnectArguments)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  Forest Phylo Name
cts <- IO (Forest Phylo Name)
-> ReaderT
     (Arguments ConnectArguments) (LoggingT IO) (Forest Phylo Name)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Forest Phylo Name)
 -> ReaderT
      (Arguments ConnectArguments) (LoggingT IO) (Forest Phylo Name))
-> IO (Forest Phylo Name)
-> ReaderT
     (Arguments ConnectArguments) (LoggingT IO) (Forest Phylo Name)
forall a b. (a -> b) -> a -> b
$ NewickFormat -> String -> IO (Forest Phylo Name)
parseTrees NewickFormat
nwF String
c
  $(Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> ELynx ConnectArguments ()
(Text -> ELynx ConnectArguments ())
-> (Text -> Text) -> Text -> ELynx ConnectArguments ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
id :: forall a. a -> a
logInfo) Text
"Constraints:"
  $(Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> ELynx ConnectArguments ()
(Text -> ELynx ConnectArguments ())
-> (Text -> Text) -> Text -> ELynx ConnectArguments ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
id :: forall a. a -> a
logInfo) (Text -> ELynx ConnectArguments ())
-> Text -> ELynx ConnectArguments ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
fromBs (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString] -> ByteString
BL.intercalate ByteString
"\n" ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ (Tree Phylo Name -> ByteString)
-> Forest Phylo Name -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map Tree Phylo Name -> ByteString
forall a. HasName a => Tree Phylo a -> ByteString
toNewick Forest Phylo Name
cts
  (Tree Length Name
tl, Tree Length Name
tr) <- String
-> String
-> ELynx ConnectArguments (Tree Length Name, Tree Length Name)
parseTreeTuple String
l String
r
  let ts :: Forest Length Name
ts = Tree Length Name -> Tree Length Name -> Forest Length Name
connectTrees Tree Length Name
tl Tree Length Name
tr
      cs :: [Constraint Name]
cs = ([Name] -> Constraint Name) -> [[Name]] -> [Constraint Name]
forall a b. (a -> b) -> [a] -> [b]
map [Name] -> Constraint Name
forall a. Ord a => [a] -> Set a
S.fromList ([[Name]] -> [Constraint Name]) -> [[Name]] -> [Constraint Name]
forall a b. (a -> b) -> a -> b
$ (Tree Phylo Name -> [[Name]]) -> Forest Phylo Name -> [[Name]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Tree Phylo Name -> [[Name]]
forall e a. Tree e a -> [[a]]
multifurcatingGroups Forest Phylo Name
cts :: [Constraint Name]
      -- Only collect trees that are compatible with the constraints.
      ts' :: Forest Length Name
ts' = (Tree Length Name -> Bool)
-> Forest Length Name -> Forest Length Name
forall a. (a -> Bool) -> [a] -> [a]
filter ((Name -> Name) -> [Constraint Name] -> Tree Length Name -> Bool
forall b a e.
(Show b, Ord b) =>
(a -> b) -> [Constraint a] -> Tree e a -> Bool
compatibleWith Name -> Name
forall a. HasName a => a -> Name
getName [Constraint Name]
cs) Forest Length Name
ts
  $(Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> ELynx ConnectArguments ()
(Text -> ELynx ConnectArguments ())
-> (Text -> Text) -> Text -> ELynx ConnectArguments ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
id :: forall a. a -> a
logInfo) (Text -> ELynx ConnectArguments ())
-> Text -> ELynx ConnectArguments ()
forall a b. (a -> b) -> a -> b
$ Text
"Connected  trees: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tShow (Forest Length Name -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Forest Length Name
ts)
  $(Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> ELynx ConnectArguments ()
(Text -> ELynx ConnectArguments ())
-> (Text -> Text) -> Text -> ELynx ConnectArguments ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
id :: forall a. a -> a
logInfo) (Text -> ELynx ConnectArguments ())
-> Text -> ELynx ConnectArguments ()
forall a b. (a -> b) -> a -> b
$ Text
"Compatible trees: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tShow (Forest Length Name -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Forest Length Name
ts')
  IO () -> ELynx ConnectArguments ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ELynx ConnectArguments ())
-> IO () -> ELynx ConnectArguments ()
forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
BL.hPutStr Handle
h (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
BL.unlines ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ (Tree Length Name -> ByteString)
-> Forest Length Name -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (Tree Phylo Name -> ByteString
forall a. HasName a => Tree Phylo a -> ByteString
toNewick (Tree Phylo Name -> ByteString)
-> (Tree Length Name -> Tree Phylo Name)
-> Tree Length Name
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree Length Name -> Tree Phylo Name
forall e a. HasLength e => Tree e a -> Tree Phylo a
measurableToPhyloTree) Forest Length Name
ts'