src/Symantic/Parser/Grammar/View.hs

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