Write.hs

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

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 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 'WriteComb'
newtype WriteComb a = WriteComb { unWriteComb :: WriteCombInh -> Maybe TLB.Builder }

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

-- ** Type 'WriteCombInh'
data WriteCombInh
 =   WriteCombInh
 {   writeCombInh_indent :: TLB.Builder
 ,   writeCombInh_op :: (Infix, Side)
 ,   writeCombInh_pair :: Pair
 }

emptyWriteCombInh :: WriteCombInh
emptyWriteCombInh = WriteCombInh
 { writeCombInh_indent = "\n"
 , writeCombInh_op = (infixN0, SideL)
 , writeCombInh_pair = pairParen
 }

writeComb :: WriteComb a -> TL.Text
writeComb (WriteComb r) = TLB.toLazyText $ fromMaybe "" $ r emptyWriteCombInh

pairWriteCombInh ::
 Semigroup s => IsString s =>
 WriteCombInh -> Infix -> Maybe s -> Maybe s
pairWriteCombInh inh op s =
  if isPairNeeded (writeCombInh_op inh) op
  then Just (fromString o<>" ")<>s<>Just (" "<>fromString c)
  else s
  where (o,c) = writeCombInh_pair inh

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