src/Symantic/Parser/Machine/View.hs

   1 {-# LANGUAGE UndecidableInstances #-} -- For ShowLetName
   2 module Symantic.Parser.Machine.View where
   3
   4 import Data.Bool (Bool(..))
   5 import Data.Function (($), (.), id)
   6 import Data.Functor ((<$>))
   7 import Data.Kind (Type)
   8 import Data.Semigroup (Semigroup(..))
   9 import Data.String (String, IsString(..))
  10 import GHC.TypeLits (symbolVal)
  11 import Text.Show (Show(..))
  12 import qualified Data.Tree as Tree
  13 import qualified Data.List as List
  14 import qualified Language.Haskell.TH.Syntax as TH
  15
  16 import Symantic.Parser.Grammar.ObserveSharing (ShowLetName(..))
  17 import Symantic.Parser.Machine.Instructions
  18
  19 -- * Type 'ViewMachine'
  20 newtype ViewMachine (showName::Bool) inp (vs:: [Type]) a
  21   =     ViewMachine { unViewMachine ::
  22   Tree.Forest String -> Tree.Forest String }
  23
  24 viewMachine ::
  25   ViewMachine sN inp vs a ->
  26   ViewMachine sN inp vs a
  27 viewMachine = id
  28
  29 -- | Helper to view a command.
  30 viewInstrCmd :: String -> Tree.Forest String -> Tree.Tree String
  31 viewInstrCmd n = Tree.Node n
  32 -- | Helper to view an argument.
  33 viewInstrArg :: String -> Tree.Forest String -> Tree.Tree String
  34 viewInstrArg n = Tree.Node ("<"<>n<>">")
  35
  36 instance Show (ViewMachine sN inp vs a) where
  37   show = drawTree . Tree.Node "" . ($ []) . unViewMachine
  38     where
  39     drawTree :: Tree.Tree String -> String
  40     drawTree  = List.unlines . draw
  41     draw :: Tree.Tree String -> [String]
  42     draw (Tree.Node x ts0) = List.lines x <> drawSubTrees ts0
  43       where
  44       drawSubTrees [] = []
  45       drawSubTrees [t] = shift "" "  " (draw t)
  46       drawSubTrees (t:ts) = shift "" "| " (draw t) <> drawSubTrees ts
  47       shift first other = List.zipWith (<>) (first : List.repeat other)
  48 instance IsString (ViewMachine sN inp vs a) where
  49   fromString s = ViewMachine $ \is -> Tree.Node (fromString s) [] : is
  50
  51 instance InstrValuable (ViewMachine sN) where
  52   pushValue a k = ViewMachine $ \is -> viewInstrCmd ("pushValue "<>showsPrec 10 a "") [] : unViewMachine k is
  53   popValue k = ViewMachine $ \is -> viewInstrCmd "popValue" [] : unViewMachine k is
  54   lift2Value f k = ViewMachine $ \is -> viewInstrCmd ("lift2Value "<>showsPrec 10 f "") [] : unViewMachine k is
  55   swapValue k = ViewMachine $ \is -> viewInstrCmd "swapValue" [] : unViewMachine k is
  56 instance InstrExceptionable (ViewMachine sN) where
  57   raiseException lbl _err = ViewMachine $ \is -> viewInstrCmd ("raiseException "<> show (symbolVal lbl)) [] : is
  58   popException lbl k = ViewMachine $ \is -> viewInstrCmd ("popException "<> show (symbolVal lbl)) [] : unViewMachine k is
  59   catchException lbl t h = ViewMachine $ \is -> viewInstrCmd ("catchException "<> show (symbolVal lbl))
  60     [ viewInstrArg "try" (unViewMachine t [])
  61     , viewInstrArg "handler" (unViewMachine h [])
  62     ] : is
  63 instance InstrBranchable (ViewMachine sN) where
  64   caseBranch l r = ViewMachine $ \is -> viewInstrCmd "case"
  65     [ viewInstrArg "left" (unViewMachine l [])
  66     , viewInstrArg "right" (unViewMachine r [])
  67     ] : is
  68   choicesBranch ps bs d = ViewMachine $ \is ->
  69     viewInstrCmd ("choicesBranch "<>show ps) (
  70       (viewInstrArg "branch" . ($ []) . unViewMachine <$> bs) <>
  71       [ viewInstrArg "default" (unViewMachine d []) ]
  72     ) : is
  73 instance
  74   ShowLetName sN TH.Name =>
  75   InstrLetable (ViewMachine sN) where
  76   defLet (LetName n) sub k = ViewMachine $ \is ->
  77     Tree.Node (showLetName @sN n<>":") (unViewMachine sub [])
  78     : unViewMachine k is
  79   jump (LetName n) = ViewMachine $ \is -> viewInstrCmd ("jump "<>showLetName @sN n) [] : is
  80   call (LetName n) k = ViewMachine $ \is -> viewInstrCmd ("call "<>showLetName @sN n) [] : unViewMachine k is
  81   ret = ViewMachine $ \is -> viewInstrCmd "ret" [] : is
  82 instance
  83   ShowLetName sN TH.Name =>
  84   InstrJoinable (ViewMachine sN) where
  85   defJoin (LetName n) j k = ViewMachine $ \is ->
  86     Tree.Node (showLetName @sN n<>":") (unViewMachine j [])
  87     : unViewMachine k is
  88   refJoin (LetName n) = ViewMachine $ \is -> viewInstrCmd ("refJoin "<>showLetName @sN n) [] : is
  89 instance InstrInputable (ViewMachine sN) where
  90   loadInput k = ViewMachine $ \is -> viewInstrCmd "loadInput" [] : unViewMachine k is
  91   pushInput k = ViewMachine $ \is -> viewInstrCmd "pushInput" [] : unViewMachine k is
  92 instance InstrReadable tok (ViewMachine sN) where
  93   read _es p k = ViewMachine $ \is -> viewInstrCmd ("read "<>showsPrec 10 p "") [] : unViewMachine k is