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