src/Symantic/Parser/Grammar/View.hs

   1 module Symantic.Parser.Grammar.View where
   2
   3 import Data.Bool (Bool)
   4 import Data.Function (($), (.), id)
   5 import Data.Semigroup (Semigroup(..))
   6 import Data.String (String, IsString(..))
   7 import Text.Show (Show(..))
   8 import qualified Control.Applicative as Fct
   9 import qualified Data.Tree as Tree
  10 import qualified Data.List as List
  11
  12 import Symantic.Univariant.Letable
  13 import Symantic.Parser.Grammar.Combinators
  14
  15 -- * Type 'ViewGrammar'
  16 newtype ViewGrammar (showName::Bool) a = ViewGrammar { unViewGrammar ::
  17   Tree.Tree String }
  18
  19 viewGrammar :: ViewGrammar sN a -> ViewGrammar sN a
  20 viewGrammar = id
  21
  22 instance Show (ViewGrammar sN a) where
  23   show = drawTree . unViewGrammar
  24     where
  25     drawTree :: Tree.Tree String -> String
  26     drawTree  = List.unlines . draw
  27     draw :: Tree.Tree String -> [String]
  28     draw (Tree.Node x ts0) = List.lines x <> drawSubTrees ts0
  29       where
  30       drawSubTrees [] = []
  31       drawSubTrees [t] = shift "` " "  " (draw t)
  32       drawSubTrees (t:ts) = shift "+ " "| " (draw t) <> drawSubTrees ts
  33       shift first other = List.zipWith (<>) (first : List.repeat other)
  34 instance IsString (ViewGrammar sN a) where
  35   fromString s = ViewGrammar $ Tree.Node (fromString s) []
  36
  37 instance
  38   ShowLetName sN letName =>
  39   Letable letName (ViewGrammar sN) where
  40   def name x = ViewGrammar $
  41     Tree.Node ("def "<>showLetName @sN name) [unViewGrammar x]
  42   ref rec name = ViewGrammar $
  43     Tree.Node
  44       ( (if rec then "rec " else "ref ")
  45       <> showLetName @sN name
  46       ) []
  47 instance Applicable (ViewGrammar sN) where
  48   _f <$> x = ViewGrammar $ Tree.Node "<$>" [unViewGrammar x]
  49   pure a = ViewGrammar $ Tree.Node ("pure "<>showsPrec 10 a "") []
  50   x <*> y = ViewGrammar $ Tree.Node "<*>" [unViewGrammar x, unViewGrammar y]
  51   x <* y = ViewGrammar $ Tree.Node "<*" [unViewGrammar x, unViewGrammar y]
  52   x *> y = ViewGrammar $ Tree.Node "*>" [unViewGrammar x, unViewGrammar y]
  53 instance Alternable (ViewGrammar sN) where
  54   empty = ViewGrammar $ Tree.Node "empty" []
  55   x <|> y = ViewGrammar $ Tree.Node "<|>" [unViewGrammar x, unViewGrammar y]
  56   try x = ViewGrammar $ Tree.Node "try" [unViewGrammar x]
  57 instance Satisfiable tok (ViewGrammar sN) where
  58   satisfy _es _p = ViewGrammar $ Tree.Node "satisfy" []
  59 instance Selectable (ViewGrammar sN) where
  60   branch lr l r = ViewGrammar $ Tree.Node "branch"
  61     [ unViewGrammar lr, unViewGrammar l, unViewGrammar r ]
  62 instance Matchable (ViewGrammar sN) where
  63   conditional a _ps bs b = ViewGrammar $ Tree.Node "conditional"
  64     [ unViewGrammar a
  65     , Tree.Node "bs" (unViewGrammar Fct.<$> bs)
  66     , unViewGrammar b
  67     ]
  68 instance Lookable (ViewGrammar sN) where
  69   look x = ViewGrammar $ Tree.Node "look" [unViewGrammar x]
  70   negLook x = ViewGrammar $ Tree.Node "negLook" [unViewGrammar x]
  71   eof = ViewGrammar $ Tree.Node "eof" []
  72 instance Foldable (ViewGrammar sN) where
  73   chainPre f x = ViewGrammar $ Tree.Node "chainPre" [unViewGrammar f, unViewGrammar x]
  74   chainPost x f = ViewGrammar $ Tree.Node "chainPost" [unViewGrammar x, unViewGrammar f]