src/Symantic/Parser/Grammar/View.hs

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