src/Symantic/Parser/Grammar/View.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 module Symantic.Parser.Grammar.View where
   3
   4 import Data.Bool (Bool)
   5 import Data.Eq (Eq(..))
   6 import Data.Function (($), (.), id, on)
   7 import Data.Ord (Ord(..))
   8 import Data.Semigroup (Semigroup(..))
   9 import Data.String (String)
  10 import Data.Tuple (fst, snd)
  11 import Text.Show (Show(..))
  12 import qualified Data.Functor as Functor
  13 import qualified Data.HashMap.Strict as HM
  14 import qualified Data.List as List
  15 import qualified Data.Tree as Tree
  16
  17 import Symantic.ObserveSharing
  18 import Symantic.Parser.Grammar.Combinators
  19 import Symantic.Parser.Grammar.ObserveSharing
  20 import qualified Symantic.Parser.Grammar.Production as Prod
  21
  22 -- * Type 'ViewGrammar'
  23 newtype ViewGrammar (showName::Bool) a = ViewGrammar { unViewGrammar ::
  24   Tree.Tree (String, String) }
  25
  26 viewGrammar :: ViewGrammar sN a -> ViewGrammar sN a
  27 viewGrammar = id
  28
  29 instance Show (ViewGrammar sN a) where
  30   show = List.unlines . draw . unViewGrammar
  31     where
  32     draw :: Tree.Tree (String, String) -> [String]
  33     draw (Tree.Node (x, n) ts0) =
  34       (List.zipWith (<>) (List.lines x) (n : List.repeat "")) <>
  35       (drawTrees ts0)
  36     drawTrees [] = []
  37     drawTrees [t] = shift "` " "  " (draw t)
  38     drawTrees (t:ts) = shift "+ " "| " (draw t) <> drawTrees ts
  39     shift ind0 ind = List.zipWith (<>) (ind0 : List.repeat ind)
  40
  41 instance CombAlternable (ViewGrammar sN) where
  42   empty = ViewGrammar $ Tree.Node ("empty", "") []
  43   alt exn x y = ViewGrammar $ Tree.Node
  44     ("<|>" <> if exn == ExceptionFailure then "" else ("^"<>show exn), "")
  45     [unViewGrammar x, unViewGrammar y]
  46   throw exn = ViewGrammar $ Tree.Node ("throw "<>show exn, "") []
  47   failure _sf = ViewGrammar $ Tree.Node ("failure", "") []
  48   try x = ViewGrammar $ Tree.Node ("try", "") [unViewGrammar x]
  49 instance CombApplicable (ViewGrammar sN) where
  50   _f <$> x = ViewGrammar $ Tree.Node ("<$>", "") [unViewGrammar x]
  51   pure a = ViewGrammar $ Tree.Node ("pure " <> showsPrec 10 (Prod.prodCode a) "", "") []
  52   x <*> y = ViewGrammar $ Tree.Node ("<*>", "") [unViewGrammar x, unViewGrammar y]
  53   x <* y = ViewGrammar $ Tree.Node ("<*", "") [unViewGrammar x, unViewGrammar y]
  54   x *> y = ViewGrammar $ Tree.Node ("*>", "") [unViewGrammar x, unViewGrammar y]
  55 instance CombFoldable (ViewGrammar sN) where
  56   chainPre f x = ViewGrammar $ Tree.Node ("chainPre", "") [unViewGrammar f, unViewGrammar x]
  57   chainPost x f = ViewGrammar $ Tree.Node ("chainPost", "") [unViewGrammar x, unViewGrammar f]
  58 instance
  59   ShowLetName sN letName =>
  60   Referenceable letName (ViewGrammar sN) where
  61   ref isRec name = ViewGrammar $
  62     Tree.Node
  63       ( if isRec then "rec" else "ref"
  64       , " "<>showLetName @sN name
  65       ) []
  66 instance
  67   ShowLetName sN letName =>
  68   Letsable letName (ViewGrammar sN) where
  69   lets defs x = ViewGrammar $
  70     Tree.Node ("lets", "") $
  71       (<> [unViewGrammar x]) $
  72       List.sortBy (compare `on` (((fst Functor.<$>) Functor.<$>) . Tree.levels)) $
  73       HM.foldrWithKey'
  74         (\name (SomeLet val) ->
  75           (Tree.Node ("let", " "<>showLetName @sN name) [unViewGrammar val] :))
  76         [] defs
  77 instance CombLookable (ViewGrammar sN) where
  78   look x = ViewGrammar $ Tree.Node ("look", "") [unViewGrammar x]
  79   negLook x = ViewGrammar $ Tree.Node ("negLook", "") [unViewGrammar x]
  80   eof = ViewGrammar $ Tree.Node ("eof", "") []
  81 instance CombMatchable (ViewGrammar sN) where
  82   conditional a bs b = ViewGrammar $ Tree.Node ("conditional", "")
  83     [ unViewGrammar a
  84     , Tree.Node ("branches", "") (unViewGrammar . snd Functor.<$> bs)
  85     , unViewGrammar b
  86     ]
  87 instance CombSatisfiable tok (ViewGrammar sN) where
  88   satisfyOrFail _fs _p = ViewGrammar $ Tree.Node ("satisfy", "") []
  89 instance CombSelectable (ViewGrammar sN) where
  90   branch lr l r = ViewGrammar $ Tree.Node ("branch", "")
  91     [ unViewGrammar lr, unViewGrammar l, unViewGrammar r ]
  92 instance CombRegisterableUnscoped (ViewGrammar sN) where
  93   newUnscoped r x y = ViewGrammar $ Tree.Node ("new "<>show r, "") [ unViewGrammar x,  unViewGrammar y ]
  94   getUnscoped r = ViewGrammar $ Tree.Node ("get "<>show r, "") [ ]
  95   putUnscoped r x = ViewGrammar $ Tree.Node ("put "<>show r, "") [ unViewGrammar x ]