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 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 Symantic.ObserveSharing
import Symantic.Optimize (normalOrderReduction)
import Symantic.Parser.Grammar.Combinators
import Symantic.Parser.Grammar.ObserveSharing
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

showProduction :: Prod.Production a -> String
showProduction p = showsPrec 10 (normalOrderReduction (Prod.prodCode p)) ""

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 "<>showProduction 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 "<>showProduction p, "") [unViewGrammar b]) Functor.<$> bs)
instance CombSatisfiable tok (ViewGrammar sN) where
  satisfyOrFail _fs p = ViewGrammar $ Tree.Node
    ("satisfy "<>showProduction 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 ]