View.hs

{-# LANGUAGE OverloadedStrings #-}
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 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 Symantic.Typed.ObserveSharing
import Symantic.Parser.Grammar.Combinators
import qualified Symantic.Parser.Grammar.Production as Prod

-- * 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", "") []
  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, "") []
  failure _sf = ViewGrammar $ Tree.Node ("failure", "") []
  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 (Prod.prodCode 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 Functor.<$> bs)
    , unViewGrammar b
    ]
instance CombSatisfiable tok (ViewGrammar sN) where
  satisfyOrFail _fs _p = ViewGrammar $ Tree.Node ("satisfy", "") []
instance CombSelectable (ViewGrammar sN) where
  branch lr l r = ViewGrammar $ Tree.Node ("branch", "")
    [ unViewGrammar lr, unViewGrammar l, unViewGrammar r ]