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 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
  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 Applicable (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 Alternable (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 Satisfiable tok (ViewGrammar sN) where
  satisfy _es _p = ViewGrammar $ Tree.Node ("satisfy", "") []
instance Selectable (ViewGrammar sN) where
  branch lr l r = ViewGrammar $ Tree.Node ("branch", "")
    [ unViewGrammar lr, unViewGrammar l, unViewGrammar r ]
instance Matchable (ViewGrammar sN) where
  conditional a _ps bs b = ViewGrammar $ Tree.Node ("conditional", "")
    [ unViewGrammar a
    , Tree.Node ("branches", "") (unViewGrammar Fct.<$> bs)
    , unViewGrammar b
    ]
instance Lookable (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 Foldable (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]