{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
module Parsers.Brainfuck.SymanticParser.Grammar where

import Data.Char (Char)
import Data.Function ((.))
import qualified Language.Haskell.TH.Syntax as TH
import qualified Prelude

import Symantic.Univariant.Trans
import qualified Symantic.Parser as SP
import qualified Symantic.Parser.Haskell as H

import Parsers.Utils
import Parsers.Brainfuck.Types

haskell :: TH.Lift a => a -> SP.TermGrammar a
haskell a = H.Term (H.ValueCode a [||a||])

-- | Use with @$$(runParser @Text grammar)@,
-- but in another Haskell module to avoid
-- GHC stage restriction on such top-level splice.
grammar :: forall tok repr.
  CoerceEnum Char tok =>
  CoerceEnum tok Char =>
  SP.Grammarable tok repr =>
  repr [Instruction]
grammar = whitespace SP.*> bf
  where
  whitespace = SP.skipMany (SP.noneOf (coerceEnum @_ @tok Prelude.<$> "<>+-,.[]"))
  lexeme :: repr a -> repr a
  lexeme p = p SP.<* whitespace
  bf :: repr [Instruction]
  bf = SP.many (lexeme (SP.match (SP.look (SP.item @tok))
                               (haskell . coerceEnum Prelude.<$> "<>+-,.[")
                               op SP.empty))
  op :: H.Term H.ValueCode tok -> repr Instruction
  op (trans -> H.ValueCode c _) = case coerceEnum c of
    '<' -> SP.item @tok SP.$> SP.code Backward
    '>' -> SP.item @tok SP.$> SP.code Forward
    '+' -> SP.item @tok SP.$> SP.code Increment
    '-' -> SP.item @tok SP.$> SP.code Decrement
    ',' -> SP.item @tok SP.$> SP.code Input
    '.' -> SP.item @tok SP.$> SP.code Output
    '[' -> SP.between (lexeme (SP.item @tok))
                      (SP.token (coerceEnum @_ @tok ']'))
                      (H.Term (H.ValueCode Loop [||Loop||]) SP.<$> bf)
    _ -> Prelude.undefined