{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Text.TEIWA.Source.Common (
      AnnotationContext(..)
    , Field
    , Row
    , TEIWAParser
    , annotationContext
    , eol
    , recordLine
  ) where

import Control.Applicative ((<|>))
import Control.Monad.Except (MonadError(..))
import Control.Monad.Reader (MonadReader(..), ReaderT)
import Data.List (findIndex)
import Data.Text.Lazy as Text (Text, toLower, unpack)
import Text.Parsec (
      Column, Line, ParsecT, Stream, char, endOfLine, getParserState, sourceLine, statePos
    , try
  )
import Text.TEIWA.Config (Config(..))
import Text.TEIWA.Error (Error(..))

data AnnotationContext = AnnotationContext {
      columnIndex :: Column
    , columnName :: Text
    , header :: Header
  }

type Field = Text
type Header = [Text]
type Row = (Line, [Field])

type TEIWAParser = ParsecT Text () (ReaderT Config (Either Error))

eol :: Stream s m Char => ParsecT s u m ()
eol = (try endOfLine <|> char '\r') *> return ()

recordLine :: Monad m => ParsecT s u m a -> ParsecT s u m (Line, a)
recordLine p = (,) <$> currentLine <*> p
  where
    currentLine = sourceLine . statePos <$> getParserState

annotationContext :: Header -> TEIWAParser AnnotationContext
annotationContext defaultFields = do
  Config {formColumn, headerOverride} <- ask
  --headerFields <- maybe defaultFields pure headerOverride
  let headerFields = maybe defaultFields id headerOverride
  column <- catchNothing ((Right <$> formColumn) <|> findForm headerFields)
  buildContext column headerFields
  where
    findForm = fmap Left . findIndex ((==) "form" . Text.toLower)
    catchNothing = maybe (throwError NoFormColumn) return

buildContext :: MonadError Error m =>
  Either Int Text -> Header -> m AnnotationContext
buildContext column = build . either splitAt (break . (==)) column
  where
    build (_, []) =
      throwError . NoSuchColumn $ either (\_ -> "form") Text.unpack column
    build (before, columnName:after) =
      let columnIndex = length before in
      let header = (before ++ after) in
      return $ AnnotationContext {columnIndex, columnName, header}