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 Text.Show (Show(..))
  10 import qualified Control.Applicative as Fct
  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 Symantic.Parser.Grammar.Combinators
  18
  19 -- * Type 'ViewGrammar'
  20 newtype ViewGrammar (showName::Bool) a = ViewGrammar { unViewGrammar ::
  21   Tree.Tree (String, String) }
  22
  23 viewGrammar :: ViewGrammar sN a -> ViewGrammar sN a
  24 viewGrammar = id
  25
  26 instance Show (ViewGrammar sN a) where
  27   show = List.unlines . draw . unViewGrammar
  28     where
  29     draw :: Tree.Tree (String, String) -> [String]
  30     draw (Tree.Node (x, n) ts0) =
  31       (List.zipWith (<>) (List.lines x) (n : List.repeat "")) <>
  32       (drawTrees ts0)
  33     drawTrees [] = []
  34     drawTrees [t] = shift "` " "  " (draw t)
  35     drawTrees (t:ts) = shift "+ " "| " (draw t) <> drawTrees ts
  36     shift ind0 ind = List.zipWith (<>) (ind0 : List.repeat ind)
  37
  38 instance
  39   ShowLetName sN letName =>
  40   Letable letName (ViewGrammar sN) where
  41   shareable name x = ViewGrammar $
  42     Tree.Node ("shareable", " "<>showLetName @sN name) [unViewGrammar x]
  43   ref isRec name = ViewGrammar $
  44     Tree.Node
  45       ( if isRec then "rec" else "ref"
  46       , " "<>showLetName @sN name
  47       ) []
  48 instance
  49   ShowLetName sN letName =>
  50   Letsable letName (ViewGrammar sN) where
  51   lets defs x = ViewGrammar $
  52     Tree.Node ("lets", "") $
  53       (<> [unViewGrammar x]) $
  54       List.sortBy (compare `on` (((fst Functor.<$>) Functor.<$>) . Tree.levels)) $
  55       HM.foldrWithKey'
  56         (\name (SomeLet val) ->
  57           (Tree.Node ("let", " "<>showLetName @sN name) [unViewGrammar val] :))
  58         [] defs
  59 instance Applicable (ViewGrammar sN) where
  60   _f <$> x = ViewGrammar $ Tree.Node ("<$>", "") [unViewGrammar x]
  61   pure a = ViewGrammar $ Tree.Node ("pure "<>showsPrec 10 a "", "") []
  62   x <*> y = ViewGrammar $ Tree.Node ("<*>", "") [unViewGrammar x, unViewGrammar y]
  63   x <* y = ViewGrammar $ Tree.Node ("<*", "") [unViewGrammar x, unViewGrammar y]
  64   x *> y = ViewGrammar $ Tree.Node ("*>", "") [unViewGrammar x, unViewGrammar y]
  65 instance Alternable (ViewGrammar sN) where
  66   empty = ViewGrammar $ Tree.Node ("empty", "") []
  67   x <|> y = ViewGrammar $ Tree.Node ("<|>", "") [unViewGrammar x, unViewGrammar y]
  68   try x = ViewGrammar $ Tree.Node ("try", "") [unViewGrammar x]
  69 instance Satisfiable tok (ViewGrammar sN) where
  70   satisfy _es _p = ViewGrammar $ Tree.Node ("satisfy", "") []
  71 instance Selectable (ViewGrammar sN) where
  72   branch lr l r = ViewGrammar $ Tree.Node ("branch", "")
  73     [ unViewGrammar lr, unViewGrammar l, unViewGrammar r ]
  74 instance Matchable (ViewGrammar sN) where
  75   conditional a _ps bs b = ViewGrammar $ Tree.Node ("conditional", "")
  76     [ unViewGrammar a
  77     , Tree.Node ("branches", "") (unViewGrammar Fct.<$> bs)
  78     , unViewGrammar b
  79     ]
  80 instance Lookable (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 Foldable (ViewGrammar sN) where
  85   chainPre f x = ViewGrammar $ Tree.Node ("chainPre", "") [unViewGrammar f, unViewGrammar x]
  86   chainPost x f = ViewGrammar $ Tree.Node ("chainPost", "") [unViewGrammar x, unViewGrammar f]