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 System.IO (IO)
  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 import qualified Language.Haskell.TH as TH
  18 import qualified Language.Haskell.TH.Show as TH
  19 import qualified Language.Haskell.TH.Syntax as TH
  20
  21 import Symantic.Typed.Letable
  22 import qualified Symantic.Typed.Trans as Sym
  23 import qualified Symantic.Typed.Data as Sym
  24 import qualified Symantic.Typed.View as Sym
  25 import Symantic.Parser.Grammar.Combinators
  26 import qualified Symantic.Parser.Grammar.Production as Prod
  27
  28 -- * Type 'ViewGrammar'
  29 newtype ViewGrammar (showName::Bool) a = ViewGrammar { unViewGrammar ::
  30   Tree.Tree (String, String) }
  31
  32 viewGrammar :: ViewGrammar sN a -> ViewGrammar sN a
  33 viewGrammar = id
  34
  35 instance Show (ViewGrammar sN a) where
  36   show = List.unlines . draw . unViewGrammar
  37     where
  38     draw :: Tree.Tree (String, String) -> [String]
  39     draw (Tree.Node (x, n) ts0) =
  40       (List.zipWith (<>) (List.lines x) (n : List.repeat "")) <>
  41       (drawTrees ts0)
  42     drawTrees [] = []
  43     drawTrees [t] = shift "` " "  " (draw t)
  44     drawTrees (t:ts) = shift "+ " "| " (draw t) <> drawTrees ts
  45     shift ind0 ind = List.zipWith (<>) (ind0 : List.repeat ind)
  46
  47 instance CombAlternable (ViewGrammar sN) where
  48   empty = ViewGrammar $ Tree.Node ("empty", "") []
  49   alt exn x y = ViewGrammar $ Tree.Node
  50     ("<|>" <> if exn == ExceptionFailure then "" else ("^"<>show exn), "")
  51     [unViewGrammar x, unViewGrammar y]
  52   throw exn = ViewGrammar $ Tree.Node ("throw "<>show exn, "") []
  53   failure _sf = ViewGrammar $ Tree.Node ("failure", "") []
  54   try x = ViewGrammar $ Tree.Node ("try", "") [unViewGrammar x]
  55 instance CombApplicable (ViewGrammar sN) where
  56   _f <$> x = ViewGrammar $ Tree.Node ("<$>", "") [unViewGrammar x]
  57   pure a = ViewGrammar $ Tree.Node ("pure " <> TH.showCode (Sym.trans (Prod.prodCode a)), "") []
  58   x <*> y = ViewGrammar $ Tree.Node ("<*>", "") [unViewGrammar x, unViewGrammar y]
  59   x <* y = ViewGrammar $ Tree.Node ("<*", "") [unViewGrammar x, unViewGrammar y]
  60   x *> y = ViewGrammar $ Tree.Node ("*>", "") [unViewGrammar x, unViewGrammar y]
  61 instance CombFoldable (ViewGrammar sN) where
  62   chainPre f x = ViewGrammar $ Tree.Node ("chainPre", "") [unViewGrammar f, unViewGrammar x]
  63   chainPost x f = ViewGrammar $ Tree.Node ("chainPost", "") [unViewGrammar x, unViewGrammar f]
  64 instance
  65   ShowLetName sN letName =>
  66   Letable letName (ViewGrammar sN) where
  67   shareable name x = ViewGrammar $
  68     Tree.Node ("shareable", " "<>showLetName @sN name) [unViewGrammar x]
  69   ref isRec name = ViewGrammar $
  70     Tree.Node
  71       ( if isRec then "rec" else "ref"
  72       , " "<>showLetName @sN name
  73       ) []
  74 instance
  75   ShowLetName sN letName =>
  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", " "<>showLetName @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 _ps bs b = ViewGrammar $ Tree.Node ("conditional", "")
  91     [ unViewGrammar a
  92     , Tree.Node ("branches", "") (unViewGrammar Functor.<$> bs)
  93     , unViewGrammar b
  94     ]
  95 instance CombSatisfiable tok (ViewGrammar sN) where
  96   satisfyOrFail _fs _p = ViewGrammar $ Tree.Node ("satisfy", "") []
  97 instance CombSelectable (ViewGrammar sN) where
  98   branch lr l r = ViewGrammar $ Tree.Node ("branch", "")
  99     [ unViewGrammar lr, unViewGrammar l, unViewGrammar r ]