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

import Data.Bool (Bool(..))
import Data.Either (Either(..))
import Data.Function (($), (.), id, on)
import Data.Functor ((<$>))
import Data.Kind (Type)
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String)
import Data.Tuple (fst)
import Text.Show (Show(..))
import qualified Data.HashMap.Strict as HM
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Tree as Tree
import qualified Language.Haskell.TH.Syntax as TH
import Prelude (error)

import Symantic.Parser.Grammar.Combinators (UnscopedRegister(..))
import Symantic.Parser.Grammar.ObserveSharing
import Symantic.Parser.Machine.Instructions
import Symantic.ObserveSharing (SomeLet(..))
import Symantic.Parser.Machine.Generate

-- * Type 'ViewMachine'
data ViewMachine (showName::Bool) inp (vs:: [Type]) a
  =  ViewMachine
  { viewGen :: Gen inp vs a
    -- ^ Provide 'GenAnalysis', which is important for debugging
    -- and improving golden tests, see 'viewInstrCmd'.
  , unViewMachine ::
      CallTrace ->
      LetRecs TH.Name GenAnalysis -> -- Output of 'runOpenRecs'.
      Tree.Forest (String, String) ->
      Tree.Forest (String, String)
  }

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

-- | Helper to view a command.
viewInstrCmd ::
  Either TH.Name (Gen inp vs a) ->
  CallTrace ->
  LetRecs TH.Name GenAnalysis ->
  (String, String) -> Tree.Forest (String, String) -> Tree.Tree (String, String)
viewInstrCmd gen ct lm (n, no) = Tree.Node $ (n
  <> "\nminReads="<>showsPrec 11 (minReads ga) ""
  <> "\nmayRaise="<>showsPrec 11 (Map.keys (mayRaise ga)) ""
  , no)
  where
  ga = case gen of
         Right r -> (\f -> f ct) $ genAnalysis r $ (\f _ct -> f) <$> lm
         Left l -> HM.findWithDefault (error (show (l, HM.keys lm))) l lm

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

instance Show (ViewMachine sN inp vs a) where
  show vm = List.unlines $ drawTrees $
      unViewMachine vm [] (runOpenRecs (genAnalysisByLet (viewGen vm))) []
    where
    draw :: Tree.Tree (String, String) -> [String]
    draw (Tree.Node (x, n) ts0) =
      shift "" "  " (List.zipWith (<>) (List.lines x) (n : List.repeat "")) <>
      shift "| " "| " (drawTrees ts0)
    drawTrees [] = []
    drawTrees [t] = draw t
    drawTrees (t:ts) = draw t <> drawTrees ts
    shift ind0 ind = List.zipWith (<>) (ind0 : List.repeat ind)

instance InstrValuable (ViewMachine sN) where
  pushValue a k = ViewMachine
    { unViewMachine = \ct lm next ->
        viewInstrCmd (Right gen) ct lm ("pushValue "<>showsPrec 10 a "", "") [] :
        unViewMachine k ct lm next
    , viewGen = gen
    } where gen = pushValue a (viewGen k)
  popValue k = ViewMachine
    { unViewMachine = \ct lm next ->
        viewInstrCmd (Right gen) ct lm ("popValue", "") [] :
        unViewMachine k ct lm next
    , viewGen = gen
    } where gen = popValue (viewGen k)
  lift2Value f k = ViewMachine
    { unViewMachine = \ct lm next ->
        viewInstrCmd (Right gen) ct lm ("lift2Value "<>showsPrec 10 f "", "") [] :
        unViewMachine k ct lm next
    , viewGen = gen
    } where gen = lift2Value f (viewGen k)
  swapValue k = ViewMachine
    { unViewMachine = \ct lm next ->
        viewInstrCmd (Right gen) ct lm ("swapValue", "") [] :
        unViewMachine k ct lm next
    , viewGen = gen
    } where gen = swapValue (viewGen k)
instance InstrExceptionable (ViewMachine sN) where
  raise exn = ViewMachine
    { unViewMachine = \ct lm next ->
        viewInstrCmd (Right gen) ct lm ("raise "<>show exn, "") [] : next
    , viewGen = gen
    } where gen = raise exn
  fail flr = ViewMachine
    { unViewMachine = \ct lm next ->
        viewInstrCmd (Right gen) ct lm ("fail "<>show (Set.toList flr), "") [] : next
    , viewGen = gen
    } where gen = fail flr
  commit exn k = ViewMachine
    { unViewMachine = \ct lm next ->
        viewInstrCmd (Right gen) ct lm ("commit "<>show exn, "") [] :
        unViewMachine k ct lm next
    , viewGen = gen
    } where gen = commit exn (viewGen k)
  catch exn ok ko = ViewMachine
    { unViewMachine = \ct lm next ->
        viewInstrCmd (Right gen) ct lm ("catch "<>show exn, "")
          [ viewInstrArg "ok" (unViewMachine ok ct lm [])
          , viewInstrArg "ko" (unViewMachine ko ct lm [])
          ] : next
    , viewGen = gen
    } where gen = catch exn (viewGen ok) (viewGen ko)
