{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module      :  ELynx.Import.Nexus
-- Description :  Nexus types and classes
-- Copyright   :  (c) Dominik Schrempf 2021
-- 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
  { Block a -> ByteString
name :: BS.ByteString,
    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 :: Block a -> Parser a
nexusBlock Block a
b = do
  Parser ()
start
  [Char]
_ <- Parser ByteString Char -> Parser () -> Parser ByteString [Char]
forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
manyTill Parser ByteString Char
anyChar (Parser () -> Parser ()
forall i a. Parser i a -> Parser i a
lookAhead (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ Block a -> Parser ()
forall a. Block a -> Parser ()
beginB Block a
b) Parser ByteString [Char] -> [Char] -> Parser ByteString [Char]
forall i a. Parser i a -> [Char] -> Parser i a
<?> [Char]
"nexusBlockSkipUntilBlock"
  a
r <- Block a -> Parser a
forall a. Block a -> Parser a
block Block a
b Parser a -> [Char] -> Parser a
forall i a. Parser i a -> [Char] -> Parser i a
<?> [Char]
"nexusBlock"
  [Char]
_ <- Parser ByteString Char -> Parser ByteString [Char]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser ByteString Char
anyChar Parser ByteString [Char] -> [Char] -> Parser ByteString [Char]
forall i a. Parser i a -> [Char] -> Parser i a
<?> [Char]
"nexusBlockSkipUntilEnd"
  ()
_ <- Parser ()
forall t. Chunk t => Parser t ()
endOfInput
  a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r

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

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

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

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