{-# 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 GHC.TypeLits (symbolVal)
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]) a
  =     ViewMachine { unViewMachine ::
  Tree.Forest String -> Tree.Forest String }

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

instance InstrValuable (ViewMachine sN) where
  pushValue a k = ViewMachine $ \is -> viewInstrCmd ("pushValue "<>showsPrec 10 a "") [] : unViewMachine k is
  popValue k = ViewMachine $ \is -> viewInstrCmd "popValue" [] : unViewMachine k is
  lift2Value f k = ViewMachine $ \is -> viewInstrCmd ("lift2Value "<>showsPrec 10 f "") [] : unViewMachine k is
  swapValue k = ViewMachine $ \is -> viewInstrCmd "swapValue" [] : unViewMachine k is
instance InstrExceptionable (ViewMachine sN) where
  raiseException lbl _err = ViewMachine $ \is -> viewInstrCmd ("raiseException "<> show (symbolVal lbl)) [] : is
  popException lbl k = ViewMachine $ \is -> viewInstrCmd ("popException "<> show (symbolVal lbl)) [] : unViewMachine k is
  catchException lbl t h = ViewMachine $ \is -> viewInstrCmd ("catchException "<> show (symbolVal lbl))
    [ viewInstrArg "try" (unViewMachine t [])
    , viewInstrArg "handler" (unViewMachine h [])
    ] : is
instance InstrBranchable (ViewMachine sN) where
  caseBranch l r = ViewMachine $ \is -> viewInstrCmd "case"
    [ viewInstrArg "left" (unViewMachine l [])
    , viewInstrArg "right" (unViewMachine r [])
    ] : is
  choicesBranch ps bs d = ViewMachine $ \is ->
    viewInstrCmd ("choicesBranch "<>show ps) (
      (viewInstrArg "branch" . ($ []) . unViewMachine <$> bs) <>
      [ viewInstrArg "default" (unViewMachine d []) ]
    ) : is
instance
  ShowLetName sN TH.Name =>
  InstrLetable (ViewMachine sN) where
  defLet (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 =>
  InstrJoinable (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 InstrInputable (ViewMachine sN) where
  loadInput k = ViewMachine $ \is -> viewInstrCmd "loadInput" [] : unViewMachine k is
  pushInput k = ViewMachine $ \is -> viewInstrCmd "pushInput" [] : unViewMachine k is
instance InstrReadable tok (ViewMachine sN) where
  read _es p k = ViewMachine $ \is -> viewInstrCmd ("read "<>showsPrec 10 p "") [] : unViewMachine k is