# LANGUAGE GeneralizedNewtypeDeriving #
{-# LANGUAGE OverloadedStrings #-}

module Amy.Syntax.Monad
  ( AmyParser
  , runAmyParser
  , withBlockIndentation
  , currentIndentation
  , assertIndented
  , assertSameIndentation
  , indentedBlock
  , indentedBlockNonEmpty
  ) where

import Control.Applicative (Alternative)
import qualified Control.Applicative.Combinators.NonEmpty as CNE
import Control.Monad.State.Strict
import Data.List.NonEmpty (NonEmpty)
import Data.Monoid ((<>))
import Data.Text (Text, pack, unpack)
import Data.Void (Void)
import Text.Megaparsec hiding (State)

import Amy.Syntax.Lexer

newtype AmyParser a = AmyParser (StateT Int (Parsec Void AmyTokens) a)
  deriving (Functor, Applicative, Alternative, MonadPlus, Monad, MonadState Int, MonadParsec Void AmyTokens)

runAmyParser :: AmyParser a -> Parsec Void AmyTokens a
runAmyParser (AmyParser action) = evalStateT action 0

withBlockIndentation :: AmyParser a -> AmyParser a
withBlockIndentation action = do
  originalIndent <- currentIndentation
  nextIndent <- maybe (unexpected EndOfInput) (pure . unPos . sourceColumn) =<< getNextTokenPosition
  setIndentation nextIndent
  result <- action
  setIndentation originalIndent
  pure result

currentIndentation :: AmyParser Int
currentIndentation = get

setIndentation :: Int -> AmyParser ()
setIndentation x = modify' (const x)

-- | Check that the current indentation level is past the stored indentation
assertIndented :: AmyParser ()
assertIndented = checkIndentation "indentation past column" (>)

-- | Check that the current indentation level is the same as the stored indentation
assertSameIndentation :: AmyParser ()
assertSameIndentation = checkIndentation "indentation at column" (==)

-- | Check that the current identation level matches a predicate
checkIndentation
  :: Text
  -> (Int -> Int -> Bool)
  -> AmyParser ()
checkIndentation msg rel = do
  currentIndent <- currentIndentation
  nextIndent <- maybe (unexpected EndOfInput) (pure . unPos . sourceColumn) =<< getNextTokenPosition
  guard (nextIndent `rel` currentIndent) <?> unpack (msg <> " " <> pack (show currentIndent))

-- A block is defined as a group of things that are at the same indentation
-- level. Block items can also be separated by semicolons.
indentedBlock
  :: AmyParser a
  -> AmyParser [a]
indentedBlock p =
  fmap concat $ withBlockIndentation $ many $
    assertSameIndentation *> p `sepBy1` semiColon

indentedBlockNonEmpty
  :: AmyParser a
  -> AmyParser (NonEmpty a)
indentedBlockNonEmpty p =
  fmap join $ withBlockIndentation $ CNE.some $
    assertSameIndentation *> p `CNE.sepBy1` semiColon

# LANGUAGE OverloadedStrings #
 | Check that the current indentation level is past the stored indentation
 | Check that the current indentation level is the same as the stored indentation
 | Check that the current identation level matches a predicate
 A block is defined as a group of things that are at the same indentation
 level. Block items can also be separated by semicolons.
# LANGUAGE GeneralizedNewtypeDeriving #

module Amy.Syntax.Monad
  ( AmyParser
  , runAmyParser
  , withBlockIndentation
  , currentIndentation
  , assertIndented
  , assertSameIndentation
  , indentedBlock
  , indentedBlockNonEmpty
  ) where

import Control.Applicative (Alternative)
import qualified Control.Applicative.Combinators.NonEmpty as CNE
import Control.Monad.State.Strict
import Data.List.NonEmpty (NonEmpty)
import Data.Monoid ((<>))
import Data.Text (Text, pack, unpack)
import Data.Void (Void)
import Text.Megaparsec hiding (State)

import Amy.Syntax.Lexer

newtype AmyParser a = AmyParser (StateT Int (Parsec Void AmyTokens) a)
  deriving (Functor, Applicative, Alternative, MonadPlus, Monad, MonadState Int, MonadParsec Void AmyTokens)

runAmyParser :: AmyParser a -> Parsec Void AmyTokens a
runAmyParser (AmyParser action) = evalStateT action 0

withBlockIndentation :: AmyParser a -> AmyParser a
withBlockIndentation action = do
  originalIndent <- currentIndentation
  nextIndent <- maybe (unexpected EndOfInput) (pure . unPos . sourceColumn) =<< getNextTokenPosition
  setIndentation nextIndent
  result <- action
  setIndentation originalIndent
  pure result

currentIndentation :: AmyParser Int
currentIndentation = get

setIndentation :: Int -> AmyParser ()
setIndentation x = modify' (const x)

assertIndented :: AmyParser ()
assertIndented = checkIndentation "indentation past column" (>)

assertSameIndentation :: AmyParser ()
assertSameIndentation = checkIndentation "indentation at column" (==)

checkIndentation
  :: Text
  -> (Int -> Int -> Bool)
  -> AmyParser ()
checkIndentation msg rel = do
  currentIndent <- currentIndentation
  nextIndent <- maybe (unexpected EndOfInput) (pure . unPos . sourceColumn) =<< getNextTokenPosition
  guard (nextIndent `rel` currentIndent) <?> unpack (msg <> " " <> pack (show currentIndent))

indentedBlock
  :: AmyParser a
  -> AmyParser [a]
indentedBlock p =
  fmap concat $ withBlockIndentation $ many $
    assertSameIndentation *> p `sepBy1` semiColon

indentedBlockNonEmpty
  :: AmyParser a
  -> AmyParser (NonEmpty a)
indentedBlockNonEmpty p =
  fmap join $ withBlockIndentation $ CNE.some $
    assertSameIndentation *> p `CNE.sepBy1` semiColon
