module Symantic.Parser.Grammar.View where

import Data.Bool (Bool)
import Data.Function (($), (.), id, on)
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String)
import Data.Tuple (fst)
import GHC.TypeLits (symbolVal)
import Text.Show (Show(..))
import qualified Control.Applicative as Fct
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 Symantic.Univariant.Letable
import Symantic.Parser.Grammar.Combinators

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

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", "") []
  x <|> y = ViewGrammar $ Tree.Node ("<|>", "") [unViewGrammar x, unViewGrammar y]
  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 "<>showsPrec 10 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
  ShowLetName sN letName =>
  Letable letName (ViewGrammar sN) where
  shareable name x = ViewGrammar $
    Tree.Node ("shareable", " "<>showLetName @sN name) [unViewGrammar x]
  ref isRec name = ViewGrammar $
    Tree.Node
      ( if isRec then "rec" else "ref"
      , " "<>showLetName @sN name
      ) []
instance
  ShowLetName sN letName =>
  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", " "<>showLetName @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 _ps bs b = ViewGrammar $ Tree.Node ("conditional", "")
    [ unViewGrammar a
    , Tree.Node ("branches", "") (unViewGrammar Fct.<$> bs)
    , unViewGrammar b
    ]
instance CombSatisfiable tok (ViewGrammar sN) where
  satisfy _es _p = ViewGrammar $ Tree.Node ("satisfy", "") []
instance CombSelectable (ViewGrammar sN) where
  branch lr l r = ViewGrammar $ Tree.Node ("branch", "")
    [ unViewGrammar lr, unViewGrammar l, unViewGrammar r ]
instance CombThrowable (ViewGrammar sN) where
  throw lbl = ViewGrammar $ Tree.Node ("throw "<>symbolVal lbl, "") []