instance InstrBranchable (ViewMachine sN) where
  caseBranch l r = ViewMachine
    { unViewMachine = \ct lm next ->
        viewInstrCmd (Right gen) ct lm ("case", "")
          [ viewInstrArg "left" (unViewMachine l ct lm [])
          , viewInstrArg "right" (unViewMachine r ct lm [])
          ] : next
    , viewGen = gen
    } where gen = caseBranch (viewGen l) (viewGen r)
  choicesBranch bs d = ViewMachine
    { unViewMachine = \ct lm next ->
        viewInstrCmd (Right gen) ct lm ("choicesBranch", "") (
          ((\(p, b) -> viewInstrArg ("branch "<>showsPrec 10 p "") $
            unViewMachine b ct lm []) <$> bs) <>
          [ viewInstrArg "default" (unViewMachine d ct lm []) ]
        ) : next
    , viewGen = gen
    } where gen = choicesBranch ((viewGen <$>) <$> bs) (viewGen d)
instance
  ShowLetName sN TH.Name =>
  InstrCallable (ViewMachine sN) where
  defLet defs k = ViewMachine
    { unViewMachine = \ct lm next ->
        (<> unViewMachine k ct lm next) $
        List.sortBy (compare `on` (((fst <$>) <$>) . Tree.levels)) $
        ((\(n, SomeLet sub) ->
          viewInstrCmd (Left n) ct lm
            ("let", " "<>showLetName @sN n)
            (unViewMachine sub ct lm []))
          <$> HM.toList defs)
    , viewGen = gen
    } where gen = defLet ((\(SomeLet x) -> SomeLet (viewGen x)) <$> defs) (viewGen k)
  jump ln@(LetName n) = ViewMachine
    { unViewMachine = \ct lm next ->
        viewInstrCmd (Right gen) ct lm ("jump", " "<>showLetName @sN n) [] : next
    , viewGen = gen
    } where gen = jump ln
  call ln@(LetName n) k = ViewMachine
    { unViewMachine = \ct lm next ->
        viewInstrCmd (Right gen) ct lm ("call", " "<>showLetName @sN n) [] :
        unViewMachine k (n:ct) lm next
    , viewGen = gen
    } where gen = call ln (viewGen k)
  ret = ViewMachine
    { unViewMachine = \ct lm next ->
        viewInstrCmd (Right gen) ct lm ("ret", "") [] : next
    , viewGen = gen
    } where gen = ret
instance
  ShowLetName sN TH.Name =>
  InstrJoinable (ViewMachine sN) where
  defJoin ln@(LetName n) j k = ViewMachine
    { unViewMachine = \ct lm next ->
        viewInstrCmd (Left n) ct lm
          ("join", " "<>showLetName @sN n)
          (unViewMachine j ct lm []) :
        unViewMachine k (n:ct) lm next
    , viewGen = gen
    } where gen = defJoin ln (viewGen j) (viewGen k)
  refJoin ln@(LetName n) = ViewMachine
    { unViewMachine = \ct lm next ->
        viewInstrCmd (Right gen) ct lm ("refJoin", " "<>showLetName @sN n) [] : next
    , viewGen = gen
    } where gen = refJoin ln
instance InstrInputable (ViewMachine sN) where
  pushInput k = ViewMachine
    { unViewMachine = \ct lm next ->
        viewInstrCmd (Right gen) ct lm ("pushInput", "") [] :
        unViewMachine k ct lm next
    , viewGen = gen
    } where gen = pushInput (viewGen k)
  loadInput k = ViewMachine
    { unViewMachine = \ct lm next ->
        viewInstrCmd (Right gen) ct lm ("loadInput", "") [] :
        unViewMachine k ct lm next
    , viewGen = gen
    } where gen = loadInput (viewGen k)
instance
  InstrReadable tok Gen =>
  InstrReadable tok (ViewMachine sN) where
  read es p k = ViewMachine
    { unViewMachine = \ct lm next ->
        viewInstrCmd (Right gen) ct lm ("read "<>showsPrec 10 p "", "") [] :
        unViewMachine k ct lm next
    , viewGen = gen
    } where gen = read es p (viewGen k)
instance
  ShowLetName sN TH.Name =>
  InstrIterable (ViewMachine sN) where
  iter jumpName@(LetName n) ok ko = ViewMachine
    { unViewMachine = \ct lm next ->
        viewInstrCmd (Right gen) ct lm ("iter", " "<>showLetName @sN n)
          [ viewInstrArg "ok" (unViewMachine ok ct lm [])
          , viewInstrArg "ko" (unViewMachine ko ct lm [])
          ] : next
    , viewGen = gen
    } where gen = iter jumpName (viewGen ok) (viewGen ko)
instance
  ShowLetName sN TH.Name =>
  InstrRegisterable (ViewMachine sN) where
  newRegister reg@(UnscopedRegister r) k = ViewMachine
    { unViewMachine = \ct lm next ->
        viewInstrCmd (Right gen) ct lm ("newRegister", " "<>showLetName @sN r) [] :
        unViewMachine k ct lm next
    , viewGen = gen
    } where gen = newRegister reg (viewGen k)
  readRegister reg@(UnscopedRegister r) k = ViewMachine
    { unViewMachine = \ct lm next ->
        viewInstrCmd (Right gen) ct lm ("readRegister", " "<>showLetName @sN r) [] :
        unViewMachine k ct lm next
    , viewGen = gen
    } where gen = readRegister reg (viewGen k)
  writeRegister reg@(UnscopedRegister r) k = ViewMachine
    { unViewMachine = \ct lm next ->
        viewInstrCmd (Right gen) ct lm ("writeRegister", " "<>showLetName @sN r) [] :
        unViewMachine k ct lm next
    , viewGen = gen
    } where gen = writeRegister reg (viewGen k)