View.hs

module Symantic.Parser.Grammar.View where

import Data.Bool (Bool)
import Data.Function (($), (.), id)
import Data.Semigroup (Semigroup(..))
import Data.String (String, IsString(..))
import Text.Show (Show(..))
import qualified Control.Applicative as Fct
import qualified Data.Tree as Tree
import qualified Data.List as List

import Symantic.Univariant.Letable
import Symantic.Parser.Grammar.Combinators

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

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

instance Show (ViewGrammar sN a) where
  show = drawTree . unViewGrammar
    where
    drawTree :: Tree.Tree String -> String
    drawTree  = List.unlines . draw
    draw :: Tree.Tree String -> [String]
    draw (Tree.Node x ts0) = List.lines x <> drawSubTrees ts0
      where
      drawSubTrees [] = []
      drawSubTrees [t] = shift "` " "  " (draw t)
      drawSubTrees (t:ts) = shift "+ " "| " (draw t) <> drawSubTrees ts
      shift first other = List.zipWith (<>) (first : List.repeat other)
instance IsString (ViewGrammar sN a) where
  fromString s = ViewGrammar $ Tree.Node (fromString s) []

instance
  ShowLetName sN letName =>
  Letable letName (ViewGrammar sN) where
  def name x = ViewGrammar $
    Tree.Node ("def "<>showLetName @sN name) [unViewGrammar x]
  ref rec name = ViewGrammar $
    Tree.Node
      ( (if rec then "rec " else "ref ")
      <> showLetName @sN name
      ) []
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 "bs" (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]