src/Symantic/Parser/Grammar/View.hs

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