View.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UndecidableInstances #-} -- For HideableName
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 Language.Haskell.TH.HideName
import qualified Language.Haskell.TH.Syntax as TH
import Prelude (error)

import Symantic.Optimize (normalOrderReduction)
import Symantic.Parser.Grammar.Combinators (UnscopedRegister(..))
import Symantic.Parser.Grammar.ObserveSharing
import Symantic.Parser.Machine.Instructions
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 ::
      LetRecs TH.Name GenAnalysis -> -- Output of 'mutualFix'.
      Tree.Forest (String, String) ->
      Tree.Forest (String, String)
  }

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

showSplice :: Splice a -> String
showSplice p = showsPrec 10 (normalOrderReduction p) ""

-- | Helper to view a command.
viewInstrCmd ::
  forall (sN::Bool) inp vs a.
  HideableName sN =>
  Either TH.Name (Gen inp vs a) ->
  LetRecs TH.Name GenAnalysis ->
  (String, String) -> Tree.Forest (String, String) -> Tree.Tree (String, String)
viewInstrCmd gen finalByLet (cmd, no) = Tree.Node $ (cmd
  <> "\nminReads="<>showsPrec 11 (minReads ga) ""
  <> "\nmayRaise="<>show (Map.keys (mayRaise ga))
  <> "\nalwaysRaise="<>show (Set.toList (alwaysRaise ga))
  <> "\nfreeRegs="<>show (hideableName @sN (Set.toList (freeRegs ga)))
  , no)
  where
  ga = case gen of
         Right a -> genAnalysis a finalByLet
         Left n -> HM.findWithDefault (error (show (n, HM.keys finalByLet))) n finalByLet

