{-# Language ImplicitParams #-}

module Fig.Bless.Runtime
  ( ValueF(..), Value
  , ValueSort(..), valueSort
  , RuntimeError(..)
  , RunningTop, Running
  , BuiltinProgram, Builtin, Builtins
  , VM(..)
  , initialize
  , runProgram, runWord, run
  ) where

import Fig.Prelude

import Control.Exception.Safe (Typeable)

import qualified Data.Text as Text
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map

import qualified Data.Aeson as Aeson

import Fig.Bless.Types
import qualified Fig.Bless.Syntax as Syn

data ValueF t v
  = ValueInteger Integer
  | ValueDouble Double
  | ValueString Text
  | ValueProgram (Syn.ProgramF t)
  | ValueArray [v]
  deriving (Show, Eq, Ord, Generic)
instance (Aeson.ToJSON t, Aeson.ToJSON v) => Aeson.ToJSON (ValueF t v)
instance (Pretty t, Pretty v) => Pretty (ValueF t v) where
  pretty (ValueInteger i) = tshow i
  pretty (ValueDouble d) = tshow d
  pretty (ValueString s) = tshow s
  pretty (ValueProgram p) = pretty p
  pretty (ValueArray vs) = mconcat
    [ "["
    , Text.intercalate ", " $ pretty <$> vs
    , "]"
    ]
type Value = ValueF (Fix Syn.TermF) (Fix (ValueF (Fix Syn.TermF)))

data ValueSort
  = ValueSortInteger
  | ValueSortDouble
  | ValueSortString
  | ValueSortWord
  | ValueSortProgram
  | ValueSortArray
  deriving (Show, Eq, Ord, Generic)
instance Aeson.ToJSON ValueSort
instance Pretty ValueSort where
  pretty ValueSortInteger = "integer"
  pretty ValueSortDouble = "double"
  pretty ValueSortString = "string"
  pretty ValueSortWord = "word"
  pretty ValueSortProgram = "program"
  pretty ValueSortArray = "list"
valueSort :: ValueF t v -> ValueSort
valueSort (ValueInteger _) = ValueSortInteger
valueSort (ValueDouble _) = ValueSortDouble
valueSort (ValueString _) = ValueSortString
valueSort (ValueProgram _) = ValueSortProgram
valueSort (ValueArray _) = ValueSortArray

data RuntimeError t
  = RuntimeErrorWordNotFound (Maybe t) Syn.Word
  | RuntimeErrorOutOfFuel (Maybe t)
  | RuntimeErrorStackUnderflow (Maybe t)
  | RuntimeErrorSortMismatch (Maybe t) ValueSort ValueSort
  deriving (Show, Eq, Ord, Generic)
instance (Show t, Typeable t) => Exception (RuntimeError t)
instance Aeson.ToJSON t => Aeson.ToJSON (RuntimeError t)
runtimeErrorPrefix :: Pretty t => Maybe t -> Text
runtimeErrorPrefix Nothing = ""
runtimeErrorPrefix (Just t) = mconcat
  [ "while evaluating term: ", pretty t, "\n"
  ]
instance Pretty t => Pretty (RuntimeError t) where
  pretty (RuntimeErrorWordNotFound t w) = mconcat
    [ runtimeErrorPrefix t
    , "word definition not found for: ", pretty w
    ]
  pretty (RuntimeErrorOutOfFuel t) = mconcat
    [ runtimeErrorPrefix t
    , "out of fuel"
    ]
  pretty (RuntimeErrorStackUnderflow t) = mconcat
    [ runtimeErrorPrefix t
    , "stack underflow"
    ]
  pretty (RuntimeErrorSortMismatch t expected actual) = mconcat
    [ runtimeErrorPrefix t
    , "sort mismatch at runtime (this probably shouldn't happen, please report it as a bug):\n"
    , "expected: ", pretty expected, "\n"
    , "actual: ", pretty actual
    ]

type RunningTop m t v = (MonadThrow m, Typeable t, Show t)
type Running m t v = (RunningTop m t v, ?term :: Maybe t)
type BuiltinProgram m t v = VM m t v -> m (VM m t v)
type Builtin m t v = (BuiltinProgram m t v, BProgType)
type Builtins m t v = Maybe t -> Map Syn.Word (Builtin m t v)
data VM m t v = VM
  { fuel :: Maybe Integer
  , bindings :: Syn.DictionaryF t
  , builtins :: Builtins m t v
  , stack :: [ValueF t v]
  }

initialize :: Running m t v => Maybe Integer -> Syn.DictionaryF t -> Builtins m t v -> VM m t v
initialize fuel bindings builtins = VM{..}
  where
    stack = []

checkFuel :: Running m t v => VM m t v -> m (VM m t v)
checkFuel vm
  | Just f <- vm.fuel
  = if f <= 0
    then throwM $ RuntimeErrorOutOfFuel ?term
    else pure vm { fuel = Just $ f - 1 }
checkFuel vm = pure vm

push :: Running m t v => ValueF t v -> VM m t v -> VM m t v
push v vm = vm
  { stack = v : vm.stack
  }

runProgram :: Running m t v => Syn.Extractor m t -> Syn.ProgramF t -> VM m t v -> m (VM m t v)
runProgram f (Syn.Program p) vm = foldM (flip (run f)) vm p

runWord :: Running m t v => Syn.Extractor m t -> Syn.Word -> VM m t v -> m (VM m t v)
runWord _ w vm | Just (b, _) <- Map.lookup w $ vm.builtins ?term = b vm
runWord f w vm | Just p <- lookup w vm.bindings.defs = runProgram f p vm
runWord _ w _ = throwM $ RuntimeErrorWordNotFound ?term w

run :: Running m t v => Syn.Extractor m t -> t -> VM m t v -> m (VM m t v)
run f v vm =
  let ?term = Just v in f v >>= \case
    Syn.TermLiteral (Syn.LiteralInteger i) -> push (ValueInteger i) <$> checkFuel vm
    Syn.TermLiteral (Syn.LiteralDouble i) -> push (ValueDouble i) <$> checkFuel vm
    Syn.TermLiteral (Syn.LiteralString i) -> push (ValueString i) <$> checkFuel vm
    Syn.TermQuote p -> push (ValueProgram p) <$> checkFuel vm
    Syn.TermWord w -> runWord f w =<< checkFuel vm