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