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