module Symantic.Parser.Machine.View 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 'ViewMachine'
newtype ViewMachine inp (vs:: [Type]) (es::Peano) a
  =     ViewMachine { unViewMachine ::
  Tree.Forest String -> Tree.Forest String }

viewInstr :: ViewMachine inp vs es a -> ViewMachine inp vs es a
viewInstr = 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 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 inp vs es a) where
  fromString s = ViewMachine $ \is -> Tree.Node (fromString s) [] : is

instance Stackable ViewMachine 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 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 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 where
  loadInput k = ViewMachine $ \is -> viewInstrCmd "loadInput" [] : unViewMachine k is
  pushInput k = ViewMachine $ \is -> viewInstrCmd "pushInput" [] : unViewMachine k is
instance Routinable ViewMachine where
  subroutine n sub k = ViewMachine $ \is ->
    Tree.Node (show n<>":") (unViewMachine sub [])
    : unViewMachine k is
  jump n = ViewMachine $ \is -> viewInstrCmd ("jump "<>show n) [] : is
  call n k = ViewMachine $ \is -> viewInstrCmd ("call "<>show n) [] : unViewMachine k is
  ret = ViewMachine $ \is -> viewInstrCmd "ret" [] : is
instance Joinable ViewMachine where
  defJoin n sub k = ViewMachine $ \is ->
    Tree.Node (show n<>":") (unViewMachine sub [])
    : unViewMachine k is
  refJoin n = ViewMachine $ \is -> viewInstrCmd ("refJoin "<>show n) [] : is
instance Readable tok ViewMachine where
  read _es p k = ViewMachine $ \is -> viewInstrCmd ("read "<>showsPrec 10 p "") [] : unViewMachine k is