src/Symantic/Parser/Grammar/View.hs

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