Write.hs

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

import Control.Monad (Monad(..))
import Data.Bool (Bool(..))
import Data.Function (($))
import Data.Maybe (Maybe(..), fromMaybe, catMaybes)
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.String (IsString(..))
import Language.Haskell.TH.HideName
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.ObserveSharing
import Symantic.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{-TODO: print?-}
  -- 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
  ( Show letName
  , HideName letName
  , HideableName sN
  ) => Referenceable letName (WriteGrammar sN) where
  ref isRec name = WriteGrammar $ \inh ->
    pairWriteGrammarInh inh op $
      Just (if isRec then "rec " else "ref ") <>
      Just (fromString (show (hideableName @sN name)))
    where
    op = infixN 9
instance
  ( Show letName
  , HideName letName
  , HideableName sN
  ) => Letsable letName (WriteGrammar sN) where
  lets defs x = WriteGrammar $ \inh ->
    pairWriteGrammarInh inh op $
      Just "let "
      <> HM.foldMapWithKey
        (\name (SomeLet val) ->
          Just (fromString (show (hideableName @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 bs d = WriteGrammar $ \inh ->
    pairWriteGrammarInh inh op $
      Just "conditional " <>
      unWriteGrammar a inh <>
      unWriteGrammar d inh <>
      Just " [" <>
      Just (mconcat (List.intersperse ", " $
      catMaybes $ (Functor.<$> bs) $ \(p{-TODO: print?-}, b) ->
        unWriteGrammar b inh{writeGrammarInh_op=(infixN 0, SideL)})) <>
      Just "] "
    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