{-# LANGUAGE TupleSections #-}

module Code where

import Constant
import Control.Monad.Trans.State.Lazy (StateT)
import qualified Data.Map as M
import IR (StrTable)
import Operators (Ops)
import Parser (PAST)
import System.Console.Haskeline (InputT)

data Id =
  Id
    { str :: !Int
    , arity :: !Int
    }
  deriving (Show, Eq, Ord)

data Datum
  = C !Constant -- unifies a constant
  | Struct !Id -- unifies a structure with arity
  | VoidRef -- unifies with anything
  | LocalRef !Int -- code-local variable idx (should never occur on heap)
  | HeapRef !Int -- something further on the heap
  deriving (Show, Eq, Ord)

data Instr
  = U !Datum -- unify/resolve something
  | Invoke Builtin -- give control to a builtin (invoked from head)
  | Done -- all done, can return
  | Cut -- remove choicepoints of the current goal
  | Choices [Code] -- split off several possibilities (push choicepoints)
  deriving (Show)

type Code = [Instr]

type Defs = M.Map Id [Code]

data Heap =
  Heap !Int (M.Map Int Datum)
  deriving (Show)

emptyHeap = Heap 1 M.empty

type Scope = M.Map Int Int

emptyScope :: Scope
emptyScope = M.empty

data Cho =
  Cho
    { _hed :: Code -- head pointer
    , _hvar :: Scope -- variables unified in head (so far)
    , _gol :: Code -- goal pointer
    , _gvar :: Scope -- variables unified in the goal
    , _unis :: Int -- items left to unify
    , _retcut :: Bool -- cut after this goal succeeds
    , _heap :: Heap -- a snapshot of the heap (there's no trail; we rely on CoW copies in other choicepoints)
    , _stk :: [(Code, Scope, [Cho], Bool)] -- remaining goals together with their vars, cuts, and ret-cut flag
    , _cut :: [Cho] -- snapshot of choicepoints before entering the goal
    , _hcut :: [Cho] -- save of choicepoints just before starting to match head
    }
  deriving (Show)

data Interp =
  Interp
    { _defs :: Defs -- global definitions for lookup
    , _cur :: Cho -- the choice that is being evaluated right now
    , _cho :: [Cho] -- remaining choice points
    , _ops :: Ops -- currently defined operators
    , _opstash :: [Ops] -- saved operators
    , _macrostash :: [(Maybe [Code], Maybe [Code])] -- saved expansion defs (load, query)
    , _strtable :: StrTable -- string table
    , _cmdq :: [(Bool, PAST)] -- isQuery, lexemes
    }
  deriving (Show)

type PrlgEnv = StateT Interp (InputT IO)

type InterpFn = PrlgEnv (Maybe (Either String Bool))

data Builtin =
  Builtin InterpFn

instance Show Builtin where
  show _ = "Builtin _"