View.hs

{-# LANGUAGE UndecidableInstances #-} -- For ShowLetName
module Symantic.Parser.Machine.View where

import Data.Bool (Bool(..))
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 qualified Language.Haskell.TH.Syntax as TH

import Symantic.Parser.Grammar.ObserveSharing (ShowLetName(..))
import Symantic.Parser.Machine.Instructions

-- * Type 'ViewMachine'
newtype ViewMachine (showName::Bool) inp (vs:: [Type]) (es::Peano) a
  =     ViewMachine { unViewMachine ::
  Tree.Forest String -> Tree.Forest String }

viewMachine ::
  ViewMachine sN inp vs es a ->
  ViewMachine sN inp vs es a
viewMachine = id

-- | Helper to view a command.
viewInstrCmd :: String -> Tree.Forest String -> Tree.Tree String
viewInstrCmd n = Tree.Node n
-- | Helper to view an argument.
viewInstrArg :: String -> Tree.Forest String -> Tree.Tree String
viewInstrArg n = Tree.Node ("<"<>n<>">")

instance Show (ViewMachine sN inp vs es a) where
  show = drawTree . Tree.Node "" . ($ []) . unViewMachine
    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 (ViewMachine sN inp vs es a) where
  fromString s = ViewMachine $ \is -> Tree.Node (fromString s) [] : is

instance Stackable (ViewMachine sN) where
  push a k = ViewMachine $ \is -> viewInstrCmd ("push "<>showsPrec 10 a "") [] : unViewMachine k is
  pop k = ViewMachine $ \is -> viewInstrCmd "pop" [] : unViewMachine k is
  liftI2 f k = ViewMachine $ \is -> viewInstrCmd ("lift "<>showsPrec 10 f "") [] : unViewMachine k is
  swap k = ViewMachine $ \is -> viewInstrCmd "swap" [] : unViewMachine k is
instance Branchable (ViewMachine sN) where
  caseI l r = ViewMachine $ \is -> viewInstrCmd "case"
    [ viewInstrArg "left" (unViewMachine l [])
    , viewInstrArg "right" (unViewMachine r [])
    ] : is
  choices ps bs d = ViewMachine $ \is ->
    viewInstrCmd ("choices "<>show ps) (
      (viewInstrArg "branch" . ($ []) . unViewMachine <$> bs) <>
      [ viewInstrArg "default" (unViewMachine d []) ]
    ) : is
instance Failable (ViewMachine sN) where
  fail _err = ViewMachine $ \is -> viewInstrCmd "fail" [] : is
  popFail k = ViewMachine $ \is -> viewInstrCmd "popFail" [] : unViewMachine k is
  catchFail t h = ViewMachine $ \is -> viewInstrCmd "catchFail"
    [ viewInstrArg "try" (unViewMachine t [])
    , viewInstrArg "handler" (unViewMachine h [])
    ] : is
instance Inputable (ViewMachine sN) where
  loadInput k = ViewMachine $ \is -> viewInstrCmd "loadInput" [] : unViewMachine k is
  pushInput k = ViewMachine $ \is -> viewInstrCmd "pushInput" [] : unViewMachine k is
instance
  ShowLetName sN TH.Name =>
  Routinable (ViewMachine sN) where
  subroutine (LetName n) sub k = ViewMachine $ \is ->
    Tree.Node (showLetName @sN n<>":") (unViewMachine sub [])
    : unViewMachine k is
  jump (LetName n) = ViewMachine $ \is -> viewInstrCmd ("jump "<>showLetName @sN n) [] : is
  call (LetName n) k = ViewMachine $ \is -> viewInstrCmd ("call "<>showLetName @sN n) [] : unViewMachine k is
  ret = ViewMachine $ \is -> viewInstrCmd "ret" [] : is
instance
  ShowLetName sN TH.Name =>
  Joinable (ViewMachine sN) where
  defJoin (LetName n) j k = ViewMachine $ \is ->
    Tree.Node (showLetName @sN n<>":") (unViewMachine j [])
    : unViewMachine k is
  refJoin (LetName n) = ViewMachine $ \is -> viewInstrCmd ("refJoin "<>showLetName @sN n) [] : is
instance Readable tok (ViewMachine sN) where
  read _es p k = ViewMachine $ \is -> viewInstrCmd ("read "<>showsPrec 10 p "") [] : unViewMachine k is