{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveLift #-}
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 Control.DeepSeq (NFData(..))
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH
import Prelude (undefined)
import Debug.Trace

import Symantic.Semantics.SharingObserver
import Symantic.Semantics.Viewer.Fixity
import Symantic.Parser.Grammar.Combinators
import Symantic.Parser.Grammar.SharingObserver

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

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

-- ** Type 'WriteGrammarEnv'
data WriteGrammarEnv
 =   WriteGrammarEnv
 {   writeGrammarEnvIndent :: TLB.Builder
 ,   writeGrammarEnvOpFixity :: Infix
 ,   writeGrammarEnvOpSide :: Side
 ,   writeGrammarEnvPair :: Pair
 } deriving (Show)

writeGrammar :: WriteGrammar sN a -> TL.Text
writeGrammar (WriteGrammar go) =
  TLB.toLazyText $ fromMaybe "" $
  go WriteGrammarEnv
    { writeGrammarEnvIndent = "\n"
    , writeGrammarEnvOpFixity = infixN0
    , writeGrammarEnvOpSide = SideL
    , writeGrammarEnvPair = pairParen
    }

instance Show (WriteGrammar sN a) where
  show = TL.unpack . writeGrammar

writeGrammarPair ::
  Infix -> (WriteGrammarEnv -> Maybe TLB.Builder) -> WriteGrammar sN a
writeGrammarPair op wg = WriteGrammar $ \env ->
  let newEnv = env{writeGrammarEnvOpFixity=op, writeGrammarEnvOpSide=SideL} in
  if isPairNeeded (writeGrammarEnvOpFixity env, writeGrammarEnvOpSide env) op
  then
    let (o,c) = writeGrammarEnvPair env in
    Just (fromString o)<> wg newEnv <> Just (fromString c)
  else wg newEnv

instance CombAlternable (WriteGrammar sN) where
  alt exn x y = writeGrammarPair (infixB SideL 3) $ \env ->
    unWriteGrammar x env
     { writeGrammarEnvOpSide = SideL
     , writeGrammarEnvPair = pairParen
     } <>
    Just (" |^"<>fromString (show exn)<>" ") <>
    unWriteGrammar y env
     { writeGrammarEnvOpSide = SideR
     , writeGrammarEnvPair = pairParen
     }
  throw exn = writeGrammarPair (infixN 9) $ \env ->
    Just ("throw "<>fromString (show exn))
  empty = "empty"
  try x = writeGrammarPair (infixN 9) $ \env ->
    Just "try " <> unWriteGrammar x env
instance CombApplicable (WriteGrammar sN) where
  pure _ = WriteGrammar $ return Nothing{-TODO: print?-}
  -- pure _ = "pure"
  x <*> y = writeGrammarPair (infixB SideL 4) $ \env ->
    let env' side = env { writeGrammarEnvPair = pairParen } in
    case unWriteGrammar x (env' SideL) of
      Nothing -> unWriteGrammar y (env' SideR)
      Just xText ->
       case unWriteGrammar y (env' SideR) of
         Nothing -> Just xText
         Just _yText ->
           unWriteGrammar x env{writeGrammarEnvOpSide = SideL} <>
           Just " " <>
           unWriteGrammar y env{writeGrammarEnvOpSide = SideR}
instance CombFoldable (WriteGrammar sN) where
  chainPre f x = writeGrammarPair (infixN 9) $ \env ->
    Just "chainPre " <>
    unWriteGrammar f env <> Just " " <>
    unWriteGrammar x env
  chainPost f x = writeGrammarPair (infixN 9) $ \env ->
    Just "chainPost " <>
    unWriteGrammar f env <> Just " " <>
    unWriteGrammar x env
instance
  ( Show letName
  , HideName letName
  , HideableName sN
  ) => Referenceable letName (WriteGrammar sN) where
  ref isRec name = writeGrammarPair (infixN 9) $ \env ->
    Just (if isRec then "rec " else "ref ") <>
    Just (fromString (show (hideableName @sN name)))
instance
  ( Show letName
  , HideName letName
  , HideableName sN
  ) => Letsable letName (WriteGrammar sN) where
  lets defs x = writeGrammarPair (infixN 9) $ \env ->
    Just "let "
    <> HM.foldMapWithKey
      (\name (SomeLet val) ->
        Just (fromString (show (hideableName @sN name)))
        <> unWriteGrammar val env)
      defs
    <> unWriteGrammar x env
instance CombLookable (WriteGrammar sN) where
  look x = writeGrammarPair (infixN 9) $ \env ->
    Just "look " <> unWriteGrammar x env
  negLook x = writeGrammarPair (infixN 9) $ \env ->
    Just "negLook " <> unWriteGrammar x env
  eof = "eof"
instance CombMatchable (WriteGrammar sN) where
  conditional a bs d = writeGrammarPair (infixN 9) $ \env ->
    Just "conditional " <>
    unWriteGrammar a env <>
    unWriteGrammar d env <>
    Just " [" <>
    Just (mconcat (List.intersperse ", " $
    catMaybes $ (Functor.<$> bs) $ \(p{-TODO: print?-}, b) ->
      unWriteGrammar b env
        { writeGrammarEnvOpFixity = infixN 0
        , writeGrammarEnvOpSide = SideL
        })) <>
    Just "] "
instance CombSatisfiable tok (WriteGrammar sN) where
  satisfyOrFail p = writeGrammarPair (infixN 9) $ \env ->
    Just "satisfy " <>
    Just (fromString (showsPrec 10 p ""))
instance CombSelectable (WriteGrammar sN) where
  branch lr l r = writeGrammarPair (infixN 9) $ \env ->
    Just "branch " <>
    unWriteGrammar lr env <> Just " " <>
    unWriteGrammar l env <> Just " " <>
    unWriteGrammar r env
instance CombRegisterableUnscoped (WriteGrammar sN) where
  newUnscoped r x y = writeGrammarPair (infixN 9) $ \env ->
    Just "newUnscoped " <> Just (fromString (show r)) <>
    unWriteGrammar x env <> Just " " <>
    unWriteGrammar y env
  getUnscoped r = writeGrammarPair (infixN 9) $ \env ->
    Just "getUnscoped " <> Just (fromString (show r))
  putUnscoped r x = writeGrammarPair (infixN 9) $ \env ->
    Just "putUnscoped " <> Just (fromString (show r)) <>
    unWriteGrammar x env
instance CombRegisterable (WriteGrammar sN) where
  new x f = undefined
  get = undefined
  put = undefined
  -- FIXME