Dump.hs

module Symantic.Parser.Machine.Dump where

import Data.Function (($), (.), id)
import Data.Functor ((<$>))
import Data.Kind (Type)
import Data.Semigroup (Semigroup(..))
import Data.String (String, IsString(..))
import Text.Show (Show(..))
import qualified Data.Tree as Tree
import qualified Data.List as List

import Symantic.Parser.Machine.Instructions

-- * Type 'DumpInstr'
newtype DumpInstr inp (vs:: [Type]) (es::Peano) a
  =     DumpInstr { unDumpInstr ::
  Tree.Forest String -> Tree.Forest String }

dumpInstr :: DumpInstr inp vs es a -> DumpInstr inp vs es a
dumpInstr = id

-- | Helper to dump a command.
dumpInstrCmd :: String -> Tree.Forest String -> Tree.Tree String
dumpInstrCmd n = Tree.Node n
-- | Helper to dump an argument.
dumpInstrArg :: String -> Tree.Forest String -> Tree.Tree String
dumpInstrArg n = Tree.Node ("<"<>n<>">")

instance Show (DumpInstr inp vs es a) where
  show = drawTree . Tree.Node "" . ($ []) . unDumpInstr
    where
    drawTree :: Tree.Tree String -> String
    drawTree  = List.unlines . draw
    draw :: Tree.Tree String -> [String]
    draw (Tree.Node x ts0) = List.lines x <> drawSubTrees ts0
      where
      drawSubTrees [] = []
      drawSubTrees [t] = shift "" "  " (draw t)
      drawSubTrees (t:ts) = shift "" "| " (draw t) <> drawSubTrees ts
      shift first other = List.zipWith (<>) (first : List.repeat other)
instance IsString (DumpInstr inp vs es a) where
  fromString s = DumpInstr $ \is -> Tree.Node (fromString s) [] : is

instance Stackable DumpInstr where
  push a k = DumpInstr $ \is -> dumpInstrCmd ("push "<>showsPrec 10 a "") [] : unDumpInstr k is
  pop k = DumpInstr $ \is -> dumpInstrCmd "pop" [] : unDumpInstr k is
  liftI2 f k = DumpInstr $ \is -> dumpInstrCmd ("lift "<>show f) [] : unDumpInstr k is
  swap k = DumpInstr $ \is -> dumpInstrCmd "swap" [] : unDumpInstr k is
instance Branchable DumpInstr where
  case_ l r = DumpInstr $ \is -> dumpInstrCmd "case"
    [ dumpInstrArg "left" (unDumpInstr l [])
    , dumpInstrArg "right" (unDumpInstr r [])
    ] : is
  choices ps bs d = DumpInstr $ \is ->
    dumpInstrCmd ("choices "<>show ps) (
      (dumpInstrArg "branch" . ($ []) . unDumpInstr <$> bs) <>
      [ dumpInstrArg "default" (unDumpInstr d []) ]
    ) : is
instance Failable DumpInstr where
  fail _err = DumpInstr $ \is -> dumpInstrCmd "fail" [] : is
  popFail k = DumpInstr $ \is -> dumpInstrCmd "popFail" [] : unDumpInstr k is
  catchFail t h = DumpInstr $ \is -> dumpInstrCmd "catchFail"
    [ dumpInstrArg "try" (unDumpInstr t [])
    , dumpInstrArg "handler" (unDumpInstr h [])
    ] : is
instance Inputable DumpInstr where
  loadInput k = DumpInstr $ \is -> dumpInstrCmd "loadInput" [] : unDumpInstr k is
  pushInput k = DumpInstr $ \is -> dumpInstrCmd "pushInput" [] : unDumpInstr k is
instance Routinable DumpInstr where
  subroutine n sub k = DumpInstr $ \is ->
    Tree.Node (show n<>":") (unDumpInstr sub [])
    : unDumpInstr k is
  jump n = DumpInstr $ \is -> dumpInstrCmd ("jump "<>show n) [] : is
  call n k = DumpInstr $ \is -> dumpInstrCmd ("call "<>show n) [] : unDumpInstr k is
  ret = DumpInstr $ \is -> dumpInstrCmd "ret" [] : is
instance Joinable DumpInstr where
  defJoin n sub k = DumpInstr $ \is ->
    Tree.Node (show n<>":") (unDumpInstr sub [])
    : unDumpInstr k is
  refJoin n = DumpInstr $ \is -> dumpInstrCmd ("refJoin "<>show n) [] : is
instance Readable DumpInstr inp where
  read _es _p k = DumpInstr $ \is -> dumpInstrCmd "read" [] : unDumpInstr k is