Write.hs

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

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

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

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

instance IsString (WriteGrammar sN 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 sN 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
  ShowLetName sN letName =>
  Letable letName (WriteGrammar sN) where
  def name x = WriteGrammar $ \inh ->
    pairWriteGrammarInh inh op $
      Just "def "
      <> Just (fromString (showLetName @sN 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 (showLetName @sN name))
    where
    op = infixN 9
instance Applicable (WriteGrammar sN) 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 sN) 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 Satisfiable tok (WriteGrammar sN) where
  satisfy _es _f = "satisfy"
instance Selectable (WriteGrammar sN) 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 sN) where
  conditional a _ps bs d = WriteGrammar $ \inh ->
    pairWriteGrammarInh inh op $
      Just "conditional " <>
      unWriteGrammar a inh <>
      Just " [" <>
      Just (mconcat (List.intersperse ", " $
      catMaybes $ (Pre.<$> bs) $ \x ->
        unWriteGrammar x inh{writeGrammarInh_op=(infixN 0, SideL)})) <>
      Just "] " <>
      unWriteGrammar d inh
    where
    op = infixN 9
instance Lookable (WriteGrammar sN) 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
  eof = "eof"
instance Foldable (WriteGrammar sN) 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