{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE StandaloneDeriving #-}
module Symantic.Parser.Grammar.View where

import Data.Bool (Bool)
import Data.Eq (Eq(..))
import Data.Function (($), (.), id, on)
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String)
import Data.Tuple (fst)
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.Tree as Tree
import Prelude (undefined)
import Control.DeepSeq (NFData(..))

import Symantic.Semantics.SharingObserver
import Symantic.Semantics.Data (normalOrderReduction)
import Symantic.Parser.Grammar.Combinators
import Symantic.Parser.Grammar.SharingObserver
import qualified Symantic.Parser.Grammar.Production as Prod
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH

-- * Type 'ViewGrammar'
newtype ViewGrammar (showName::Bool) a = ViewGrammar { unViewGrammar :: Tree.Tree (String, String) }
  deriving (NFData, TH.Lift)

viewGrammar :: ViewGrammar sN a -> ViewGrammar sN a
viewGrammar = id

instance Show (ViewGrammar sN a) where
  show = List.unlines . draw . unViewGrammar
    where
    draw :: Tree.Tree (String, String) -> [String]
    draw (Tree.Node (x, n) ts0) =
      (List.zipWith (<>) (List.lines x) (n : List.repeat "")) <>
      (drawTrees ts0)
    drawTrees [] = []
    drawTrees [t] = shift "` " "  " (draw t)
    drawTrees (t:ts) = shift "+ " "| " (draw t) <> drawTrees ts
    shift ind0 ind = List.zipWith (<>) (ind0 : List.repeat ind)

instance CombAlternable (ViewGrammar sN) where
  empty = ViewGrammar $ Tree.Node ("empty", "") []
  alt exn x y = ViewGrammar $ Tree.Node
    ("<|>" <> if exn == ExceptionFailure then "" else ("^"<>show exn), "")
    [unViewGrammar x, unViewGrammar y]
  throw exn = ViewGrammar $ Tree.Node ("throw "<>show exn, "") []
  try x = ViewGrammar $ Tree.Node ("try", "") [unViewGrammar x]
instance CombApplicable (ViewGrammar sN) where
  _f <$> x = ViewGrammar $ Tree.Node ("<$>", "") [unViewGrammar x]
  pure a = ViewGrammar $ Tree.Node ("pure "<>show a, "") []
  x <*> y = ViewGrammar $ Tree.Node ("<*>", "") [unViewGrammar x, unViewGrammar y]
  x <* y = ViewGrammar $ Tree.Node ("<*", "") [unViewGrammar x, unViewGrammar y]
  x *> y = ViewGrammar $ Tree.Node ("*>", "") [unViewGrammar x, unViewGrammar y]
instance CombFoldable (ViewGrammar sN) where
  chainPre f x = ViewGrammar $ Tree.Node ("chainPre", "") [unViewGrammar f, unViewGrammar x]
  chainPost x f = ViewGrammar $ Tree.Node ("chainPost", "") [unViewGrammar x, unViewGrammar f]
instance
  ( Show letName
  , HideName letName
  , HideableName sN
  ) => Referenceable letName (ViewGrammar sN) where
  ref isRec name = ViewGrammar $
    Tree.Node
      ( if isRec then "rec" else "ref"
      , " "<>show (hideableName @sN name)
      ) []
instance
  ( Show letName
  , HideName letName
  , HideableName sN
  ) => Letsable letName (ViewGrammar sN) where
  lets defs x = ViewGrammar $
    Tree.Node ("lets", "") $
      (<> [unViewGrammar x]) $
      List.sortBy (compare `on` (((fst Functor.<$>) Functor.<$>) . Tree.levels)) $
      HM.foldrWithKey'
        (\name (SomeLet val) ->
          (Tree.Node ("let", " "<>show (hideableName @sN name)) [unViewGrammar val] :))
        [] defs
instance CombLookable (ViewGrammar sN) where
  look x = ViewGrammar $ Tree.Node ("look", "") [unViewGrammar x]
  negLook x = ViewGrammar $ Tree.Node ("negLook", "") [unViewGrammar x]
  eof = ViewGrammar $ Tree.Node ("eof", "") []
instance CombMatchable (ViewGrammar sN) where
  conditional a bs d = ViewGrammar $ Tree.Node ("conditional", "")
    $ Tree.Node ("condition", "") [unViewGrammar a]
    : Tree.Node ("default", "") [unViewGrammar d]
    : ((\(p,b) -> Tree.Node ("branch "<>show p, "") [unViewGrammar b]) Functor.<$> bs)
instance CombSatisfiable tok (ViewGrammar sN) where
  satisfyOrFail p = ViewGrammar $ Tree.Node ("satisfy "<>show p, "") []
instance CombSelectable (ViewGrammar sN) where
  branch lr l r = ViewGrammar $ Tree.Node ("branch", "")
    [ unViewGrammar lr, unViewGrammar l, unViewGrammar r ]
instance CombRegisterableUnscoped (ViewGrammar sN) where
  newUnscoped r x y = ViewGrammar $ Tree.Node ("new "<>show r, "") [ unViewGrammar x,  unViewGrammar y ]
  getUnscoped r = ViewGrammar $ Tree.Node ("get "<>show r, "") [ ]
  putUnscoped r x = ViewGrammar $ Tree.Node ("put "<>show r, "") [ unViewGrammar x ]
instance CombRegisterable (ViewGrammar sN) where
  new x f = undefined
  get = undefined
  put = undefined
  -- FIXME