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 Text.Show (Show(..))
import qualified Data.Functor as Functor
import qualified Data.HashMap.Strict as HM
import qualified Data.List as List
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB

import Symantic.Typed.ObserveSharing
import Symantic.Typed.Fixity
import Symantic.Parser.Grammar.Combinators

-- * 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 go) =
  TLB.toLazyText $ fromMaybe "" $
  go 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 CombAlternable (WriteGrammar sN) where
  alt exn x y = WriteGrammar $ \inh ->
    pairWriteGrammarInh inh op $
    unWriteGrammar x inh
     { writeGrammarInh_op = (op, SideL)
     , writeGrammarInh_pair = pairParen
     } <>
    Just (" |^"<>fromString (show exn)<>" ") <>
    unWriteGrammar y inh
     { writeGrammarInh_op = (op, SideR)
     , writeGrammarInh_pair = pairParen
     }
    where op = infixB SideL 3
  throw exn = WriteGrammar $ \inh ->
    pairWriteGrammarInh inh op $
      Just ("throw "<>fromString (show exn))
    where
    op = infixN 9
  failure _sf = "failure"
  empty = "empty"
  try x = WriteGrammar $ \inh ->
    pairWriteGrammarInh inh op $
      Just "try " <> unWriteGrammar x inh
    where
    op = infixN 9
instance CombApplicable (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 CombFoldable (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
instance
  ShowLetName sN letName =>
  Letable letName (WriteGrammar sN) where
  shareable name x = WriteGrammar $ \inh ->
    pairWriteGrammarInh inh op $
      Just "shareable "
      <> 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
  ShowLetName sN letName =>
  Letsable letName (WriteGrammar sN) where
  lets defs x = WriteGrammar $ \inh ->
    pairWriteGrammarInh inh op $
      Just "let "
      <> HM.foldMapWithKey
        (\name (SomeLet val) ->
          Just (fromString (showLetName @sN name))
          <> unWriteGrammar val inh)
        defs
      <> unWriteGrammar x inh
    where
    op = infixN 9
instance CombLookable (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 CombMatchable (WriteGrammar sN) where
  conditional a _ps bs d = WriteGrammar $ \inh ->
    pairWriteGrammarInh inh op $
      Just "conditional " <>
      unWriteGrammar a inh <>
      Just " [" <>
      Just (mconcat (List.intersperse ", " $
      catMaybes $ (Functor.<$> bs) $ \x ->
        unWriteGrammar x inh{writeGrammarInh_op=(infixN 0, SideL)})) <>
      Just "] " <>
      unWriteGrammar d inh
    where
    op = infixN 9
instance CombSatisfiable tok (WriteGrammar sN) where
  satisfyOrFail _fs _f = "satisfy"
instance CombSelectable (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