-- | 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 (mutualFix (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
  HideableName sN =>
  InstrComment (ViewMachine sN) where
  comment msg k = ViewMachine 
    { unViewMachine = \lm next ->
        viewInstrCmd @sN (Right gen) lm ("comment "<>show msg, "") [] :
        unViewMachine k lm next
    , viewGen = gen
    } where gen = comment msg (viewGen k)
instance
  HideableName sN =>
  InstrValuable (ViewMachine sN) where
  pushValue a k = ViewMachine
    { unViewMachine = \lm next ->
        viewInstrCmd @sN (Right gen) lm ("pushValue "<>showSplice a, "") [] :
        unViewMachine k lm next
    , viewGen = gen
    } where gen = pushValue a (viewGen k)
  popValue k = ViewMachine
    { unViewMachine = \lm next ->
        viewInstrCmd @sN (Right gen) lm ("popValue", "") [] :
        unViewMachine k lm next
    , viewGen = gen
    } where gen = popValue (viewGen k)
  lift2Value f k = ViewMachine
    { unViewMachine = \lm next ->
        viewInstrCmd @sN (Right gen) lm ("lift2Value "<>showSplice f, "") [] :
        unViewMachine k lm next
    , viewGen = gen
    } where gen = lift2Value f (viewGen k)
  swapValue k = ViewMachine
    { unViewMachine = \lm next ->
        viewInstrCmd @sN (Right gen) lm ("swapValue", "") [] :
        unViewMachine k lm next
    , viewGen = gen
    } where gen = swapValue (viewGen k)
instance
  HideableName sN =>
  InstrExceptionable (ViewMachine sN) where
  raise exn = ViewMachine
    { unViewMachine = \lm next ->
        viewInstrCmd @sN (Right gen) lm ("raise "<>show exn, "") [] : next
    , viewGen = gen
    } where gen = raise exn
  fail fs = ViewMachine
    { unViewMachine = \lm next ->
        viewInstrCmd @sN (Right gen) lm ("fail "<>show (Set.toList fs), "") [] : next
    , viewGen = gen
    } where gen = fail fs
  commit exn k = ViewMachine
    { unViewMachine = \lm next ->
        viewInstrCmd @sN (Right gen) lm ("commit "<>show exn, "") [] :
        unViewMachine k lm next
    , viewGen = gen
    } where gen = commit exn (viewGen k)
  catch exn ok ko = ViewMachine
    { unViewMachine = \lm next ->
        viewInstrCmd @sN (Right gen) lm ("catch "<>show exn, "")
          [ viewInstrArg "catchScope" (unViewMachine ok lm [])
          , viewInstrArg ("onException "<>show exn) (unViewMachine ko lm [])
          ] : next
    , viewGen = gen
    } where gen = catch exn (viewGen ok) (viewGen ko)
instance
  HideableName sN =>
  InstrBranchable (ViewMachine sN) where
  caseBranch l r = ViewMachine
    { unViewMachine = \lm next ->
        viewInstrCmd @sN (Right gen) lm ("case", "")
          [ viewInstrArg "left" (unViewMachine l lm [])
          , viewInstrArg "right" (unViewMachine r lm [])
          ] : next
    , viewGen = gen
    } where gen = caseBranch (viewGen l) (viewGen r)
  choicesBranch bs d = ViewMachine
    { unViewMachine = \lm next ->
        viewInstrCmd @sN (Right gen) lm ("choicesBranch", "") (
          ((\(p, b) -> viewInstrArg ("branch "<>showSplice p) $
            unViewMachine b lm []) <$> bs) <>
          [ viewInstrArg "default" (unViewMachine d lm []) ]
        ) : next
    , viewGen = gen
    } where gen = choicesBranch ((viewGen <$>) <$> bs) (viewGen d)
instance
  HideableName sN =>
  InstrCallable (ViewMachine sN) where
  defLet defs k = ViewMachine
    { unViewMachine = \lm next ->
        (<> unViewMachine k lm next) $
        List.sortBy (compare `on` (((fst <$>) <$>) . Tree.levels)) $
        ((\(n, SomeLet sub) ->
          viewInstrCmd @sN (Left n) lm
            ("let", " "<>show (hideableName @sN n))
            (unViewMachine sub lm []))
          <$> HM.toList defs)
    , viewGen = gen
    } where gen = defLet ((\(SomeLet x) -> SomeLet (viewGen x)) <$> defs) (viewGen k)
  jump isRec ln@(LetName n) = ViewMachine
    { unViewMachine = \lm next ->
        viewInstrCmd @sN (Right gen) lm ("jump", " "<>show (hideableName @sN n)) [] : next
    , viewGen = gen
    } where gen = jump isRec ln
  call isRec ln@(LetName n) k = ViewMachine
    { unViewMachine = \lm next ->
        viewInstrCmd @sN (Right gen) lm ("call", " "<>show (hideableName @sN n)) [] :
        unViewMachine k lm next
    , viewGen = gen
    } where gen = call isRec ln (viewGen k)
  ret = ViewMachine
    { unViewMachine = \lm next ->
        viewInstrCmd @sN (Right gen) lm ("ret", "") [] : next
    , viewGen = gen
    } where gen = ret
instance
  HideableName sN =>
  InstrJoinable (ViewMachine sN) where
  defJoin ln@(LetName n) sub k = ViewMachine
    { unViewMachine = \lm next ->
        viewInstrCmd @sN (Left n) lm
          ("join", " "<>show (hideableName @sN n))
          (unViewMachine sub lm []) :
        unViewMachine k lm next
    , viewGen = gen
    } where gen = defJoin ln (viewGen sub) (viewGen k)
  refJoin ln@(LetName n) = ViewMachine
    { unViewMachine = \lm next ->
        viewInstrCmd @sN (Right gen) lm ("refJoin", " "<>show (hideableName @sN n)) [] : next
    , viewGen = gen
    } where gen = refJoin ln
instance
  HideableName sN =>
  InstrInputable (ViewMachine sN) where
  saveInput k = ViewMachine
    { unViewMachine = \lm next ->
        viewInstrCmd @sN (Right gen) lm ("saveInput", "") [] :
        unViewMachine k lm next
    , viewGen = gen
    } where gen = saveInput (viewGen k)
  loadInput k = ViewMachine
    { unViewMachine = \lm next ->
        viewInstrCmd @sN (Right gen) lm ("loadInput", "") [] :
        unViewMachine k lm next
    , viewGen = gen
    } where gen = loadInput (viewGen k)
instance
  ( HideableName sN
  , InstrReadable tok Gen
  ) => InstrReadable tok (ViewMachine sN) where
  read es p k = ViewMachine
    { unViewMachine = \lm next ->
        viewInstrCmd @sN (Right gen) lm ("read "<>showSplice p, "") [] :
        unViewMachine k lm next
    , viewGen = gen
    } where gen = read es p (viewGen k)
instance
  HideableName sN =>
  InstrIterable (ViewMachine sN) where
  iter jumpName@(LetName n) ok ko = ViewMachine
    { unViewMachine = \lm next ->
        viewInstrCmd @sN (Right gen) lm ("iter", " "<>show (hideableName @sN n))
          [ viewInstrArg "ok" (unViewMachine ok lm [])
          , viewInstrArg "ko" (unViewMachine ko lm [])
          ] : next
    , viewGen = gen
    } where gen = iter jumpName (viewGen ok) (viewGen ko)
instance
  HideableName sN =>
  InstrRegisterable (ViewMachine sN) where
  newRegister reg@(UnscopedRegister r) k = ViewMachine
    { unViewMachine = \lm next ->
        viewInstrCmd @sN (Right gen) lm ("newRegister", " "<>show (hideableName @sN r)) [] :
        unViewMachine k lm next
    , viewGen = gen
    } where gen = newRegister reg (viewGen k)
  readRegister reg@(UnscopedRegister r) k = ViewMachine
    { unViewMachine = \lm next ->
        viewInstrCmd @sN (Right gen) lm ("readRegister", " "<>show (hideableName @sN r)) [] :
        unViewMachine k lm next
    , viewGen = gen
    } where gen = readRegister reg (viewGen k)
  writeRegister reg@(UnscopedRegister r) k = ViewMachine
    { unViewMachine = \lm next ->
        viewInstrCmd @sN (Right gen) lm ("writeRegister", " "<>show (hideableName @sN r)) [] :
        unViewMachine k lm next
    , viewGen = gen
    } where gen = writeRegister reg (viewGen k)