{-# LANGUAGE OverloadedStrings #-}
module Symantic.Parser.Grammar.Write where

import Data.Function (($))
import qualified Data.Functor as Pre
import Control.Monad (Monad(..))
import Data.Maybe (Maybe(..), fromMaybe, catMaybes)
import Data.String (IsString(..))
import Data.Semigroup (Semigroup(..))
import Data.Monoid (Monoid(..))
import Text.Show (Show(..))
import qualified Data.List as List
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB

import Symantic.Base.Fixity
import Symantic.Univariant.Letable
import Symantic.Parser.Grammar.Combinators

-- * Type 'WriteGrammar'
newtype WriteGrammar a = WriteGrammar { unWriteGrammar :: WriteGrammarInh -> Maybe TLB.Builder }

instance IsString (WriteGrammar a) where
  fromString s = WriteGrammar $ \_inh ->
    if List.null s then Nothing
    else Just (fromString s)

-- ** Type 'WriteGrammarInh'
data WriteGrammarInh
 =   WriteGrammarInh
 {   writeGrammarInh_indent :: TLB.Builder
 ,   writeGrammarInh_op :: (Infix, Side)
 ,   writeGrammarInh_pair :: Pair
 }

emptyWriteGrammarInh :: WriteGrammarInh
emptyWriteGrammarInh = WriteGrammarInh
 { writeGrammarInh_indent = "\n"
 , writeGrammarInh_op = (infixN0, SideL)
 , writeGrammarInh_pair = pairParen
 }

writeGrammar :: WriteGrammar a -> TL.Text
writeGrammar (WriteGrammar r) = TLB.toLazyText $ fromMaybe "" $ r emptyWriteGrammarInh

pairWriteGrammarInh ::
 Semigroup s => IsString s =>
 WriteGrammarInh -> Infix -> Maybe s -> Maybe s
pairWriteGrammarInh inh op s =
  if isPairNeeded (writeGrammarInh_op inh) op
  then Just (fromString o<>" ")<>s<>Just (" "<>fromString c)
  else s
  where (o,c) = writeGrammarInh_pair inh

instance Show letName => Letable letName WriteGrammar where
  def name x = WriteGrammar $ \inh ->
    pairWriteGrammarInh inh op $
      Just "def "
      <> Just (fromString (show name))
      <> unWriteGrammar x inh
    where
    op = infixN 9
  ref rec name = WriteGrammar $ \inh ->
    pairWriteGrammarInh inh op $
      Just (if rec then "rec " else "ref ") <>
      Just (fromString (show name))
    where
    op = infixN 9
instance Applicable WriteGrammar where
  pure _ = WriteGrammar $ return Nothing
  -- pure _ = "pure"
  WriteGrammar x <*> WriteGrammar y = WriteGrammar $ \inh ->
    let inh' side = inh
         { writeGrammarInh_op = (op, side)
         , writeGrammarInh_pair = pairParen
         } in
    case x (inh' SideL) of
     Nothing -> y (inh' SideR)
     Just xt ->
      case y (inh' SideR) of
       Nothing -> Just xt
       Just yt ->
        pairWriteGrammarInh inh op $
          Just $ xt <> ", " <> yt
    where
    op = infixN 1
instance Alternable WriteGrammar where
  empty = "empty"
  try x = WriteGrammar $ \inh ->
    pairWriteGrammarInh inh op $
      Just "try " <> unWriteGrammar x inh
    where
    op = infixN 9
  x <|> y = WriteGrammar $ \inh ->
    pairWriteGrammarInh inh op $
    unWriteGrammar x inh
     { writeGrammarInh_op = (op, SideL)
     , writeGrammarInh_pair = pairParen
     } <>
    Just " | " <>
    unWriteGrammar y inh
     { writeGrammarInh_op = (op, SideR)
     , writeGrammarInh_pair = pairParen
     }
    where op = infixB SideL 3
instance Charable WriteGrammar where
  satisfy _f = "sat"
instance Selectable WriteGrammar where
  branch lr l r = WriteGrammar $ \inh ->
    pairWriteGrammarInh inh op $
      Just "branch " <>
      unWriteGrammar lr inh <> Just " " <>
      unWriteGrammar l inh <> Just " " <>
      unWriteGrammar r inh
    where
    op = infixN 9
instance Matchable WriteGrammar where
  conditional _cs bs a b = WriteGrammar $ \inh ->
    pairWriteGrammarInh inh op $
      Just "conditional " <>
      Just "[" <>
      Just (mconcat (List.intersperse ", " $
      catMaybes $ (Pre.<$> bs) $ \x ->
        unWriteGrammar x inh{writeGrammarInh_op=(infixN 0, SideL)})) <>
      Just "] " <>
      unWriteGrammar a inh <> Just " " <>
      unWriteGrammar b inh
    where
    op = infixN 9
instance Lookable WriteGrammar where
  look x = WriteGrammar $ \inh ->
    pairWriteGrammarInh inh op $
      Just "look " <> unWriteGrammar x inh
    where op = infixN 9
  negLook x = WriteGrammar $ \inh ->
    pairWriteGrammarInh inh op $
      Just "negLook " <> unWriteGrammar x inh
    where op = infixN 9
instance Foldable WriteGrammar where
  chainPre f x = WriteGrammar $ \inh ->
    pairWriteGrammarInh inh op $
      Just "chainPre " <>
      unWriteGrammar f inh <> Just " " <>
      unWriteGrammar x inh
    where op = infixN 9
  chainPost f x = WriteGrammar $ \inh ->
    pairWriteGrammarInh inh op $
      Just "chainPost " <>
      unWriteGrammar f inh <> Just " " <>
      unWriteGrammar x inh
    where op = infixN 9