{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module      :  ELynx.Import.Nexus
-- Description :  Nexus types and classes
-- Copyright   :  2021 Dominik Schrempf
-- License     :  GPL-3
--
-- Maintainer  :  dominik.schrempf@gmail.com
-- Stability   :  unstable
-- Portability :  portable
--
-- Creation date: Tue Apr 28 17:10:05 2020.
module ELynx.Import.Nexus
  ( Block (..),
    nexusBlock,
  )
where

import Control.Applicative
import Data.Attoparsec.ByteString.Char8
import Data.Attoparsec.Combinator
import qualified Data.ByteString.Char8 as BS

-- | A Nexus block has a name (e.g., TREES), and parser for the entry.
data Block a = Block
  { forall a. Block a -> ByteString
name :: BS.ByteString,
    forall a. Block a -> Parser a
parser :: Parser a
  }

-- This has to be refined. Like this, only one block can be parsed, and the
-- block type has to be known beforehand.

-- | Parse a given 'Block' in a Nexus file.
--
-- The Nexus file can contain other blocks.
nexusBlock :: Block a -> Parser a
nexusBlock :: forall a. Block a -> Parser a
nexusBlock Block a
b = do
  Parser ()
start
  [Char]
_ <- forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
manyTill Parser Char
anyChar (forall i a. Parser i a -> Parser i a
lookAhead forall a b. (a -> b) -> a -> b
$ forall a. Block a -> Parser ()
beginB Block a
b) forall i a. Parser i a -> [Char] -> Parser i a
<?> [Char]
"nexusBlockSkipUntilBlock"
  a
r <- forall a. Block a -> Parser a
block Block a
b forall i a. Parser i a -> [Char] -> Parser i a
<?> [Char]
"nexusBlock"
  [Char]
_ <- forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser Char
anyChar forall i a. Parser i a -> [Char] -> Parser i a
<?> [Char]
"nexusBlockSkipUntilEnd"
  ()
_ <- forall t. Chunk t => Parser t ()
endOfInput
  forall (m :: * -> *) a. Monad m => a -> m a
return a
r

start :: Parser ()
start :: Parser ()
start = do
  ByteString
_ <- ByteString -> Parser ByteString ByteString
stringCI ByteString
"#nexus" forall i a. Parser i a -> [Char] -> Parser i a
<?> [Char]
"nexusStart"
  (Char -> Bool) -> Parser ()
skipWhile Char -> Bool
isSpace
  forall (m :: * -> *) a. Monad m => a -> m a
return ()

block :: Block a -> Parser a
block :: forall a. Block a -> Parser a
block Block a
b = do
  forall a. Block a -> Parser ()
beginB Block a
b
  a
r <- forall a. Block a -> Parser a
parser Block a
b forall i a. Parser i a -> [Char] -> Parser i a
<?> [Char]
"blockParser"
  Parser ()
endB
  forall (m :: * -> *) a. Monad m => a -> m a
return a
r

beginB :: Block a -> Parser ()
beginB :: forall a. Block a -> Parser ()
beginB (Block ByteString
n Parser a
_) = do
  ByteString
_ <- ByteString -> Parser ByteString ByteString
stringCI ByteString
"begin" forall i a. Parser i a -> [Char] -> Parser i a
<?> [Char]
"blockBegin"
  (Char -> Bool) -> Parser ()
skipWhile Char -> Bool
isSpace
  ByteString
_ <- ByteString -> Parser ByteString ByteString
stringCI ByteString
n forall i a. Parser i a -> [Char] -> Parser i a
<?> [Char]
"blockName"
  Char
_ <- Char -> Parser Char
char Char
';' forall i a. Parser i a -> [Char] -> Parser i a
<?> [Char]
"blockEnd"
  (Char -> Bool) -> Parser ()
skipWhile Char -> Bool
isSpace
  forall (m :: * -> *) a. Monad m => a -> m a
return ()

endB :: Parser ()
endB :: Parser ()
endB = do
  ByteString
_ <- ByteString -> Parser ByteString ByteString
stringCI ByteString
"end;" forall i a. Parser i a -> [Char] -> Parser i a
<?> [Char]
"nexusEnd"
  (Char -> Bool) -> Parser ()
skipWhile Char -> Bool
isSpace
  forall (m :: * -> *) a. Monad m => a -> m a
return ()