-- "src/Dao/Interpreter.hs"  defines the Dao programming language semantics.
-- 
-- Copyright (C) 2008-2014  Ramin Honary.
-- This file is part of the Dao System.
--
-- The Dao System is free software: you can redistribute it and/or
-- modify it under the terms of the GNU General Public License as
-- published by the Free Software Foundation, either version 3 of the
-- License, or (at your option) any later version.
-- 
-- The Dao System is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU General Public License for more details.
-- 
-- You should have received a copy of the GNU General Public License
-- along with this program (see the file called "LICENSE"). If not, see
-- <http://www.gnu.org/licenses/agpl.html>.

{-# LANGUAGE CPP #-}

module Dao.Interpreter(
    Action(Action), actionTokens, actionPattern, actionMatch, actionCodeBlock,
    makeActionsForQuery, betweenBeginAndEnd, daoShutdown, getLocalRuleSet,
    getGlobalRuleSet, defaultTokenizer, constructPatternWith, constructPattern,
    DaoSetupM(), DaoSetup, haskellType, daoProvides, daoClass, daoConstant, daoFunction,
    daoFunction0, daoInitialize, setupDao, evalDao, DaoFunc, daoFunc, funcAutoDerefParams,
    daoForeignFunc, executeDaoFunc,
    Sizeable(getSizeOf),
    ObjectClass(obj, fromObj, castToCoreType),
    execCastToCoreType, listToObj, listFromObj, new, opaque, objFromHata,
    Struct(Nullary, Struct), structLookup,
    ToDaoStructClass(toDaoStruct), toDaoStructExec, pPrintStructForm,
    FromDaoStructClass(fromDaoStruct), withFromDaoStructExec, fromDaoStructExec,
    StructError(StructError),
    structErrName, structErrField, structErrValue, structErrExtras,
    mkLabel, mkStructName, mkFieldName,
    ToDaoStruct(),
    fromData, innerToStruct, innerToStructWith, renameConstructor, makeNullary, putNullaryUsingShow,
    define, optionalField, setField, defObjField, (.=), putObjField, (.=@), defMaybeObjField, (.=?),
    FromDaoStruct(),
    toData, constructor, innerFromStruct, nullary, getNullaryWithRead, structCurrentField,
    tryCopyField, tryField, copyField, field,
    convertFieldData, req, opt, reqList, optList,
    ObjectUpdate, ObjectTraverse,
    ObjectLens(updateIndex), ObjectFunctor(objectFMap),
    ObjectFocus, ObjFocusState(), getFocalReference,
    execToFocusUpdater, withInnerLens, runObjectFocus, focusObjectClass, focusStructAsDict,
    focusLiftExec, focalPathSuffix, focusGuardStructName, updateHataAsStruct, callMethod,
    innerDataUpdateIndex, referenceUpdateName, referenceLookupName,
    Object(
      ONull, OTrue, OType, OInt, OWord, OLong,
      OFloat, ORatio, OComplex, OAbsTime, ORelTime,
      OChar, OString, ORef, OList, ODict, OTree, OBytes, OHaskell
    ),
    T_type, T_int, T_word, T_long, T_ratio, T_complex, T_float, T_time, T_diffTime,
    T_char, T_string, T_ref, T_bytes, T_list, T_dict, T_struct,
    isNumeric, typeMismatchError,
    initializeGlobalKey, destroyGlobalKey, evalTopLevelAST,
    Reference(Reference, RefObject), reference, refObject, referenceHead, refUnwrap,
    refNames, referenceFromUStr, fmapReference, setQualifier, modRefObject,
    refAppendSuffix, referenceLookup, referenceUpdate,
    CoreType(
      NullType, TrueType, TypeType, IntType, WordType, DiffTimeType, FloatType,
      LongType, RatioType, ComplexType, TimeType, CharType, StringType, RefType,
      ListType, DictType, TreeType, BytesType, HaskellType
    ),
    typeOfObj, coreType, hataType, objTypeFromCoreType, objTypeFromName,
    TypeSym(CoreType, TypeSym, TypeVar), TypeStruct(TypeStruct), ObjType(ObjType), typeChoices,
    RefSuffix(NullRef, DotRef, Subscript, FuncCall),
    refSuffixHead, refSuffixHasFuncCall, refSuffixToList, dotRef, subscript, funcCall,
    Complex(Complex),
    realPart, imagPart, mkPolar, cis, polar, magnitude, phase, conjugate, complex,
    minAccumArray, minArray,
    FuzzyStr(FuzzyStr),
    ExecUnit(), ExecTokenizer(ExecTokenizer), runExecTokenizer,
    globalMethodTable, defaultTimeout, importGraph, currentWithRef, taskForExecUnits,
    currentQuery, currentPattern, currentBranch, providedAttributes, programModuleName,
    preExec, postExec, quittingTime, programTokenizer, currentCodeBlock, ruleSet,
    newExecUnit, inModule,
    Task(), initTask, throwToTask, killTask, taskLoop, taskLoop_,
    Executable(execute), DerefAssignExpr,
    ExecRef(execReadRef, execTakeRef, execPutRef, execSwapRef, execModifyRef, execModifyRef_),
    ExecControl(ExecReturn, ExecError), execReturnValue,
    execErrorMessage, execErrorInModule, execErrorLocation, execErrorSubtype, execErrorInfo,
    ExecErrorSubtype(
      ExecErrorUntyped, ExecThrow, ExecStructError, ExecUndefinedRef, ExecTypeError,
      ExecUpdateOpError, ExecInfixOpError, ExecIOException, ExecHaskellError
    ),
    errInFunc, errInConstr, errInInitzr, errOfReference, argNum, numArgsPassed,
    expectNumArgs, exectDimension, expectType, actualType, leftSideType, rightSideType,
    modifiedConst, assertFailed, returnedVoid, errorDict,
    newError, throwArityError, throwParseError, throwBadTypeError, errLocation, errModule,
    errCurrentModule, errInfo, updateExecErrorInfo, logUncaughtErrors, clearUncaughtErrorLog,
    execForM, execForM_,
    Exec(Exec), execToPredicate, XPure(XPure), xpureToState, runXPure, evalXPure, xpure, xobj,
    xnote, xonUTF8, xmaybe,
    ExecThrowable(toExecErrorInfo, execThrow), ioExec,
    ExecHandler(ExecHandler), execHandler,
    newExecIOHandler, execCatchIO, execHandleIO, execIOHandler,
    execErrorHandler, catchReturn, execNested, execNested_, execFuncPushStack,
    execFuncPushStack_, execWithStaticStore, execWithWithRefStore, withExecTokenizer,
    Subroutine(Subroutine), setupCodeBlock,
    origSourceCode, staticVars, staticRules, staticLambdas, executable, runCodeBlock, runCodeBlock_,
    RuleSet(), CallableCode(CallableCode), argsPattern, returnType, codeSubroutine, 
    PatternRule(PatternRule), rulePatterns, ruleAction, 
    asReference, asInteger, asRational, asPositive, asComplex, objConcat,
    objToBool, extractStringElems, requireAllStringArgs,
    shiftLeft, shiftRight,
    evalArithPrefixOp, evalInfixOp, evalUpdateOp, runTokenizerWith, runTokenizer, makePrintFunc,
    paramsToGlobExpr, matchFuncParams, execGuardBlock, objToCallable, callCallables,
    callObject, checkPredicate, checkVoid,
    evalConditional,
    localVarDefine, localVarUpdate, localVarLookup, maybeDerefObject, derefObjectGetReference, derefObject,
    updateExecError,
    assignUnqualifiedOnly,
    LimitedObject(LimitedObject, unlimitObject),
    MethodTable(), execGetObjTable, lookupMethodTable,
    ReadIterable(readForLoop), UpdateIterable(updateForLoop),
    HataClass(haskellDataInterface), toHata, fromHata,
    InitItem(InitSingle, InitAssign),
    Interface(),
    objCastFrom, objEquality, objOrdering, objBinaryFormat, objNullTest, objPPrinter,
    objSizer, objIndexer, objIndexUpdater, objToStruct, objFromStruct, objInitializer, objTraverse,
    objInfixOpTable, objArithPfxOpTable, objCallable, objDereferencer,
    interfaceAdapter, interfaceToDynamic,
    DaoClassDefM(), interface, DaoClassDef,
    defCastFrom, autoDefEquality, defEquality, autoDefOrdering, defOrdering, autoDefBinaryFmt,
    defBinaryFmt, autoDefNullTest, defNullTest, defPPrinter, autoDefPPrinter, defReadIterable,
    autoDefReadIterable, defUpdateIterable, autoDefUpdateIterable, defIndexer, defIndexUpdater,
    defSizer, autoDefSizeable, autoDefToStruct, defToStruct, autoDefFromStruct, defFromStruct,
    defInitializer, defTraverse, autoDefTraverse, defInfixOp, defPrefixOp, defCallable, defDeref,
    defMethod, defMethod0, defLeppard
  )
  where

import           Dao.Glob
import           Dao.PPrint
import           Dao.Predicate
import           Dao.Random
import           Dao.Stack
import           Dao.String
import           Dao.Token
import           Dao.RefTable
import qualified Dao.HashMap as H
import qualified Dao.Binary  as B
import qualified Dao.Interval as Iv
import qualified Dao.Tree    as T
import           Dao.Interpreter.Tokenizer
import           Dao.Interpreter.AST

import           Data.Array.IArray
import           Data.Binary (encode)
import           Data.Bits
import           Data.Char
import           Data.Dynamic
import           Data.IORef
import           Data.List
import           Data.Monoid
import           Data.Ratio
import           Data.Time.Clock
import           Data.Word
import qualified Data.ByteString.Lazy.UTF8 as U
import qualified Data.ByteString.Lazy      as B
import qualified Data.Binary               as D
import qualified Data.Binary.Put           as D
import qualified Data.Binary.Get           as D
import qualified Data.Complex              as C
import qualified Data.Map                  as M
import qualified Data.Set                  as S

import           Control.Applicative
import           Control.Concurrent
import           Control.DeepSeq
import           Control.Exception
import           Control.Monad
import           Control.Monad.Error
import           Control.Monad.Reader
import           Control.Monad.State

#if 0
import Debug.Trace
import System.IO
strace :: PPrintable s => String -> s -> s
strace msg s = trace (msg++": "++prettyShow s) s
dbg :: MonadIO m => String -> m ()
dbg = liftIO . hPutStrLn stderr . ("(DEBUG) "++) . (>>=(\c -> if c=='\n' then "\n(DEBUG) " else [c]))
dbg' :: MonadIO m => String -> m a -> m a
dbg' msg f = f >>= \a -> dbg msg >> return a
dbg0 :: (MonadPlus m, MonadIO m, MonadError e m, Show e) => String -> m a -> m a
dbg0 msg f = do
  dbg (msg++" (BEGIN)")
  catchError
    (mplus (f >>= \a -> dbg (msg++" (DONE)") >> return a) (dbg (msg++" (BACKTRACKED)") >> mzero))
    (\e -> dbg (msg++" (ERROR) "++show e) >> throwError e)
updbg :: MonadIO m => String -> (Maybe Object -> m (Maybe Object)) -> Maybe Object -> m (Maybe Object)
updbg msg f o = dbg ("(update with "++msg++")") >> f o >>= \o -> dbg ("(update complete "++show o++")") >> return o
#endif
#if 0
_randTrace :: String -> RandO a -> RandO a
_randTrace = Dao.Random.randTrace
#else
_randTrace :: String -> RandO a -> RandO a
_randTrace _ = id
#endif

----------------------------------------------------------------------------------------------------

-- A note on the binary format.
--     Most constructors have a unique prefix byte, and this allows more efficient encoding because
-- it is not necessary to place null terminators everywhere and you can determine exactly which
-- constructor is under the decoder cursor just from the byte prefix. This means there is an
-- address space for prefix bytes between 0x00 and 0xFF. This is an overview of that address space.
-- 
-- 0x00..0x07 > The "Dao.Binary" module declares a few unique prefixes of its own for booleans,
--              variable-length integers, and maybe types, and of course the null terminator.
-- 0x08..0x1A > Each prefix here used alone indicates a 'CoreType's. But each prefix may be followed
--              by data which indicates that it is actuall one of the constructors for the 'Object'
--              data type.
-- 
-- 0x25..0x26 'Struct'
-- 0x2E..0x2F 'TypeSym'
-- 0x33       'TypeStruct'
-- 0x37       'ObjType' (T_type)
-- 
-- 0x42..0x45 > The 'RefSuffix' data type. These prefixes are re-used for the 'ReferenceExpr' data type
--              because there is a one-to-one mapping between these two data types.
-- 0x48..0x4F > The 'Reference' data type. These prefixes are re-used for the 'ReferenceExpr' data type
--              execpt for the 'RefWrapper' constructor which is mapped to @'RefPrefixExpr' 'REF'@.
-- 
-- -- the abstract syntax tree -- --
-- 
-- 0x52..0x53 'RefPrefixExpr'
-- 0x59       'ParenExpr'
-- 0x60..0x64 'ObjectExpr'
-- 0x6A       'ArithExpr'
-- 0x6F       'AssignExpr'
-- 0x73       'ObjTestExpr'
-- 0x74..0x76 'RuleFuncExpr'
-- 0x7A..0x7B 'RuleHeadExpr'
-- 0x81       'DotLabelExpr'
-- 0x82       'AttributeExpr'
-- 0x86       'ObjListExpr'
-- 0xBA..0xCD 'InfixOp'
-- 0x8D..0x9D 'UpdateOp' -- Partially overlaps with 'InfixOp'
-- 0x8E..0x9B 'ArithPfxOp' -- Partially overlaps with 'InfixOp'
-- 0xA8..0xAF 'ScriptExpr'
-- 0xB6       'ElseExpr'
-- 0xBA       'IfElseExpr'
-- 0xBE       'WhileExpr'
-- 0xC5..0xC7 'TyChkExpr'
-- 0xCF..0xD0 'ParamExpr'
-- 0xD6       'ParamListExpr'
-- 0xDD       'CodeBlock'
-- 0xE9..0xEE 'TopLevelExpr'

----------------------------------------------------------------------------------------------------

-- | An 'Action' is the result of a pattern match that occurs during an input string query. It is a
-- data structure that contains all the information necessary to run an 'Subroutine' assocaited with
-- a 'Glob', including the parent 'ExecUnit', the 'Dao.Glob.Glob' and the 'Dao.Glob.Match' objects,
-- and the 'Executables'. Use 'execute' to evaluate a 'Action' in the current thread.
-- 
-- To execute an action in a separate thread, use 'forkExecAction'.
data Action
  = Action
    { actionTokens    :: [Object]
    , actionPattern   :: Glob Object
    , actionMatch     :: M.Map Name Object
    , actionCodeBlock :: Subroutine
    }
  deriving (Eq, Typeable)

instance PPrintable Action where { pPrint = pPrintStructForm }

instance ToDaoStructClass Action where
  toDaoStruct = renameConstructor "Action" $ do
    "tokens"  .=@ actionTokens
    "pattern" .=@ actionPattern
    "match"   .=@ actionMatch
    "code"    .=@ actionCodeBlock

instance FromDaoStructClass Action where
  fromDaoStruct = do
    constructor "Action"
    let err name o = flip (execThrow "match dictionary items must contain lists of tokens") [] $
          StructError
          { structErrName   = Nothing
          , structErrField  = Just (toUStr name)
          , structErrValue  = Just $ obj (typeOfObj o)
          , structErrExtras = []
          }
    let fmtMatches = fmap M.fromList .
          mapM (\ (name, o) -> xmaybe (fromObj o) <|> err name o >>= return . (,) name) . M.assocs
    return Action <*> req "tokens" <*> req "pattern" <*> (req "match" >>= fmtMatches) <*> req "code"

instance ObjectClass Action where { obj=new; fromObj=objFromHata; }

instance HataClass Action where
  haskellDataInterface = interface "Action" $ do
    autoDefEquality >> autoDefPPrinter
    autoDefToStruct >> autoDefFromStruct

instance Executable Action (Maybe Object) where
  execute act = do
    cq  <- gets currentQuery
    cp  <- gets currentPattern
    ccb <- gets currentCodeBlock
    let setVar :: ObjectClass o => String -> (Action -> o) -> T_dict -> T_dict
        setVar name f = M.insert (ustr name) (obj $ f act)
    let setTokensVar = setVar "tokens" actionTokens
    let setSelfVar = M.union (M.singleton (ustr "self") (obj $ setTokensVar $ mempty))
    let localVars = setSelfVar $ actionMatch act
    modify $ \xunit -> 
      xunit
      { currentQuery     = Just $ actionTokens act
      , currentPattern   = Just $ actionPattern act
      , currentCodeBlock = Just $ actionCodeBlock act
      }
    success <- optional $ runCodeBlock_ localVars (actionCodeBlock act)
    modify (\xunit -> xunit{ currentQuery=cq, currentPattern=cp, currentCodeBlock=ccb })
    xmaybe success

instance Executable [Action] [Object] where
  execute = fmap concat .
    mapM (\act -> catchPredicate (execute act) >>= \p -> case p of
             OK                (Just o)  -> return [o]
             PFail (ExecReturn (Just o)) -> return [o]
             PFail              err      -> logUncaughtErrors [err] >> return []
             _                           -> return []
         )

-- | Using an 'ExecTokenizer' function, break up a string into a list of tokens, returning them as a
-- 'TokenList' object. Input paramaters can be strings or lists of strings. If an input paramter is
-- a string, it is tokenized to a list of strings. If an input parameter is a list of strings, it is
-- considered to be already tokenized and simply appended to list of tokens produced by previous
-- parameters.
runTokenizerWith :: ExecTokenizer -> [Object] -> Exec [Object]
runTokenizerWith tok ox = fmap concat $ forM ox $ \o -> case o of
  OString o -> fmap obj <$> runExecTokenizer tok o
  OList  ox -> return ox
  o         -> return [o]

-- | Like 'runTokenizerWith', but uses the default tokenizer function set for this module.
runTokenizer :: [Object] -> Exec [Object]
runTokenizer ox = gets programTokenizer >>= \tok -> runTokenizerWith tok ox

-- | Match a given input string to the 'Dao.Evaluator.currentPattern' of the current 'ExecUnit'.
-- Return all patterns and associated match results and actions that matched the input string, but
-- do not execute the actions. This is done by tokenizing the input string and matching the tokens
-- to the program using 'Dao.Glob.matchTree'. NOTE: Rules that have multiple patterns may execute
-- more than once if the input matches more than one of the patterns associated with the rule. *This
-- is not a bug.* Each pattern may produce a different set of match results, it is up to the
-- programmer of the rule to handle situations where the action may execute many times for a single
-- input.
-- 
-- Once you have created an action group, you can execute it with 'Dao.Evaluator.execute'.
makeActionsForQuery :: [PatternTree Object [Subroutine]] -> [Object] -> Exec [Action]
makeActionsForQuery tree tokens = do
  let match = matchTree False (T.unionsWith (++) tree) tokens
  fmap concat $ forM match $ \ (patn, match, execs) -> do
    match <- catchPredicate $ fmap M.fromList $ -- evaluate pattern type checkers
      forM (M.assocs match) $ \ (name, (vartyp, ox)) -> case vartyp of
        Nothing     -> return (name, obj ox)
        Just vartyp -> do
          match <- catchPredicate $ referenceLookup $ Reference UNQUAL vartyp $ FuncCall [OList ox] NullRef
          case match of
            OK (_, Nothing)             -> return (name, obj ox)
            OK (_, Just  o)             -> return (name, o)
            PFail (ExecReturn Nothing)  -> return (name, obj ox)
            PFail (ExecReturn (Just o)) -> return (name, o)
            PFail err                   -> throwError err
            Backtrack                   -> mzero
    case match of
      Backtrack -> return []
      PFail err -> logUncaughtErrors [err] >> return []
      OK  match -> return $
        flip fmap execs $ \exec -> deepseq exec $! deepseq tokens $! deepseq patn $! deepseq match $!
          Action
          { actionPattern   = patn
          , actionTokens    = fmap obj tokens
          , actionMatch     = match
          , actionCodeBlock = exec
          }

-- | Evaluate an executable function between evaluating all of the "BEGIN{}" and "END{}" statements.
betweenBeginAndEnd :: Exec a -> Exec a
betweenBeginAndEnd runInBetween = get >>= \xunit -> do
  -- Run all "BEGIN{}" procedures.
  mapM_ execute (preExec xunit)
  clearUncaughtErrorLog
  -- Run the given function, presumably it performs a string execution.
  a <- runInBetween
  -- Update the "global this" pointer to include the uncaught exceptions.
  errs <- OList . map new <$> clearUncaughtErrorLog
  let upd = M.union (M.singleton (ustr "errors") errs)
  referenceUpdate (Dao.Interpreter.reference GLOBAL (ustr "self")) False $ \o ->
    return $ Just $ ODict $ upd $ case o of { Just (ODict o) -> o; _ -> mempty; }
  -- Run all "END{}" procedures.
  mapM_ execute (postExec xunit)
  return a

-- | Evaluates the @EXIT@ scripts for every presently loaded dao program, and then clears the
-- 'Dao.Interpreter.importGraph', effectively removing every loaded dao program and idea file from memory.
daoShutdown :: Exec ()
daoShutdown = (M.elems <$> gets importGraph) >>=
  mapM_ (\xunit -> inModule xunit $ gets quittingTime >>= mapM_ execute)

-- | Returns a list of @'PatternTree' 'Object' ['Subroutine']@ objects from the global rule set and
-- the local rule set.
getLocalRuleSet :: Exec [PatternTree Object [Subroutine]]
getLocalRuleSet = do
  sub <- gets currentCodeBlock
  return $ maybe [] (return . staticRules) sub

-- | Returns a list of @'PatternTree' 'Object' ['Subroutine']@ objects from the global rule set and
-- the local rule set.
getGlobalRuleSet :: Exec [PatternTree Object [Subroutine]]
getGlobalRuleSet = return <$> gets ruleSet

_mkDoFunc :: String -> [Exec [PatternTree Object [Subroutine]]] -> (DaoFunc (), DaoFunc (), DaoFunc ())
_mkDoFunc name selectors = (mkDo, mkDoAll, mkQuery) where
  run f () ox = do
    inTrees <- concat <$> sequence selectors
    flip (,) () <$> (runTokenizer ox >>= makeActionsForQuery inTrees >>= f)
  mkQuery = daoFunc{daoFuncName=ustr("query"++name), daoForeignFunc=run(return . Just . obj . fmap obj)}
  mkDo    = daoFunc{daoFuncName=ustr("do"   ++name), daoForeignFunc=run(betweenBeginAndEnd . msum . fmap execute)}
  mkDoAll = daoFunc{daoFuncName=ustr("doAll"++name), daoForeignFunc=run(betweenBeginAndEnd . fmap (Just . obj) . execute)}

builtin_do    :: DaoFunc ()
builtin_doAll :: DaoFunc ()
builtin_query :: DaoFunc ()
(builtin_do, builtin_doAll, builtin_query) = _mkDoFunc "" [getLocalRuleSet, getGlobalRuleSet]

builtin_doLocal    :: DaoFunc ()
builtin_doAllLocal :: DaoFunc ()
builtin_queryLocal :: DaoFunc ()
(builtin_doLocal, builtin_doAllLocal, builtin_queryLocal) = _mkDoFunc "Local" [getLocalRuleSet]

builtin_doGlobal    :: DaoFunc ()
builtin_doAllGlobal :: DaoFunc ()
builtin_queryGlobal :: DaoFunc ()
(builtin_doGlobal, builtin_doAllGlobal, builtin_queryGlobal) = _mkDoFunc "Global" [getGlobalRuleSet]

----------------------------------------------------------------------------------------------------

-- | When a 'Dao.Interpreter.AST.RuleExpr' is evaluated to an 'Object', it takes this form.
-- 'PatternRule' instantiats 'Executable' such that 'execute' converts it to a 'PatternTree'.
data PatternRule
  = PatternRule{ rulePatterns :: [Object], ruleAction :: Subroutine }
  deriving (Show, Typeable)

instance NFData PatternRule where { rnf (PatternRule a b) = deepseq a $! deepseq b () }

instance HasNullValue PatternRule where
  nullValue = PatternRule{rulePatterns=[], ruleAction=nullValue}
  testNull (PatternRule a b) = null a && testNull b

instance PPrintable PatternRule where
  pPrint (PatternRule pats exe) = (\a -> ppCallableAction "rule" a nullValue exe) $ case pats of
    []    -> pString "()"
    [pat] -> pPrint pat
    pats  -> pList (pString "rule") "(" ", " ")" (map pPrint pats)

instance ToDaoStructClass PatternRule where
  toDaoStruct = renameConstructor "PatternRule" $ do
    "patterns" .=@ rulePatterns
    "action"   .=@ ruleAction

instance FromDaoStructClass PatternRule where
  fromDaoStruct = return PatternRule <*> req "patterns" <*> req "action"

instance Executable PatternRule (PatternTree Object [Subroutine]) where
  execute (PatternRule{ rulePatterns=pats, ruleAction=sub }) = do
    globs <- mapM (constructPattern . return) pats
    return $ insertMultiPattern (++) globs [sub] mempty

instance ObjectClass PatternRule where { obj=new; fromObj=objFromHata; }

instance HataClass PatternRule where
  haskellDataInterface = interface "PatternRule" $ do
    autoDefPPrinter >> autoDefToStruct >> autoDefFromStruct

defaultTokenizer :: ExecTokenizer
defaultTokenizer = ExecTokenizer $ return . fmap obj . simpleTokenizer . uchars

-- | This function takes a list of objects and constructs a list of @('Dao.Glob.Glob' 'Object')@s to
-- be inserted into a 'Dao.Glob.PatternTree' object. The input list of @['Object']@s will each form
-- a single pattern, then all of the patterns are unioned together to form the pattern tree. This
-- means token strings matched against the resulting @('Dao.Glob.Glob' 'Object')@ constructed by
-- this function will match any and all of the patterns.  If any of the objects in the input list
-- are strings, the strings will be parsed into 'Dao.Glob.Glob' objects, and each string constant
-- within the 'Dao.Glob.Glob' object will be further tokenized with the 'programTokenizer'.
constructPatternWith :: ExecTokenizer -> [Object] -> Exec (Glob Object)
constructPatternWith tok = fmap (mconcat . mconcat) . mapM (derefObject>=>construct) where
  construct o = case o of
    OString o -> case readsPrec 0 (uchars o) of
      [(glob, "")] -> fmap return $ parseOverSinglesM glob $ \str -> case str of
        ""  -> return []
        str -> fmap obj <$> runExecTokenizer tok (ustr str)
      _ -> execThrow "unable to parse pattern" ExecErrorUntyped []
    OList ox -> return [makeGlob $ fmap Single ox]
    OHaskell (Hata _ d) -> do
      let err = throwBadTypeError "could not use as pattern expression" o []
      maybe err return $ msum $
        [ return <$> fromDynamic d
        , fmap (makeGlob . fst) . T.assocs . ruleSetRules <$> fromDynamic d
        ]
    _ -> throwBadTypeError "could not create pattern from data of type" o []

-- | Like 'constructPatternWith' but uses the default 'ExecTokenizer' that has been set for the
-- current 'ExecUnit'.
constructPattern :: [Object] -> Exec (Glob Object)
constructPattern ox = gets programTokenizer >>= flip constructPatternWith ox

----------------------------------------------------------------------------------------------------

-- The stateful data for the 'DaoSetup' monad.
data SetupModState
  = SetupModState
    { daoSatisfies      :: M.Map UStr ()
      -- ^ a set of references that can satisfy "required" statements in Dao scripts.
    , daoSetupConstants :: M.Map Name Object
    , daoClasses        :: MethodTable
    , daoEntryPoint     :: Exec ()
    }

-- | This monadic type allows you to define a built-in module using procedural
-- programming syntax. Simply define each addition to the module one line at a time. Functions that
-- you can use include 'modProvides', 'modFunction', 'daoClass', and 'daoInitalize'.
-- 
-- Define clever names for every 'DaoSetup' you write, then 
type DaoSetup = DaoSetupM ()
newtype DaoSetupM a = DaoSetup{ daoSetupM :: State SetupModState a }
  deriving (Functor, Applicative, Monad)

-- | This function is a placeholder used by the type system. The value of this function is
-- undefined, so strictly evaluating it will throw an exception. Fortunately, the only time you will
-- ever use this function is with the 'daoClass' function, which uses the type of this function but
-- never it's value. Refer to the documentation on 'daoClass' to see how to properly use this
-- function.
haskellType :: HataClass o => o
haskellType = error $ unwords $
  [ "the haskellType function is just a placeholder"
  , "used by the type system, it must not be evaluated."
  ]

_updateSetupModState :: (SetupModState -> SetupModState) -> DaoSetup
_updateSetupModState f = DaoSetup (modify f)

-- | Dao programs can declare "requires" statements along with it's imports. If your built-in module
-- provides what Dao programs might "required", then declare that this module provides that feature
-- using this function.
daoProvides :: UStrType s => s -> DaoSetup
daoProvides label = _updateSetupModState $ \st ->
  st{ daoSatisfies = M.insert (toUStr label) () $ daoSatisfies st }

-- | Associate an 'HataClass' with a 'Name'. This 'Name' will be callable from within Dao scripts.
-- > newtype MyClass = MyClass { ... } deriving (Eq, Ord)
-- >
-- > instance 'HataClass' MyClass where
-- >     'haskellDataInterface' = 'interface' $ do
-- >         'autoDefEquality'
-- >         'autoDefOrdering'
-- >         ...
-- >
-- > setupDao :: 'DaoSetup'
-- > setupDao = do
-- >     daoClass "myClass" (haskellType::MyClass)
-- >     ...
daoClass :: (Typeable o, HataClass o) => o -> DaoSetup
daoClass ~o = _updateSetupModState $ \st ->
  st{ daoClasses = _insertMethodTable o haskellDataInterface (daoClasses st) }

-- | Define a built-in top-level function that is not a member method of any object. Examples of
-- built-in functions provided in this module are "println()" and "typeof()".
daoFunction :: (Show name, UStrType name) => name -> DaoFunc () -> DaoSetup
daoFunction name func = _updateSetupModState $ \st -> let nm = (fromUStr $ toUStr name) in
  st{ daoSetupConstants = M.insert nm (new $ func{ daoFuncName=nm }) (daoSetupConstants st) }

-- | Like 'daoFunction' but creates a function that takes no parameters.
daoFunction0 :: Name -> Exec (Maybe Object) -> DaoSetup
daoFunction0 name f = daoFunction name $
  DaoFunc
  { daoFuncClass = []
  , daoFuncName  = nil
  , funcAutoDerefParams = False
  , daoForeignFunc = \ () ox -> case ox of
      [] -> flip (,) () <$> f
      _  -> throwArityError "" 0 ox [(errInFunc, obj $ reference UNQUAL name)]
  }

-- | Define a constant value for any arbitrary 'Object'.
daoConstant :: (Show name, UStrType name) => name -> Object -> DaoSetup
daoConstant name o = _updateSetupModState $ \st ->
  st{ daoSetupConstants = M.insert (fromUStr $ toUStr name) o (daoSetupConstants st) }

-- | Provide an 'Exec' monad to perform when 'setupDao' is evaluated. You may use this function as
-- many times as you wish, every 'Exec' monad will be executed in the order they are specified. This
-- is a good way to create a read-eval-print loop.
daoInitialize :: Exec () -> DaoSetup
daoInitialize f = _updateSetupModState $ \st -> st{ daoEntryPoint = daoEntryPoint st >> f }

-- | Use this function evaluate a 'DaoSetup' in the IO () monad. Use this to define the 'main'
-- function of your program.
setupDao :: DaoSetup -> IO (Predicate ExecControl ())
setupDao setup0 = do
  let setup = execState (daoSetupM $ loadEssentialFunctions >> setup0) $
        SetupModState
        { daoSatisfies      = M.empty
        , daoSetupConstants = M.empty
        , daoClasses        = mempty
        , daoEntryPoint     = return ()
        }
  xunit  <- _initExecUnit
  fmap fst $ ioExec (daoEntryPoint setup) $
    xunit
    { providedAttributes = daoSatisfies setup
    , builtinConstants   = daoSetupConstants setup
    , globalMethodTable  = daoClasses setup
    }

-- | Simply run a single 'Exec' function in a fresh environment with no setup, and delete the
-- envrionment when finished returning only the 'Dao.Predicate.Predicate' result of the 'Exec'
-- evaluation. If you want to have more control over the runtime in which the 'Exec' function runs,
-- use 'setupDao' with 'daoInitialize'.
evalDao :: Exec a -> IO (Predicate ExecControl a)
evalDao f = _initExecUnit >>= fmap fst . ioExec f

----------------------------------------------------------------------------------------------------

-- | All object methods that operate on object data types built-in to the Dao language, or built-in
-- to a library extending the Dao language, are stored in 'Data.Map.Map's from the functions name to
-- an object of this type.
--
-- The @this@ of this function is the data type of what languages like C++ or Java would call the
-- "self" variable. 'DaoFunc's where the @this@ is () are considered ordinary functions that do not
-- operate on any object apart from their input parameters.
data DaoFunc this
  = DaoFunc
    { daoFuncClass        :: [Name]
    , daoFuncName         :: Name
    , funcAutoDerefParams :: Bool
    , daoForeignFunc      :: this -> [Object] -> Exec (Maybe Object, this)
    }
  deriving Typeable
instance Eq   (DaoFunc this) where { a == b = daoFuncName a == daoFuncName b; }
instance Ord  (DaoFunc this) where { compare a b = compare (daoFuncName a) (daoFuncName b) }
instance Show (DaoFunc this) where
  show func =
    if null (daoFuncClass func)
    then uchars (daoFuncName func)
    else foldr (\name str -> uchars name ++ "." ++ str) (uchars $ daoFuncName func) (daoFuncClass func)
instance PPrintable (DaoFunc this) where { pPrint = pShow }

-- | Use this as the constructor of a 'DaoFunc'. By default the @this@ type is (). To change the
-- @this@ type, simply supply a different function type for the 'daoForeignFunc' field. For example:
-- > daoFunc{ daoFuncName=ustr "add", daoForeignFunc = retrun . (+1) } :: DaoFunc Int
daoFunc :: DaoFunc typ
daoFunc =
  DaoFunc
  { daoFuncClass        = []
  , daoFuncName         = nil
  , funcAutoDerefParams = True
  , daoForeignFunc      = \typ _ -> return (Nothing, typ)
  }

-- | Execute a 'DaoFunc' 
executeDaoFunc :: DaoFunc this -> this -> [Object] -> Exec (Maybe Object, this)
executeDaoFunc fn this params = do
  args <- (if funcAutoDerefParams fn then mapM derefObject else return) params
  pval <- catchPredicate (daoForeignFunc fn this args)
  case pval of
    OK            (o, this) -> return (o, this)
    PFail (ExecReturn    o) -> return (o, this)
    PFail              err  -> throwError err
    Backtrack               -> mzero

-- Evaluate this function as one of the instructions in the monadic function passed to the
-- 'setupDao' function in order to install the most fundamental functions into the Dao evaluator.
-- This function must be evaluated in order to have access to the following functions:
-- > print, join, defined, delete
loadEssentialFunctions :: DaoSetup
loadEssentialFunctions = do
  daoClass (haskellType :: H.HashMap Object Object)
  daoClass (haskellType :: RuleSet)
  daoClass (haskellType :: Pair)
  daoFunction "print"    builtin_print
  daoFunction "println"  builtin_println
  daoFunction "join"     builtin_join
  daoFunction "str"      builtin_str
  daoFunction "quote"    builtin_quote
  daoFunction "concat"   builtin_concat
  daoFunction "concat1"  builtin_concat1
  daoFunction "reverse"  builtin_reverse
  daoFunction "int"      builtin_int
  daoFunction "long"     builtin_long
  daoFunction "ratio"    builtin_ratio
  daoFunction "float"    builtin_float
  daoFunction "complex"  builtin_complex
  daoFunction "imag"     builtin_imag
  daoFunction "phase"    builtin_phase
  daoFunction "conj"     builtin_conj
  daoFunction "abs"      builtin_abs
  daoFunction "time"     builtin_time
  daoFunction "now"      builtin_now
  daoFunction "ref"      builtin_ref
  daoFunction "defined"  builtin_check_if_defined
  daoFunction "delete"   builtin_delete
  daoFunction "typeof"   builtin_typeof
  daoFunction "sizeof"   builtin_sizeof
  daoFunction "call"     builtin_call
  daoFunction "toHash"   builtin_toHash
  daoFunction "fromHash" builtin_fromHash
  daoFunction "tokenize" builtin_tokenize
  daoFunction "query"    builtin_query
  daoFunction "doAll"    builtin_doAll
  daoFunction "do"       builtin_do
  daoFunction "fromStruct"  builtin_fromStruct
  daoFunction "toStruct"    builtin_toStruct
  daoFunction "queryGlobal" builtin_queryGlobal
  daoFunction "doAllGlobal" builtin_doAllGlobal
  daoFunction "doGlobal"    builtin_doGlobal
  daoFunction "queryLocal"  builtin_queryLocal
  daoFunction "doAllLocal"  builtin_doAllLocal
  daoFunction "doLocal"     builtin_doLocal
  daoFunction "HashMap"     builtin_HashMap
  daoFunction "assocs"      builtin_assocs
  daoFunction "Pair"        builtin_Pair
  mapM_ (uncurry daoConstant) $ flip fmap [minBound..maxBound] $ \t ->
    (toUStr $ show t, OType $ objTypeFromCoreType t)

instance ObjectClass (DaoFunc ())      where { obj=new; fromObj=objFromHata; }
instance ObjectClass (DaoFunc Dynamic) where { obj=new; fromObj=objFromHata; }
instance ObjectClass (DaoFunc Hata)    where { obj=new; fromObj=objFromHata; }
instance ObjectClass (DaoFunc Object)  where { obj=new; fromObj=objFromHata; }

instance HataClass (DaoFunc ()) where
  haskellDataInterface = interface "Builtin_Function" $ do
    autoDefEquality >> autoDefOrdering >> autoDefPPrinter

instance HataClass (DaoFunc Dynamic) where
  haskellDataInterface = interface "Builtin_Dynamic_Method" $ do
    autoDefEquality >> autoDefOrdering >> autoDefPPrinter

instance HataClass (DaoFunc Hata) where
  haskellDataInterface = interface "Builtin_Haskell_Data_Method" $ do
    autoDefEquality >> autoDefOrdering >> autoDefPPrinter

instance HataClass (DaoFunc Object) where
  haskellDataInterface = interface "Builtin_Object_Method" $ do
    autoDefEquality >> autoDefOrdering >> autoDefPPrinter

----------------------------------------------------------------------------------------------------

-- | This class provides a consistent interface, the 'obj' function, for converting a wide range of
-- types to an 'Object' type.
class ObjectClass o where
  obj            :: o -> Object
  fromObj        :: Object -> Maybe o
  castToCoreType :: CoreType -> o -> XPure Object
  castToCoreType _ _ = mzero

execCastToCoreType :: ObjectClass o => CoreType -> o -> Exec Object
execCastToCoreType t = execute . castToCoreType t

instance ObjectClass () where
  obj () = ONull
  fromObj o = case o of { ONull -> return (); _ -> mzero; }
  castToCoreType t () = case t of
    NullType     -> return ONull
    CharType     -> return $ OChar '\0'
    IntType      -> return $ OInt 0
    WordType     -> return $ OWord 0
    LongType     -> return $ OLong 0
    DiffTimeType -> return $ ORelTime 0
    FloatType    -> return $ OFloat 0
    RatioType    -> return $ ORatio 0
    ComplexType  -> return $ OComplex $ complex 0 0
    StringType   -> return $ OString nil
    BytesType    -> return $ OBytes mempty
    ListType     -> return $ OList []
    DictType     -> return $ ODict mempty
    _            -> mzero

instance ObjectClass Bool where
  obj true = if true then OTrue else ONull
  fromObj o = case o of { OTrue -> return True; ONull -> return False; _ -> mzero }
  castToCoreType t o = case t of
    NullType     -> guard (not o) >> return ONull
    TrueType     -> guard o >> return OTrue
    CharType     -> return $ OChar    $ if o then '1' else '0'
    IntType      -> return $ OInt     $ if o then 1 else 0
    WordType     -> return $ OWord    $ if o then 1 else 0
    LongType     -> return $ OLong    $ if o then 1 else 0
    DiffTimeType -> return $ ORelTime $ if o then 1 else 0
    FloatType    -> return $ OFloat   $ if o then 1 else 0
    RatioType    -> return $ ORatio   $ if o then 1 else 0
    ComplexType  -> return $ OComplex $ if o then complex 1 0 else complex 0 0
    StringType   -> return $ obj      $ if o then "true" else "false"
    BytesType    -> return $ OBytes $ B.pack $ return $ if o then 1 else 0
    _            -> mzero

instance ObjectClass Char where
  obj = OChar
  fromObj o = case o of { OChar o -> return o; _ -> mzero; }
  castToCoreType t = case t of
    NullType     -> \o -> guard (o=='\0') >> return ONull
    TrueType     -> \o -> case o of
      '0' -> return ONull
      '1' -> return OTrue
      _   -> mzero
    CharType     -> return . OChar
    IntType      -> return . OInt     . ord
    WordType     -> return . OWord    . fromIntegral . ord
    LongType     -> return . OLong    . fromIntegral . ord
    DiffTimeType -> return . ORelTime . fromRational . toRational . ord
    FloatType    -> return . OFloat   . fromRational . toRational . ord
    RatioType    -> return . ORatio   . toRational   . ord
    ComplexType  -> return . OComplex . flip complex 0 . fromRational . toRational . ord
    StringType   -> return . obj      . (:[])
    BytesType    -> return . OBytes . D.runPut . D.putWord64le . fromIntegral . ord
    _            -> \ _ -> mzero

charFromIntegral :: (MonadPlus m, Integral i) => i -> m Char
charFromIntegral i0 =
  let i = fromIntegral i0
  in if ord(minBound::Char) <= i && i <= ord(maxBound::Char) then return (chr i) else mzero

instance ObjectClass Int where
  obj = OInt
  fromObj o = case o of { OInt o -> return o; _ -> mzero; }
  castToCoreType t = case t of
    NullType     -> \o -> guard (o==0) >> return ONull
    TrueType     -> \o -> return $ if o==0 then ONull else OTrue
    CharType     -> fmap OChar . charFromIntegral
    IntType      -> return . OInt
    WordType     -> return . OWord    . fromIntegral
    LongType     -> return . OLong    . toInteger
    FloatType    -> return . OFloat   . fromRational   . toRational
    RatioType    -> return . ORatio   . toRational
    ComplexType  -> return . OComplex . flip complex 0 . fromRational . toRational
    DiffTimeType -> return . ORelTime . fromRational   . toRational
    StringType   -> return . obj      . prettyShow     . obj
    BytesType    -> return . OBytes . D.runPut . D.putWord64le . fromIntegral
    _            -> \ _ -> mzero

instance ObjectClass Word where
  obj = OWord . fromIntegral
  fromObj o = case o of { OWord o -> return (fromIntegral o); _ -> mzero; }
  castToCoreType t = case t of
    NullType     -> \o -> guard (o==0) >> return ONull
    TrueType     -> \o -> return $ if o==0 then ONull else OTrue
    CharType     -> fmap OChar . charFromIntegral
    IntType      -> return . OInt     . fromIntegral
    WordType     -> return . OWord    . fromIntegral
    LongType     -> return . OLong    . toInteger
    FloatType    -> return . OFloat   . fromRational . toRational
    RatioType    -> return . ORatio   . toRational
    ComplexType  -> return . OComplex . flip complex 0 . fromRational . toRational
    DiffTimeType -> return . ORelTime . fromRational . toRational
    StringType   -> return . obj      . prettyShow . obj
    BytesType    -> return . OBytes . D.runPut . D.putWord64le . fromIntegral
    _            -> \ _ -> mzero

instance ObjectClass Word64 where
  obj = OWord
  fromObj o = case o of { OWord o -> return o; _ -> mzero; }
  castToCoreType t = case t of
    NullType     -> \o -> guard (o==0) >> return ONull
    TrueType     -> \o -> return $ if o==0 then ONull else OTrue
    CharType     -> fmap OChar . charFromIntegral
    IntType      -> return . OInt     . fromIntegral
    WordType     -> return . OWord
    LongType     -> return . OLong    . toInteger
    FloatType    -> return . OFloat   . fromRational . toRational
    RatioType    -> return . ORatio   . toRational
    ComplexType  -> return . OComplex . flip complex 0 . fromRational . toRational
    DiffTimeType -> return . ORelTime . fromRational . toRational
    StringType   -> return . obj      . prettyShow . obj
    BytesType    -> return . OBytes   . D.runPut . D.putWord64le . fromIntegral
    _            -> \ _ -> mzero

instance ObjectClass Integer where
  obj = OLong
  fromObj o = case o of { OLong o -> return o; _ -> mzero; }
  castToCoreType t = case t of
    NullType     -> \o -> guard (o==0) >> return ONull
    TrueType     -> \o -> return $ if o==0 then ONull else OTrue
    CharType     -> fmap OChar . charFromIntegral
    IntType      -> return . OInt     . fromInteger
    WordType     -> return . OWord    . fromInteger
    LongType     -> return . OLong
    FloatType    -> return . OFloat   . fromRational . toRational
    RatioType    -> return . ORatio   . toRational
    ComplexType  -> return . OComplex . flip complex 0 . fromRational . toRational
    DiffTimeType -> return . ORelTime . fromRational . toRational
    StringType   -> return . obj      . show
    BytesType    -> return . OBytes . B.reverse . D.encode
    _            -> \ _ -> mzero

instance ObjectClass NominalDiffTime where
  obj = ORelTime
  fromObj o = case o of { ORelTime o -> return o; _ -> mzero; }
  castToCoreType t = case t of
    NullType     -> \o -> guard (toRational o == 0) >> return ONull
    TrueType     -> \o -> return $ if toRational o == 0 then ONull else OTrue
    IntType      -> return . OInt . round
    WordType     -> return . OWord . round
    LongType     -> return . OLong . round
    FloatType    -> return . OFloat . fromRational . toRational
    DiffTimeType -> return . ORelTime
    ComplexType  -> return . OComplex . flip complex 0 . fromRational . toRational
    _            -> \ _ -> mzero

instance ObjectClass Double where
  obj = OFloat
  fromObj o = case o of { OFloat o -> return o; _ -> mzero; }
  castToCoreType t = case t of
    NullType     -> \o -> guard (o==0) >> return ONull
    TrueType     -> \o -> return $ if o==0 then ONull else OTrue
    CharType     -> fmap OChar . charFromIntegral . (round :: Double -> Int)
    IntType      -> return . OInt     . round
    WordType     -> return . OWord    . round
    LongType     -> return . OLong    . round
    FloatType    -> return . OFloat
    RatioType    -> return . ORatio   . toRational
    ComplexType  -> return . OComplex . flip complex 0 . fromRational . toRational
    DiffTimeType -> return . ORelTime . fromRational . toRational
    StringType   -> return . obj      . show
    BytesType    -> return . OBytes . D.encode
    _            -> \ _ -> mzero

instance ObjectClass Rational where
  obj = ORatio
  fromObj o = case o of { ORatio o -> return o; _ -> mzero; }
  castToCoreType t = case t of
    NullType     -> \o -> guard (o==0) >> return ONull
    TrueType     -> \o -> return $ if o==0 then ONull else OTrue
    CharType     -> fmap OChar . charFromIntegral . (round :: Rational -> Int)
    IntType      -> return . OInt     . round
    WordType     -> return . OWord    . round
    LongType     -> return . OLong    . round
    FloatType    -> return . OFloat   . fromRational
    RatioType    -> return . ORatio
    ComplexType  -> return . OComplex . flip complex 0 . fromRational
    DiffTimeType -> return . ORelTime . fromRational . toRational
    StringType   -> return . obj      . prettyShow . obj
    _            -> \ _ -> mzero

instance ObjectClass Complex where
  obj = OComplex
  fromObj o = case o of { OComplex o -> return o; _ -> mzero; }
  castToCoreType t = case t of
    NullType     -> \o -> guard (complex 0 0 == o) >> return ONull
    TrueType     -> \o -> return $ if complex 0 0 == o then ONull else OTrue
    IntType      -> i OInt
    WordType     -> return . OWord . round . magnitude
    LongType     -> i OLong
    FloatType    -> f OFloat
    RatioType    -> f ORatio
    ComplexType  -> return . OComplex
    DiffTimeType -> f ORelTime
    StringType   -> return . obj . prettyShow
    _            -> \ _ -> mzero
    where
      f constr o = guard (imagPart o == 0) >> return (constr $ fromRational $ toRational $ realPart o)
      i constr = f (constr . fromInteger . (round :: Rational -> Integer))

instance ObjectClass UStr where
  obj = OString
  fromObj o = case o of { OString o -> return o; _ -> mzero; }
  castToCoreType t = case t of
    StringType -> return . OString
    _          -> castToCoreType t . uchars

instance ObjectClass String where
  obj = obj . toUStr
  fromObj = fromObj >=> maybeFromUStr
  castToCoreType t = case t of
      NullType   -> \o -> guard (o=="null") >> return ONull
      TrueType   -> \o -> case map toLower o of
        "true"   -> return OTrue
        "yes"    -> return OTrue
        "no"     -> return ONull
        "false"  -> return ONull
        "null"   -> return ONull
        _        -> mzero
      IntType    -> pars OInt
      WordType   -> pars OWord
      LongType   -> pars OLong
      FloatType  -> pars OFloat
      TimeType   -> pars OAbsTime
      StringType -> return . OString . ustr
      RefType    -> pars ORef
      _          -> \ _ -> mzero
    where
      nospc = dropWhile isSpace
      pars f str = case fmap (reverse . nospc . reverse) <$> readsPrec 0 (nospc str) of
        [(o, "")] -> return (f o)
        _         -> mzero

instance ObjectClass B.ByteString where
  obj = OBytes
  fromObj o = case o of { OBytes o -> return o; _ -> mzero; }
  castToCoreType t = case t of
    NullType  -> f (D.isEmpty >>= guard >> return ONull)
    TrueType  ->
      f (D.getWord8 >>= \w ->
          return $ case w of { 0->Just ONull; 1->Just OTrue; _->mzero; }) >=> xmaybe
    CharType  -> fmap OChar . (f D.getWord64le >=> charFromIntegral)
    IntType   -> fmap (OInt . fromIntegral) . f D.getWord64le
    WordType  -> fmap (OWord . fromIntegral) . f D.getWord64le
    LongType  -> return . OLong . D.decode . B.reverse
    FloatType -> return . OFloat . D.decode
    _         -> \ _ -> mzero
    where
      f :: D.Get o -> B.ByteString -> XPure o
      f get = return . D.runGet get

instance ObjectClass [Object] where
  obj = OList
  fromObj o = case o of { OList o -> return o; _ -> mzero; }
  castToCoreType t = case t of
    StringType -> fmap OList . loop return
    BytesType  -> fmap (OBytes . D.runPut . mapM_ D.putLazyByteString) . loop (\ (OBytes o) -> [o])
    ListType   -> return . OList
    _          -> \ _ -> mzero
    where
      loop f = fmap concat .
        mapM (\o -> (xmaybe (fromObj o) >>= loop f) <|> (f <$> castToCoreType t o))

instance ObjectClass (M.Map Name Object) where
  obj = ODict
  fromObj o = case o of { ODict o -> return o; _ -> mzero; }
  castToCoreType t o = case t of
    NullType -> guard (M.null o) >> return ONull
    DictType -> return $ ODict o
    _        -> mzero

instance ObjectClass Reference where
  obj = ORef
  fromObj o = case o of { ORef o -> return o; _ -> mzero; }
  castToCoreType t o = case t of
    StringType -> return $ obj $ '$':prettyShow o
    RefType    -> return (ORef o)
    _          -> mzero

instance ObjectClass Name where
  obj n = ORef $ Reference UNQUAL n NullRef
  fromObj o = case o of
    OString o -> maybeFromUStr o
    ORef (Reference UNQUAL name NullRef) -> return name
    _ -> mzero

instance ObjectClass ObjType where
  obj = OType
  fromObj o = case o of { OType o -> return o; _ -> mzero; }
  castToCoreType t = case t of
    TypeType   -> return . OType
    StringType -> return . obj . prettyShow
    _          -> \ _ -> mzero

instance ObjectClass CoreType where
  obj = OType . objTypeFromCoreType
  fromObj o = case o of
    OType (ObjType [TypeStruct [CoreType o]]) -> return o
    _ -> mzero
  castToCoreType t = case t of
    IntType    -> return . OInt  . fromIntegral . fromEnum
    WordType   -> return . OWord . fromIntegral . fromEnum
    LongType   -> return . OLong . fromIntegral . fromEnum
    StringType -> return . obj   . show
    TypeType   -> return . obj
    _          -> \ _ -> mzero

instance ObjectClass Struct where
  obj = OTree
  fromObj o = case o of { OTree o -> return o; _ -> mzero; }
  castToCoreType t = case t of
    TreeType   -> return . OTree
    RefType    -> return . obj . structName
    StringType -> return . obj . prettyShow
    _          -> \ _ -> mzero

instance ObjectClass UTCTime where
  obj = OAbsTime
  fromObj o = case o of { OAbsTime o -> return o; _ -> mzero; }
  castToCoreType t = case t of
    StringType -> return . obj . prettyShow . obj
    TimeType   -> return . OAbsTime
    _          -> \ _ -> mzero

instance ObjectClass Hata where
  obj = OHaskell
  fromObj o = case o of { OHaskell o -> return o; _ -> mzero; }

instance ObjectClass Dynamic where
  obj = opaque
  fromObj o = case o of { OHaskell (Hata _ o) -> return o; _ -> mzero; }

instance ObjectClass Object where
  obj = id;
  fromObj = return;
  castToCoreType t o = case o of
    ONull      ->  f False
    OTrue      ->  f True
    OChar    o ->  f o
    OInt     o ->  f o
    OWord    o ->  f o
    OLong    o ->  f o
    OAbsTime o ->  f o
    OFloat   o ->  f o
    ORatio   o ->  f o
    OComplex o ->  f o
    OString  o ->  f o
    OBytes   o ->  f o
    OList    o ->  f o
    ODict    o ->  f o
    ORef     o ->  f o
    OType    o ->  f o
    OTree    o ->  f o
    ORelTime o ->  f o
    OHaskell _ -> mzero
    where
      f :: ObjectClass o => o -> XPure Object
      f = castToCoreType t

instance ObjectClass Location where { obj=new; fromObj=objFromHata; }

instance ObjectClass Comment where { obj=new; fromObj=objFromHata; }

instance ObjectClass [Comment] where { obj=listToObj; fromObj=listFromObj; }

instance ObjectClass DotNameExpr where { obj=new; fromObj=objFromHata; }

instance ObjectClass AST_DotName where { obj=new; fromObj=objFromHata; }

instance ObjectClass DotLabelExpr where { obj=new; fromObj=objFromHata; }

instance ObjectClass AST_DotLabel where { obj=new; fromObj=objFromHata; }

listToObj :: ObjectClass o => [o] -> Object
listToObj = OList . map obj

listFromObj :: ObjectClass o => Object -> Maybe [o]
listFromObj o = case o of
  OList o -> mapM fromObj o
  _       -> mzero

-- | Create a new 'Object' containing the original value and a reference to the 'Interface'
-- retrieved by the instance of 'haskellDataInterface' for the data type.
new :: (HataClass typ, Typeable typ) => typ -> Object
new = OHaskell . toHata

-- | Create a completely opaque haskell data type that can be used stored to a Dao language
-- variable, but never inspected or modified in any way.
opaque :: forall typ . Typeable typ => typ -> Object
opaque o = OHaskell $ flip Hata (toDyn o) $
  interfaceToDynamic (interface (show $ typeOf o) (return ()) :: Interface typ)

-- | The inverse operation of 'new', uses 'fromObj' and 'fromHata' to extract the data type
-- wrapped up in the 'Object', assuming the 'Object' is the 'OHaskell' constructor holding a
-- 'Hata' container.
objFromHata :: (Typeable o, HataClass o) => Object -> Maybe o
objFromHata = fromObj >=> fromHata

----------------------------------------------------------------------------------------------------

-- | This is the "Haskell Data" data type used to wrap-up a Haskell data types into a
-- 'Data.Dynamic.Dynamic' data type and associate this dynamic data with the 'Interface' used by the
-- runtime to read and modify the data. Whenever an non-primitive 'Object' is created, the data is
-- converted to a 'Data.Dynamic.Dynamic' value and paired with a copy of the 'Interface'.
data Hata = Hata (Interface Dynamic) Dynamic deriving Typeable

instance Eq Hata where
  Hata ifcA a == Hata ifcB b =
    ((ifcA==ifcB)&&) $ maybe False id $ objEquality ifcA >>= \eq -> return (eq a b)

instance Ord Hata where
  compare (Hata ifcA a) (Hata ifcB b) = maybe err id $
    guard (ifcA==ifcB) >> objOrdering ifcA >>= \comp -> return (comp a b) where
      err = error $ unwords $
        [ "cannot compare object of type", show (objHaskellType ifcA)
        , "with obejct of type", show (objHaskellType ifcB)
        ]

instance Show Hata where { show (Hata o _) = show (objHaskellType o) }

instance NFData Hata where { rnf (Hata _ _) = () }

instance PPrintable Object where
  pPrint o = case o of
    ONull            -> pString "null"
    OTrue            -> pString "true"
    OChar      o     -> pShow o
    OInt       o     -> pShow o
    OWord      o     -> pString (show o++"U")
    OLong      o     -> pString (show o++"L")
    ORelTime   o     -> pShow o
    OFloat     o     -> pString (show o++"f")
    ORatio     o     ->
      if denominator o == 1
        then  pString (show (numerator o)++"R")
        else  pWrapIndent $
                [ pString "(", pString (show (numerator o)), pString "/"
                , pString (show (denominator o)++"R"), pString ")"
                ]
    OComplex   o     -> pPrint o
    OString    o     -> pShow o
    OBytes     o     ->
      if B.null o
        then  pString "data{}"
        else  pList (pString "data") "{" ", " "}" (map (pString . showHex) (B.unpack o))
    OList      ox    -> if null ox then pString "list{}" else pContainer "list " pPrint ox
    ODict      o     ->
      if M.null o
      then pString "dict{}"
      else pContainer "dict " (\ (a, b) -> pWrapIndent [pPrint a, pString " = ", pPrint b]) (M.assocs o)
    ORef       o     -> pPrint o
    OType      o     -> pPrint o
    OTree      o     -> pPrint o
    OAbsTime   o     -> pString ("date "++show o)
    OHaskell (Hata ifc o) -> case objPPrinter ifc of
      Nothing -> fail $ "cannot pretty print Haskell data type: "++show (objHaskellType ifc)
      Just pp -> pp o

instance B.Binary Hata MTab where
  put (Hata ifc o) = do
    let typeName = objInterfaceName ifc 
    mtab <- B.getCoderTable
    case B.getEncoderForType typeName mtab of
      Just fn -> do
        tid  <- B.newInStreamID typeName
        B.put tid >> B.putWithBlockStream1M (fn o)
      Nothing -> fail $ unwords ["no binary format method defied for Haskell type", uchars (toUStr typeName)]
  get = do
    B.updateTypes
    mtab <- B.getCoderTable
    tid  <- B.get >>= B.decodeIndexLookup
    maybe mzero id $ do
      tid <- tid
      fn  <- B.getDecoderForType tid mtab
      tab <- lookupMethodTable tid mtab
      return (Hata tab <$> B.getWithBlockStream1M fn)

instance HasNullValue Hata where
  nullValue = toHata ()
  testNull (Hata ifc o) = case objNullTest ifc of
    Nothing -> error ("to check whether objects of type "++show (objHaskellType ifc)++" are null is undefined behavior")
    Just fn -> fn o

-- | This is a convenience function for calling 'OHaskell' using just an initial value of type
-- @typ@. The 'Interface' is retrieved automatically using the instance of 'haskellDataInterface' for
-- the @typ@.
toHata :: (HataClass typ, Typeable typ) => typ -> Hata
toHata t = flip Hata (toDyn t) (interfaceTo t haskellDataInterface) where
  interfaceTo :: Typeable typ => typ -> Interface typ -> Interface Dynamic
  interfaceTo _ ifc = interfaceToDynamic ifc

-- | Inverse operation of 'toHata', useful when instantiating 'ObjectClass', uses
-- 'Data.Dynamic.fromDynamic' to extract the value that has been wrapped in up the 'Hata'
-- constructor.
fromHata :: (HataClass typ, Typeable typ) => Hata -> Maybe typ
fromHata (Hata _ o) = fromDynamic o

----------------------------------------------------------------------------------------------------

class Sizeable o where { getSizeOf :: o -> Exec Object  }

instance Sizeable Char where { getSizeOf = return . obj . ord }
instance Sizeable Word64 where { getSizeOf = return . obj }
instance Sizeable Int where { getSizeOf = return . obj . abs }
instance Sizeable Double where { getSizeOf = return . obj . abs }
instance Sizeable Integer where { getSizeOf = return . obj . abs }
instance Sizeable NominalDiffTime where { getSizeOf = return . obj . abs }
instance Sizeable Rational where { getSizeOf = return . obj . abs }
instance Sizeable Complex where { getSizeOf = return . obj . magnitude }
instance Sizeable UStr where { getSizeOf = return . obj . ulength }
instance Sizeable [Object] where { getSizeOf = return . obj . length }
instance Sizeable (M.Map Name Object) where { getSizeOf = return . obj . M.size }
instance Sizeable (H.HashMap Object Object) where { getSizeOf = return . obj . H.size }
instance Sizeable Hata where { getSizeOf (Hata ifc o) = maybe mzero ($ o) (objSizer ifc) }

instance Sizeable Object where
  getSizeOf o = case o of
    OChar    o -> getSizeOf o
    OWord    o -> getSizeOf o
    OInt     o -> getSizeOf o
    OLong    o -> getSizeOf o
    ORelTime o -> getSizeOf o
    OFloat   o -> getSizeOf o
    ORatio   o -> getSizeOf o
    OComplex o -> getSizeOf o
    OString  o -> getSizeOf o
    OList    o -> getSizeOf o
    ODict    o -> getSizeOf o
    OHaskell o -> getSizeOf o
    _          -> mzero

----------------------------------------------------------------------------------------------------

-- $Building_structs
-- Here are all the basic functions for converting between Haskell language data types and Dao
-- language structures.
-- 
-- Most 'FromDaoStruct' functions will backtrack when they fail to get the necessary data. This
-- function can make a backtracking function fail. For example:
-- > 'tryField' "x" >>= 'objType'
-- backtracks in any case
-- 
-- > required (tryField "x" >>= objType)
-- > tryField "x" >>= required objType
-- These two forms do the same thing: fails if 'objType' backtracks, but not if the field doesn't
-- exist.
-- 
-- > 'Control.Applicative.optional' ('tryField' "x" >>= 'objType')
-- returns 'Prelude.Nothing' if the field does not exist or if 'objType' backtracks
-- 
-- > 'field' "x" >>= 'objType'
-- fails if the field does not exist, backtracks if it exists but is the wrong type
-- (you probably don't ever want to do this).
-- 
-- > 'required' ('field' "x" >>= 'objType')
-- > 'field' "x" >>= 'required' 'objType'
-- These two forms are the same: fails if either the field does not exist or if 'objType'
-- backtracks.

-- | This is the data type used as the intermediary between Haskell objects and Dao objects. If you
-- would like your Haskell data type to be used as a non-opaque data type in a Dao language script,
-- the first step is to instantiate your data type into this class. The next step would be to
-- instantiate your object into the 'HataClass' class. Instantiating the
-- 'HataClass' class alone will make your object usable in Dao language scripts, but
-- it will be an opaque type. Instantiating 'Struct' and declaring 'autoDefStruct' in the
-- 'defObjectInterface' will allow functions in the Dao language script to read and write
-- information to your data structure, modifying it during runtime.
-- 
-- 'Struct' values are used lazily, so your data types will only be converted to and from 'Struct's
-- when absolutely necessary. This helps to conserver memory usage.
data Struct
  = Nullary{ structName :: Name }
    -- ^ models a constructor with no fields, for example 'Prelude.EQ', 'Prelude.GT' and
    -- 'Prelude.LT'.
  | Struct
    { structName :: Name -- ^ provide the name for this constructor.
    , fieldMap   :: M.Map Name Object
    }
  deriving (Eq, Ord, Show, Typeable)

structLookup :: Name -> Struct -> Maybe Object
structLookup name struct = case struct of
  Nullary{}            -> Nothing
  Struct{ fieldMap=m } -> M.lookup name m

instance NFData Struct where
  rnf (Nullary a  ) = deepseq a ()
  rnf (Struct  a b) = deepseq a $! deepseq b ()

instance HasNullValue Struct where
  nullValue = Nullary{ structName=ustr "NULL" }
  testNull (Nullary{ structName=name }) = name == ustr "NULL"
  testNull _ = False

-- binary 0x25 0x26
instance B.Binary Struct MTab where
  put o = case o of
    Nullary  o -> B.putWord8 0x25 >> B.put o
    Struct n o -> B.putWord8 0x26 >> B.put n >> B.put o
  get = B.word8PrefixTable <|> fail "expecting Struct"

instance B.HasPrefixTable Struct B.Byte MTab where
  prefixTable = B.mkPrefixTableWord8 "Struct" 0x25 0x26 $
    [ Nullary <$> B.get
    , return Struct <*> B.get <*> B.get
    ]

instance PPrintable Struct where
  pPrint o = case o of
    Nullary{ structName=name } -> pString ('#' : uchars (toUStr name))
    Struct{ structName=name, fieldMap=dict } ->
      pList (pString ('#' : uchars (toUStr name))) "{" ", " "}" $
        flip map (M.assocs dict) $ \ (left, right) -> pInline $
          [pPrint left, pString " = ", pPrint right]

instance HasRandGen Struct where
  randO = _randTrace "Struct" $ countNode $ runRandChoice 
  randChoice = randChoiceList $
    [ scramble $
        return Struct <*> randO <*> (M.fromList <$> randListOf 1 4 (pure (,) <*> randO <*> randO))
    , Nullary <$> randO
    ]
  defaultO = _randTrace "D.Struct" $ Nullary <$> defaultO

instance ToDaoStructClass Struct where { toDaoStruct = return () }

instance FromDaoStructClass Struct where { fromDaoStruct = FromDaoStruct $ lift get }

instance HataClass Struct where
  haskellDataInterface = interface "Struct" $ do
    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter
    autoDefToStruct >> autoDefFromStruct

-- | You can make your data type readable but not writable in the Dao runtime. That means a Dao
-- script can inspect elements of your data type, but not modify them As an example lets say you
-- have a 3D-point data type you would like to use in your Dao script.
-- > data Finite =
-- >     Point2D{ get_x::'T_float', get_y::'T_float' }
-- >   | Point3D{ get_x::'T_float', get_y::'T_float', get_z::'T_float' }
-- 
-- Lets say you have already instantiated the 'HataClass' class and provided the Dao runtime with
-- a 'DaoFunc' (via 'setupDao') that constructs a Point3D at runtime:
-- > p = Point3D(1.9, 4.4, -2.1);
-- Now you would like to extend the 'HataClass' of your Point3D to also be readable at runtime.
-- If you instantiate 'ToDaoStructClass' your Dao language script could also read elements from the
-- point like so:
-- > distFromOrigin = sqrt(p.x*p.x + p.y*p.y + p.z*p.z);
-- However you cannot modify the point unless you also instantiate 'FromDaoStructClass'. So a statement
-- like this would result in an error:
-- > p.x /= distFromOrigin;
-- > p.y /= distFromOrigin;
-- > p.z /= distFromOrigin;
-- 
-- You can convert this to a 'Struct' type using the 'fromData' function. There are many ways to
-- define fields in a 'Struct', here are a few:
-- > instance 'ToDaoStructClass' Point3D 'Object' where
-- >     'toDaoStruct' = 'fromData' "@Point2D@" $ do
-- >         'putPrimField' "x" get_x
-- >         'putPrimField' "y" get_y
-- >          obj <- 'Control.Monad.Reader.Class.ask'
-- >          case obj of
-- >             Point3D _ _ z -> 'renameConstructor' "@Point3D@" $ do
-- >                 'define' "z" ('obj' z)
-- >             _             -> return ()
-- 
-- Finally, you should define the instantiation of Point3D into the 'HataClass' class so it
-- includes the directive 'autoDefToStruct'.
class ToDaoStructClass haskData where { toDaoStruct :: ToDaoStruct haskData () }

-- | Continuing the example from above, if you do want your data type to be modifyable by functions
-- running in the Dao language runtime, you must instantiate this class, which is facilitated by the
-- 'toData' function.
-- > instance 'FromDaoStructClass' 'Point3D' where
-- >     fromDaoStruct = 'toData' $ 'Control.Monad.msum' $
-- >         [ do 'constructor' "@Point2D@"
-- >              return Point3D 'Control.Applicative.<*>' 'req' "x" 'Control.Applicative.<*>' 'req' "y"
-- >         , do 'constructor' "@Point3D@"
-- >              return Point3D 'Control.Applicative.<*>' 'req' "x" 'Control.Applicative.<*>' 'req' "y" 'Control.Applicative.<*>' 'req' "z"
-- >         ]
-- 
-- Do not forget to define the instantiation of Point3D into the 'HataClass' class so it
-- includes the directive 'autoDefFromStruct'.
-- 
-- Note that an instance of 'FromDaoStructClass' must also instantiate 'ToDaoStructClass'. I can see no
-- use for objects that are only writable, that is they can be created at runtime but never
-- inspected at runtime.
class ToDaoStructClass haskData => FromDaoStructClass haskData where
  fromDaoStruct :: FromDaoStruct haskData

-- | If there is ever an error converting to or from your Haskell data type, you can
-- 'Control.Monad.Error.throwError' a 'StructError'.
data StructError
  = StructError
    { structErrName   :: Maybe UStr
    , structErrField  :: Maybe UStr
    , structErrValue  :: Maybe Object
    , structErrExtras :: [Name]
    }
  deriving (Eq, Ord, Typeable)

instance PPrintable StructError where
  pPrint err = do
    let pp p msg f = case f err of
          Nothing -> return ()
          Just  o -> pString (msg++": ") >> p o >> pNewLine
    pp pUStr "on constructor" structErrName
    pp pUStr "on field" structErrField
    pp pPrint "with value" structErrValue
    let extras = structErrExtras err
    if null extras then return () else pString ("non-member fields: "++show extras)

instance HasNullValue StructError where
  nullValue =
    StructError
    { structErrName=Nothing
    , structErrField=Nothing
    , structErrValue=Nothing
    , structErrExtras=[]
    }
  testNull
    ( StructError
      { structErrName=Nothing
      , structErrField=Nothing
      , structErrValue=Nothing
      , structErrExtras=[]
      }
    ) = True
  testNull _ = False

pPrintStructForm :: ToDaoStructClass o => o -> PPrint
pPrintStructForm o = case fromData toDaoStruct o of
  PFail err -> pPrint err
  Backtrack -> pString "(### FAILED TO CONVERT OBJECT TO STRUCT ###)"
  OK struct -> pPrint struct

----------------------------------------------------------------------------------------------------

-- Used to instantiate 'MonadError.throwError' by both the 'ToDaoStruct' and 'FromDaoStruct' monads.
_structThrowError
  :: (MonadError ExecControl m)
  => (forall a . PredicateT ExecControl (State st) a -> m a) -> (st -> Struct) -> ExecControl -> m b
_structThrowError constr inside err =
  constr (lift $ gets inside) >>= \struct -> constr $ throwError $ case err of
    ExecError{execErrorSubtype = ExecStructError info} ->
      err { execErrorSubtype = ExecStructError $
              info{ structErrName = structErrName info <|> Just (toUStr $ structName struct) } }
    err -> err

----------------------------------------------------------------------------------------------------

instance ToDaoStructClass StructError where
  toDaoStruct = renameConstructor "StructError" $ do
    asks structErrName   >>= optionalField "structName" . fmap OString
    asks structErrField  >>= optionalField "field" . fmap OString
    asks structErrValue  >>= optionalField "value"
    asks structErrExtras >>= optionalField "extras" . fmap obj . refNames

instance ToDaoStructClass (ParseError () DaoTT) where
  toDaoStruct = renameConstructor "ParseError" $ do
    asks parseErrMsg >>= ("message" .=?)
    asks parseErrMsg >>= ("onToken" .=?) . fmap show
    asks parseErrLoc >>= putLocation

instance FromDaoStructClass StructError where
  fromDaoStruct = do
    constructor "StructError"
    let str o = case o of
          OString o -> return o
          _         -> fail "expecting string value"
    let ref o = case o of
          ORef    o -> case o of
            Reference UNQUAL o NullRef -> return o
            _ -> fail "not an unqualified reference singleton"
          _ -> fail "not a reference type"
    let lst o = case o of
          OList   o -> forM o ref
          _         -> fail "expecting list value"
    return StructError
      <*> optional (tryField "structName" $ str)
      <*> optional (tryField "field" $ str)
      <*> optional (tryField "value" return)
      <*> (tryField "extras" $ lst)

instance ToDaoStructClass Comment where
  toDaoStruct = ask >>= \co -> case co of
    InlineComment  o -> renameConstructor "InlineComment"  $ "comment" .= o
    EndlineComment o -> renameConstructor "EndlineComment" $ "comment" .= o

instance FromDaoStructClass Comment where
  fromDaoStruct = msum $
    [ constructor "InlineComment"  >> InlineComment  <$> req "comment"
    , constructor "EndlineComment" >> EndlineComment <$> req "comment"
    ]

instance ToDaoStructClass AST_DotName where
  toDaoStruct = renameConstructor "DotName" $ ask >>= \ (AST_DotName coms n) -> case coms of
    Com () -> "name"     .= n
    coms   -> "comments" .= coms >> "name" .= n

instance FromDaoStructClass AST_DotName where
  fromDaoStruct = constructor "DotName" >>
    return AST_DotName <*> (maybe (Com ()) id <$> opt "comments") <*> req "name"

instance ToDaoStructClass AST_DotLabel where
  toDaoStruct = renameConstructor "DotLabel" $ do
    (AST_DotLabel n nx loc) <- ask
    "head" .= n
    "tail" .= OList (map obj nx)
    putLocation loc

instance FromDaoStructClass AST_DotLabel where
  fromDaoStruct = do
    constructor "DotLabel"
    let convert o = case sequence (map fromObj o) of
          Nothing -> fail "\"tail\" field must contain a list of \"#DotName\" data types."
          Just ox -> return ox
    return AST_DotLabel <*> req "head" <*> (req "tail" >>= convert) <*> location

instance ObjectClass StructError where { obj=new; fromObj=objFromHata; }

instance HataClass StructError where
  haskellDataInterface = interface "StructError" $ do
    autoDefEquality >> autoDefOrdering >> autoDefNullTest
    autoDefToStruct >> autoDefFromStruct

-- | Used to convert a 'Prelude.String' to a 'Dao.String.Name' by functions like 'define' and
-- 'setField'. Usually you will not need to use it.
mkLabel :: (UStrType name, MonadPlus m) => name -> m Name
mkLabel name = xmaybe $ maybeFromUStr (toUStr name)

mkStructName :: (UStrType name, MonadPlus m) => name -> m Name
mkStructName name = mplus (mkLabel name) $ fail "invalid constructor name"

mkFieldName :: (UStrType name, MonadPlus m) => name -> m Name
mkFieldName name = mplus (mkLabel name) $ fail "invalid field name"

-- | This is a handy monadic and 'Data.Functor.Applicative' interface for instantiating
-- 'toDaoStruct' in the 'ToDaoStructClass' class.
newtype ToDaoStruct haskData a
  = ToDaoStruct
    { _runToDaoStruct :: PredicateT ExecControl (State (Struct, haskData)) a }
  deriving (Functor, Applicative, Alternative, MonadPlus)

instance Monad (ToDaoStruct haskData) where
  return = ToDaoStruct . return
  m >>= f = ToDaoStruct $ _runToDaoStruct m >>= _runToDaoStruct . f
  fail msg = execThrow msg (ExecStructError nullValue) []

instance MonadState Struct (ToDaoStruct haskData) where
  state f = ToDaoStruct $ lift $ state $ \ (struct, haskData) ->
    let (a, struct') = f struct in (a, (struct', haskData))

instance MonadReader haskData (ToDaoStruct haskData) where
  ask = ToDaoStruct $ lift $ fmap snd get
  local upd f = ToDaoStruct $ PredicateT $ do
    haskData <- gets snd
    modify (\ (struct, _) -> (struct, upd haskData))
    a <- runPredicateT $ _runToDaoStruct f
    modify (\ (struct, _) -> (struct, haskData))
    return a

instance MonadError ExecControl (ToDaoStruct haskData) where
  throwError = _structThrowError ToDaoStruct fst
  catchError f catch = ToDaoStruct $ catchError (_runToDaoStruct f) (_runToDaoStruct . catch)

instance MonadPlusError ExecControl (ToDaoStruct haskData) where
  catchPredicate = ToDaoStruct . catchPredicate . _runToDaoStruct
  predicate      = ToDaoStruct . predicate

-- | This function is typically used to evaluate the instantiation of 'toDaoStruct'. It takes two
-- parameters: first a computation to convert your data type to the 'Struct' using the 'ToDaoStruct'
-- monad, and second the data type you want to convert. You can use functions like 'defineWith' and
-- 'setField' to build your 'ToDaoStruct' computation. For example, lets say you have a Haskell data
-- type called @mydat::MyData@ where @MyData@ instantiates 'ToDaoStruct', you can convert it to a
-- Dao 'Struct' like so:
-- > 'fromData' 'toDaoStruct' mydat
-- Notice how it reads similar to ordinary English, "convert from (Haskell) data to a Dao 'Struct'"
fromData
  :: ToDaoStruct haskData x
  -> haskData
  -> Predicate ExecControl Struct
fromData pred hask = evalState (runPredicateT $ _runToDaoStruct $ pred >> get) $
  (Struct{ structName=nil, fieldMap=M.empty }, hask)

toDaoStructExec :: ToDaoStruct typ x -> typ -> Exec Struct
toDaoStructExec toDaoStruct = (predicate :: Predicate ExecControl T_struct -> Exec T_struct) .
  fmapPFail ((\o -> newError{ execReturnValue=Just o}) . new) . fromData toDaoStruct

-- | Overwrite the current 'Struct' with a 'Struct' produced by a 'toDaoStruct' instance of a
-- different type. This is useful when instantiating a newtype or a data type constructor that
-- contains only one item (the "inner" item), and the data type of the inner item instantiates
-- 'ToDaoStructClass', you can simply use the instance of 'toDaoStruct' for that data type to
-- instantiate 'toDaoStruct' for the outer data type. Just be sure that the constructor name for the
-- inner type does not conflict with the constructor name for the outer data type. For example:
-- > data X = X1 { ... } | X2 { ... }
-- > instance 'DaoToStructClass' X 'Object' where { ... }
-- > data Y = Y1 { ... } | Y2 { ... }
-- > instance 'DaoToStructClass' Y 'Object' where { ... }
-- > 
-- > newtype WrapX = WrapX { unwrapX :: X }
-- > instance 'DaoToStructClass' WrapX 'Object' where
-- >     'toDaoStruct' = 'Control.Monad.Reader.ask' >>= 'innerToStruct' . unwrapX
-- > 
-- > data X_or_Y = Is_X { getX :: X } | Is_Y { getY :: Y }
-- > instance 'DaoToStructClass' X_or_Y 'Object' where
-- >     'toDaoStruct' = 'Control.Monad.Reader.ask' >>= \xy -> case xy of
-- >         Is_X x -> 'innerToStruct' x
-- >         Is_Y y -> 'innerToStruct' y
-- 
-- The inverse of this operation in the 'FromDaoStructClass' is 'Prelude.fmap', or equivalently the
-- 'Control.Applicative.<$>' operator. Here is an example using 'Control.Applicative.<$>':
-- > instance 'FromDaoStructClass' WrapX 'Object' where
-- >     'fromDaoStruct' = WrapX <$> 'fromDaoStruct'
-- > 
-- > instance 'FromDaoStructClass' X_or_Y 'Object' where
-- >     'fromDaoStruct' = Is_X <$> 'fromDaoStruct' <|> Is_Y <$> 'fromDaoStruct'
-- 
-- Another way to do exactly the same thing as the example above is:
-- > instance 'FromDaoStructClass' WrapX 'Object' where
-- >     'fromDaoStruct' = 'Prelude.fmap' WrapX 'fromDaoStruct'
-- > 
-- > instance 'FromDaoStructClass' X_or_Y 'Object' where
-- >     'fromDaoStruct' = 'Prelude.fmap' Is_X 'fromDaoStruct' `'Control.Monad.mplus'` 'Prelude.fmap' Is_Y 'fromDaoStruct'
-- 
-- It is possible to use 'renameConstructor' after evaluating 'innerToStruct' to use a different
-- constructor name while keeping all of the fields set by the evaluation of 'innerToStruct',
-- however if this is done, 'Prelude.fmap' will backtrack, so you should use 'innerFromStruct'
-- instead.
innerToStruct :: ToDaoStructClass inner => inner -> ToDaoStruct haskData ()
innerToStruct = innerToStructWith toDaoStruct

-- | Like 'innerToStruct' but lets you supply a 'ToDaoStruct' function for an arbitrary data type,
-- not just one that instantiates 'ToDaoStructClass'.
innerToStructWith :: ToDaoStruct inner () -> inner -> ToDaoStruct haskData ()
innerToStructWith toDaoStruct o = ask >>= \haskData ->
  predicate (fromData toDaoStruct o) >>= ToDaoStruct . lift . put . flip (,) haskData

fmapHaskDataToStruct :: (haskData -> dyn) -> (dyn -> haskData) -> ToDaoStruct haskData a -> ToDaoStruct dyn a
fmapHaskDataToStruct to from (ToDaoStruct (PredicateT f)) =
  ToDaoStruct $ PredicateT $ state $ fmap (fmap to) . runState f . fmap from

-- | Use this function to set the 'structName' name of the constructor at some point, for example
-- when you observe some condition of the @haskData@ type that merits an alternative constructor
-- name.
renameConstructor :: UStrType name => name -> ToDaoStruct haskData ig -> ToDaoStruct haskData ()
renameConstructor name f = do
  name <- mkStructName name
  modify $ \struct -> struct{ structName=name }
  void f

-- | Like 'renameConstructor' but deletes everything and makes the 'Struct' being constructed into a
-- 'Nullary'. You would typically do this only when you are instantiating 'toDaoStruct' and you
-- only have one constructor to define.
makeNullary :: UStrType name => name -> ToDaoStruct haskData ()
makeNullary name = mkStructName name >>= \name -> put $ Nullary{ structName=name }

-- | Use this when you have derived the "Prelude.Show" class for a data type where every constructor
-- in that data type takes no parameters, for example, the 'Prelude.Ordering' data type.
putNullaryUsingShow :: Show haskData => ToDaoStruct haskData ()
putNullaryUsingShow = ask >>= makeNullary . show

define :: UStrType name => name -> Object -> ToDaoStruct haskData Object
define name value = do
  name <- mkFieldName name
  modify $ \struct -> struct{ fieldMap = M.insert name value (fieldMap struct) }
  return value

-- | Defines an optional field. If the value given is 'Prelude.Nothing', nothing happens. Otherwise
-- the value is placed into the 'Struct' at the given @name@d field. This is the inverse opreation
-- of using 'Control.Applicative.optional' in the 'FromDaoStruct' monad.
optionalField :: UStrType name => name -> Maybe Object -> ToDaoStruct haskData (Maybe Object)
optionalField name = maybe (return Nothing) (fmap Just . define name)

setField :: UStrType name => name -> (haskData -> Object) -> ToDaoStruct haskData Object
setField name f = ask >>= define name . f

-- | This is an important function for instantiating 'ToDaoStructClass'. It takes any
-- value instantiating 'HataClass', converts it to an 'Object' using the 'new'
-- function. It is the inverse of 'objType'.
--
-- It is recommended you use this function instead of 'defStructField', 'defPrimField', or
-- 'defDynField' whenever it is possible, i.e. whenever the data type you are putting instantiated
-- the 'HataClass' class.
defObjField
  :: (UStrType name, Typeable o, ObjectClass o)
  => name -> o -> ToDaoStruct haskData Object
defObjField name o = define name (obj o)

-- | Synonym for 'defObjField'
(.=) :: (UStrType name, Typeable o, ObjectClass o) => name -> o -> ToDaoStruct haskData Object
(.=) = defObjField
infixr 2 .=

-- | Like 'defObjField' but takes a field accessor to extract the data to be stored from the object
-- being converted. This function is defined as:
-- > \name accessor -> asks accessor >>= defObjField name
putObjField
  :: (UStrType name, Typeable o, ObjectClass o)
  => name -> (haskData -> o) -> ToDaoStruct haskData Object
putObjField name which = asks which >>= defObjField name

-- | Synonym for 'putObjField'
(.=@)
  :: (UStrType name, Typeable o, ObjectClass o)
  => name -> (haskData -> o) -> ToDaoStruct haskData Object
(.=@) = putObjField
infixr 2 .=@

-- | Like 'putObjField' but operates on an object wrapped in a 'Prelude.Maybe', not doing anything
-- in the case of 'Prelude.Nothing'.
defMaybeObjField
  :: (UStrType name, Typeable o, ObjectClass o)
  => name -> Maybe o -> ToDaoStruct haskData (Maybe Object)
defMaybeObjField name = maybe (return Nothing) (fmap Just . defObjField name)

(.=?) 
  :: (UStrType name, Typeable o, ObjectClass o)
  => name -> Maybe o -> ToDaoStruct haskData (Maybe Object)
(.=?) = defMaybeObjField

----------------------------------------------------------------------------------------------------

-- | This is a handy monadic and 'Data.Functor.Applicative' interface for instantiating
-- 'fromDaoStruct' in the 'FromDaoStructClass' class. It takes the form of a reader because what you
-- /read/ from the 'Struct' here in the Haskell language was /written/ by the Dao language
-- runtime. Think of it as "this is the data type used when the Dao runtime wants to write
-- information to my data structure."
-- 
-- Because Dao is such a messy, fuzzy, not statically typed, interpreted language, the information
-- coming in from the Dao runtime requires a lot of sanitization. Therefore this monad provides
-- several functions for checking the type of information you are using to build your Haskell data
-- type.
--
-- Be sure to make ample use of the 'Control.Monad.guard', 'Control.Monad.Error.throwError', and
-- 'Control.Monad.fail' functions.
-- 
-- /NOTE:/ refer to the documentation of the 'constructor' monad for an important note on reading
-- Haskell data types with multiple constructors.
newtype FromDaoStruct a =
  FromDaoStruct{ _runFromDaoStruct :: PredicateT ExecControl (State Struct) a }
  deriving (Functor, Applicative, Alternative, MonadPlus)

instance Monad FromDaoStruct where
  return = FromDaoStruct . return
  m >>= f = FromDaoStruct $ _runFromDaoStruct m >>= _runFromDaoStruct . f
  fail msg = FromDaoStruct (lift $ gets structName) >>= \name ->
    execThrow msg (ExecStructError $ nullValue{ structErrName = Just $ toUStr name }) []

instance MonadReader Struct FromDaoStruct where
  ask = FromDaoStruct $ lift get
  local upd f = FromDaoStruct $ PredicateT $ get >>= \st ->
   return $ evalState (runPredicateT $ _runFromDaoStruct f) (upd st)

instance MonadError ExecControl FromDaoStruct where
  throwError = _structThrowError FromDaoStruct id
  catchError (FromDaoStruct f) catch = FromDaoStruct $ catchError f (_runFromDaoStruct . catch)

instance MonadPlusError ExecControl FromDaoStruct where
  catchPredicate = FromDaoStruct . catchPredicate . _runFromDaoStruct
  predicate      = FromDaoStruct . predicate

-- | This function is typically used to evaluate the instantiation of 'fromDaoStruct'. It takes two
-- parameters: first a computation to convert your data type to the Haskell data type from a
-- 'Struct' using the 'FromDaoStruct' monad, and second the 'Struct' you want to convert. For
-- example, if you have a Haskell data type 'MyData' which instantiates 'FromDaoStruct', you could
-- construct it from a properly formatted Dao 'Struct' using this statement:
-- > 'toData' 'fromDaoStruct' struct
-- Notice that this reads similar to ordinary English: "convert to (Haskell) data from a dao
-- struct."
toData :: FromDaoStruct haskData -> Struct -> Predicate ExecControl haskData
toData f = evalState (runPredicateT $ _runFromDaoStruct $ f >>= \o -> checkEmpty >> return o)

-- | Using a 'FromDaoStruct' monadic function, convert a given 'Struct' to a Haskell data type
-- @typ@.
withFromDaoStructExec :: FromDaoStruct typ -> Struct -> Exec typ
withFromDaoStructExec fromDaoStruct =
  predicate . fmapPFail ((\o -> newError{ execReturnValue=Just o }) . new) .  toData fromDaoStruct

-- | Given a 'Struct', use the 'structName' to lookup a 'FromDaoStruct' monadic function in the
-- current 'ExecUnit' suitable for constructing a 'Hata' Haskell data type.
fromDaoStructExec :: Struct -> Exec Hata
fromDaoStructExec struct = do
  let name = structName struct
  (MethodTable mtab) <- gets globalMethodTable
  let badType msg = execThrow msg (ExecTypeError $ objTypeFromName name) []
  case M.lookup (structName struct) mtab of
    Nothing  -> badType "no available built-in data type"
    Just ifc -> case objFromStruct ifc of
      Nothing   -> badType "data type cannot be constructed from hashed structure"
      Just from -> Hata ifc <$> withFromDaoStructExec from struct

-- | Checks if the 'structName' is equal to the given name, and if not then backtracks. This is
-- important when constructing Haskell data types with multiple constructors.
--
-- A haskell data type with multiple constructors should be constructed with the
-- 'Control.Monad.msum' function like so:
-- > data MyData = A | B Int | C Int Int
-- > instance 'FromDaoStruct' ('Object) where
-- >     'fromDaoStruct' = 'toData' $ 'Control.Monad.msum' $
-- >         [ 'constructor' "A" >> return a,
-- >           do 'constructor' "B"
-- >              B 'Control.Applicative.<$>' ('field' "b1" >>= 'primType')
-- >           do 'constructor' "C"
-- >              'Control.Applicative.return' C
-- >                  'Control.Applicative.<*>' 'required' ('field' "c1" >>= 'primType')
-- >                  'Control.Applicative.<*>' 'required' ('field' "c2" >>= 'primType')
-- >         ]
-- /NOTE/ that if all three 'constructor's backtrack (evaluate to 'Control.Monad.mzero') the whole
-- monad will backtrack. By convention, you should let the monad backtrack, rather than writing a
-- 'Control.Monad.fail' statement as the final item in the 'Control.Monad.msum' list.
constructor :: UStrType name => name -> FromDaoStruct ()
constructor name = (return (==) <*> mkStructName name <*> asks structName) >>= guard

-- | The inverse operation of 'innerToStruct', but looks for a constructor of a different name. This
-- is important because every 'toDaoStruct' should set it's own unique constructor name, and if you
-- set a different constructor name while using the same 'fromDaoStruct' function to read the fields
-- of the struct, the 'fromDaoStruct' function will backtrack seeing the wrong constructor name.
-- If you have not renamed the constructor with 'renameConstructor' after using 'innerToStruct', do
-- not use this function, simply use 'Prelude.fmap' or the 'Control.Applicative.<$>' operator
-- instead.
-- 
-- This function temporarily changes the constructor name to the constructor set by the @inner@
-- type, that way the 'fromDaoStruct' instance of the @inner@ type will be fooled and read the
-- 'Struct' fields without backtracking. For example:
-- > newtype X = X{ getX :: Int }
-- > instance 'ToDataStruct' X where
-- >     'toDaoStruct' = do
-- >         'renameConstructor' "X"
-- >         "getX" '.=@' getX
-- > 
-- > newtype Y = Y{ innerX :: X }
-- > instance 'ToDataStruct' Y where
-- >     'toDaoStruct' = do
-- >         -- the 'innerToStruct' function will use the 'toDaoStruct' for X
-- >         'Control.Monad.Reader.ask' >>= 'innerToStruct' . innerX
-- >         -- then rename the constructor from "X" to "Y"
-- >         'renameConstructor' "Y"
-- > 
-- Now when we want to define the accompanying 'FromDaoStructClass', we need to remember that we
-- used 'innerToStruct' and changed the 'structName' from "X" to "Y". Simply using 'Prelude.fmap'
-- (or equivalently 'Control.Applicative.<$>') will not work because the instance of 'fromDaoStruct'
-- for the @X@ data type will backtrack when it sees the 'structName' is "Y".
-- > instance 'FromDaoStructClass' Y where
-- >     'fromDaoStruct' = Y 'Control.Applicative.<$>' 'fromDaoStruct' -- /WRONG!/ This will always backtrack.
-- 
-- The correct way to do it is to use 'innerFromStruct' like so:
-- > instance 'FromDaoStructClass' Y where
-- >     'fromDaoStruct' = Y 'Control.Applicative.<$> 'innerFromStruct' "X" -- CORRECT!
-- 
innerFromStruct :: (UStrType name, FromDaoStructClass inner) => name -> FromDaoStruct inner
innerFromStruct tempName = do
  name     <- asks structName
  tempName <- mkStructName tempName
  let setname name = FromDaoStruct $ lift $ modify $ \struct -> struct{ structName=name }
  o <- setname tempName >> mplus fromDaoStruct (setname name >> mzero)
  setname name >> return o

-- | Succeeds if the current 'Struct' is a 'Nullary' where the 'structName' is equal to the name
-- given to this function.
nullary :: UStrType name => name -> FromDaoStruct ()
nullary name = ask >>= \struct -> case struct of
  Nullary{} -> constructor name
  _         -> mzero

-- | Use the instantiation of 'Prelude.Read' derived for a type @haskData@ to construct the
-- @haskData from the 'structName' stored in a 'Nullary' 'Struct'.
getNullaryWithRead :: Read haskData => FromDaoStruct haskData
getNullaryWithRead = ask >>= \struct -> case struct of
  Nullary{ structName=name } -> case readsPrec 0 (uchars name) of
    [(haskData, "")] -> return haskData
    _ -> mzero
  _ -> mzero

-- | If an error is thrown using 'Control.Monad.Error.throwError' or 'Control.Monad.fail' within the
-- given 'FromDaoStruct' function, the 'structErrField' will automatically be set to the provided
-- 'Name' value.
structCurrentField :: Name -> FromDaoStruct o -> FromDaoStruct o
structCurrentField name (FromDaoStruct f) = FromDaoStruct $ catchPredicate f >>= \o -> case o of
  PFail (err@(ExecError{execErrorSubtype=ExecStructError info})) -> throwError $ 
    err{ execErrorSubtype = ExecStructError $ info{ structErrField = Just (toUStr name) } }
  PFail err -> throwError err
  OK      o -> return o
  Backtrack -> mzero

-- | Retrieves an arbitrary 'Object' by it's field name, and backtraks if no such field is defined.
-- The value of the field is copied, and can be copied again after this operation. It is best not to
-- use this function, rather use 'tryField' to make sure each field is retrieved exactly once, then
-- use 'checkEmpty' to make sure there is no hidden extraneous data in the struct.
tryCopyField :: UStrType name => name -> (Object -> FromDaoStruct o) -> FromDaoStruct o
tryCopyField name f = (return M.lookup <*> mkFieldName name <*> asks fieldMap) >>=
  xmaybe >>= structCurrentField (fromUStr $ toUStr name) . f

-- | Like 'copyField', retrieves an arbitrary 'Object' by it's field name, and backtraks if no such
-- field is defined. However unlike 'tryCopyField', if the item is retrieved, it is deleted from the
-- inner 'Struct' so that it may not be used again. The reason for this is to use 'checkEmpty' and
-- 'requireEmpty', which can backtrack or fail if there are extraneous fields in the structure.
tryField :: UStrType name => name -> (Object -> FromDaoStruct o) -> FromDaoStruct o
tryField name f = do
  name <- mkFieldName name
  o    <- tryCopyField name f
  FromDaoStruct $ lift $ modify $ \st ->
    case st of{ Struct{ fieldMap=m } -> st{ fieldMap=M.delete name m }; s -> s; }
  return o

_throwMissingFieldError :: Name -> FromDaoStruct o
_throwMissingFieldError name = throwError $
  newError{ execErrorSubtype = ExecStructError $ nullValue{ structErrField = Just $ toUStr name } }

-- | Like 'field' but evaluates 'Control.Monad.Error.throwError' if the 'FromDaoStruct' function
-- backtracks or throws it's own error. Internally, this function makes use of 'copyField' and /not/
-- 'tryField', so the field is preserved if it exists.
copyField :: UStrType name => name -> (Object -> FromDaoStruct o) -> FromDaoStruct o
copyField name f = mkFieldName name >>= \name ->
  mplus (tryCopyField name f) (_throwMissingFieldError name)

-- | Like 'field' but evaluates 'Control.Monad.Error.throwError' if the 'FromDaoStruct' function
-- backtracks or throws it's own error. Internally, this function makes use of 'tryField' and /not/
-- 'tryCopyField', so the field is removed if it exists -- two consecutive calls to this function
-- with the same key absolutely will fail.
field :: UStrType name => name -> (Object -> FromDaoStruct o) -> FromDaoStruct o
field name f = mkFieldName name >>= \name -> mplus (tryField name f) (_throwMissingFieldError name)

-- As you make calls to 'field' and 'tryField', the items in these fields in the 'Struct' are
-- being removed. Once you have all of the nata neccessary to construct the data 'Object', you can
-- check to make sure there are no extraneous unused data fields. If the 'Struct' is empty, this
-- function evaluates to @return ()@. If there are extranous fields in the 'Struct', 'throwError' is
-- evaluated. It is highly recommended that this function always be used as the last function
-- evaluated in the 'FromDaoStruct' monadic function.
checkEmpty :: FromDaoStruct ()
checkEmpty = FromDaoStruct (lift get) >>= \st -> case st of
  Struct{ fieldMap=m } -> when (not $ M.null m) $
    execThrow "assigned to non-member fields of structure"
      (ExecStructError $ nullValue{ structErrExtras = M.keys m }) []
  Nullary{} -> return ()

-- | Takes a conversion as the first parameter. The second parameter will be provided by 'field' or
-- 'tryField' when you pass it as a partial function application. If the conversion function
-- backtracks, 'Control.Monad.Error.throwError' is evaluated with the appropriate error data set.
-- This function should usually not be required, as it is called by functions like 'opt', 'req', and
-- 'reqList'.
convertFieldData :: (Object -> FromDaoStruct o) -> Object -> FromDaoStruct o
convertFieldData f o = mplus (f o) $ throwError $
  newError{ execErrorSubtype = ExecStructError $ nullValue{ structErrValue=Just o } }

-- | A required 'Struct' 'field'. This function is defined as
req :: (UStrType name, Typeable o, ObjectClass o) => name -> FromDaoStruct o
req name = field name (convertFieldData (xmaybe . fromObj))

-- | Check if a 'Struct' field exists using 'tryField', if it exists, convert it to the necessary
-- data type using 'fromObj' (which fails if an unexpected type is stored in that field).
opt :: (UStrType name, Typeable o, ObjectClass o) => name -> FromDaoStruct (Maybe o)
opt name = Just <$> tryField name (convertFieldData (xmaybe . fromObj)) <|> return Nothing

-- | Like 'req' but internally uses 'listFromObj' instead of 'fromObj'. The field must exist, if it
-- does not this function evaluates to 'Control.Monad.Error.throwError'. Use 'optList' instead if
-- you can accept an empty list when the field is not defined.
reqList :: (UStrType name, Typeable o, ObjectClass o) => name -> FromDaoStruct [o]
reqList name = field name $ convertFieldData (xmaybe . listFromObj)

-- | Like 'opt' but internally uses 'listFromObj' instead of 'fromObj'. The field may not exist, and
-- if it does not this function returns an empty list. Use 'reqList' to evaluate to
-- 'Control.Monad.Error.throwError' in the case the field does not exist.
optList :: (UStrType name, Typeable o, ObjectClass o) => name -> FromDaoStruct [o]
optList name = tryField name $ convertFieldData (maybe (return []) return . listFromObj)

----------------------------------------------------------------------------------------------------

builtin_toStruct :: DaoFunc ()
builtin_toStruct =
  daoFunc
  { daoForeignFunc = \ () ox -> do
      let qref = reference UNQUAL (ustr "toStruct")
      let wrongTypeErr o = throwBadTypeError "cannot convert to a struct from object of the given type" o []
      case ox of
        [o] -> case o of
          OTree              _  -> return (Just o, ())
          OHaskell (Hata ifc d) -> case objToStruct ifc of
            Just to -> flip (,) () . Just . obj <$> toDaoStructExec to d
            Nothing -> wrongTypeErr o
          o                     -> wrongTypeErr o
        ox  -> throwArityError "" 1 ox [(errInFunc, obj qref)]
  }

builtin_fromStruct :: DaoFunc ()
builtin_fromStruct =
  daoFunc
  { daoForeignFunc = \ () ox -> do
      let qref = reference UNQUAL (ustr "fromStruct")
      case ox of
        [o] -> case o of
          OTree o -> flip (,) () . Just . OHaskell <$> fromDaoStructExec o
          o       -> throwBadTypeError "argument parameter is not a struct data type" o []
        ox -> throwArityError "" 1 ox [(errInFunc, obj qref)]
  }

----------------------------------------------------------------------------------------------------

instance ToDaoStructClass Location where
  toDaoStruct = ask >>= \lo -> case lo of
    LocationUnknown -> makeNullary "NoLocation"
    Location{} -> renameConstructor "Location" $ do
      "startingLine"   .=@ startingLine
      "startingColumn" .=@ startingColumn
      "endingLine"     .=@ endingLine
      "endingColumn"   .=@ endingColumn

instance FromDaoStructClass Location where
  fromDaoStruct = msum $
    [ nullary "NoLocation" >> return LocationUnknown
    , do  constructor "Location"
          return Location
            <*> req "startingLine"
            <*> req "startingColumn"
            <*> req "endingLine"
            <*> req "endingColumn"
    ]

putLocation :: Location -> ToDaoStruct haskData ()
putLocation loc = case loc of
  LocationUnknown -> return ()
  Location{} -> void $ "location" .= loc

location :: FromDaoStruct Location
location = opt "location" >>= maybe (return LocationUnknown) return

putComments :: [Comment] -> ToDaoStruct haskData ()
putComments = void . defObjField "comments"

comments :: FromDaoStruct [Comment]
comments = req "comments"

optComments :: FromDaoStruct (Maybe [Comment])
optComments = opt "comments"

instance HasRandGen Object where
  randO = countNode $ recurse $ runRandChoice
  randChoice = mappend (fmap unlimitObject defaultChoice) $ randChoiceList $
    [ ORef  <$> randO
    , depthLimitedInt 24 >>= \x ->
        scramble $ OList <$> randList 0 x
    , depthLimitedInt 24 >>= \x ->
        scramble $ ODict . M.fromList <$> randListOf 0 x (return (,) <*> randO <*> randO)
    , OType <$> randO
    , OTree <$> randO
    , ORatio <$> randO
    , OComplex <$> randO
    ]
  defaultO = _randTrace "D.Object" runDefaultChoice
  defaultChoice = randChoiceList $
    [ do  i <- nextInt 10 -- OBytes
          fmap (OBytes . B.concat) $ replicateM i $
            fmap (encode . (\i -> fromIntegral i :: Word32)) randInt
    ]

-- | This is a newtype of 'Object' with a specially defined instance for 'HasRandGen' that
-- guarantees the 'Object' values generated randomly can be pretty-printed an re-parsed back to the
-- exact same value, unambiguously. For example, the instance of 'HasRandGen' for 'LimitedObject'
-- will not produce any values of:
-- > 'Dao.Interpreter.OList' ['Dao.Interpreter.OInt' 1, 'Dao.Interpreter.OInt' 2, 'Dao.Interpreter.OInt' 3]
-- because this will be pretty-printed to "list {1,2,3}" and parsing that pretty printed object will
-- yield the data type:
-- > ('Dao.Interpreter.AST_Init'
-- >     ('Dao.Interpreter.AST_DotLabel' ('Dao.String.Name' "list") [] 'Dao.Token.LocationUnknown')
-- >     ('Dao.Interpreter.AST_OptObjList' [] 'Prelude.Nothing')
-- >     ('Dao.Interpreter.AST_ObjList' []
-- >         [ 'Dao.Interpreter.Com' ('Dao.Interpreter.AST_Eval' ('Dao.Interpreter.AST_ObjArith' ('Dao.Interpreter.AST_Object' ('Dao.Interpreter.AST_ObjLiteral' (OInt 1 'Dao.Token.LocationUnknown')))))
-- >         , 'Dao.Interpreter.Com' ('Dao.Interpreter.AST_Eval' ('Dao.Interpreter.AST_ObjArith' ('Dao.Interpreter.AST_Object' ('Dao.Interpreter.AST_ObjLiteral' (OInt 2 'Dao.Token.LocationUnknown')))))
-- >         , 'Dao.Interpreter.Com' ('Dao.Interpreter.AST_Eval' ('Dao.Interpreter.AST_ObjArith' ('Dao.Interpreter.AST_Object' ('Dao.Interpreter.AST_ObjLiteral' (OInt 3 'Dao.Token.LocationUnknown')))))
-- >         ]
-- >     )
-- > )
-- Obviously this is a completely different data structure than the data originally randomly
-- generated. If one were to evaluate it using 'Dao.Interpreter.execute', it would evaluate to the
-- originally generated random object value. But for simplicity the test suit does not evaluate
-- anything, it only compares the original randomly generated test object value to the object value
-- that was constructed by parsing the pretty printed form.
--
-- Therefore, the only data structures that should be randomly generated for testing are the data
-- structures that pretty print to a form that can be parsed back to an identical value when
-- compared to the original. This limits the objects that can be generated to simple string and
-- integer literals, hence the name 'LimitedObject'.
newtype LimitedObject = LimitedObject { unlimitObject :: Object } deriving (Eq, Ord, Show)

instance HasNullValue LimitedObject where
  nullValue = LimitedObject nullValue
  testNull (LimitedObject o) = testNull o

instance HasRandGen LimitedObject where
  randO =  _randTrace "LimitedObject" $ countNode $ runRandChoice
  randChoice = fmap LimitedObject $ randChoiceList $
    [ return ONull, return OTrue
    , OInt     <$> defaultO
    , OWord    <$> defaultO
    , OLong    <$> defaultO
    , OFloat   <$> defaultO
    , OString  <$> defaultO
    , OAbsTime <$> defaultO
    , ORelTime <$> defaultO
    , OChar . chr . flip mod (ord(maxBound::Char)) <$> defaultO
    ]
  defaultO = randO

----------------------------------------------------------------------------------------------------

-- | The 'Object' type extends the 'Data.Dynamic.Dynamic' data type with a few more constructors for
-- data types that are fundamental to a programming language, like integers, strings, and lists.
data Object
  = ONull
  | OTrue
  | OChar      T_char
  | OInt       T_int
  | OWord      T_word
  | OLong      T_long
  | ORelTime   T_diffTime
  | OFloat     T_float
  | ORatio     T_ratio
  | OComplex   T_complex
  | OString    T_string
  | OBytes     T_bytes
  | OList      T_list
  | ODict      T_dict
  | ORef       T_ref
  | OType      T_type
  | OTree      T_struct
  | OAbsTime   T_time
  | OHaskell   Hata
  deriving (Eq, Ord, Typeable, Show)

type T_char     = Char
type T_int      = Int
type T_word     = Word64
type T_long     = Integer
type T_diffTime = NominalDiffTime
type T_float    = Double
type T_ratio    = Rational
type T_complex  = Complex
type T_string   = UStr
type T_bytes    = B.ByteString
type T_list     = [Object]
type T_dict     = M.Map Name Object
type T_ref      = Reference
type T_type     = ObjType
type T_struct   = Struct
type T_time     = UTCTime

instance NFData Object where
  rnf  ONull         = ()
  rnf  OTrue         = ()
  rnf (OChar      a) = deepseq a ()
  rnf (OInt       a) = deepseq a ()
  rnf (OWord      a) = deepseq a ()
  rnf (OLong      a) = deepseq a ()
  rnf (ORelTime   a) = deepseq a ()
  rnf (OFloat     a) = deepseq a ()
  rnf (ORatio     a) = deepseq a ()
  rnf (OComplex   a) = deepseq a ()
  rnf (OString    a) = deepseq a ()
  rnf (OBytes     a) = seq a ()
  rnf (OList      a) = deepseq a ()
  rnf (ODict      a) = deepseq a ()
  rnf (ORef       a) = deepseq a ()
  rnf (OType      a) = deepseq a ()
  rnf (OTree      a) = deepseq a ()
  rnf (OAbsTime   a) = deepseq a ()
  rnf (OHaskell   a) = deepseq a ()

instance Monoid (XPure Object) where
  mempty = return ONull
  mappend a b = a >>= \a -> b >>= \b -> case a of
    ONull     -> return b
    OTrue     -> case b of
      OTrue     -> return OTrue
      _         -> mzero
    a         -> case b of
      ONull     -> return a
      b         -> xpure a + xpure b

instance HasNullValue Object where
  nullValue = ONull
  testNull a = case a of
    ONull        -> True
    OChar     c  -> testNull c
    OInt      i  -> testNull i
    OWord     i  -> testNull i
    OLong     i  -> testNull i
    OFloat    f  -> testNull f
    ORelTime  s  -> testNull s
    ORatio    r  -> testNull r
    OComplex  c  -> testNull c
    OString   s  -> testNull s
    OBytes    o  -> testNull o
    OList     s  -> testNull s
    ODict     m  -> testNull m
    OTree     t  -> testNull t
    OHaskell  o  -> testNull o
    _            -> False

-- binary 0x08 0x1A Object-->CoreType
instance B.Binary Object MTab where
  put o = do
    let t   = B.put (typeOfObj o)
        p o = t >> B.put o
    case o of
      ONull      -> t
      OTrue      -> t
      OChar    o -> p o
      OInt     o -> p o
      OWord    o -> p o
      OLong    o -> p o
      ORelTime o -> p o
      OFloat   o -> p o
      ORatio   o -> p o
      OComplex o -> p o
      OString  o -> p o
      OBytes   o -> p o
      OList    o -> t >> B.putUnwrapped o
      ODict    o -> p o
      ORef     o -> p o
      OType    o -> p o
      OTree    o -> p o
      OAbsTime o -> p o
      OHaskell o -> B.put o
  get = B.word8PrefixTable <|> fail "expecting Object"

instance B.HasPrefixTable Object B.Byte MTab where
  prefixTable =
    let g f = fmap f B.get
    in  mappend (OTree <$> B.prefixTable) $ B.mkPrefixTableWord8 "Object" 0x08 0x1A $
          [ return ONull
          , return OTrue
          , g OChar
          , g OInt
          , g OWord
          , g OLong
          , g ORelTime
          , g OFloat
          , g ORatio
          , g OComplex
          , g OString
          , g OBytes
          , OList <$> B.getUnwrapped
          , g ODict
          , g ORef
          , g OType
          , g OTree
          , g OAbsTime
          , mplus (OHaskell <$> B.get)
                  (B.get >>= \ (B.BlockStream1M bs1m) -> return (OBytes bs1m))
          ]

----------------------------------------------------------------------------------------------------

instance ToDaoStructClass RefQualifier where { toDaoStruct=putNullaryUsingShow; }

instance FromDaoStructClass RefQualifier where { fromDaoStruct=getNullaryWithRead; }

instance ObjectClass RefQualifier where { obj=new; fromObj=objFromHata; }

instance HataClass RefQualifier where
  haskellDataInterface = interface "RefQualifier" $ do
    autoDefEquality >> autoDefOrdering >> autoDefPPrinter
    autoDefToStruct >> autoDefFromStruct

----------------------------------------------------------------------------------------------------

data Reference
  = Reference  RefQualifier Name RefSuffix
  | RefObject  Object RefSuffix
  | RefWrapper Reference
  deriving (Eq, Ord, Typeable, Show)

instance Monoid (XPure Reference) where
  mempty = mzero
  mappend a b = msum $
    [ a >>= \a -> b >>= \b -> case b of
        Reference UNQUAL name suf -> let suf2 = DotRef name suf in case a of
          Reference  q name suf1 -> return $ Reference q name (suf1 <> suf2)
          RefObject  o      suf1 -> return $ RefObject   o    (suf1 <> suf2)
          RefWrapper a           -> return a <> return b
        _  -> execThrow
                "only unqualified references can be appended to other references"
                  ExecErrorUntyped [(assertFailed, obj b)]
    , a, b
    ]

instance Read Reference where
  readsPrec _ str = loop [] (sp str) where
    sp = dropWhile isSpace
    loop rx str = do
      (a,  str) <- pure (span (\c -> isAlpha    c || c=='_') str)
      guard (not $ null a)
      (ax, str) <- pure (span (\c -> isAlphaNum c || c=='_') str)
      ax  <- pure (fromUStr $ toUStr $ a++ax)
      str <- pure (sp str)
      case str of
        '.':str            -> loop (rx++[ax]) (sp str)
        "" | not $ null rx -> [(Reference UNQUAL (head rx) $ refSuffixFromNames (tail $ rx++[ax]), "")]
        ""                 -> [(Reference UNQUAL ax NullRef, "")]
        _                  -> error $ concat ["a=", show a, "ax=", show ax, "str=", show str]

-- | Construct a 'Reference' with a 'RefQualifier' and a 'Name'.
reference :: RefQualifier -> Name -> Reference
reference q name = Reference q name NullRef

-- | Construct a 'Reference' with an object.
refObject :: Object -> Reference
refObject = flip RefObject NullRef

-- | Strip the 'RefSuffix' from the given 'Reference', changing it 'NullRef' and returning the
-- updated 'Referene' along with the 'RefSuffix' that was removed. If the 'Reference' is a
-- 'RefWrapper', nothing is changed.
referenceHead :: Reference -> (Reference, Maybe RefSuffix)
referenceHead qref = case qref of
  Reference q name suf -> (Reference q name NullRef, Just suf)
  RefObject   o    suf -> (RefObject   o    NullRef, Just suf)
  RefWrapper  r        -> (RefWrapper  r           , Nothing )

-- | The 'Reference' data type has a 'RefWrapper' constructor which wraps a 'Reference' value,
-- protecting it from being de-referenced. This function unwraps the inner 'Reference' if it is
-- within a 'RefWrapper', or else returns the 'Reference' unchanged.
refUnwrap :: Reference -> Reference
refUnwrap r = case r of { RefWrapper r -> r; r -> r; }

instance NFData Reference where
  rnf (Reference q n r) = deepseq q $! deepseq n $! deepseq r ()
  rnf (RefObject o r  ) = deepseq o $! deepseq r ()
  rnf (RefWrapper  r  ) = deepseq r ()

instance PPrintable Reference where
  pPrint qref = case qref of
    Reference q n r -> case q of
      UNQUAL -> pInline [pPrint n, pPrint r]
      q      -> pInline [pPrint q, pString " ", pPrint n, pPrint r]
    RefObject o r -> pInline [pString "(", pPrint o, pString ")", pPrint r]
    RefWrapper  r -> pInline [pString "$", pPrint r]

-- binary 0x48 0x4E
instance B.Binary Reference MTab where
  put qref = case qref of
    Reference q n r -> prefix q $ B.put n >> B.put r where
      prefix q = B.prefixByte $ case q of
        { UNQUAL -> 0x48; LOCAL -> 0x49; CONST -> 0x4A; STATIC -> 0x4B; GLOBAL -> 0x4C; GLODOT -> 0x4D; }
    RefObject o r -> B.prefixByte 0x4E $ B.put o >> B.put r
    RefWrapper  r -> B.prefixByte 0x4F $ B.put r
  get = B.word8PrefixTable <|> fail "expecting Reference"

instance B.HasPrefixTable Reference B.Byte MTab where
  prefixTable = B.mkPrefixTableWord8 "Reference" 0x48 0x4F $
    [ f UNQUAL, f LOCAL, f CONST, f STATIC, f GLOBAL, f GLODOT
    , return RefObject  <*> B.get <*> B.get
    , return RefWrapper <*> B.get
    ] where { f q = return (Reference q) <*> B.get <*> B.get }

instance HasRandGen Reference where
  randO = _randTrace "Reference" $ recurse $ countNode $ runRandChoice
  randChoice = randChoiceList $
    [ return Reference <*> randO   <*> randO <*> randO
    , return RefObject <*> scrambO <*> randO
    , RefWrapper <$> scrambO
    ]
  defaultO = _randTrace "D.Reference" runDefaultChoice
  defaultChoice = randChoiceList $
    [ return Reference <*> defaultO <*> defaultO <*> defaultO
    , return RefObject <*> defaultO <*> defaultO
    ]

-- 'execute'-ing a 'Reference' will dereference it, essentially reading the value associated with
-- that reference from the 'ExecUnit'.
instance Executable Reference (Reference, Maybe Object) where { execute qref = referenceLookup qref }

refAppendSuffix :: Reference -> RefSuffix -> Reference
refAppendSuffix qref appref = case qref of
  Reference q name ref -> Reference q name (ref<>appref)
  RefObject   o    ref -> RefObject   o    (ref<>appref)
  RefWrapper      qref -> RefWrapper $ refAppendSuffix qref appref

-- | This is an important function used throughout most of the intepreter to lookup 'Object's
-- associated with 'Reference's. It returns a a pair containing updated copy of the given
-- 'Reference' and the 'Object' that was looked-up. The 'Reference' returned is a copy of the
-- 'Reference' parameter given but updated with information about where the reference was looked up.
-- For example, if you pass an 'UNQUAL' (unqualified) reference, it may be looked up in the local,
-- global, or const variable tables.  The reference returned will not be 'UNQUAL', it will be either
-- 'GLOBAL', 'LOCAL', or 'CONST', depending on where the 'Object' returned was found.
--
-- If the 'Reference' is a function call, the object returned will be the evaluation of the function
-- call, which may be void (a.k.a. 'Prelude.Nothing').
referenceLookup :: Reference -> Exec (Reference, Maybe Object)
referenceLookup qref = case qref of
  RefWrapper ref -> return $ (qref, Just (obj ref))
  qref           -> do
    (a, (qref, _, _)) <- runObjectFocus (updateIndex qref get) True qref ()
    return (qref, a)

refNames :: [Name] -> Maybe Reference
refNames nx = case nx of
  []   -> Nothing
  n:nx -> Just $ Reference UNQUAL n $ refSuffixFromNames nx

referenceFromUStr :: UStr -> Maybe Reference
referenceFromUStr s = breakup [] $ uchars s where
  breakup refs s = case break (=='.') s of
    (n, '.':s) -> breakup (refs++[ustr n]) s
    (n, ""   ) -> refNames $ refs++[ustr n]
    _          -> Nothing

fmapReference :: (RefSuffix -> RefSuffix) -> Reference -> Reference
fmapReference fn ref = case ref of
  Reference q nm ref -> Reference q nm (fn ref)
  RefObject   o  ref -> RefObject   o  (fn ref)
  RefWrapper    qref -> RefWrapper $ fmapReference fn qref

setQualifier :: RefQualifier -> Reference -> Reference
setQualifier q ref = case ref of
  Reference _ name ref -> Reference q name ref
  RefObject   o    ref -> RefObject   o    ref
  RefWrapper      qref -> RefWrapper $ setQualifier q qref

modRefObject :: (Object -> Object) -> Reference -> Reference
modRefObject mod ref = case ref of
  RefObject o ref -> RefObject (mod o) ref
  ref             -> ref

-- | This function performs an update on a 'Reference', it is the complement to the 'referenceLookup'
-- function. Evaluating 'referenceUpdate' on a 'Reference' will write/update the value associated with
-- it. If the boolean parameter is 'Prelude.True' it indicates that the value updated must already
-- exist, and an undefined reference error will be thrown if it does not exist.
referenceUpdate :: Reference -> Bool -> (Maybe Object -> Exec (Maybe Object)) -> Exec (Reference, Maybe Object)
referenceUpdate qref mustExist upd = do
  -- The 'ExecUnit' is not actually modified in any way by 'updateIndex'. It is only used to
  -- instruct Haskell's type system to select the class instance of 'updateIndex' for the data type:
  -- > 'ObjectLens' 'ExecUnit' 'Reference'
  (result, (qref, _, _)) <-
    runObjectFocus (updateIndex qref $ execToFocusUpdater upd) mustExist (fst $ referenceHead qref) ()
  return (qref, result)

----------------------------------------------------------------------------------------------------

-- $Object_types
-- Here we have a lambda calculus for describing types. Computationally, it is very similar to the
-- Prolog programming language, however an 'ObjType' is written using a subset the Dao scripting
-- langauge.

data CoreType
  = NullType
  | TrueType
  | CharType
  | IntType
  | WordType
  | LongType
  | DiffTimeType
  | FloatType
  | RatioType
  | ComplexType
  | StringType
  | BytesType
  | ListType
  | DictType
  | RefType
  | TypeType
  | TreeType
  | TimeType
  | HaskellType
  deriving (Eq, Ord, Typeable, Enum, Bounded)

instance Show CoreType where
  show t = case t of
    NullType     -> "Null"
    TrueType     -> "True"
    CharType     -> "Char"
    IntType      -> "Int"
    WordType     -> "Word"
    LongType     -> "Long"
    DiffTimeType -> "Diff"
    FloatType    -> "Float"
    RatioType    -> "Ratio"
    ComplexType  -> "Complex"
    StringType   -> "String"
    BytesType    -> "Bytes"
    ListType     -> "List"
    DictType     -> "Dict"
    RefType      -> "Ref"
    TypeType     -> "Type"
    TreeType     -> "Tree"
    TimeType     -> "Time"
    HaskellType  -> "Haskell"

instance Read CoreType where
  readsPrec _ str = map (\a -> (a, "")) $ case str of
    "Null"    -> [NullType]
    "True"    -> [TrueType]
    "Char"    -> [CharType]
    "Int"     -> [IntType]
    "Word"    -> [WordType]
    "Long"    -> [LongType]
    "Diff"    -> [DiffTimeType]
    "Float"   -> [FloatType]
    "Ratio"   -> [RatioType]
    "Complex" -> [ComplexType]
    "String"  -> [StringType]
    "Bytes"   -> [BytesType]
    "List"    -> [ListType]
    "Dict"    -> [DictType]
    "Ref"     -> [RefType]
    "Type"    -> [TypeType]
    "Tree"    -> [TreeType]
    "Time"    -> [TimeType]
    "Haskell" -> [HaskellType]
    _         -> []

instance NFData CoreType where { rnf a = seq a () }

instance UStrType CoreType where
  toUStr = derive_ustr
  maybeFromUStr a = case readsPrec 0 (uchars a) of
    [(o, "")] -> Just o
    _         -> Nothing
  fromUStr a = case maybeFromUStr a of
    Nothing -> error (show a++" is not a valid type identifier")
    Just  a -> a

instance Iv.InfBound CoreType where
  minBoundInf = Iv.Finite minBound
  maxBoundInf = Iv.Finite maxBound

instance PPrintable CoreType where { pPrint = pShow }

-- binary 0x08 0x1A CoreType
instance B.Binary CoreType mtab where
  put t = B.putWord8 $ case t of
    NullType     -> 0x08
    TrueType     -> 0x09
    CharType     -> 0x0A
    IntType      -> 0x0B
    WordType     -> 0x0C
    LongType     -> 0x0D
    DiffTimeType -> 0x0E
    FloatType    -> 0x0F
    RatioType    -> 0x10
    ComplexType  -> 0x11
    StringType   -> 0x12
    BytesType    -> 0x13
    ListType     -> 0x14
    DictType     -> 0x15
    RefType      -> 0x16
    TypeType     -> 0x17
    TreeType     -> 0x18
    TimeType     -> 0x19
    HaskellType  -> 0x1A
  get = B.word8PrefixTable <|> fail "expecting CoreType"

instance B.HasPrefixTable CoreType B.Byte mtab where
  prefixTable = B.mkPrefixTableWord8 "CoreType" 0x08 0x1A $ map return $
    [ NullType
    , TrueType
    , CharType
    , IntType
    , WordType
    , LongType
    , DiffTimeType
    , FloatType
    , RatioType
    , ComplexType
    , StringType
    , BytesType
    , ListType
    , DictType
    , RefType
    , TypeType
    , TreeType
    , TimeType
    , HaskellType
    ]

instance HasRandGen CoreType where
  randO = toEnum <$> nextInt (fromEnum (maxBound::CoreType))
  defaultO = randO

-- | Get the 'CoreType' o an 'Object'.
coreType :: Object -> CoreType
coreType o = case o of
  ONull      -> NullType
  OTrue      -> TrueType
  OChar    _ -> CharType
  OInt     _ -> IntType
  OWord    _ -> WordType
  OLong    _ -> LongType
  ORelTime _ -> DiffTimeType
  OFloat   _ -> FloatType
  ORatio   _ -> RatioType
  OComplex _ -> ComplexType
  OString  _ -> StringType
  OBytes   _ -> BytesType
  OList    _ -> ListType
  ODict    _ -> DictType
  ORef     _ -> RefType
  OType    _ -> TypeType
  OTree    _ -> TreeType
  OAbsTime _ -> TimeType
  OHaskell _ -> HaskellType

----------------------------------------------------------------------------------------------------

-- | A symbol in the type calculus.
data TypeSym
  = CoreType CoreType
    -- ^ used when the type of an object is equal to it's value, for example Null and True,
    -- or in situations where the type of an object has a value, for example the dimentions of a
    -- matrix.
  | TypeSym  Name
  | TypeVar  Name [ObjType]
    -- ^ a polymorphic type, like 'AnyType' but has a name.
  deriving (Eq, Ord, Show, Typeable)

instance NFData TypeSym where
  rnf (CoreType a  ) = deepseq a ()
  rnf (TypeSym  a  ) = deepseq a ()
  rnf (TypeVar  a b) = deepseq a $! deepseq b ()

instance HasRandGen TypeSym where
  randO = _randTrace "TypeSym" $ countNode $ runRandChoice
  randChoice = randChoiceList $
    [CoreType <$> randO, TypeSym <$> randO, scramble $ return TypeVar <*> randO <*> randList 1 4]
  defaultO = _randTrace "D.TypeSym" $ CoreType <$> defaultO

instance PPrintable TypeSym where
  pPrint t = case t of
    CoreType t     -> pPrint t
    TypeSym  t     -> pPrint t
    TypeVar  t ctx -> pInline $
      concat [[pPrint t], guard (not (null ctx)) >> [pList_ "[" ", " "]" (map pPrint ctx)]]

-- binary 0x2E 0x2F
instance B.Binary TypeSym mtab where
  put o = case o of
    CoreType o      -> B.prefixByte 0x2D $ B.put o
    TypeSym  o      -> B.prefixByte 0x2E $ B.put o
    TypeVar ref ctx -> B.prefixByte 0x2F $ B.put ref >> B.put ctx
  get = B.word8PrefixTable <|> fail "expecting TypeSym"

instance B.HasPrefixTable TypeSym B.Byte mtab where
  prefixTable =
    B.mkPrefixTableWord8 "TypeSym" 0x2D 0x2F [CoreType <$> B.get, return TypeVar <*> B.get <*> B.get]

----------------------------------------------------------------------------------------------------

-- | Complex type structures can be programmed by combining 'ObjSimpleType's. An empty 'TypeStruct'
-- is the "any-type", which matches anything.
newtype TypeStruct = TypeStruct [TypeSym] deriving (Eq, Ord, Show, Typeable)

instance NFData TypeStruct where { rnf (TypeStruct a) = deepseq a () }

instance HasNullValue TypeStruct where { nullValue = TypeStruct []; testNull (TypeStruct a) = null a; }

instance PPrintable TypeStruct where
  pPrint (TypeStruct tx) = case tx of
    [] -> pString "AnyType"
    tx -> pList (pString "type") "(" ", " ")" (map pPrint tx)

-- binary 0x33 
instance B.Binary TypeStruct mtab where
  put (TypeStruct o) = B.prefixByte 0x33 $ B.put o
  get = B.word8PrefixTable <|> fail "expecting TypeStruct"

instance B.HasPrefixTable TypeStruct B.Byte mtab where
  prefixTable = B.mkPrefixTableWord8 "TypeStruct" 0x33 0x33 [TypeStruct <$> B.get]

instance HasRandGen TypeStruct where
  randO    = _randTrace "TypeStruct" $ TypeStruct <$> randList 0 4
  defaultO = _randTrace "D.TypeStruct" $ TypeStruct <$> defaultList 0 4

----------------------------------------------------------------------------------------------------

-- | The fundamental 'Type' used to reason about whether an object is fit to be used for a
-- particular function. Any empty 'ObjType' is the "void-type" which matches nothing.
newtype ObjType = ObjType { typeChoices :: [TypeStruct] } deriving (Eq, Ord, Show, Typeable)

instance NFData ObjType where { rnf (ObjType a) = deepseq a () }

instance HasNullValue ObjType where { nullValue = ObjType []; testNull (ObjType a) = null a; }

instance PPrintable ObjType where
  pPrint t@(ObjType tx) = case fromObj (obj t) of
    Just  t -> pString $ show (t::CoreType)
    Nothing -> case tx of
      [] -> pString "VoidType"
      tx -> pList (pString "anyOf") "(" ", " ")" (map pPrint tx)

-- binary 0x37 
instance B.Binary ObjType mtab where
  put (ObjType o) = B.prefixByte 0x37 $ B.put o
  get = B.word8PrefixTable <|> fail "expecting ObjType"

instance B.HasPrefixTable ObjType B.Byte mtab where
  prefixTable = B.mkPrefixTableWord8 "ObjType" 0x37 0x37 [ObjType <$> B.get]

instance HasRandGen ObjType where
  randO = _randTrace "ObjType" $ recurse $ ObjType <$> randList 0 3
  defaultO = _randTrace "D.ObjType" $ ObjType <$> defaultList 1 4

typeOfObj :: Object -> ObjType
typeOfObj o = case o of
  OHaskell o -> hataType o
  o          -> ObjType [TypeStruct [CoreType $ coreType o]]

hataType :: Hata -> ObjType
hataType (Hata ifc _) = ObjType [TypeStruct [TypeSym $ objInterfaceName ifc]]

objTypeFromCoreType :: CoreType -> ObjType
objTypeFromCoreType = ObjType . return . TypeStruct . return . CoreType

objTypeFromName :: Name -> ObjType
objTypeFromName name = ObjType{ typeChoices = [TypeStruct [TypeSym name]] }

----------------------------------------------------------------------------------------------------

-- | This is actually a part of the 'Reference' constructor, and 'Reference' is one of the built-in
-- 'Object' data types.  There is a one-to-one mapping from this type to the 'RefSuffixExpr' and
-- 'AST_Ref' data types produced by the parser.
data RefSuffix
  = NullRef
  | DotRef     Name    RefSuffix
  | Subscript [Object] RefSuffix
  | FuncCall  [Object] RefSuffix
  deriving (Eq, Ord, Typeable, Show)

instance Monoid RefSuffix where
  mempty = NullRef
  mappend left right = case left of
    NullRef           -> right
    DotRef    nm left -> DotRef    nm $ left<>right
    Subscript ox left -> Subscript ox $ left<>right
    FuncCall  ox left -> FuncCall  ox $ left<>right

-- | If the 'RefSuffix' is 'DotRef', 'Subscript', or 'FuncCall', the second parameter to these
-- constructors is overwritten with 'NullRef' so only the first parameter remains.
refSuffixHead :: RefSuffix -> RefSuffix
refSuffixHead suf = let lst = refSuffixToList suf in if null lst then NullRef else head lst

-- | Evaluates to 'Prelude.True' if ay of the constructors within the 'RefSuffix' are 'FuncCall'.
refSuffixHasFuncCall :: RefSuffix -> Bool
refSuffixHasFuncCall suf = case suf of
  NullRef         -> False
  DotRef    _ suf -> refSuffixHasFuncCall suf
  Subscript _ suf -> refSuffixHasFuncCall suf
  FuncCall  _ _   -> True

-- | The 'RefSuffix' is a list-like data type, where most of the constructors may contain another
-- 'RefSuffix' structure as the "tail" of the list. This function "explodes" a 'RefSuffix' into a
-- list of 'RefSuffix's where "tail" is 'NullRef'. This is the inverse operation of
-- 'Data.Monoid.mconcat', so the following equality is always True:
-- > \r -> mconcat (refSuffixToList r) == r
refSuffixToList :: RefSuffix -> [RefSuffix]
refSuffixToList suf = case suf of
  NullRef         -> []
  DotRef    a suf -> DotRef    a NullRef : refSuffixToList suf
  Subscript a suf -> Subscript a NullRef : refSuffixToList suf
  FuncCall  a suf -> FuncCall  a NullRef : refSuffixToList suf

-- | Construct a 'DotRef' with a 'NullRef' suffix.
dotRef :: Name -> RefSuffix
dotRef = flip DotRef NullRef

-- | Construct a 'Subscript' with a 'NullRef' suffix.
subscript :: [Object] -> RefSuffix
subscript = flip Subscript NullRef

-- | Construct a 'FuncCall' with a 'NullRef' suffix.
funcCall :: [Object] -> RefSuffix
funcCall = flip FuncCall NullRef

instance HasNullValue RefSuffix where
  nullValue = NullRef
  testNull r = case r of { NullRef -> True; _ -> False }

refSuffixFromNames :: [Name] -> RefSuffix
refSuffixFromNames nx = case nx of { [] -> NullRef; n:nx -> DotRef n $ refSuffixFromNames nx; }

instance Read RefSuffix where
  readsPrec _ str = case str of
    '.':c:str  | isAlpha c ->
      case break (\c -> c=='.' || isAlphaNum c) (c:str) of
        (cx, str) ->
          maybe [] (return . (\ref -> (refSuffixFromNames ref, str))) $ sequence $
            fix (\loop str -> case break (=='.') str of
                    (cx, str) -> case cx of
                      [] -> []
                      cx -> maybeFromUStr (ustr (dropWhile (=='.') cx)) : loop str
                ) cx
    str -> [(NullRef, str)]

instance NFData RefSuffix where
  rnf  NullRef        = ()
  rnf (DotRef    a b) = deepseq a $! deepseq b ()
  rnf (Subscript a b) = deepseq a $! deepseq b ()
  rnf (FuncCall  a b) = deepseq a $! deepseq b ()

instance PPrintable RefSuffix where
  pPrint = pWrapIndent . loop where 
    loop r = case r of
      NullRef       -> []
      DotRef    a b -> pString "." : pUStr (toUStr a) : loop b
      Subscript a b -> pList_ "[" ", " "]" (map pPrint a) : loop b
      FuncCall  a b -> pList_ "(" ", " ")" (map pPrint a) : loop b

instance HasRandGen RefSuffix where
  randO = _randTrace "RefSuffix" $ recurse $ countNode $ runRandChoice
  randChoice = randChoiceList $
    [ return NullRef
    , scramble $ return DotRef <*> randO <*> randO
    , depthLimitedInt 8 >>= \x -> return Subscript <*> randList 0 x <*> scrambO
    , depthLimitedInt 8 >>= \x -> return FuncCall  <*> randList 0 x <*> scrambO
    ]
  defaultO = _randTrace "D.RefSuffix" runDefaultChoice
  defaultChoice = randChoiceList $ 
    [ return NullRef
    , return Subscript <*> defaultList 0 1 <*> pure NullRef
    , return FuncCall  <*> defaultList 0 1 <*> pure NullRef
    ]

-- binary 0x42 0x45
instance B.Binary RefSuffix MTab where
  put r = case r of
    NullRef       -> B.putWord8   0x42
    DotRef    a b -> B.prefixByte 0x43 $ B.put a >> B.put b
    Subscript a b -> B.prefixByte 0x44 $ B.put a >> B.put b
    FuncCall  a b -> B.prefixByte 0x45 $ B.put a >> B.put b
  get = B.word8PrefixTable <|> fail "expecting RefSuffix"

instance B.HasPrefixTable RefSuffix B.Byte MTab where
  prefixTable = B.mkPrefixTableWord8 "RefSuffix" 0x42 0x45 $
    [ return NullRef
    , return DotRef    <*> B.get <*> B.get
    , return Subscript <*> B.get <*> B.get
    , return FuncCall  <*> B.get <*> B.get
    ]

----------------------------------------------------------------------------------------------------

newtype Complex = Complex (C.Complex Double)
  deriving (Eq, Typeable, Floating, Fractional, Num)

-- | Since 'Object' requires all of it's types instantiate 'Prelude.Ord', I have defined
-- 'Prelude.Ord' of 'Data.Complex.Complex' numbers to be the distance from 0, that is, the radius of
-- the polar form of the 'Data.Complex.Complex' number, ignoring the angle argument.
instance Ord Complex where
  compare (Complex a) (Complex b) = compare (C.polar a) (C.polar b)

instance Show Complex where
  show (Complex a) = "("++show re++(if im<0 then "-" else "+")++show im++"i)" where
    re = C.realPart a
    im = C.imagPart a

instance NFData Complex where { rnf (Complex a) = deepseq a $! () }

instance HasNullValue Complex where
  nullValue = Complex (0 C.:+ 0)
  testNull (Complex c) = C.realPart c == 0 && C.imagPart c == 0

instance B.Binary Complex mtab where
  put o = B.put (realPart o) >> B.put (imagPart o)
  get   = return complex <*> B.get <*> B.get

instance PPrintable Complex where
  pPrint (Complex (a C.:+ b))
    | a==0.0 && b==0.0 = pString "0i"
    | a==0.0           = pString (show b++"i")
    | b==0.0           = pShow a
    | otherwise        = pInline [pShow a, pString (if b<0 then "-" else "+"), pString (show b++"i")]

instance HasRandGen Complex where { randO = return mkPolar <*> randO <*> randO; defaultO = randO; }

realPart :: Complex -> Double
realPart (Complex o) = C.realPart o

imagPart :: Complex -> Double
imagPart (Complex o) = C.imagPart o

mkPolar :: Double -> Double -> Complex
mkPolar a b = Complex (C.mkPolar a b)

cis :: Double -> Complex
cis = Complex . C.cis

polar :: Complex -> (Double, Double)
polar (Complex o) = C.polar o

magnitude :: Complex -> Double
magnitude (Complex o) = C.magnitude o

phase :: Complex -> Double
phase (Complex o) = C.phase o

conjugate :: Complex -> Complex
conjugate (Complex o) = Complex (C.conjugate o)

complex :: Double -> Double -> Complex
complex a b = Complex (a C.:+ b)

----------------------------------------------------------------------------------------------------

-- | Create the minimum-sized array that can store all of the indices in the given list, setting the
-- 'Data.Array.IArray.bounds' of the array automatically. Evaluates to 'Prelude.Nothing' if the
-- given list of elements is empty.
minAccumArray :: Ix i => (e -> e' -> e) -> e -> [(i, e')] -> Maybe (Array i e)
minAccumArray accfn deflt elems =
  if null elems then Nothing else Just (accumArray accfn deflt bnds elems) where
    idxs = map fst elems
    i0   = head idxs
    bnds = foldl (\ (lo, hi) i -> (min lo i, max hi i)) (i0, i0) (tail idxs)

-- | Create the minimum-sized array that can store all of the indices in the given list, and setting
-- the 'Data.Array.IArray.bounds' of the array automatically. Evaluates to 'Prelude.Nothing' if the
-- given list of elements is empty.
minArray :: Ix i => e -> [(i, e)] -> Maybe (Array i e)
minArray deflt elems = minAccumArray (flip const) deflt elems

----------------------------------------------------------------------------------------------------

-- | An alternative to 'Glob' expressions containing ordinary 'Dao.String.UStr's is a 'Glob'
-- expression containing 'FuzzyStr's. These strings approximately match the input string, ignoring
-- minor spelling errors and transposed characters.
newtype FuzzyStr = FuzzyStr UStr deriving (Ord, Typeable)

instance Eq FuzzyStr where
  a==b = 
    let ax = S.map toLower (S.fromList (uchars a))
        bx = S.map toLower (S.fromList (uchars b))
    in     a == b
        || ax == bx
        || S.size (S.difference (S.union ax bx) (if S.size ax < S.size bx then ax else bx)) <= 1

instance Show FuzzyStr where { show (FuzzyStr str) = show str }

instance Read FuzzyStr where
  readsPrec p input = readsPrec p input >>= \ (s, rem) -> return (FuzzyStr (ustr s), rem)

instance Monoid FuzzyStr where
  mempty = FuzzyStr mempty
  mappend (FuzzyStr a) (FuzzyStr b) = FuzzyStr (a<>b)

instance HasNullValue FuzzyStr where
  nullValue = FuzzyStr nullValue
  testNull (FuzzyStr s) = testNull s

instance UStrType FuzzyStr where { fromUStr = FuzzyStr; toUStr (FuzzyStr u) = u; }

instance PPrintable FuzzyStr where { pPrint (FuzzyStr str) = pShow str }

instance ObjectClass FuzzyStr where { obj=new; fromObj=objFromHata; }

instance HataClass FuzzyStr where
  haskellDataInterface = interface "FuzzyStr" $ do
    autoDefEquality >> autoDefOrdering >> autoDefPPrinter 

--instance Show (Glob FuzzyStr) where { show = show . fmap toUStr }

--instance Read (Glob FuzzyStr) where
--  readsPrec prec str = readsPrec prec str >>= \ (glob, str) -> [(fmap fromUStr glob, str)]

instance Show (GlobUnit Object) where
  show o = case o of
    Single o -> show o
    globunit -> show (fmap (const "") globunit)

instance PPrintable (GlobUnit Object) where { pPrint = pShow }

instance Show (Glob Object) where
  show glob = (++"\"") $ ('"':) $ do
    o <- getPatUnits glob
    let other o = "$("++prettyShow o++")"
    case o of
      Single o -> case o of
        OString  o -> uchars o
        OHaskell (Hata _ifc dyn) -> case fromDynamic dyn of
          Nothing           -> other o
          Just (FuzzyStr o) -> uchars o
        _ -> other o
      globunit -> show (fmap (const "") globunit)

instance PPrintable (Glob Object) where { pPrint = pShow }

instance ToDaoStructClass (GlobUnit Object) where
  toDaoStruct = ask >>= \o -> case o of
    Wildcard a t -> renameConstructor "Wildcard" $ "name" .= reference UNQUAL a >> "type" .=? t
    AnyOne   a t -> renameConstructor "AnyOne"   $ "name" .= reference UNQUAL a >> "type" .=? t
    Single   a   -> renameConstructor "Single"   $ "item" .= a

instance FromDaoStructClass (GlobUnit Object) where
  fromDaoStruct = msum $
    [ constructor "Wildcard" >> return Wildcard <*> req "name" <*> opt "type"
    , constructor "AnyOne"   >> return AnyOne   <*> req "name" <*> opt "type"
    , constructor "Single"   >>        Single   <$> req "item"
    ]

instance ObjectClass (GlobUnit Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (GlobUnit Object) where
  haskellDataInterface = interface "GlobUnit" $ do
    autoDefEquality >> autoDefOrdering >> autoDefPPrinter
    autoDefFromStruct >> autoDefToStruct

instance ToDaoStructClass (Glob Object) where
  toDaoStruct = renameConstructor "GlobPattern" $ "items" .=@ obj . map obj . getPatUnits

instance FromDaoStructClass (Glob Object) where
  fromDaoStruct = do
    constructor "GlobPattern"
    items <- reqList "items"
    return (Glob{ getPatUnits=items, getGlobLength=length items })

instance ObjectClass (Glob Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (Glob Object) where
  haskellDataInterface = interface "GlobPattern" $ do
    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter
    autoDefToStruct >> autoDefFromStruct
    defMethod "match" $
      daoFunc
      { daoForeignFunc = \glob ox -> fmap (flip (,) glob . Just . obj) $
          forM (matchPattern False glob ox) $ \match -> fmap (obj . M.fromList . concat) $
            forM (M.assocs match) $ \ (name, (vartyp, ox)) -> case vartyp of
              Nothing     -> return [(name, obj ox)]
              Just vartyp -> do
                match <- catchPredicate $ referenceLookup $ Reference UNQUAL vartyp $ FuncCall ox NullRef
                case match of
                  Backtrack       -> return []
                  OK (_, Nothing) -> return [(name, obj ox)]
                  OK (_, Just  o) -> return [(name, obj o)]
                  PFail err       -> throwError err
      }

----------------------------------------------------------------------------------------------------

newtype Pair = Pair (Object, Object) deriving (Eq, Ord, Show, Typeable)

instance PPrintable Pair where
  pPrint (Pair (a,b)) = pList (pString "Pair") "(" ", " ")" [pPrint a, pPrint b]

instance ToDaoStructClass Pair where
  toDaoStruct = renameConstructor "Pair" $ ask >>= \ (Pair (a, b)) -> "fst" .= a >> "snd" .= b

instance FromDaoStructClass Pair where
  fromDaoStruct = constructor "Pair" >> Pair <$> (return (,) <*> req "fst" <*> req "snd")

instance ObjectClass Pair where { obj=new; fromObj=objFromHata; }

instance HataClass Pair where
  haskellDataInterface = interface "Pair" $ do
    autoDefEquality >> autoDefOrdering >> autoDefPPrinter
    autoDefToStruct >> autoDefFromStruct
    defIndexUpdater $ \ix upd -> do
      (Pair (a,b)) <- get
      let casti = extractXPure . castToCoreType IntType >=> fromObj
      let badindex = execThrow "index for Pair data type must be a either 0 or 1" ExecErrorUntyped
      let qref = reference UNQUAL (ustr "Pair")
      case ix of
        [i] -> do
          i <- focusLiftExec (derefObject i) >>=
            maybe (badindex [(actualType, obj (typeOfObj i))]) return . casti
          (o, setter) <- case i of
            0 -> pure (a, \a -> (a, b))
            1 -> pure (b, \b -> (a, b))
            i -> badindex [(assertFailed, OInt i)]
          (result, (changed, o)) <- withInnerLens (Just o) upd
          if changed
          then
            case o of
              Nothing ->
                execThrow "item in Pair object updated with void" ExecErrorUntyped [(ustr "index", obj i)]
              Just  o -> put (Pair $ setter o) >> return result
          else  return result
        ix  -> throwArityError "for subscript to Pair data type" 1 ix [(errInConstr, obj qref)]

builtin_assocs :: DaoFunc ()
builtin_assocs =
  daoFunc
  { daoForeignFunc = \ () ox -> do
      let qref = reference UNQUAL (ustr "assocs")
      case ox of
        [o] -> do
          let fromDict o = return $
                (Just $ obj $ fmap (\ (a,b) -> obj $ Pair (obj a, obj b)) $ M.assocs o, ())
          let badtype = throwBadTypeError "object does not contain association Pairs" o []
          case o of
            ODict                  d   -> fromDict d
            OTree (Struct{fieldMap=d}) -> fromDict d
            OHaskell               _   -> maybe badtype (return . flip (,) () . Just) $ msum $
              [ fromObj o >>= return . obj . fmap (\ (ix, o) -> obj $ Pair (H.indexKey ix, o)) . H.assocs
              ]
            _ -> badtype
        ox -> throwArityError "" 1 ox [(errInFunc, obj qref)]
  }

builtin_Pair :: DaoFunc ()
builtin_Pair =
  daoFunc
  { daoForeignFunc = \ () ox -> case ox of
      [a, b] -> return $ (Just $ obj $ Pair(a, b), ())
      ox -> throwArityError "Pair() constructor requires exactly two arguments" 2 ox []
  }

----------------------------------------------------------------------------------------------------

-- | This is a newtype wrapper around a function that tokenizes a 'UStr' into smaller 'UStr's used
-- for constructing rule patterns, and also for tokenizing input strings into objects that can be
-- matched against rule patterns.
newtype ExecTokenizer = ExecTokenizer { runExecTokenizer :: UStr -> Exec [Object] }
  deriving Typeable

----------------------------------------------------------------------------------------------------

-- | This is the state that is used to run the evaluation algorithm. Every Dao program file that has
-- been loaded will have a single 'ExecUnit' assigned to it. Parameters that are stored in
-- 'Dao.Debug.DMVar's or 'Dao.Type.Resource's will be shared across all rules which are executed in
-- parallel, so for example 'execHeap' contains the variables global to all rules in a given
-- program. The remainder of the parameters, those not stored in 'Dao.Debug.DMVar's or
-- 'Dao.Type.Resource's, will have a unique copy of those values assigned to each rule as it
-- executes.
data ExecUnit
  = ExecUnit
    { globalMethodTable  :: MethodTable
      -- ^ In this slot will be stored a read-only @'Data.Map.Lazy.Map' 'Dao.String.UStr'
      -- 'Interface'@ object that will allow any method with access to this
      -- 'GenRuntime' to retrieve a 'Interface' by it's name string. Specifically,
      -- this will be used by objects stored in the 'OHaskell' constructor.
    , importGraph        :: M.Map UPath ExecUnit
      -- ^ every file opened, whether it is a data file or a program file, is registered here under
      -- it's file path (file paths map to 'File's).
    , defaultTimeout     :: Maybe Int
      -- ^ the default time-out value to use when evaluating 'execInputString'
    , currentWithRef     :: Maybe Object
      -- ^ the current document is set by the @with@ statement during execution of a Dao script.
    , taskForExecUnits   :: Task
    , currentQuery       :: Maybe [Object]
    , currentPattern     :: Maybe (Glob Object)
    , currentCodeBlock   :: Maybe Subroutine
      -- ^ when evaluating a 'Subroutine' selected by a string query, the action resulting from
      -- that query is defnied here. It is only 'Data.Maybe.Nothing' when the module is first being
      -- loaded from source code.
    , currentBranch      :: [Name]
      -- ^ set by the @with@ statement during execution of a Dao script. It is used to prefix this
      -- to all global-dot references before reading from or writing to those references.
    , execStack          :: Stack Name Object
      -- ^ stack of local variables used during evaluation
    , globalData         :: T_dict
    , providedAttributes :: M.Map UStr ()
    , builtinConstants   :: T_dict
    , execOpenFiles      :: M.Map UPath ExecUnit
    , programModuleName  :: Maybe UPath
    , preExec            :: [Subroutine]
      -- ^ the "guard scripts" that are executed before every string execution.
    , postExec           :: [Subroutine]
      -- ^ the "guard scripts" that are executed after every string execution.
    , quittingTime       :: [Subroutine]
    , programTokenizer   :: ExecTokenizer
    , ruleSet            :: PatternTree Object [Subroutine]
    , lambdaSet          :: [CallableCode]
    , uncaughtErrors     :: [ExecControl]
    , runtimeRefTable    :: RefTable Object Dynamic
    }

-- Initializes a completely empty 'ExecUnit'
_initExecUnit :: IO ExecUnit
_initExecUnit = do
  execTask <- initTask
  reftable <- newRefTable
  return $
    ExecUnit
    { globalMethodTable  = mempty
    , defaultTimeout     = Nothing
    , importGraph        = mempty
    , currentWithRef     = Nothing
    , currentQuery       = Nothing
    , currentPattern     = Nothing
    , currentCodeBlock   = Nothing
    , currentBranch      = []
    , globalData         = mempty
    , providedAttributes = mempty
    , builtinConstants   = mempty
    , taskForExecUnits   = execTask
    , execStack          = emptyStack
    , execOpenFiles      = mempty
    , programModuleName  = Nothing
    , preExec            = []
    , quittingTime       = mempty
    , programTokenizer   = defaultTokenizer
    , postExec           = []
    , ruleSet            = T.Void
    , lambdaSet          = []
    , uncaughtErrors     = []
    , runtimeRefTable    = reftable
    }

-- | Creates a new 'ExecUnit'. This is the only way to create a new 'ExecUnit', and it must be run
-- within the 'Exec' monad. The 'ExecUnit' produced by this function will have it's parent
-- 'ExecUnit' set to the value returned by the 'Control.Monad.Reader.Class.ask' instance of the
-- 'Exec' monad.
--
-- The parent of all other 'ExecUnit's, the root of the family tree, is initalized internally by the
-- 'startDao' function.
newExecUnit :: Maybe UPath -> Exec ExecUnit
newExecUnit modName = get >>= \parent -> liftIO _initExecUnit >>= \child -> return $
  child
  { programModuleName = modName
  , builtinConstants  = builtinConstants  parent
  , defaultTimeout    = defaultTimeout    parent
  , globalMethodTable = globalMethodTable parent
  , runtimeRefTable   = runtimeRefTable   parent
  }

-- | Execute an 'Exec' monadic function within a different 'ExecUnit' module. The result of the
-- 'Exec' monadic function is the first value in the tuple returned, any modifications to the given
-- 'ExecUnit' module are stored as the second value of the tuple returned.
inModule :: ExecUnit -> Exec a -> Exec (a, ExecUnit)
inModule subxunit exe = do
  xunit    <- get
  result   <- put subxunit >> catchPredicate exe
  subxunit <- get
  put    xunit
  result   <- predicate result
  return (result, subxunit)

----------------------------------------------------------------------------------------------------

-- | A 'Task' is simply a group of threads executing in parallel, but evaluating a task is still
-- synchronous, i.e. evaluating 'taskLoop' on a 'Task' will block until every thread in the task has
-- completed.
data Task
  = Task
    { taskWaitChan       :: Chan (ThreadId, Int)
    , taskRunningThreads :: MVar (S.Set ThreadId)
    }

-- | Create a new 'Task'.
initTask :: IO Task
initTask = do
  wait    <- newChan
  running <- newMVar S.empty
  return $ Task{ taskWaitChan=wait, taskRunningThreads=running }

-- | To halt a single thread in a 'Task', simply signal it with 'Control.Concurrent.killThread'. But
-- to halt everything the task is doing, use this function. Use of this function will never result in
-- deadlocks (I hope).
throwToTask :: Exception e => Task -> e -> IO ()
throwToTask task e = do
  let mvar = taskRunningThreads task
  ((S.elems <$> readMVar mvar) >>= mapM_ (flip throwTo e))
    `finally` getChanContents (taskWaitChan task) >> return ()

-- | Like 'throwToTask', but throws 'Control.Exception.ThreadKilled'.
killTask :: Task -> IO ()
killTask = flip throwToTask ThreadKilled

-- | This is a better way to manage a 'Task' because all tasks evaluated are waited for
-- synchronously, but you can provide a callback that is evaluated after each task completes. This
-- prevents exceptions from occurring, for example:
-- > "thread blocked indefinitely in an MVar operation"
-- 
-- Provide a list of IO functions to be evaluated in parallel. Also provide a callback function
-- that will be evaluated after each thread completes. This function should take two parameters and
-- return a bool: the 'Control.Concurrent.ThreadId' of the thread that completed and a positive
-- integer value indicating the number of threads that are still running, and the bool returned
-- should indicate whether or not the loop should continue. If you should halt the loop by returning
-- 'Prelude.False', the threads in the task that are still running will continue running, and you
-- should call 'killTask' after 'taskLoop' to halt them if halting them should be necessary.
-- 
-- This function is also exception safe. All tasks evaluated in parallel will not fail to singal the
-- callback, even if the thread halts with an exception or asynchronous signal from a function like
-- 'Control.Concurrent.killThread'. If the thread evaluating this function is halted by an
-- exception, all threads in the 'Task' are also killed.
taskLoop :: Task -> [IO ()] -> (ThreadId -> Int -> IO Bool) -> IO ()
taskLoop task parallelIO threadHaltedEvent = unless (null parallelIO) $
  (do mapM_ (forkInTask task) parallelIO
      fix $ \loop -> waitFirst task >>= \ (thread, remain) ->
        threadHaltedEvent thread remain >>= \contin -> unless (not contin || remain==0) loop
  ) `onException` killTask task
  where
    waitFirst :: Task -> IO (ThreadId, Int)
    waitFirst task = readChan (taskWaitChan task)
    forkInTask :: Task -> IO () -> IO ThreadId
    forkInTask task run = forkIO $ do
      self <- myThreadId
      bracket
        (modifyMVar (taskRunningThreads task) $ \s' -> do
            let s = S.delete self s'
            return (s, S.size s)
        )
        (\i -> writeChan (taskWaitChan task) (self, i))
        (\ _i -> run)

-- | Works exactly like 'taskLoop', except you do not need to provide a callback function to be
-- evaluated after every task completes. Essentially, every IO function is evaluated in the 'Task'
-- in parallel, and this function blocks until all tasks have completed.
taskLoop_ :: Task -> [IO ()] -> IO ()
taskLoop_ task inits = taskLoop task inits (\ _ _ -> return True)

----------------------------------------------------------------------------------------------------

-- | This simple, humble little class is one of the most important in the Dao program because it
-- defines the 'execute' function. Any data type that can result in procedural execution in the
-- 'Exec' monad can instantiate this class. This will allow the instnatiated data type to be used as
-- a kind of executable code that can be passed around and evaluated at arbitrary points in your Dao
-- program.
-- 
-- Note that there the @result@ type parameter is functionally dependent on the @exec@ type
-- parameter. This guarantees there is a one-to-one mapping from independent @exec@ types to
-- dependent @result@ types, i.e. if you data type @MyDat@ maps to a data type @Rzlt@, then @Rzlt@
-- is the only possible data type that could ever be evaluated by 'execute'-ing the @MyDat@
-- function.
--
-- As a reminder, functional dependencies do not necessitate a one-to-one mapping from the
-- dependent type to the independent type, so the @result@ parameter may be the same for many
-- different @exec@ types. But once the compiler infers that the @exec@ parameter of the 'Executable'
-- class is @MyDat@, the @result@ type /must/ be @Rzlt@ and nothing else.
-- > instance Executable MyDat Rzlt
-- > instance Executable A     () -- OK (different @exec@ parameters, same @result@ parameters)
-- > instance Executable B     () -- OK
-- > instance Executable C     () -- OK
-- > 
-- > instance Executable D     ()   -- COMPILER ERROR (same @exec@ parameters, different @result@ parameters)
-- > instance Executable D     Int  -- COMPILER ERROR
-- > instance Executable D     Char -- COMPILER ERROR
-- In this example, should D instantiate () or Int or Char as it's result? You must choose only one.
class Executable exec result | exec -> result where { execute :: exec -> Exec result }

----------------------------------------------------------------------------------------------------

-- | Since the 'ExecUnit' deals with a few different kinds of pointer values, namely
-- 'Data.IORef.IORef' and 'MVar', which all have similar functions for reading and updating, I have
-- defined this class to provide a consistent set of functions for working with the various pointers
-- data types.
class ExecRef var where
  execReadRef    :: var a -> Exec a
  execTakeRef    :: var a -> Exec a
  execPutRef     :: var a -> a -> Exec ()
  execSwapRef    :: var a -> a -> Exec a
  execModifyRef  :: var a -> (a -> Exec (a, b)) -> Exec b
  execModifyRef_ :: var a -> (a -> Exec  a    ) -> Exec ()
  execModifyRef_ var upd = execModifyRef var (\a -> upd a >>= \a -> return (a, ()))

instance ExecRef MVar where
  execModifyRef mvar upd =
    Exec $ PredicateT $ StateT $ \xunit -> modifyMVar mvar $ \var -> do
      (result, xunit) <- flip ioExec xunit $ execCatchIO (upd var) $
        [ newExecIOHandler $ flip (execThrow "") [] . ExecHaskellError
        , newExecIOHandler $ flip (execThrow "") [] . ExecIOException
        ]
      let x var p = return (var, (p, xunit))
      case result of
        Backtrack   -> x var $ Backtrack
        OK (var, o) -> x var $ OK      o
        PFail   err -> x var $ PFail err
  execModifyRef_ mvar upd = execModifyRef mvar (\var -> upd var >>= \var -> return (var, ()))
  execReadRef      = liftIO . readMVar
  execTakeRef      = liftIO . takeMVar
  execPutRef  mvar = liftIO . putMVar  mvar
  execSwapRef mvar = liftIO . swapMVar mvar

instance ExecRef IORef where
  execModifyRef  ref upd = liftIO (readIORef ref) >>= upd >>= \ (var, b) -> liftIO (writeIORef ref var) >> return b
  execModifyRef_ ref upd = liftIO (readIORef ref) >>= upd >>= liftIO . writeIORef ref
  execReadRef            = liftIO . readIORef
  execTakeRef            = execReadRef
  execPutRef     ref     = liftIO . writeIORef ref
  execSwapRef    ref obj = liftIO (readIORef ref >>= \sw -> writeIORef ref obj >> return sw)

----------------------------------------------------------------------------------------------------

data ObjFocusState o
  = ObjFocusState
    { targetReference      :: Reference
      -- ^ the whole reference we intend to use
    , focalReference       :: Reference
      -- ^ the reference that is constructed piecewise as each part of the 'targetReference' is resolved.
    , objectInFocus        :: o
    , objectInFocusChanged :: Bool
      -- ^ this value is automatically set whenever the 'Control.Monad.State.put' function, or
      -- 'Control.Monad.State.modify' functions are evaluated. This value is returned by functions
      -- like 'withInnerFocus' and 'runObjectFocus' to indicate when the item being modified was
      -- actually modified.
    , focusLookup          :: Bool
      -- ^ when true, indicates that the current focus operation is a lookup. Lookups are different
      -- from updates in that an update can continue recursive searching through an object tree even
      -- if the reference to be updated is void. Assignment operations, for example, update void
      -- references by writing to the reference. Lookup operations, on the other hand, will always
      -- fail as soon as a void is encountered.
    }

-- Although the 'ObjectFocus' monad is a wrapper around a 'Dao.Predicate.PredicateT' monad
-- transformer that lifts the 'Exec' monad, backtracking (the instantiation  of
-- 'Control.Monad.mzero') has a very different semantical meaning from the 'Exec' monad's semantical
-- meaning of backtracking. In the case of 'ObjectFocus', evaluating 'Control.Monad.mzero' indicates
-- a refernece being looked-up is undefined. To allow for 'Exec' to be lifted into 'ObjectFocus' and
-- also possibly evaluate to 'Control.Monad.mzero' without triggering a backtracking in the
-- 'ObjectFocus' monad, backtracking in the 'Exec' monad needs to be "caught" and re-thrown as an
-- error using 'Control.Monad.Error.throwError' wrapped up in the 'ObjFocusError' data type. However
-- this is all done "under the hood," the public API of the 'ObjectFocus' monad still has
-- 'Control.Monad.Error.throwError' instantiated to throw 'ExecControl' just like the 'Exec' monad:
-- > 'Control.Monad.Error.Class.MonadError' 'ExecControl' 'ObjectFocus'
-- and when evaluting the 'ObjectFocus' monad in the 'Exec' monad using 'runObjectFocus', this
-- error type is automatically caught again and converted back to 'Control.Monad.mzero', initiating
-- ordinary backtracking in the 'Exec' monad.
data ObjFocusError
  = InnerExecBacktrack -- ^ a lifted 'Exec' monad evaluated to 'Control.Monad.mzero'
  | InnerExecPFail ExecControl
    -- ^ a lifted 'Exec' monad evaluated to 'Control.Monad.Error.throwError'

-- | This is the stateful monad used by the 'ObjectLens' and 'ObjectFunctor' classes. It is called a
-- "focus" because the object we are focused on (on which we are looking up indicies or modifying
-- indicies) is stored in the state of the monad. The 'Control.Monad.State.modify' function modifies
-- the object in the focus.
newtype ObjectFocus o a
  = ObjectFocus{ mapObjectLensToPredicate :: PredicateT ObjFocusError (StateT (ObjFocusState o) Exec) a }
  deriving (Functor, Applicative, Alternative, MonadPlus)

instance Monad (ObjectFocus o) where
  return = ObjectFocus . return
  (ObjectFocus m) >>= f = ObjectFocus $ m >>= mapObjectLensToPredicate . f
  fail msg = _mapStructState (gets focalReference) >>= flip (execThrow msg) []

instance MonadError ExecControl (ObjectFocus o) where
  throwError = ObjectFocus . throwError . InnerExecPFail
  catchError (ObjectFocus f) catch = ObjectFocus $ catchError f $ \err -> case err of
    InnerExecPFail err -> mapObjectLensToPredicate (catch err)
    InnerExecBacktrack -> throwError InnerExecBacktrack

instance MonadPlusError ExecControl (ObjectFocus o) where
  catchPredicate (ObjectFocus f) = ObjectFocus $ catchPredicate f >>= \p -> case p of
    OK                    o  -> return $ OK o
    PFail (InnerExecPFail e) -> return $ PFail e
    PFail InnerExecBacktrack -> throwError InnerExecBacktrack
    Backtrack                -> return Backtrack
  predicate = ObjectFocus . predicate . fmapPFail InnerExecPFail

instance MonadIO (ObjectFocus o) where { liftIO = ObjectFocus . liftIO }

instance MonadState o (ObjectFocus o) where
  get   = _mapStructState $ gets objectInFocus
  put o = _mapStructState $ modify $ \st -> st{objectInFocus=o, objectInFocusChanged=True}

-- | An 'ObjectFocus' function that updates a value within the data of type @o@ in focus at a given
-- @index@ using an inner 'ObjectFocus' function that focuses on the 'Object' value at the index if
-- it exists. The type of the inner 'ObjectFocus' is @('Prelude.Maybe' 'Object')@ because there may
-- be no value defined at the given index.
type ObjectUpdate o index = index -> ObjectFocus (Maybe Object) (Maybe Object) -> ObjectFocus o (Maybe Object)

-- | An 'ObjectFocus' that traverses the 'Object' in the focus by calling the provided traversal
-- function for every @index -> 'Object'@ relation defined within the data of type @o@. The
-- traversal function is an inner focus of type @[(index, 'Object')]@. The list in focus should
-- initially be empty when the inner traversal function is called. When the inner traversal function
-- is completed, it should contain every @(index, 'Object')@ that is intended to be stored back into
-- the data of type @o@. The outer 'ObjectFocus' should retrieve this list of pairs and determine
-- how to update the data of type @o@ accordingly.
type ObjectTraverse o index = (index -> Object -> ObjectFocus [(index, Object)] ()) -> ObjectFocus o ()

-- | This class provides functions that can be used to establish 'ObjectFocus' for various data
-- types. The class allows you to define an association between an index and and object type o, and
-- how the index is used to read and update the object o.
-- There are no functional dependencies between the object type and the index type, so using these
-- function may require type annotation.
class ObjectLens o index where { updateIndex :: ObjectUpdate o index }

-- | This class provides the 'objectFMap' function for evaluating a functor over every item in an
-- 'bject in the focus of an 'ObjectFocus'. The function that maps to the functor object takes a
-- polymorphic index type and the 'Object' associated with that index. For example, in the case of a
-- 'T_dict' type, the index would be a 'Dao.String.Name', in the case of a 'T_list' type, the index
-- would be a 'Prelude.Integer'.
class ObjectFunctor o index where { objectFMap :: ObjectTraverse o index }

_mapStructState :: StateT (ObjFocusState o) Exec a -> ObjectFocus o a
_mapStructState = ObjectFocus . lift

_getTargetRefInfo :: ObjectFocus o Reference
_getTargetRefInfo = _mapStructState $ gets targetReference

_setTargetRefInfo :: Reference -> ObjectFocus o ()
_setTargetRefInfo qref = _mapStructState $ modify $ \st -> st{targetReference=qref}

-- | This function will check if the 'focusLookup' boolean is set. If it is set, it checks if the
-- current 'objectInFocus' is 'Prelude.Nothing' and backtracks if it is. Otherwise it evaluates the
-- given function.
focusNext :: ObjectFocus (Maybe o) a -> ObjectFocus (Maybe o) a
focusNext f = do
  isLookup <- _mapStructState (gets focusLookup)
  if isLookup then get >>= maybe mzero (const f) else f

-- | When instantiating the 'ObjectLens' class with a 'RefSuffix' index type, it is useful to
-- record the head of the 'RefSuffix' that is being used to resolve the index. When an
-- 'Control.Monad.fail' is evaluated, the current path (the 'RefSuffix') to the part of the object
-- where the failure occurred will be used in the error report. Bracketing your 'ObjectFocus'
-- evaluation in this function will help create better error reports.
focalPathSuffix :: RefSuffix -> ObjectFocus o a -> ObjectFocus o a
focalPathSuffix suf f = do
  r <- _mapStructState $ get >>= \st -> do
    let r = focalReference st
    put (st{ focalReference=refAppendSuffix r suf }) >> return r
  f >>= \a -> _mapStructState (modify $ \st -> st{ focalReference=r }) >> return a

focusLiftExec :: Exec a -> ObjectFocus o a
focusLiftExec exec = ObjectFocus $ do
  p <- lift $ lift $ catchPredicate exec
  case p of
    Backtrack -> throwError InnerExecBacktrack
    PFail err -> throwError $ InnerExecPFail err
    OK    o   -> return o

execToFocusUpdater :: (Maybe Object -> Exec (Maybe Object)) -> ObjectFocus (Maybe Object) (Maybe Object)
execToFocusUpdater f = get >>= focusLiftExec . f >>= \o -> put o >> return o

getFocalReference :: ObjectFocus o Reference
getFocalReference = _mapStructState (gets focalReference)

-- | This is a kind of entry-point to the 'ObjectFocus' group of functions. First provide a boolean
-- value indicating whether this operation is a ('Prelude.True') lookup and should fail as soon as a
-- void address is encountered, or ('Prelude.False') an update that may insert a value at a void
-- address rather than failing. Second, provide a 'Reference' value for error reporting, to indicate
-- where a 'lookupIndex' or 'updateIndex' function failed. Note that using 'lookupIndex' and
-- 'updateIndex' functions instantiated for 'RefSuffix' indicies will append these indicies to the
-- 'Reference', so it might be better to pass the 'referenceHead' of the 'Reference'. Then supply an
-- object upon which the 'lookupIndex', 'updateIndex', or 'objectFMap' functions will be evaluating.
runObjectFocus :: ObjectFocus o a -> Bool -> Reference -> o -> Exec (a, (Reference, Bool, o))
runObjectFocus f isLookup qref o = _runObjectFocus f st >>= \p -> case p of
  OK                    o  -> return o
  PFail (InnerExecPFail e) -> throwError e
  PFail InnerExecBacktrack -> mzero
  Backtrack                -> execThrow "undefined reference" qref []
  where
    st= ObjFocusState
        { targetReference      = qref
        , focalReference       = fst (referenceHead qref)
        , objectInFocus        = o
        , objectInFocusChanged = False
        , focusLookup          = isLookup
        }

_runObjectFocus :: ObjectFocus o a -> ObjFocusState o -> Exec (Predicate ObjFocusError (a, (Reference, Bool, o)))
_runObjectFocus (ObjectFocus f) st = flip evalStateT st $ runPredicateT $ f >>= \a -> do
  o <- lift $ return (,,) <*> gets targetReference <*> gets objectInFocusChanged <*> gets objectInFocus
  return (a, o)

-- | This is a very important function because it allows you to evaluate an inner 'ObjectFocus'
-- monad that is focused on a different type from the type focus of the monad in the context in
-- which this function is evaluated. It allows you to select a sub-field of the current focus (for
-- example using 'Control.Monad.State.gets') and evaluate an updating function or lookup function
-- that uses value of the sub-field. This function returns the result of the evaluation, and the
-- updated value which can then be placed back into the sub-field if necessary. By composing
-- 'withInnerLens' functions, it is possible to construct a lens that can read and update any value
-- in arbitrarily complex data types.
withInnerLens :: sub -> ObjectFocus sub a -> ObjectFocus o (a, (Bool, sub))
withInnerLens sub f = do
  st <- _mapStructState get
  o  <- focusLiftExec $ _runObjectFocus f $ st{objectInFocus=sub}
  ObjectFocus $ predicate $ o >>= \ (a, (_ref, changed, o)) -> return (a, (changed, o))

-- Used in the 'Interface' table to convert between a @typ@ and 'Data.Dynamic.Dynamic' value.
convertFocus :: (a -> b) -> (b -> a) -> ObjectFocus a x -> ObjectFocus b x
convertFocus a2b b2a f = get >>= flip withInnerLens f . b2a >>= \ (x, (changed, a)) ->
  when changed (put $ a2b a) >> return x

focusObjectClass :: ObjectClass o => ObjectFocus o a -> ObjectFocus Object a
focusObjectClass f = do
  (a, (changed, o)) <- get >>= xmaybe . fromObj >>= flip withInnerLens f
  when changed (put $ obj o) >> return a

instance ObjectLens T_dict Name where
  updateIndex name f = do
    (result, (changed, o)) <- get >>= flip withInnerLens (focusNext f) . (M.lookup name)
    when changed (modify $ M.alter (const o) name)
    return result

instance ObjectFunctor T_dict Name where
  objectFMap f = get >>=
     mapM (\ (name, o) -> focalPathSuffix (DotRef name NullRef) $ withInnerLens [] $ f name o
          ) . M.assocs >>= put . M.fromList . concatMap (snd . snd)

focusGuardStructName :: Name -> ObjectFocus T_struct ()
focusGuardStructName name = get >>= guard . (==name) . structName

focusStructAsDict :: ObjectFocus T_dict a -> ObjectFocus T_struct a
focusStructAsDict f = get >>= \struct -> case struct of
  Nullary{ structName=name } -> do
    (a, (changed, sub)) <- withInnerLens M.empty f
    if M.null sub
    then return ()
    else when changed (put $ Struct{ structName=name, fieldMap=sub })
    return a
  Struct{ structName=name, fieldMap=sub } -> do
    (a, (changed, sub)) <- withInnerLens sub f
    when changed $ do
      if M.null sub
      then put (Nullary{ structName=name })
      else put (struct{ fieldMap=sub })
    return a

instance ObjectLens T_struct Name where
  updateIndex name f = focusStructAsDict $ updateIndex name f

instance ObjectFunctor T_struct Name where
  objectFMap f = focusStructAsDict $ objectFMap f

updateHataAsStruct :: ObjectFocus T_struct a -> ObjectFocus Hata a
updateHataAsStruct f = do
  (Hata ifc o) <- get
  (fromStruct, toStruct) <- xmaybe (return (,) <*> objFromStruct ifc <*> objToStruct ifc)
    -- here ^ evaluation backtracks if the field cannot be accessed
  struct <- predicate $ fromData toStruct o
  (a, (changed, struct)) <- withInnerLens struct f
  when changed (predicate (toData fromStruct struct) >>= put . Hata ifc)
  return a

lookupHataAsStruct :: ObjectFocus T_struct a -> ObjectFocus Hata a
lookupHataAsStruct f = do
  (Hata ifc o) <- get
  toStruct <- xmaybe (objToStruct ifc)
  struct <- predicate $ fromData toStruct o
  fst <$> withInnerLens struct f

instance ObjectLens Hata Name where
  updateIndex name f = updateHataAsStruct $ updateIndex name f

instance ObjectFunctor Hata Name where
  objectFMap = flip mplus (return ()) . updateHataAsStruct . focusStructAsDict . objectFMap

instance ObjectLens [Object] Integer where
  updateIndex idx f = get >>= \ox ->
    if idx == negate 1
    then do
      (result, (changed, o)) <- withInnerLens Nothing f
      when changed (put $ maybe ox (:ox) o)
      return result
    else do
      let splitlen i rx ox = case ox of
            []   -> (i, rx, [])
            o:ox -> if i<idx then splitlen (i+1) (rx++[o]) ox else (i, rx, o:ox)
      let (len, lo, hi) = splitlen 0 [] ox
      if 0<=idx && idx<=len
      then
        if null hi
        then do
          (result, (changed, o)) <- withInnerLens Nothing f
          when changed (put $ maybe ox ((ox++) . return) o)
          return result
        else do
          (result, (changed, o)) <- withInnerLens (Just $ head hi) f
          when changed (put $ lo ++ maybe [] return o ++ tail hi)
          return result
      else execThrow "index ouf of bounds" ExecErrorUntyped [(assertFailed, OLong idx)]

instance ObjectFunctor [Object] Integer where
  objectFMap f = get >>=
     mapM (\ (idx, o) -> focalPathSuffix (Subscript [obj idx] NullRef) $ withInnerLens [] $ f idx o
          ) . zip [0..] >>= put . map snd . sortBy (\a b -> compare (fst a) (fst b)) . concatMap (snd . snd)

_dictSubscriptUpdate
  :: ObjectLens o Name
  => String -> [Object]
  -> ObjectFocus (Maybe Object) (Maybe Object)
  -> ObjectFocus o (Maybe Object)
_dictSubscriptUpdate msg ix f = focusLiftExec (mapM derefObject ix) >>= \ix -> case ix of
  []  -> fail $ "void subscript used to index "++msg
  [ORef (Reference UNQUAL name suf)] -> updateIndex name $ updateIndex suf f
  [_] -> fail $ "non-reference subscript used to update index of "++msg
  _   -> fail $ "multi-dimensional subscript used to update index of "++msg

-- Converts the function @f@ that is passed to an 'objectFMap' which takes an index value of type
-- @i@ to a value suitable for invoking an 'objectFMap' function instantiated for a different type
-- @fi@.
objectFMapConvert
  :: (i -> ObjectFocus [(fi, Object)] fi) -> (fi -> ObjectFocus [(i, Object)] i)
  -> (fi -> Object -> ObjectFocus [(fi, Object)] ())
  -> i -> Object
  -> ObjectFocus [(i, Object)] ()
objectFMapConvert i2fi fi2i f i o = getFocalReference >>= \qref -> do
  (_, (_, changed, o)) <- focusLiftExec (runObjectFocus (i2fi i >>= flip f o) False qref [])
  o <- forM o (\ (fi, o) -> fi2i fi >>= \i -> return (i, o))
  _mapStructState $ modify $ \st -> st{objectInFocusChanged=changed, objectInFocus=o}

_dictSubscriptFMap
  :: ObjectFunctor o Name
  => String -> ([Object] -> Object -> ObjectFocus [([Object], Object)] ()) -> ObjectFocus o ()
_dictSubscriptFMap msg f = objectFMap $ objectFMapConvert i2fi fi2i f where
  i2fi :: Name -> ObjectFocus [([Object], Object)] [Object]
  i2fi name = return [ORef $ Reference UNQUAL name NullRef]
  fi2i :: [Object] -> ObjectFocus [(Name, Object)] Name
  fi2i ix = focusLiftExec (mapM derefObject ix) >>= \ix -> case ix of
    [ORef (Reference UNQUAL name NullRef)] -> return name
    _ -> fail $ "improper index value used to update field while traversing "++msg

_index1DIntegral :: Show a => String -> String -> [Object] -> (Integer -> ObjectFocus o a) -> ObjectFocus o a
_index1DIntegral msg1 msg2 ix f = focusLiftExec (mapM derefObject ix) >>= \ix -> case ix of
  []  -> fail $ "void subscript used to "++msg1++" list"++msg2
  [i] -> case extractXPure (castToCoreType LongType i) >>= fromObj of
    Nothing -> fail $ "non-integer subscript used to "++msg1++" list"++msg2
    Just  i -> f i
  _   -> fail $ "multi-dimensional subscript used to "++msg1++" list"++msg2

instance ObjectLens [Object] [Object] where
  updateIndex ix f = _index1DIntegral "update" "" ix $ flip updateIndex f

instance ObjectFunctor [Object] [Object] where
  objectFMap = objectFMap .
    objectFMapConvert (\i -> return [OLong i]) (\ix -> _index1DIntegral "traverse" "" ix return)

instance ObjectLens T_dict [Object] where
  updateIndex = _dictSubscriptUpdate "dictionary"

instance ObjectFunctor T_dict [Object] where
  objectFMap = _dictSubscriptFMap   "dictionary"

instance ObjectLens T_struct [Object] where
  updateIndex = _dictSubscriptUpdate "struct"

instance ObjectFunctor T_struct [Object] where
  objectFMap = _dictSubscriptFMap "struct"

_hataUpdateSubscript
  :: (String -> ObjectFocus T_struct (Maybe Object))
  -> ObjectFocus Hata (Maybe Object)
_hataUpdateSubscript f = do
  (Hata ifc _) <- get
  updateHataAsStruct (f $ show $ objHaskellType ifc) <|> fail "cannot update field"

_hataLookupSubscript :: (String -> ObjectFocus T_struct Object) -> ObjectFocus Hata Object
_hataLookupSubscript f = do
  (Hata ifc _) <- get
  lookupHataAsStruct $ f $ show $ objHaskellType ifc

instance ObjectLens Hata [Object] where
  updateIndex ix f = get >>= \ (Hata ifc o) -> case objIndexUpdater ifc of
    Nothing     -> _hataUpdateSubscript $ \msg -> _dictSubscriptUpdate msg ix f
    Just update -> do
      (result, (changed, o)) <- withInnerLens o $ update ix f
      when changed (put $ Hata ifc o) >> return result

instance ObjectFunctor Hata [Object] where
  objectFMap f = get >>= \ (Hata ifc o) -> case objTraverse ifc of
    Nothing       -> updateHataAsStruct (_dictSubscriptFMap (show $ objHaskellType ifc) f) <|>
      fail "cannot update field"
    Just traverse -> do
      ((), (changed, o)) <- withInnerLens o (traverse f)
      when changed (put $ Hata ifc o)

_tryFuncCall
  :: Maybe Object -> [Object] -> RefSuffix
  -> ObjectFocus (Maybe Object) (Maybe Object)
  -> ObjectFocus (Maybe Object) (Maybe Object)
  -> ObjectFocus (Maybe Object) (Maybe Object)
_tryFuncCall func args suf f els = maybe els id $ do
  (Hata ifc d) <- func >>= fromObj
  calls <- objCallable ifc
  return $ do
    -- Get the result of the function call, the result of the operation will become the focus.
    this <- get
    (result, this) <- focusLiftExec (calls d >>= flip (callCallables this) args)
    put this
    -- Focus on the result of the function call and evaluate an update on it.
    -- The updated function result is ignored, any changes made to it are lost.
    (result, _) <- case suf of
      NullRef -> withInnerLens result f
      _       -> withInnerLens result (updateIndex suf f)
    -- The function call may have updated the "this" value, place this updated value back into the focus.
    return result

_refSuffixUpdate
  :: (ObjectClass o, ObjectLens o i)
  => o -> i -> RefSuffix
  -> ObjectFocus (Maybe Object) (Maybe Object)
  -> ObjectFocus (Maybe Object) (Maybe Object)
_refSuffixUpdate o i suf f = do
  (result, (changed, o)) <- withInnerLens o $ updateIndex i $ updateIndex suf f
  when changed (put $ Just $ obj o) >> return result

-- | This is an 'ObjectUpdate' function which operates in the monad
-- > 'ObjectFocus' (Maybe 'Object') (Maybe 'Object')
-- If the object in the focus is an object constructed with 'ODict', 'OTree', or 'OHaskell', then
-- the 'Name' parameter passed to this function is used to lookup a function stored in the object in
-- focus. This function sets the object in focus to the "this" variable in the Dao runtime and then
-- calls the function with the given @['Object']@ arguments. The object in focus is updated by the
-- function call and the result of the function call is placed in the focus and updated by the next
-- update function with the next 'RefSuffix' provided (as the arguments to the 'ObjectUpdate'). This
-- is the semantics for Dao language expressions of the kind:
-- a.b(c).d(e)
-- that is, an objet stored in the variable "a" has a method "b" called with a parameter "(c)" and
-- the result of this call is an object with a method "d" that is called with the parameter "(e)".
-- Of course if the 'RefSuffix' is 'NullRef', the result of the method call is simply returned.  The
-- result of "a.b(c)" is stored on the stack and used to select and evaluate the method "d(e)",
-- however if "d(e)" modified the value on the stack, this modified value is lost when it is popped
-- off of the stack after evaluation completes. There is currently no way to update objects in this
-- way, as the Dao runtime does not have a way to update arbitrary points in it's working memory.
-- This will hopefully be improved in future versions.
callMethod :: Name -> [Object] -> ObjectUpdate (Maybe Object) RefSuffix
callMethod name args suf f = do
  qref <- _getTargetRefInfo
  let err msg = execThrow msg qref []
  o <- get
  case o of
    Nothing -> err "method call on undefined reference"
    Just  o -> case o of
      ODict    d -> _tryFuncCall (M.lookup     name d) args suf f (_refSuffixUpdate d name suf f)
      OTree    d -> _tryFuncCall (structLookup name d) args suf f (_refSuffixUpdate d name suf f)
      OHaskell (Hata ifc d) -> case M.lookup name (objMethodTable ifc) of
        Just func -> do
          (result, d) <- focusLiftExec $ executeDaoFunc func d args
          put (Just $ OHaskell $ Hata ifc d)
          -- Next we take the result of this method call and let any 'RefSuffix's that may exist to
          -- operate on it. Like _tryFuncCall, this will ignore changes made to the result of the
          -- function call.
          (result, _) <- case suf of
            NullRef -> withInnerLens result f
            _       -> withInnerLens result (updateIndex suf f)
          return result
        Nothing   -> case objToStruct ifc of
          Just toStruct -> do
            struct <- predicate (fromData toStruct d)
            _tryFuncCall (structLookup name struct) args suf f (_refSuffixUpdate (Hata ifc d) name suf f)
          Nothing       -> err "not a callable method function"
      _ -> err "method call on atomic object"
            -- TODO: provide a set of built-in methods available to every object.

instance ObjectLens (Maybe Object) RefSuffix where
  updateIndex suf f = _getTargetRefInfo >>= \qref -> focalPathSuffix suf $ get >>= \o -> case suf of
    NullRef         -> focusNext $ get >>= flip withInnerLens f >>= \ (result, (changed, o)) ->
      when changed (put o) >> return result
    DotRef name (FuncCall args suf) -> focusNext $ callMethod name args suf f
    DotRef name suf -> case o of
      Nothing -> mzero
      Just  o -> case o of
        ODict    o -> _refSuffixUpdate o name suf f
        OTree    o -> _refSuffixUpdate o name suf f
        OHaskell o -> _refSuffixUpdate o name suf f
        _          -> throwBadTypeError "referenced element of non-container object" o []
    Subscript ix suf -> focusNext $ case o of
      Nothing -> mzero
      Just  o -> case o of
        OList    o -> _refSuffixUpdate o ix suf f
        ODict    o -> _refSuffixUpdate o ix suf f
        OTree    o -> _refSuffixUpdate o ix suf f
        OHaskell o -> _refSuffixUpdate o ix suf f
        _          -> throwBadTypeError "cannot subscript of non-indexed object" o []
    FuncCall  args suf -> focusNext $ case o of
      Nothing -> mzero
      Just  o -> do
        (result, o) <- focusLiftExec (callObject qref o args)
        _mapStructState $ modify $ \st -> st{ objectInFocus=o }
        -- -^ Here we put the updated function back (it may have had it's static var table updated),
        -- but we use '_mapStructState' to do it. This is because using 'modify' or 'put' will
        -- automatically set the 'objectInFocusChanged' flag. Since many functions 'CONST' and we
        -- would like to update the function's static table without modifying the function itself
        -- without also triggering the exception thrown when a const variable is modified, we must
        -- make sure we update it in a way that would not indicate that the function object itself
        -- has been modified.
        (result, _) <- case suf of
          NullRef -> withInnerLens result f
          suf     -> withInnerLens result (updateIndex suf f)
        return result

instance ObjectFunctor Object RefSuffix where
  objectFMap f = get >>= \o -> case o of
    OList    o -> travers o int2subs subs2int OList
    ODict    o -> travers o ref2subs subs2ref ODict
    OTree    o -> travers o ref2subs subs2ref OTree
    OHaskell o -> travers o ref2subs subs2ref OHaskell
    _          -> return ()
    where
      int2subs i = return $ Subscript [OLong i] NullRef
      subs2int i = case i of
        Subscript [o] NullRef -> case extractXPure (castToCoreType LongType o) >>= fromObj of
          Nothing -> fail "while traversing list, updating function returned non-integer index value"
          Just  i -> return i
        _ -> fail "while traversing list, updating function returned non-subscript reference as index"
      ref2subs i = return $ DotRef i NullRef
      subs2ref i = case i of
        DotRef name NullRef -> return name
        _ -> fail "while traversing structure, updating function returned invalid reference"
      travers o to from constr = do
        (_, (changed, o)) <- withInnerLens o (objectFMap $ objectFMapConvert to from f)
        when changed (put $ constr o)

instance ObjectFunctor (Maybe Object) RefSuffix where
  objectFMap f = get >>= maybe (return ()) (fmap fst . flip withInnerLens (objectFMap f))

-- | If you have a data type @o@ instantiating @'ObjectLens' o index@ with a given index type, and
-- this data type @o@ is a field of another @data@ type, you can instantiate 'updateIndex' for this
-- data type by providing functions to unwrap and wrap the data type @o@ inside of it. For
-- @newtype@s, the wrapper function can be given as @('Prelude.const' MyNewtype)@ where
-- @MyNewtype@ is the newtype constructor.
innerDataUpdateIndex
  :: (Show o, ObjectLens o index)
  => (dt -> o) -> (dt -> o -> dt)
  -> index -> ObjectFocus (Maybe Object) (Maybe Object) -> ObjectFocus dt (Maybe Object)
innerDataUpdateIndex unwrap wrap i upd = get >>= \dt -> do
  (result, (changed, o)) <- withInnerLens (unwrap dt) (updateIndex i upd)
  when changed (modify $ flip wrap o) >> return result

----------------------------------------------------------------------------------------------------

instance ObjectLens (Stack Name Object) Name where
  updateIndex name upd = do
    ((result, changed), stack) <- get >>=
      stackUpdateM (flip withInnerLens upd >=> \ (result, (changed, o)) -> return ((result, changed), o)) name
    when changed (put stack) >> return result

-- | This function can be used to automatically instantiate 'updateIndex' for any type @o@ that also
-- instantiates @'ObjectLens' o 'Dao.String.Name'@.
referenceUpdateName :: ObjectLens o Name => Reference -> ObjectFocus (Maybe Object) (Maybe Object) -> ObjectFocus o (Maybe Object)
referenceUpdateName qref f = case qref of
  Reference _ name suf -> updateIndex name $ updateIndex suf f
  RefObject o suf -> case o of
    ORef o -> referenceUpdateName (refAppendSuffix o suf) f
    _      -> fail "cannot update reference"
  RefWrapper _ -> fail "cannot update reference"

-- | This function can be used to automatically instantiate 'lookupIndex' for any type @o@ that also
-- instantiates @'ObjectLens' o 'Dao.String.Name'@. This function may also performs updates on variables
-- in place if the variable contains an object and the reference is a method call which updates the
-- object.
referenceLookupName :: ObjectLens o Name => Reference -> ObjectFocus o Object
referenceLookupName qref = case qref of
  Reference _ name suf -> updateIndex name get >>=
    fmap fst . flip withInnerLens (updateIndex suf get) >>= maybe (execThrow "" qref []) return
  RefObject o      suf -> case o of
    ORef o -> referenceLookupName (refAppendSuffix o suf)
    _      -> fail "cannot update reference"
  RefWrapper _ -> fail "cannot update reference"

instance ObjectLens (Stack Name Object) Reference where { updateIndex = referenceUpdateName }

----------------------------------------------------------------------------------------------------

updateLocal :: Name -> RefSuffix -> ObjectFocus (Maybe Object) (Maybe Object) -> ObjectFocus () (Reference, Maybe Object)
updateLocal name suf f = do
  stack <- focusLiftExec (gets execStack)
  (result, (changed, o)) <- withInnerLens (stackLookup name stack) (updateIndex suf f)
  -- The updateIndex function may have performed a function call that updated the local stack so we
  -- need to get the (possibly) updated stack from the 'ExecUnit' once again and operate on that.
  when changed $ focusLiftExec (gets execStack) >>= \stack -> focusLiftExec $ modify $ \xunit ->
    xunit{ execStack = snd $ stackUpdate (const ((), o)) name stack }
  return (Reference LOCAL name suf, result)

updateConst :: Name -> RefSuffix -> ObjectFocus (Maybe Object) (Maybe Object) -> ObjectFocus () (Reference, Maybe Object)
updateConst name suf f = do
  let qref = Reference CONST name suf
  consts <- focusLiftExec (gets builtinConstants)
  (result, (changed, _)) <- withInnerLens (M.lookup name consts) (updateIndex suf f)
  when changed $ case suf of -- Modifying a const variable directly fails.
    NullRef -> execThrow "attempted modification of immutable value" ExecErrorUntyped [(modifiedConst, obj qref)]
    _       -> return () -- modifying a member of a const value is OK but the updated value is disgarded.
  return (qref, result)

updateStatic :: Name -> RefSuffix -> ObjectFocus (Maybe Object) (Maybe Object) -> ObjectFocus () (Reference, Maybe Object)
updateStatic name suf f = do
  let qref = Reference STATIC name suf
  store <- focusLiftExec (gets currentCodeBlock) >>= maybe mzero return
  (result, (changed, o)) <- withInnerLens (M.lookup name $ staticVars store) (updateIndex suf f)
  when changed $ focusLiftExec (gets currentCodeBlock) >>= \store -> case store of
    Nothing    -> return ()
    Just store -> focusLiftExec $ modify $ \xunit ->
      xunit
      { currentCodeBlock = Just $
          store{ staticVars = M.alter (const o) name (staticVars store) }
      }
  return (qref, result)

updateGlobal :: Name -> RefSuffix -> ObjectFocus (Maybe Object) (Maybe Object) -> ObjectFocus () (Reference, Maybe Object)
updateGlobal name suf f = do
  let qref = Reference GLOBAL name suf
  store <- focusLiftExec (gets globalData)
  (result, (changed, o)) <- withInnerLens (M.lookup name store) (updateIndex suf f)
  when changed $ focusLiftExec (gets globalData) >>= \store -> focusLiftExec $ modify $ \xunit ->
    xunit{ globalData = M.alter (const o) name store }
  return (qref, result)

updateWithRef :: Name -> RefSuffix -> ObjectFocus (Maybe Object) (Maybe Object) -> ObjectFocus () (Reference, Maybe Object)
updateWithRef name suf f = do
  let qref = Reference GLODOT name suf
  store <- focusLiftExec (gets currentWithRef)
  case store of
    Nothing -> updateGlobal name suf f
    Just  o -> do
      (result, (changed, o)) <- withInnerLens (Just o) (updateIndex suf f)
      when changed $ focusLiftExec $ modify $ \xunit -> xunit{ currentWithRef=o }
      return (qref, result)

instance ObjectLens () Name where
  updateIndex name = updateIndex (Reference UNQUAL name NullRef)

instance ObjectLens () Reference where
  updateIndex qref f = do
    (qref, result) <- case qref of
      Reference q name suf -> case q of
        UNQUAL -> fmap fst $ withInnerLens () $ msum $
          [ updateLocal   name suf f
          , updateConst   name suf f
          , updateStatic  name suf f
          , updateGlobal  name suf f
          , updateWithRef name suf f
          ]
        LOCAL  -> updateLocal   name suf f
        CONST  -> updateConst   name suf f
        STATIC -> updateStatic  name suf f
        GLOBAL -> updateGlobal  name suf f
        GLODOT -> updateWithRef name suf f
      _ -> execThrow "cannot update reference" qref []
    _setTargetRefInfo qref >> return result

----------------------------------------------------------------------------------------------------

-- | Error report indicating which function was being evaluated when the error occurred.
errInFunc :: Name
errInFunc = ustr "errInFunc"

-- | Error report indicating which function was being evaluated when the error occurred.
errInConstr :: Name
errInConstr = ustr "errInConstr"

-- | Error report indicating which function was being evaluated when the error occurred.
errInInitzr :: Name
errInInitzr = ustr "errInInitzr"

-- | Error report indicating which function was being evaluated when the error occurred.
errOfReference :: Name
errOfReference = ustr "errOfReference"

-- | Error report for function calls indicating which argument to the function was incorrect.
argNum :: Name
argNum = ustr "argNum"

-- | Error report for function calls indicating the number of arguments passed to the function.
numArgsPassed :: Name
numArgsPassed = ustr "numArgsPassed"

-- | Error report for subscript expressions indicating the number of dimensions expected
expectNumArgs :: Name
expectNumArgs = ustr "expectNumArgs"

-- | Error report for subscript expressions indicating the number of dimensions expected
exectDimension :: Name
exectDimension = ustr "expectDimension"

-- | Error report used any place an object value of an incorrect data type was given.
expectType :: Name
expectType = ustr "expectType"

-- | Error report indicating that the data type of the 'Object' given was incorrect.
actualType :: Name
actualType = ustr "actualType"

-- | Error report indicating the data type of the right-hand side of an infix operator.
leftSideType :: Name
leftSideType = ustr "leftSideType"

-- | Error report indicating the data type of the right-hand side of an infix operator.
rightSideType :: Name
rightSideType = ustr "rightSideType"

-- | Error report indicating an attempt to modify a 'CONST' 'Reference'.
modifiedConst :: Name
modifiedConst = ustr "modifiedConst"

-- | Error report indicating an object value was of the correct type but was out of bounds or was
-- otherwise not correct.
assertFailed :: Name
assertFailed = ustr "assertFailed"

-- | Error report indicating a function call evalauted to void.
returnedVoid :: Name
returnedVoid = ustr "returnedVoid"

-- | This is a simple dictionary of strings that can translate the keys of the 'execErrorInfo'
-- dictionary to more meaningful explanatory strings when reporting error messages.
errorDict :: M.Map Name UStr
errorDict = M.fromList $ fmap (fmap ustr) $
  [(errInFunc     , "in function call")
  ,(errInConstr   , "in constructor")
  ,(errInInitzr   , "in initializer list")
  ,(errOfReference, "of reference")
  ,(argNum        , "argument number")
  ,(expectNumArgs , "number of arguments expected")
  ,(exectDimension, "dimensional data type")
  ,(numArgsPassed , "number of arguments given")
  ,(expectType    , "expecting type")
  ,(actualType    , "actual type used")
  ,(leftSideType  , "data type of the left-hand operand")
  ,(rightSideType , "data type of the right-hand operand")
  ,(modifiedConst , "modification on constant reference")
  ,(assertFailed  , "object value fails assertion test")
  ,(returnedVoid  , "expression evaluated to void")
  ]

----------------------------------------------------------------------------------------------------

-- | This data type is use to halt normal evaluation and force the result of evaluating the code to
-- be a particular value of this type. The 'Exec' monad instantiates
-- 'Control.Monad.Error.Class.MonadError' such that 'Control.Monad.Error.Class.throwError' throws a
-- value of this type. However, it is not only used for exceptions. The Dao scripting language's
-- "return" statement throws an 'ExecReturn' value which is caught using
-- 'Control.Monad.Error.Class.catchError' when evaluating function calls.
data ExecControl
  = ExecReturn { execReturnValue :: Maybe Object }
  | ExecError
    { execErrorMessage  :: UStr
    , execErrorInModule :: Maybe UStr
    , execErrorLocation :: Location
    , execErrorSubtype  :: ExecErrorSubtype
    , execErrorInfo     :: T_dict
    }
  deriving Typeable

instance Show ExecControl where { show=prettyShow }

instance HasNullValue ExecControl where
  nullValue = ExecReturn Nothing
  testNull (ExecReturn Nothing) = True
  testNull  _                   = False

instance PPrintable ExecControl where
  pPrint err = case err of 
    ExecError{ execErrorMessage=msg, execErrorLocation=loc } -> do
      maybe (return ()) (pString . (++":") . uchars) (execErrorInModule err)
      pShow loc >> pString (if testNull loc then " " else ": ")
      when (not $ msg==nil) (pUStr msg)
      pIndent $ do
        pEndLine >> pPrint (execErrorSubtype err)
        forM_ (M.assocs $ execErrorInfo err) $ \ (key, val) -> do
          pEndLine
          maybe (pPrint key >> pString ": ") (pString . (++" ") . uchars) (M.lookup key errorDict)
          pPrint val
    ExecReturn{ execReturnValue=o } -> maybe (return ()) pPrint o

instance ToDaoStructClass ExecControl where
  toDaoStruct = ask >>= \o -> case o of
    ExecReturn{} -> renameConstructor "ExecReturn" $ asks execReturnValue >>= ("value" .=?)
    ExecError {} -> renameConstructor "ExecError" $ do
      asks execErrorInModule >>= ("inModule" .=?)
      "message"  .=@ execErrorMessage
      "location" .=@ execErrorLocation
      "subtype"  .=@ execErrorSubtype
      "info"     .=@ execErrorInfo

instance HataClass ExecControl where
  haskellDataInterface = interface "ExecControl" $ do
    autoDefPPrinter >> autoDefNullTest >> autoDefToStruct

instance HasNullValue ExecErrorSubtype where
  nullValue = ExecErrorUntyped
  testNull ExecErrorUntyped = True
  testNull _               = False

newError :: ExecControl
newError =
  ExecError
  { execErrorMessage  = nil
  , execErrorInModule = Nothing
  , execErrorLocation = LocationUnknown
  , execErrorSubtype  = ExecErrorUntyped
  , execErrorInfo     = mempty
  }

throwArityError :: MonadError ExecControl m => String -> Int -> [o] -> [(Name, Object)] -> m ig
throwArityError msg i ox info = execThrow fullmsg ExecErrorUntyped moreInfo where
  (before, after) = splitAt 100 ox
  fullmsg = (++(if null msg then "" else ", "++msg)) $
    if null after then "incorrect number of arguments given" else "over 100 arguments given"
  moreInfo = concat $
    [ if null after then [(numArgsPassed, OInt $ length before)] else []
    , [(expectNumArgs, OInt i)], info
    ]

throwBadTypeError :: MonadError ExecControl m => String -> Object -> [(Name, Object)] -> m ig
throwBadTypeError msg o info = execThrow msg (ExecTypeError $ typeOfObj o) info

throwParseError :: MonadError ExecControl m => String -> Maybe UPath -> ParseError () DaoTT -> [(Name, Object)] -> m ig
throwParseError msg mod err info = throwError $
  newError
  { execErrorMessage  = ustr msg
  , execErrorInfo     = M.fromList info
  , execErrorLocation = parseErrLoc err
      -- -^ set the error location in the 'ExecControl' structure
  , execErrorSubtype  = ExecParseError $ err{ parseErrLoc = LocationUnknown }
      -- -^ delete the location to prevent it from being displayed twice
  , execErrorInModule = mod
  }

-- | Evaluate a monadic function which may throw an 'ExecControl' 'Dao.Predicate.PFail' predicate
-- value. If the monadic function does fail, the 'Doa.Predicate.PFail' value will be updated with
-- the 'Dao.Token.Location' value retrieved by evaluating 'Dao.Token.getLocation' on the object
-- provided. If the evaluation failed and has already set an error location, the location is not
-- modified by this function, which guarantees the inner-most call to 'errLocation' will set the
-- location of the error.
errLocation :: (MonadError ExecControl m, HasLocation o) => o -> m a -> m a
errLocation o f = catchError f $ \err -> case err of
  ExecError{execErrorLocation=LocationUnknown} ->
    throwError $ err{execErrorLocation=getLocation o}
  err -> throwError err

-- | Evaluate a monadic function which may throw an 'ExecControl' 'Dao.Predicate.PFail' predicate
-- value. If the monadic function does fail, the 'Doa.Predicate.PFail' value will be updated with
-- the given module name. If the evaluation failed and has already set an error module, the module
-- is not modified by this function, which guarantees the inner-most call to 'errModule' will set
-- the module of the error.
errModule :: MonadError ExecControl m => UPath -> m a -> m a
errModule path f = catchError f $ \err -> case err of
  ExecError{execErrorInModule=mod} -> throwError $ err{execErrorInModule=mplus mod (Just path)}
  err -> throwError err

-- | Like 'errModule' but sets the module reported by the error to be the current module of the
-- 'ExecUnit' if it is defined. If it is not defined, this function is equivalent to 'Prelude.id'.
errCurrentModule :: Exec a -> Exec a
errCurrentModule f = gets programModuleName >>= \mod -> maybe id errModule mod $ f

-- | Evaluate a monadic function which may throw an 'ExecControl' 'Dao.Predicate.PFail' predicate
-- value. If the monadic function does fail, the 'execErrorInfo' field of the 'ExecError' value in
-- the 'Dao.Predicate.PFail' predicate will be updated with the field 'Name' and 'Object' value
-- provided here.
errInfo :: MonadError ExecControl m => Name -> Object -> m a -> m a
errInfo name o f = catchError f $ \err -> case err of
  ExecError{execErrorInfo=info} -> throwError $ err{execErrorInfo=M.insert name o info}
  err -> throwError err

-- | Evaluate an 'Exec', but if it throws an exception, set record an 'ObjectExpr' where
-- the exception occurred in the exception information.
updateExecErrorInfo :: Name -> Object -> Exec a -> Exec a
updateExecErrorInfo name o fn = catchError fn $ \err -> case err of
  ExecReturn{}                  -> throwError err
  ExecError{execErrorInfo=info} -> throwError $ err{ execErrorInfo = M.insert name o info }

-- | If an error has not been caught, log it in the module where it can be retrieved later. This
-- function only stores errors constructed with 'ExecError', the 'ExecReturn' constructed objects
-- are ignored.
logUncaughtErrors :: [ExecControl] -> Exec ()
logUncaughtErrors errs = modify $ \xunit ->
  xunit{ uncaughtErrors = uncaughtErrors xunit ++
    (errs >>= \e -> case e of { ExecReturn{} -> []; ExecError{} -> [e]; }) }

-- | Clear the log of uncaught 'ExecError' values stored by 'logUncaughtErrors'.
clearUncaughtErrorLog :: Exec [ExecControl]
clearUncaughtErrorLog = do
  errs <- gets uncaughtErrors
  modify $ \xunit -> xunit{ uncaughtErrors = [] }
  return errs

----------------------------------------------------------------------------------------------------

data ExecErrorSubtype
  = ExecErrorUntyped
  | ExecThrow         Object
    -- ^ thrown when evaluating a "throw" statement, that is 'Dao.Interpreter.AST.ReturnExpr'
  | ExecStructError   StructError -- ^ thrown by 'toDaoStruct' or 'fromDaoStruct'
  | ExecUndefinedRef  Reference   -- ^ signals reference lookup failed
  | ExecTypeError     ObjType     -- ^ catch-all exception thrown when wrong data type is used.
  | ExecUpdateOpError UpdateOp    -- ^ thrown when an update operator fails
  | ExecIOException   IOException -- ^ re-thrown when caught from the IO monad
  | ExecHaskellError  ErrorCall   -- ^ re-thrown when caught from the IO monad
  | ExecParseError    (ParseError () DaoTT)
  | ExecInfixOpError  ObjType InfixOp ObjType -- ^ thrown when an infix operator fails
  | ExecLoopCtrl      LoopCtrl
    -- ^ inspired by the Python language, break and continue loop control statements are exceptions.
  deriving (Eq, Typeable)

instance Show ExecErrorSubtype where { show=prettyShow }

instance ToDaoStructClass ExecErrorSubtype where
  toDaoStruct = ask >>= \o -> case o of
    ExecErrorUntyped    -> makeNullary "Error"
    ExecThrow         o -> renameConstructor "Exception"          $ "threw"     .= o
    ExecStructError   o -> innerToStruct o
    ExecUndefinedRef  o -> renameConstructor "UndefinedRef"       $ "reference" .= o
    ExecTypeError     o -> renameConstructor "TypeMismatch"       $ "usedType"  .= o
    ExecUpdateOpError o -> renameConstructor "UpdateOpError"      $ "operator"  .= o
    ExecIOException   o -> renameConstructor "HaskellIOException" $ "message"   .= obj (show o)
    ExecHaskellError  o -> renameConstructor "HaskellError"       $ "message"   .= obj (show o)
    ExecParseError    o -> innerToStruct o
    ExecInfixOpError  a o b -> renameConstructor "InfixOpError" $
      "operator" .= o >> "left" .= a >> "right" .= b
    ExecLoopCtrl      o -> innerToStruct o

instance PPrintable ExecErrorSubtype where
  pPrint o = case o of
    ExecErrorUntyped    -> return ()
    ExecThrow         o -> pString "threw exception " >> pPrint o
    ExecStructError   o -> pPrint o
    ExecUndefinedRef  o -> pString "undefined reference " >> pPrint o
    ExecTypeError     o -> pString "cannot use value of type " >> pPrint o
    ExecUpdateOpError o -> pString "cannot apply update with operator " >> pPrint o
    ExecIOException   o -> pString (show o)
    ExecHaskellError  o -> pString (show o)
    ExecParseError    o -> pPrint o
    ExecInfixOpError  a o b -> do
      pString "incompatible types on either side of operator " >> pPrint o
      pIndent $ do
        pEndLine >> pString "left-hand side of operator is value of type: "  >> pPrint a
        pEndLine >> pString "right-hand side of operator is value of type: " >> pPrint b
    ExecLoopCtrl      o -> pPrint o

instance ObjectClass ExecErrorSubtype where { obj=new; fromObj=objFromHata; }

instance HataClass ExecErrorSubtype where
  haskellDataInterface = interface "ErrorSubtype" $ do
    autoDefEquality >> autoDefPPrinter >> autoDefToStruct

----------------------------------------------------------------------------------------------------

data LoopCtrl
  = LoopCtrl
    { loopCtrlEscaped  :: Bool
      -- ^ Has this exception gone past a function call context boundary?
    , loopCtrlContinue :: Bool
      -- ^ Is this control expression a continue statement? (if not it is a break statement)
    }
  deriving (Eq, Typeable)

loopCtrl :: Bool -> LoopCtrl
loopCtrl contin = LoopCtrl{ loopCtrlEscaped=False, loopCtrlContinue=contin }

instance PPrintable LoopCtrl where  
  pPrint ctrl = pString $ concat $
    [ if loopCtrlContinue ctrl then "continue" else "break"
    , " statement evaluated is not within a loop"
    ]

instance ToDaoStructClass LoopCtrl where
  toDaoStruct = renameConstructor "LoopCtrl" $ "isContinue" .=@ loopCtrlContinue

catchLoopCtrl :: Exec a -> (Bool -> Exec a) -> Exec a
catchLoopCtrl try catch = catchError try $ \err -> case err of
  ExecError{ execErrorSubtype =
    ExecLoopCtrl (LoopCtrl{ loopCtrlEscaped=False, loopCtrlContinue=contin }) } -> catch contin
  _ -> throwError err

-- | When defining an iterator, you should catch break and continue statements. This function is a
-- replacement for 'Control.Monad.forM' that handles break and continue statements correctly.
execForM :: [o] -> (o -> Exec a) -> Exec [a]
execForM ox f = loop ox [] where
  loop ox rev = case ox of
    []   -> return rev
    o:ox -> do
      (contin, r) <- catchLoopCtrl ((,) True . return <$> f o) (return . flip (,) [])
      (if contin then loop ox else return) (rev++r)

-- | Like 'execForM' but ignores the values returned by the iterating function.
execForM_ :: [o] -> (o -> Exec a) -> Exec ()
execForM_ ox f = loop ox where
  loop ox = case ox of
    []   -> return ()
    o:ox -> catchLoopCtrl (void $ f o) (flip when (loop ox))

----------------------------------------------------------------------------------------------------

-- | All evaluation of the Dao language takes place in the 'Exec' monad. It instantiates
-- 'Control.Monad.MonadIO.MonadIO' to allow @IO@ functions to be lifeted into it. It instantiates
-- 'Control.Monad.Error.MonadError' and provides it's own exception handling mechanism completely
-- different from the Haskell runtime, so as to allow for more control over exception handling in
-- the Dao runtime.
newtype Exec a  = Exec{ execToPredicate :: PredicateT ExecControl (StateT ExecUnit IO) a }
  deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadIO)

instance MonadState ExecUnit Exec where { state = Exec . lift . state }

instance MonadError ExecControl Exec where
  throwError = Exec . throwError
  catchError (Exec try) catch = Exec (catchError try (execToPredicate . catch))

instance MonadPlusError ExecControl Exec where
  catchPredicate (Exec f) = Exec (catchPredicate f)
  predicate = Exec . predicate

----------------------------------------------------------------------------------------------------

-- | The 'XPure' type is like 'Exec' but does not lift IO or contain any reference to any
-- 'ExecUnit', so it is guaranteed to work without side-effects, but it also instantiates the
-- 'Control.Monad.MonadPlus', 'Control.Applicative.Alternative', 'Control.Monad.Error.MonadError'
-- and 'Dao.Predicate.MonadPlusError' classes so you can do computation with backtracking and
-- exceptions. Although this monad evaluates to a pure function, it does have stateful data: a
-- 'Dao.String.UStr' that will call a "print stream", which is provided for general purpose; a place
-- to print information throughout evaluation like a "print()" statement.  The 'xnote' function
-- serves as the "print()" function for this monad. Use the ordinary 'Control.Monad.State.get' and
-- 'Control.Monad.State.modify' APIs for working with the print stream data.
-- 
-- You can also evaluate an 'XPure' monad within an 'Exec' monad by simply using the 'execute'
-- function. This will automatically convert the internal 'Dao.Predicate.Predicate' of the 'XPure'
-- monad to the 'Dao.Predicate.Predicate' of the 'Exec' monad, meaning if you 'execute' an 'XPure'
-- monad that backtracks or throws an error, the 'Exec' monad will backtrack or throw the same
-- error.
newtype XPure a = XPure { xpureToState :: PredicateT ExecControl (State UStr) a }
  deriving (Functor, Applicative, Alternative, MonadPlus)

instance Show a => Show (XPure a) where
  show (XPure p) = case evalState (runPredicateT p) nil of
    Backtrack -> "(BACKTRACK)"
    PFail err -> "(PFAIL "++prettyShow err++")"
    OK     o  -> "(OK "++show o++")"

instance Monad XPure where
  return = XPure . return
  (XPure a) >>= f = XPure $ a >>= xpureToState . f
  fail msg = execThrow msg ExecErrorUntyped []

-- | Convert a value wrapped in an XPure monad to a pair containing the internal state 'Dao.String.UStr' and
-- 'Dao.Predicate.Predicate' value.
runXPure :: XPure a -> (Predicate ExecControl a, UStr)
runXPure = flip runState nil . runPredicateT . xpureToState

-- | Like 'Control.Monad.State.evalState', but works on the 'XPure' monad, i.e. it is defined as
-- > 'Prelude.fst' . 'runXPure'
evalXPure :: XPure a -> Predicate ExecControl a
evalXPure = fst . runXPure

-- | Like 'evalXPure' but evaluates to 'Prelude.Maybe' instead of a 'Dao.Predicate.Predicate'.
-- 'Dao.Predicate.Backtrack' and 'Dao.Predicate.PFail' both map to 'Prelude.Nothing',
-- 'Dao.Predicate.OK' maps to 'Prelude.Just'.
extractXPure :: XPure a -> Maybe a
extractXPure = okToJust . evalXPure

instance MonadError ExecControl XPure where
  throwError = XPure . throwError
  catchError (XPure f) catch = XPure $ catchError f (xpureToState . catch)

instance MonadPlusError ExecControl XPure where
  predicate = XPure . predicate
  catchPredicate (XPure f) = XPure $ catchPredicate f

instance MonadState UStr XPure where { state = XPure . lift . state }

instance Executable (XPure a) a where
  execute (XPure f) = predicate $ evalState (runPredicateT f) mempty

-- | Like 'Control.Applicative.pure' or 'Control.Monad.return' but the type is not polymorphic so
-- there is no need to annotate the monad to which you are 'Control.Monad.return'ing, which is
-- helpful when using functions like 'exceute' to convert the 'XPure' monad to the 'Exec' monad.
xpure :: a -> XPure a
xpure = pure

-- | Like 'xpure' but wraps any data type that instantiates the 'ObjectClass' class.
xobj :: ObjectClass a => a -> XPure Object
xobj = xpure . obj

-- | Append a string of any 'UStrType' to the general-purpose print stream contained within the
-- 'XPure' monad.
xnote :: UStrType s => s -> XPure ()
xnote = modify . flip mappend . toUStr

-- | Like 'xnote' but lets you operate on the 'Data.ByteString.Lazy.UTF8.ByteString'.
xonUTF8 :: (U.ByteString -> U.ByteString) -> XPure ()
xonUTF8 = modify . fmapUTF8String

-- | Works on any 'Control.Monad.MonadPlus' type, including 'Prelude.Maybe', 'Exec' and 'XPure', is
-- defined as: > 'Prelude.maybe' 'Control.Monad.mzero' 'Control.Monad.return' which is useful
-- shorthand for converting a value wrapped in a 'Prelude.Maybe' data type to a value wrapped in the
-- 'Control.Monad.MonadPlus' type.
xmaybe :: MonadPlus m => Maybe a -> m a
xmaybe = maybe mzero return

----------------------------------------------------------------------------------------------------

class ExecThrowable o where
  toExecErrorInfo :: o -> ExecErrorSubtype
  -- | Like 'Prelude.error' but works for the 'Exec' monad, throws an 'ExecControl' using
  -- 'Control.Monad.Error.throwError' constructed using the given 'Object' value as the
  -- 'execReturnValue'.
  execThrow
    :: (Monad m, MonadError ExecControl m, ExecThrowable o, UStrType msg)
    => msg -> o -> [(Name, Object)] -> m ig
  execThrow msg o info = throwError $
    newError
    { execErrorMessage  = toUStr msg
    , execErrorSubtype  = toExecErrorInfo o
    , execErrorInfo     = M.fromList info
    }

instance ExecThrowable ExecErrorSubtype      where { toExecErrorInfo = id                }
instance ExecThrowable Object                where { toExecErrorInfo = ExecThrow         }
instance ExecThrowable StructError           where { toExecErrorInfo = ExecStructError   }
instance ExecThrowable Reference             where { toExecErrorInfo = ExecUndefinedRef  }
instance ExecThrowable IOException           where { toExecErrorInfo = ExecIOException   }
instance ExecThrowable ErrorCall             where { toExecErrorInfo = ExecHaskellError  }
instance ExecThrowable UpdateOp              where { toExecErrorInfo = ExecUpdateOpError }
instance ExecThrowable (ParseError () DaoTT) where { toExecErrorInfo = ExecParseError    }
instance ExecThrowable LoopCtrl              where { toExecErrorInfo = ExecLoopCtrl      }

ioExec :: Exec a -> ExecUnit -> IO (Predicate ExecControl a, ExecUnit)
ioExec func xunit = runStateT (runPredicateT (execToPredicate func)) xunit

----------------------------------------------------------------------------------------------------

-- | This is the data type analogous to the 'Exec' monad what 'Control.Exception.Handler' is to the
-- @IO@ monad.
newtype ExecHandler a =
  ExecHandler { execHandler :: ExecUnit -> Handler (Predicate ExecControl a, ExecUnit) }

instance Functor ExecHandler where
  fmap f (ExecHandler h) = ExecHandler (fmap (fmap (\ (p, xunit) -> (fmap f p, xunit))) h)

-- | Create an 'ExecHandler'.
newExecIOHandler :: Exception e => (e -> Exec a) -> ExecHandler a
newExecIOHandler h = ExecHandler (\xunit -> Handler (\e -> ioExec (h e) xunit))

-- | Using an 'ExecHandler' like 'execIOHandler', catch any exceptions thrown by the Haskell
-- language runtime and wrap them up in the 'Exec' monad.
execCatchIO :: Exec a -> [ExecHandler a] -> Exec a
execCatchIO tryFunc handlers = Exec $ PredicateT $ StateT $ \xunit ->
  liftIO $ catches (ioExec tryFunc xunit) (fmap (\h -> execHandler h xunit) handlers)

-- | Like 'execCatchIO' but with the arguments 'Prelude.flip'ped.
execHandleIO :: [ExecHandler a] -> Exec a -> Exec a
execHandleIO = flip execCatchIO

-- | An 'ExecHandler' for catching 'Control.Exception.ErrorCall's and re-throwing them to the
-- 'Procedural' monad using 'Control.Monad.Error.throwError', allowing the exception to be caught
-- and handled by Dao script code.
execIOHandler :: ExecHandler ()
execIOHandler = newExecIOHandler $ flip (execThrow "") [] . ExecIOException

-- | An 'ExecHandler' for catching 'Control.Exception.ErrorCall's and re-throwing them to the
-- 'Procedural' monad using 'Control.Monad.Error.throwError', allowing the exception to be caught
-- and handled by Dao script code.
execErrorHandler :: ExecHandler ()
execErrorHandler = newExecIOHandler $ flip (execThrow "") [] . ExecHaskellError

-- | This will catch an 'ExecControl' thrown by 'Control.Monad.Error.throwError', but re-throw
-- 'ExecError's.
catchReturn :: (Maybe Object -> Exec a) -> Exec a -> Exec a
catchReturn catch f = catchPredicate f >>= \pval -> case pval of
  PFail (ExecReturn a) -> catch a
  pval                 -> predicate pval

----------------------------------------------------------------------------------------------------
-- $StackOperations
-- Operating on the local stack.

-- | Push a new empty local-variable context onto the stack. Does NOT 'catchReturnObj', so it can be
-- used to push a new context for every level of nested if/else/for/try/catch statement, or to
-- evaluate a macro, but not a function call. Use 'execFuncPushStack' to perform a function call within
-- a function call. The stack is always poped when this function is done evaluating, even if the
-- given 'Exec' function evaluates to 'Control.Monad.mzero' or 'Control.Monad.Error.throwError'.
execNested :: T_dict -> Exec a -> Exec (a, T_dict)
execNested init exe = do
  store <- gets execStack
  modify $ \xunit -> xunit{ execStack = stackPush init store }
  result <- catchPredicate exe
  store <- gets execStack
  (store, dict) <- pure (stackPop store)
  modify $ \xunit -> xunit{ execStack = store }
  result <- predicate result
  return (result, dict)

-- | Like 'execNested' but immediately disgards the local variables when the inner 'Exec' function
-- has completed evaluation.
execNested_ :: T_dict -> Exec a -> Exec a
execNested_ init = fmap fst . execNested init

-- | Keep the current 'execStack', but replace it with a new empty stack before executing the given
-- function. This function is different from 'nestedExecStak' in that it acually removes the current
-- execution stack so a function call cannot modify the local variables of the function which called
-- it. Furthermore it catches evaluation of a "return" statement allowing the function which called
-- it to procede with execution after this call has returned.
execFuncPushStack :: T_dict -> Exec (Maybe Object) -> Exec (Maybe Object, T_dict)
execFuncPushStack dict exe = execNested dict (catchPredicate exe) >>= \ (pval, dict) -> case pval of
  OK     o  -> return (o, dict)
  Backtrack -> mzero
  PFail err -> case err of
    ExecReturn o -> return (o, dict)
    ExecError{execErrorSubtype=ExecLoopCtrl ctrl} -> throwError $
      err{execErrorSubtype=ExecLoopCtrl $ ctrl{loopCtrlEscaped=False}}
    err          -> throwError err

execFuncPushStack_ :: T_dict -> Exec (Maybe Object) -> Exec (Maybe Object)
execFuncPushStack_ dict = fmap fst . execFuncPushStack dict

execWithStaticStore :: Subroutine -> Exec a -> Exec a
execWithStaticStore sub exe = do
  store <- gets currentCodeBlock
  modify (\st -> st{ currentCodeBlock=Just sub })
  result <- catchPredicate exe
  modify (\st -> st{ currentCodeBlock=store })
  predicate result

execWithWithRefStore :: Object -> Exec a -> Exec a
execWithWithRefStore o exe = do
  store <- gets currentWithRef
  modify (\st -> st{ currentWithRef=Just o })
  result <- catchPredicate exe
  modify (\st -> st{ currentWithRef=store })
  predicate result

withExecTokenizer :: ExecTokenizer -> Exec a -> Exec a
withExecTokenizer newtokzer f = do
  oldtokzer <- gets programTokenizer
  modify $ \xunit -> xunit{ programTokenizer=newtokzer }
  p <- catchPredicate f
  modify $ \xunit -> xunit{ programTokenizer=oldtokzer }
  predicate p

----------------------------------------------------------------------------------------------------

instance (Typeable a, ObjectClass a) => ToDaoStructClass (Com a) where
  toDaoStruct = renameConstructor "Com" $ do
    co <- ask
    let put o = "com" .= obj o
    case co of
      Com          o    ->                   put o >> return ()
      ComBefore c1 o    -> "before" .= c1 >> put o >> return ()
      ComAfter     o c2 ->                   put o >> "after" .= c2 >> return ()
      ComAround c1 o c2 -> "before" .= c1 >> put o >> "after" .= c2 >> return ()

instance (Typeable a, ObjectClass a) => FromDaoStructClass (Com a) where
  fromDaoStruct = do
    constructor "Com"
    let f name = tryField name (maybe (fail name) return . fromObj)
    before <- optional $ f "before"
    after  <- optional $ f "after"
    o      <- req "com"
    return $ maybe (Com o) id $ msum $
      [ return ComAround <*> before <*> pure o <*> after
      , return ComBefore <*> before <*> pure o
      , return ComAfter  <*> pure o <*> after
      ]

instance (Typeable a, ObjectClass a) =>
  ObjectClass (Com a) where { obj=new; fromObj=objFromHata; }
instance (Typeable a, ObjectClass a) => HataClass (Com a) where
  haskellDataInterface = interface "Com" $ do
    autoDefToStruct >> autoDefFromStruct

instance (Typeable a, ObjectClass a) =>
  ObjectClass [Com a] where { obj=listToObj; fromObj=listFromObj; }

----------------------------------------------------------------------------------------------------

setupCodeBlock :: CodeBlock Object -> Subroutine
setupCodeBlock scrp =
  Subroutine
  { origSourceCode = scrp
  , staticVars     = mempty
  , staticRules    = mempty
  , staticLambdas  = []
  , executable     = execute scrp >> return Nothing
  }

-- binary 0xDD 
instance B.Binary (CodeBlock Object) MTab where
  put (CodeBlock o) = B.prefixByte 0xDD $ B.put o
  get = B.tryWord8 0xDD $ CodeBlock <$> B.get

instance Executable (CodeBlock Object) () where { execute (CodeBlock ox) = mapM_ execute ox }

instance ObjectClass (CodeBlock Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (CodeBlock Object) where
  haskellDataInterface = interface "CodeBlock" $ do
    autoDefNullTest >> autoDefEquality >> autoDefNullTest >> autoDefBinaryFmt >> autoDefPPrinter
    defDeref $ \o -> catchError (execute o >> return Nothing) $ \e -> case e of
      ExecReturn o -> return o
      ExecError{}  -> throwError e
    -- TODO: define autoDefIterator, defIndexer, autoDefToStruct >> autoDefFromStruct

----------------------------------------------------------------------------------------------------

-- | A subroutine is contains a 'CodeBlock' and an 'Data.IORef.IORef' to it's own static data. It
-- also has a reference to the last evaluation of 'execute' over it's 'CodeBlock', which provides a
-- hint to the Haskell runtime system that this code can be cached rather than evaluating the
-- 'CodeBlock' fresh every time. In a sense, it is a "live" 'CodeBlock' that can actually be
-- executed.
data Subroutine
  = Subroutine
    { origSourceCode :: CodeBlock Object
    , staticVars     :: T_dict
    , staticRules    :: PatternTree Object [Subroutine]
    , staticLambdas  :: [CallableCode]
    , executable     :: Exec (Maybe Object)
    }
  deriving Typeable

instance Eq Subroutine where { a==b = origSourceCode a == origSourceCode b }

instance Ord Subroutine where { compare a b = compare (origSourceCode a) (origSourceCode b) }

instance Show Subroutine where { show o = "Subroutine "++show (codeBlock (origSourceCode o)) }

instance NFData Subroutine where { rnf (Subroutine a _ _ _ _) = deepseq a () }

instance HasNullValue Subroutine where
  nullValue =
    Subroutine
    { origSourceCode = nullValue
    , staticVars     = mempty
    , staticRules    = mempty
    , staticLambdas  = []
    , executable     = return Nothing
    }
  testNull (Subroutine a _ _ _ _) = testNull a

instance PPrintable Subroutine where
  pPrint = pPrint . flip MetaEvalExpr LocationUnknown . origSourceCode

instance ToDaoStructClass Subroutine where
  toDaoStruct = renameConstructor "Subroutine" $ do
    "code"    .=@ origSourceCode
    "vars"    .=@ staticVars
    "rules"   .=@ (\rs -> RuleSet{ ruleSetRules=rs, ruleSetTokenizer=Nothing }) . staticRules
    "lambdas" .=@ staticLambdas

instance FromDaoStructClass Subroutine where
  fromDaoStruct = do
    constructor "Subroutine"
    sub <- setupCodeBlock <$> req "code"
    vars <- req "vars"
    (RuleSet{ ruleSetRules=rules }) <- req "rules"
    lambdas <- req "lambdas"
    return $ sub{ staticVars=vars, staticRules=rules, staticLambdas=lambdas }

instance Executable Subroutine (Maybe Object) where
  execute sub = execWithStaticStore sub $
    catchReturn return ((execute (origSourceCode sub) :: Exec ()) >> return Nothing) :: Exec (Maybe Object)

instance ObjectClass Subroutine where { obj=new; fromObj=objFromHata; }

instance HataClass Subroutine where
  haskellDataInterface = interface "Subroutine" $ do
    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter
    autoDefToStruct >> autoDefFromStruct

-- | Although 'Subroutine' instantiates 'Executable', this function allows you to easily place a
-- group of defined local variables onto the call stack before and the have the 'Subroutine'
-- executed.
runCodeBlock :: T_dict -> Subroutine -> Exec (Maybe Object, T_dict)
runCodeBlock initStack sub = execWithStaticStore sub $
  execFuncPushStack initStack (executable sub >>= liftIO . evaluate)

runCodeBlock_ :: T_dict -> Subroutine -> Exec (Maybe Object)
runCodeBlock_ initStack = fmap fst . runCodeBlock initStack

----------------------------------------------------------------------------------------------------

data RuleSet
  = RuleSet
    { ruleSetRules     :: PatternTree Object [Subroutine]
    , ruleSetTokenizer :: Maybe ExecTokenizer
    }
  deriving Typeable

instance HasNullValue RuleSet where
  nullValue = RuleSet{ ruleSetRules=nullValue, ruleSetTokenizer=Nothing }
  testNull (RuleSet{ruleSetRules=r, ruleSetTokenizer=tok}) =
    testNull r && maybe True (const False) tok

instance Monoid RuleSet where
  mempty = nullValue
  mappend (RuleSet{ruleSetRules=a, ruleSetTokenizer=tokA}) (RuleSet{ruleSetRules=b, ruleSetTokenizer=tokB}) =
    RuleSet{ ruleSetRules=mappend a b, ruleSetTokenizer=mplus tokA tokB }

instance Sizeable RuleSet where { getSizeOf = return . obj . T.size . ruleSetRules }

instance PPrintable RuleSet where
  pPrint (RuleSet{ ruleSetRules=tree }) = pList (pString "RuleSet") "{ " ", " "}" $
    T.assocs tree >>= \ (ix, subs) -> do
      let rule ix = case ix of
            []                      -> ""
            Single (OString s) : ix -> uchars s ++ rule ix
            Single o           : ix -> prettyShow o ++ rule ix
            i                  : ix -> show i ++ rule ix
      sub <- subs
      [ pClosure (pString "rule " >> pShow (rule ix)) "{" "}" $
          map pPrint $ codeBlock $ origSourceCode sub ]

instance ObjectClass RuleSet where { obj=new ; fromObj=objFromHata; }

instance HataClass RuleSet where
  haskellDataInterface = interface "RuleSet" $ do
    autoDefNullTest >> autoDefSizeable >> autoDefPPrinter
    let qrefRuleSet = reference UNQUAL (ustr "RuleSet")
    let initParams ox = case ox of
          []  -> return $ RuleSet{ ruleSetRules=mempty, ruleSetTokenizer=Nothing }
          [o] -> do
            let err :: Exec RuleSet
                err = throwBadTypeError "" o [(errInConstr, obj qrefRuleSet)]
            maybe err return $ do
              fromObj o >>= \ (Hata ifc _) -> objCallable ifc
              let tok = ExecTokenizer $ \ox -> do
                    toks <- fst <$> callObject (RefObject o NullRef) o [obj ox]
                    mplus (xmaybe $ toks >>= fromObj) $
                      execThrow "tokenizer for rule function did not return a list of objects" ExecErrorUntyped []
              return $ RuleSet{ ruleSetRules=mempty, ruleSetTokenizer=Just tok }
          _  -> throwArityError "" 1 ox [(errInInitzr, obj qrefRuleSet)]
          -- TODO: ^ the constructor for a 'PatternTree' should take tokenizer function.
    let listParams tree =
          foldM (\ rs@(RuleSet{ruleSetRules=tree, ruleSetTokenizer=maybeTok}) (i, o) -> case o of
            InitSingle o -> case fromObj o >>= \ (Hata _ d) -> fromDynamic d of
              Nothing -> throwBadTypeError "expecting rule or RuleSet" o $
                [(errInFunc, obj qrefRuleSet), (errInConstr, OInt i)]
              Just  p -> do
                newtree <- maybe id withExecTokenizer maybeTok $ execute (p::PatternRule)
                return $ rs{ ruleSetRules=T.unionWith (++) tree newtree }
            InitAssign{} -> fail "cannot use assignment expression in initializer of RuleSet"
                ) tree . zip [1..]
    defInitializer initParams listParams
    defInfixOp ORB $ \ _ rs o -> fmap (obj . mappend rs) $ mplus (xmaybe $ fromObj o) $
      (throwBadTypeError "when uninioning RuleSet values" o [])
    let run f =
          daoFunc
          { daoForeignFunc = \rs ->
              runTokenizer >=> makeActionsForQuery [ruleSetRules rs] >=> fmap (flip (,) rs) . f
          }
    defMethod "query" $ run $ return . Just . obj . fmap obj
    defMethod "do"    $ run $ msum . fmap execute
    defMethod "doAll" $ run $ fmap (Just . obj . fmap obj) . execute
    defMethod "tokenize" $
      daoFunc
      { daoForeignFunc = \rs -> fmap (flip (,) rs . Just . obj) .
          maybe runTokenizer runTokenizerWith (ruleSetTokenizer rs)
      }

----------------------------------------------------------------------------------------------------

-- | A subroutine is specifically a callable function (but we don't use the name Function to avoid
-- confusion with Haskell's "Data.Function"). 
data CallableCode
  = CallableCode
    { argsPattern    :: ParamListExpr Object
    , returnType     :: ObjType
    , codeSubroutine :: Subroutine
    }
  deriving (Show, Typeable)

-- Used by the instantiation of CallableCode and PatternRule into the PPrintable class.
ppCallableAction :: String -> PPrint -> ObjType -> Subroutine -> PPrint
ppCallableAction what pats typ exe =
  pClosure (pString what >> pats >> pPrint typ) "{" "}" (map pPrint (codeBlock (origSourceCode exe)))

-- | Interface used during evaluation of Dao scripts to determine whether or not an if or while
-- statement should continue. Also, turns out to be handy for plenty of other reasons.
instance HasNullValue CallableCode where
  nullValue =
    CallableCode{argsPattern=nullValue, returnType=nullValue, codeSubroutine=nullValue}
  testNull (CallableCode a b c) = testNull a && testNull b && testNull c

instance NFData CallableCode  where { rnf (CallableCode  a b _) = deepseq a $! deepseq b () }

instance PPrintable [CallableCode] where 
  pPrint = sequence_ . intersperse (pString " ^ ") .
    fmap (\ (CallableCode pats ty exe) -> ppCallableAction "function" (pPrint pats) ty exe >> pEndLine)

instance ObjectClass [CallableCode] where { obj=new; fromObj=objFromHata; }

instance HataClass [CallableCode] where
  haskellDataInterface = interface "Function" $ do
    autoDefNullTest >> autoDefPPrinter
    defCallable return
    defInfixOp XORB $ \ _ a o -> case fromObj o of
      Just  b -> return $ obj (a++b)
      Nothing -> fail "left-hand side of bitwise-XOR operator (^) is a Function, right hand side is not"

----------------------------------------------------------------------------------------------------

instance ToDaoStructClass (AST_CodeBlock Object) where
  toDaoStruct = renameConstructor "CodeBlock" $ "list" .=@ getAST_CodeBlock

instance FromDaoStructClass (AST_CodeBlock Object) where
  fromDaoStruct = constructor "CodeBlock" >> AST_CodeBlock <$> req "list"

instance ObjectClass (AST_CodeBlock Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (AST_CodeBlock Object) where
  haskellDataInterface = interface "CodeBlockExpression" $ do
    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter
    autoDefToStruct >> autoDefFromStruct

----------------------------------------------------------------------------------------------------

-- binary 0xC5 0xC7
instance B.Binary a MTab => B.Binary (TyChkExpr a Object) MTab where
  put o = case o of
    NotTypeChecked a       -> B.prefixByte 0xC5 $ B.put a
    TypeChecked    a b c   -> B.prefixByte 0xC6 $ B.put a >> B.put b >> B.put c
    DisableCheck   a b c d -> B.prefixByte 0xC7 $ B.put a >> B.put b >> B.put c >> B.put d
  get = B.word8PrefixTable <|> fail "expecting TyChkExpr"

instance B.Binary a MTab => B.HasPrefixTable (TyChkExpr a Object) B.Byte MTab where
  prefixTable = B.mkPrefixTableWord8 "TyChkExpr" 0xC5 0xC7 $
    [ NotTypeChecked <$> B.get
    , return TypeChecked  <*> B.get <*> B.get <*> B.get
    , return DisableCheck <*> B.get <*> B.get <*> B.get <*> B.get
    ]

instance (Eq a, Ord a, Typeable a, ObjectClass a) =>
  ObjectClass (TyChkExpr Object a) where { obj=new; fromObj=objFromHata; }

instance (Eq a, Ord a, Typeable a, ObjectClass a) =>
  HataClass (TyChkExpr Object a) where
    haskellDataInterface = interface "TypedExec" $ do
      autoDefEquality >> autoDefOrdering

----------------------------------------------------------------------------------------------------

instance ObjectClass a => ToDaoStructClass (AST_TyChk a Object) where
  toDaoStruct = ask >>= \o -> case o of
    AST_NotChecked o              -> renameConstructor "UntypedExpression" $ "expr" .= obj o
    AST_Checked    o coms typ loc -> renameConstructor "TypedExpression" $ do
      "expr"     .= obj o
      "colon"    .= coms
      "typeExpr" .= typ
      putLocation loc

instance (Typeable a, ObjectClass a) => FromDaoStructClass (AST_TyChk a Object) where
  fromDaoStruct = msum $
    [do constructor "UntypedExpression"
        AST_NotChecked <$> req "expr"
    ,do constructor "TypedExpression"
        return AST_Checked <*> req "expr" <*> req "colon" <*> req "typeExpr" <*> location
    ]

instance (Eq a, Ord a, PPrintable a, Typeable a, ObjectClass a) =>
  ObjectClass (AST_TyChk a Object) where { obj=new; fromObj=objFromHata; }

instance (Eq a, Ord a, PPrintable a, Typeable a) => HataClass (AST_TyChk a Object) where
  haskellDataInterface = interface "TypedExpression" $ do
    autoDefEquality >> autoDefOrdering >> autoDefPPrinter
    -- autoDefToStruct >> autoDefFromStruct

----------------------------------------------------------------------------------------------------

-- binary 0xCF 0xD0
instance B.Binary (ParamExpr Object) MTab where
  put (ParamExpr True  a b) = B.prefixByte 0xCF $ B.put a >> B.put b
  put (ParamExpr False a b) = B.prefixByte 0xD0 $ B.put a >> B.put b
  get = B.word8PrefixTable <|> fail "expecting ParamExpr"

instance B.HasPrefixTable (ParamExpr Object) B.Byte MTab where
  prefixTable = B.mkPrefixTableWord8 "ParamExpr" 0xCF 0xD0 $
    [ return (ParamExpr True ) <*> B.get <*> B.get
    , return (ParamExpr False) <*> B.get <*> B.get
    ]

instance ObjectClass (ParamExpr Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (ParamExpr Object) where
  haskellDataInterface = interface "ParamExpr" $ do
    autoDefEquality >> autoDefOrdering >> autoDefBinaryFmt

----------------------------------------------------------------------------------------------------

instance ToDaoStructClass (AST_Param Object) where
  toDaoStruct = ask >>= \o -> case o of
    AST_NoParams             -> makeNullary "NoParameters"
    AST_Param coms tychk loc -> renameConstructor "Parameter" $ do
      maybe (return ()) putComments coms
      "typeCheck" .= tychk
      putLocation loc

instance FromDaoStructClass (AST_Param Object) where
  fromDaoStruct = msum $
    [ nullary "NoParameters" >> return AST_NoParams
    , constructor "Parameter" >> return AST_Param <*> optComments <*> req "typeCheck" <*> location
    ]

instance ObjectClass (AST_Param Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (AST_Param Object) where
  haskellDataInterface = interface "ParameterExpression" $ do
    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter
    autoDefToStruct >> autoDefFromStruct

----------------------------------------------------------------------------------------------------

-- binary 0xD6 
instance B.Binary (ParamListExpr Object) MTab where
  put (ParamListExpr tyChk loc) = B.prefixByte 0xD6 $ B.put tyChk >> B.put loc
  get = B.word8PrefixTable <|> fail "expecting ParamListExpr"

instance B.HasPrefixTable (ParamListExpr Object) B.Byte MTab where
  prefixTable = B.mkPrefixTableWord8 "ParamListExpr" 0xD6 0xD6 $
    [return ParamListExpr <*> B.get <*> B.get]

instance ObjectClass (ParamListExpr Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (ParamListExpr Object) where
  haskellDataInterface = interface "ParameterList" $ do
    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefBinaryFmt

----------------------------------------------------------------------------------------------------

instance ToDaoStructClass (AST_ParamList Object) where
  toDaoStruct = ask >>= \o -> case o of
    AST_ParamList tychk loc -> renameConstructor "ParamList" $ do
      "typeCheck" .= tychk
      putLocation loc

instance FromDaoStructClass (AST_ParamList Object) where
  fromDaoStruct = constructor "ParamList" >> return AST_ParamList <*> req "typeCheck" <*> location

instance ObjectClass (AST_ParamList Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (AST_ParamList Object) where
  haskellDataInterface = interface "ParameterListExpression" $ do
    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter
    autoDefToStruct >> autoDefFromStruct

----------------------------------------------------------------------------------------------------

-- binary 0x7A 0x7B
instance B.Binary (RuleHeadExpr Object) MTab where
  put o = case o of
    RuleStringExpr a b -> B.prefixByte 0x7A $ B.put a >> B.put b
    RuleHeadExpr   a b -> B.prefixByte 0x7B $ B.put a >> B.put b
  get = B.word8PrefixTable <|> fail "expecting RuleHeadExpr"

instance B.HasPrefixTable (RuleHeadExpr Object) B.Byte MTab where
  prefixTable = B.mkPrefixTableWord8 "RuleHeadExpr" 0x7A 0x7B
    [ return RuleStringExpr <*> B.get <*> B.get
    , return RuleHeadExpr   <*> B.get <*> B.get
    ]

instance Executable (RuleHeadExpr Object) [Object] where
  execute o = case o of
    RuleStringExpr r _ -> return [obj r]
    RuleHeadExpr   r _ -> forM r $
      execute . DerefAssignExpr >=> checkVoid (getLocation o) "item in rule header"

instance ObjectClass (RuleHeadExpr Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (RuleHeadExpr Object) where
  haskellDataInterface = interface "RuleHeader" $ do
    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefBinaryFmt

----------------------------------------------------------------------------------------------------

instance ToDaoStructClass (AST_RuleHeader Object) where
  toDaoStruct = ask >>= \o -> case o of
    AST_NullRules coms loc -> renameConstructor "NoStrings" $ do
      putComments coms >> putLocation loc
    AST_RuleString itm loc -> renameConstructor "StringItem" $ do
      "items" .= itm >> putLocation loc
    AST_RuleHeader lst loc -> renameConstructor "ValuesList" $ do
      "items" .= lst >> putLocation loc

instance FromDaoStructClass (AST_RuleHeader Object) where
  fromDaoStruct = msum $
    [ constructor "NoStrings"  >> return AST_NullRules  <*> comments <*> location
    , constructor "StringItem" >> return AST_RuleString <*> req "items" <*> location
    , constructor "ValuesList" >> return AST_RuleHeader <*> reqList "items" <*> location
    ]

instance ObjectClass (AST_RuleHeader Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (AST_RuleHeader Object) where
  haskellDataInterface = interface "RuleHeaderExpression" $ do
    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter
    autoDefToStruct >> autoDefFromStruct

----------------------------------------------------------------------------------------------------

-- $Exec_helpers
-- Functions for working with object values when building built-in functions callable from within a
-- dao script.

asReference :: Object -> XPure Reference
asReference = xmaybe . fromObj

_getRuleSetParam :: [Object] -> Exec (Maybe RuleSet, [Object])
_getRuleSetParam ox = return $ case ox of
  []   -> (Nothing, [])
  o:ox -> maybe ((Nothing, o:ox)) (\o -> (Just o, ox)) (fromObj o)

-- Checks the list of parameters, and if there are more than one, checks if the first parameter is
-- an 'OHaskell' object which can be converted to 'CallableCode' using 'objToCallable'. If so, the
-- callables are returned and the results of pattern matching can be used as parameters to these
-- functions.
_getFuncStringParams :: [Object] -> Exec (Maybe [CallableCode], [UStr])
_getFuncStringParams ox = case ox of
  []   -> fail "no parameters passed to function"
  [o]  -> (,) Nothing <$> oneOrMoreStrings [o]
  o:lst -> do
    calls <- (Just <$> objToCallable o) <|> return Nothing
    (,) calls <$> oneOrMoreStrings lst
  where
    oneOrMoreStrings ox = case concatMap extractStringElems ox of
      [] -> fail "parameter arguments contain no string values"
      ox -> return ox

asInteger :: Object -> XPure Integer
asInteger o = case o of
  OWord    o -> return (toInteger o)
  OInt     o -> return (toInteger o)
  OLong    o -> return o
  OFloat   o -> return (round o)
  ORatio   o -> return (round o)
  ORelTime o -> return (round (toRational o))
  _          -> mzero

asRational :: Object -> XPure Rational
asRational o = case o of
  OInt     o -> return (toRational o)
  OWord    o -> return (toRational o)
  OLong    o -> return (toRational o)
  OFloat   o -> return (toRational o)
  ORelTime o -> return (toRational o)
  ORatio   o -> return o
  OComplex o | imagPart o == 0 -> return (toRational (realPart o))
  _          -> mzero

asComplex :: Object -> XPure T_complex
asComplex o = case o of
  OComplex o -> return o
  o          -> asRational o >>= return . flip complex 0 . fromRational

-- | A function which is basically the absolute value function, except it also works on 'Complex'
-- numbers, returning the magnitude of the number if it is 'Complex'.
asPositive :: Object -> XPure Object
asPositive o = case o of
  OInt     o -> return (OInt     $ abs       o)
  OWord    o -> return (OWord                o)
  OLong    o -> return (OLong    $ abs       o)
  OFloat   o -> return (OFloat   $ abs       o)
  ORelTime o -> return (ORelTime $ abs       o)
  OComplex o -> return (OFloat   $ magnitude o)
  _          -> mzero

-- | Remove one layer of 'OList' objects, i.e. any objects in the list that are 'OList' constructors
-- will have the contents of those lists concatenated, and all non-'OList' constructors are treated
-- as lists of single objects. Also returns the number of concatenations.
objConcat :: [Object] -> (Int, [Object])
objConcat ox = (sum a, concat b) where
  (a, b) = unzip (ox >>= \o -> maybe [(0, [o])] (return . (,) 1) (fromObj o))

-- | Checks if an 'Object' is a numerical type, returns the numeric 'CoreType' if so, evaluates to
-- 'Control.Monad.mzero' if not.
isNumeric :: Object -> XPure CoreType
isNumeric o = do
  let t = coreType o
  guard (CharType <= t && t <= ComplexType)
  return t

eval_Prefix_op :: ArithPfxOp -> Object -> XPure Object
eval_Prefix_op op o = join $ xmaybe $
  fromObj o >>= \ (Hata ifc o) -> objArithPfxOpTable ifc >>= (! op) >>= \f -> return (f op o)

-- Pass the 'InfixOp' associated with the 'Prelude.Num' function so it can check whether the
-- 'defInfixOp' for that operator has been defined for objects of 'HaskellType'.
eval_Infix_op :: InfixOp -> Object -> Object -> XPure Object
eval_Infix_op op a b = join $ xmaybe $ onhask a b <|> (guard isCommut >> onhask b a) where
  isCommut = infixOpCommutativity op
  onhask a b = fromObj a >>= \ (Hata ifc a) ->
    (\f -> f op a b) <$> (objInfixOpTable ifc >>= (! op))

_evalNumOp1 :: (forall a . Num a => a -> a) -> Object -> XPure Object
_evalNumOp1 f o = case o of
  OChar    o -> return $ OChar    $ chr $ mod (f $ ord o) (ord maxBound)
  OInt     o -> return $ OInt     $ f o
  OWord    o -> return $ OWord    $ f o
  OLong    o -> return $ OLong    $ f o
  ORelTime o -> return $ ORelTime $ f o
  OFloat   o -> return $ OFloat   $ f o
  ORatio   o -> return $ ORatio   $ f o
  OComplex o -> return $ OComplex $ f o
  _          -> mzero

-- Evaluate a 2-ary function for any core type that instantiates the 'Prelude.Num' class.
_evalNumOp2 :: (forall a . Num a => a -> a -> a) -> Object -> Object -> XPure Object
_evalNumOp2 f a b = do
  let t = max (coreType a) (coreType b)
  a <- castToCoreType t a
  b <- castToCoreType t b
  case (a, b) of
    (OChar     a, OChar     b) -> return $ OChar    $ chr $ mod (f (ord a) (ord b)) (ord maxBound)
    (OInt      a, OInt      b) -> return $ OInt     $ f a b
    (OWord     a, OWord     b) -> return $ OWord    $ f a b
    (OLong     a, OLong     b) -> return $ OLong    $ f a b
    (ORelTime  a, ORelTime  b) -> return $ ORelTime $ f a b
    (OFloat    a, OFloat    b) -> return $ OFloat   $ f a b
    (ORatio    a, ORatio    b) -> return $ ORatio   $ f a b
    (OComplex  a, OComplex  b) -> return $ OComplex $ f a b
    _ -> mzero

instance Num (XPure Object) where
  a + b = a >>= \a -> b >>= \b -> case (a, b) of
    (OString a, OString b) -> return $ OString $ a<>b
    (OBytes  a, OBytes  b) -> return $ OBytes  $ a<>b
    (OList   a, OList   b) -> return $ OList   $ a++b
    (ODict   a, ODict   b) -> return $ ODict   $ M.union b a
    (a, b) -> _evalNumOp2 (+) a b <|> eval_Infix_op ADD a b
  a * b = a >>= \a -> case a of
    OList ax -> OList <$> mapM ((* b) . xpure) ax
    ODict ax -> (ODict . M.fromList) <$>
      mapM (\ (key, a) -> fmap ((,) key) (xpure a * b)) (M.assocs ax)
    a        -> b >>= \b -> case b of
      OList bx -> OList <$> mapM (((xpure a) *) . xpure) bx
      ODict bx -> (ODict . M.fromList) <$>
        mapM (\ (key, b) -> fmap ((,) key) (xpure a * xpure b)) (M.assocs bx)
      b        -> _evalNumOp2 (*) a b <|> eval_Infix_op MULT a b
  a - b = a >>= \a -> b >>= \b -> case a of
    -- on strings, the inverse operation of "join(b, a)", every occurence of b from a.
    OString a -> case b of
      OString b -> return $ OString $ mconcat $ splitString a b
      _         -> mzero
    -- on lists, removes the item b from the list a
    OList   a -> return $ OList $ filter (/= b) a
    ODict   a -> case b of
      ODict b -> return $ ODict $ M.difference a b
      ORef (Reference UNQUAL b NullRef) -> return $ ODict $ M.delete b a
      ORef _                            ->
        execThrow "dictionary key must be a single unqualified name" ExecErrorUntyped [(assertFailed, b)]
      _ -> mzero
    a         -> _evalNumOp2 (-) a b <|> eval_Infix_op SUB a b
  negate a = (a >>= _evalNumOp1 negate) <|> (a >>= eval_Prefix_op NEGTIV)
  abs    a = (a >>= _evalNumOp1 abs   ) <|> (a >>= eval_Prefix_op NEGTIV)
  signum a =  a >>= _evalNumOp1 signum
  fromInteger = return . obj

_xpureApplyError :: String -> String -> a
_xpureApplyError name msg = error $ concat $ concat $
  [["cannot evaluate ", name], guard (not $ null msg) >> [": ", msg]]

_xpureApply2 :: String -> (Object -> Object -> a) -> XPure Object -> XPure Object -> a
_xpureApply2 name f a b = case evalXPure ab of
  PFail   e -> _xpureApplyError name (prettyShow e)
  Backtrack -> _xpureApplyError name ""
  OK      o -> o
  where
    ab = do
      ta <- coreType <$> a
      tb <- coreType <$> b
      let t = max ta tb
      a <- a >>= castToCoreType t
      b <- b >>= castToCoreType t
      return (f a b)

_xpureApply1 :: String -> (Object -> XPure a) -> XPure Object -> a
_xpureApply1 name f o = case evalXPure $ o >>= f of
  PFail   e -> _xpureApplyError name (prettyShow e)
  Backtrack -> _xpureApplyError name ""
  OK      o -> o

_xpureMaybeApply1 :: (Object -> XPure a) -> XPure Object -> Maybe a
_xpureMaybeApply1 f o = case evalXPure $ o >>= f of
  PFail   _ -> Nothing
  Backtrack -> Nothing
  OK      o -> Just o

instance Eq (XPure Object) where
  (==) = _xpureApply2 "(==)" (==)
  (/=) = _xpureApply2 "(/=)" (/=)

instance Ord (XPure Object) where
  compare = _xpureApply2 "compare" compare
  (<)     = _xpureApply2 "(<)"  (<)
  (<=)    = _xpureApply2 "(<=)" (<=)
  (>)     = _xpureApply2 "(>)"  (>)
  (>=)    = _xpureApply2 "(>=)" (>=)

instance Real (XPure Object) where
  toRational = _xpureApply1 "toRational" $ castToCoreType LongType >=> xmaybe . fromObj

eval_Int_op1 :: String -> (forall a . Integral a => a -> a) -> XPure Object -> XPure Object
eval_Int_op1 name f o = o >>= \o -> case o of
  OChar o -> return $ OChar (chr $ flip mod (ord maxBound) $ f $ ord o)
  OInt  o -> return $ OInt  (f o)
  OWord o -> return $ OWord (f o)
  OLong o -> return $ OLong (f o)
  _       -> throwBadTypeError "wrong data type for object passed to function" o $
                [(errInFunc, obj (ustr name :: Name))]

_xpureCastTo :: XPure CoreType -> XPure Object -> XPure Object
_xpureCastTo typ a = join $ xpure castToCoreType <*> typ <*> a

-- In order for @('XPure' 'Object')@ to be used with the 'Prelude.Div' and 'Prelude.mod' functions,
-- it must instantiate 'Integral', which means it must instantiate 'Prelude.Enum'. This
-- instantiation is an attempt at making the functions behave as they would for ordinary enumerated
-- data types; it is /NOT/ pretty, but it basically works.
instance Enum (XPure Object) where
  succ = eval_Int_op1 "succ" succ
  pred = eval_Int_op1 "pred" pred
  toEnum = return . obj
  fromEnum = _xpureApply1 "fromEnum" $ castToCoreType IntType >=> xmaybe . fromObj
  enumFrom = fix (\loop o -> o : loop (succ o))
  enumFromThen lo hi = fix (\loop o -> o : loop (hi-lo+o)) lo
  enumFromTo a b =
    if maybe False (const True) (extractXPure typ)
    then  case compare aa bb of
            EQ -> repeat aa
            LT -> loop (<bb)         inc  aa
            GT -> loop (>bb) (negate inc) aa
    else  []
    where
      loop ok inc a = a : let b = a+inc in if ok b then loop ok inc b else []
      typ   = a >>= \a -> b >>= \b -> do
        let t = max (coreType a) (coreType b)
        guard (CharType <= t && t <= ComplexType) >> xpure t
      inc = typ >>= flip castToCoreType (OChar '\x01')
      aa  = _xpureCastTo typ a
      bb  = _xpureCastTo typ b
  enumFromThenTo a b c =
    if maybe False (const True) $ extractXPure typ
    then  case compare aa bb of
            EQ -> repeat aa
            LT -> if aa<cc then loop (<cc) aa else []
            GT -> if aa>cc then loop (>cc) aa else []
    else  []
    where
      loop ok a = a : let b = a+inc in if ok b then loop ok b else []
      typ = a >>= \a -> b >>= \b -> c >>= \c -> do
        let t = max (coreType a) $ max (coreType b) $ (coreType c)
        guard (CharType <= t && t <= RatioType) >> xpure t
      inc = bb-aa
      aa  = _xpureCastTo typ a
      bb  = _xpureCastTo typ b
      cc  = _xpureCastTo typ c

_xpureDivFunc
  :: String
  -> (forall a . Integral a => a -> a -> (a, a))
  -> XPure Object -> XPure Object -> (XPure Object, XPure Object)
_xpureDivFunc name div a b = _xpureApply2 name f aa bb where
    f a b = case (a, b) of
      (OChar a, OChar b) -> pair (ord a) (ord b) (OChar . chr)
      (OInt  a, OInt  b) -> pair a b OInt
      (OWord a, OWord b) -> pair a b OWord
      (OLong a, OLong b) -> pair a b OLong
      _                  -> (mzero, mzero)
    pair a b constr = let (c, d) = div a b in (xpure $ constr c, xpure $ constr d)
    typ = a >>= \a -> b >>= \b -> do
      let t = max (coreType a) (coreType b)
      guard (CharType <= t && t <= LongType) >> xpure t
    aa = _xpureCastTo typ a
    bb = _xpureCastTo typ b

instance Integral (XPure Object) where
  toInteger = _xpureApply1 "toInteger" (castToCoreType LongType >=> xmaybe . fromObj)
  quotRem a b = _xpureDivFunc "quoteRem" quotRem a b
  divMod  a b = _xpureDivFunc "divMod"   divMod  a b
  div     a b = a >>= \a -> b >>= \b -> case (a, b) of
    (OString a, OString b) -> return $ OWord $ fromIntegral $ length $ splitString a b
    _ -> fst (_xpureDivFunc "(/)" divMod (xpure a) (xpure b)) <|> eval_Infix_op DIV a b
  mod     a b = a >>= \a -> b >>= \b -> case (a, b) of
    (OString a, OString b) -> return $ OList $ map OString $ splitString a b
    _ -> snd (_xpureDivFunc "(%)" divMod (xpure a) (xpure b)) <|> eval_Infix_op MOD a b

_xpureFrac :: (forall a . Floating a => a -> a) -> XPure Object -> XPure Object
_xpureFrac f a = a >>= \a -> case a of
  ORelTime a -> xpure $ ORelTime $ fromRational $ toRational $
    f (fromRational (toRational a) :: Double)
  OFloat   a -> xpure $ OFloat   $ f a
  ORatio   a -> xpure $ ORatio   $ toRational $ f $ (fromRational a :: Double)
  OComplex a -> xpure $ OComplex $ f a
  _          -> mzero

_xpureFrac2 :: (forall a . Floating a => a -> a -> a) -> XPure Object -> XPure Object -> XPure Object
_xpureFrac2 f a b = a >>= \a -> b >>= \b -> do
  let t = max (coreType a) (coreType b)
  a <- castToCoreType t a
  b <- castToCoreType t b
  case (a, b) of
    (ORelTime a, ORelTime b) -> xpure $ ORelTime $ fromRational $ toRational $
      f (fromRational (toRational a) :: Double) (fromRational (toRational b) :: Double)
    (OFloat   a, OFloat   b) -> xpure $ OFloat   $ f a b
    (ORatio   a, ORatio   b) -> xpure $ ORatio   $ toRational $
      f (fromRational a :: Double) (fromRational b :: Double)
    (OComplex a, OComplex b) -> xpure $ OComplex $ f a b
    _                        -> mzero

instance Fractional (XPure Object) where
  a / b  = _xpureFrac2 (/) a b
  recip = _xpureFrac recip
  fromRational = xpure . ORatio

instance Floating (XPure Object) where
  pi      = xpure $ OFloat pi
  logBase = _xpureFrac2 logBase
  (**)    a b = _xpureFrac2 (**) a b
  exp     = _xpureFrac exp
  sqrt    = _xpureFrac sqrt
  log     = _xpureFrac log
  sin     = _xpureFrac sin
  tan     = _xpureFrac tan
  cos     = _xpureFrac cos
  asin    = _xpureFrac asin
  atan    = _xpureFrac atan
  acos    = _xpureFrac acos
  sinh    = _xpureFrac sinh
  tanh    = _xpureFrac tanh
  cosh    = _xpureFrac cosh
  asinh   = _xpureFrac asinh
  atanh   = _xpureFrac atanh
  acosh   = _xpureFrac acosh

_xpureRealFrac :: Integral b => String -> (forall a . RealFrac a => a -> b) -> XPure Object -> b
_xpureRealFrac name f = _xpureApply1 name $ \o -> case o of
  ORelTime a -> xpure $ f a
  OFloat   a -> xpure $ f a
  ORatio   a -> xpure $ f a
  _          -> mzero

instance RealFrac (XPure Object) where
  properFraction = let name = "properFraction" in _xpureApply1 name $ \o -> case o of
    ORelTime o -> f ORelTime o
    OFloat   o -> f OFloat   o
    ORatio   o -> f ORatio   o
    _          -> xpure (error $ "cannot evaluate properFraction on object "++prettyShow o, mzero)
    where { f constr o = let (i, b) = properFraction o in xpure (i, xpure $ constr b) }
  truncate = _xpureRealFrac "truncate" truncate
  round    = _xpureRealFrac "round"    round
  ceiling  = _xpureRealFrac "ceiling"  ceiling
  floor    = _xpureRealFrac "floor"    floor

_xpureBits :: (forall a . Bits a => a -> a) -> (B.ByteString -> B.ByteString) -> XPure Object -> XPure Object
_xpureBits f g o = o >>= \o -> case o of
  OChar  o -> return $ OChar  $ chr $ mod (f $ ord o) (ord maxBound)
  OInt   o -> return $ OInt   $ f o
  OWord  o -> return $ OWord  $ f o
  OLong  o -> return $ OLong  $ f o
  OBytes o -> return $ OBytes $ g o
  _        -> mzero

_xpureBits2 :: InfixOp -> (forall a . Bits a => a -> a -> a) -> (T_dict -> T_dict -> T_dict) -> (B.ByteString -> B.ByteString -> B.ByteString) -> XPure Object -> XPure Object -> XPure Object
_xpureBits2 op bits dict bytes a b = a >>= \a -> b >>= \b -> do
  let t = max (coreType a) (coreType b)
  a <- castToCoreType t a
  b <- castToCoreType t b
  case (a, b) of
    (OChar  a, OChar  b) -> return $ OChar  $ chr $ mod (bits (ord a) (ord b)) (ord maxBound)
    (OInt   a, OInt   b) -> return $ OInt   $ bits a b
    (OWord  a, OWord  b) -> return $ OWord  $ bits a b
    (OLong  a, OLong  b) -> return $ OLong  $ bits a b
    (ODict  a, ODict  b) -> return $ ODict  $ dict a b
    (OTree  a, OTree  b) -> case (a, b) of
      (Struct{ structName=na, fieldMap=ma }, Struct{ structName=nb, fieldMap=mb }) | na==nb ->
        xpure $ OTree $ a{ fieldMap = dict ma mb }
      _ -> throwBadTypeError "cannot operate on dissimilar struct types" (OTree b) $
              [(expectType, obj (typeOfObj (OTree a)))]
    (OBytes a, OBytes b) -> return $ OBytes $ bytes a b
    _                    -> eval_Infix_op op a b

_dict_XOR :: (Object -> Object -> Object) -> T_dict -> T_dict -> T_dict
_dict_XOR f a b = M.difference (M.unionWith f a b) (M.intersectionWith f a b)

instance Bits (XPure Object) where
  a .&. b = _xpureBits2 AND (.&.) (M.intersectionWith (flip const)) (bytesBitArith (.&.)) a b <|>
    (a >>= \a -> b >>= \b -> eval_Infix_op ANDB a b)
  a .|. b = _xpureBits2 ORB (.|.) (M.unionWith (flip const))        (bytesBitArith (.|.)) a b <|>
    (a >>= \a -> b >>= \b -> eval_Infix_op ORB  a b)
  xor a b = _xpureBits2 XORB xor  (_dict_XOR (flip const))          (bytesBitArith  xor ) a b <|>
    (a >>= \a -> b >>= \b -> eval_Infix_op XORB a b)
  complement  = _xpureBits complement (B.map complement)
  shift   o i = o >>= \o -> case o of
    OList o -> xpure $ OList $ case compare i 0 of
      EQ -> o
      LT -> reverse $ drop (negate i) $ reverse o
      GT -> drop i o
    _ -> _xpureBits (flip shift i) (flip bytesShift (fromIntegral i)) (xpure o)
  rotate  o i = _xpureBits (flip shift i) (flip bytesRotate (fromIntegral i)) o
  bit       i = xpure $ if i<64 then OWord (bit i) else OBytes (bytesBit (fromIntegral i))
  testBit o i = _xpureApply1 "testBit" testbit o where
    testbit o = case o of
      OChar  o -> xpure $ testBit (ord o) i
      OInt   o -> xpure $ testBit o i
      OWord  o -> xpure $ testBit o i
      OLong  o -> xpure $ testBit o i
      OBytes o -> xpure $ bytesTestBit o (fromIntegral i)
      _        -> mzero
  bitSize = _xpureApply1 "bitSize" $ \o -> case o of
    OInt   o -> xmaybe $ bitSizeMaybe o
    OWord  o -> xmaybe $ bitSizeMaybe o
    OBytes o -> xpure $ fromIntegral $ bytesBitSize o
    _        -> mzero
  bitSizeMaybe = _xpureMaybeApply1 $ \o -> case o of
    OInt   o -> xmaybe $ bitSizeMaybe o
    OWord  o -> xmaybe $ bitSizeMaybe o
    OBytes o -> xpure $ fromIntegral $ bytesBitSize o
    _        -> mzero
  isSigned = _xpureApply1 "isSigned" $ \o -> case o of
    OChar  _ -> xpure False
    OInt   _ -> xpure True
    OWord  _ -> xpure False
    OLong  _ -> xpure True
    OBytes _ -> xpure False
    _        -> mzero
  popCount = _xpureApply1 "popCount" $ \o -> case o of
    OChar  o -> xpure $ popCount (ord o)
    OInt   o -> xpure $ popCount o
    OWord  o -> xpure $ popCount o
    OLong  o -> xpure $ popCount o
    OBytes o -> xpure $ fromIntegral $ bytesPopCount o
    _        -> mzero

_shiftOp :: (Int -> Int) -> Object -> Object -> XPure Object
_shiftOp neg a b = case b of
  OInt  b -> shift (xpure a) (neg b)
  OWord b -> shift (xpure a) (neg $ fromIntegral b)
  OLong b -> shift (xpure a) (neg $ fromIntegral b)
  _       -> mzero

-- | Evaluate the shift-left operator in the 'XPure' monad.
shiftLeft :: Object -> Object -> XPure Object
shiftLeft a b = _shiftOp id a b <|> eval_Infix_op SHL a b

-- | Evaluate the shift-right operator in the 'XPure' monad.
shiftRight :: Object -> Object -> XPure Object
shiftRight a b = _shiftOp negate a b <|> eval_Infix_op SHR a b

-- | Throw an error declaring that the two types cannot be used together because their types are
-- incompatible. Provide the a string describing the /what/ could not be done as a result of the
-- type mismatch, it will be placed in the message string:
-- > "could not <WHAT> the item <A> of type <A-TYPE> with the item <B> of type <B-TYPE>"
typeMismatchError :: InfixOp -> Object -> Object -> XPure ig
typeMismatchError op a b = throwError $
  newError{ execErrorSubtype = ExecInfixOpError (typeOfObj a) op (typeOfObj b) }

eval_ADD :: Object -> Object -> XPure Object
eval_ADD a b = (xpure a + xpure b) <|> typeMismatchError ADD a b

eval_SUB :: Object -> Object -> XPure Object
eval_SUB a b = (xpure a - xpure b) <|> typeMismatchError SUB a b

eval_MULT :: Object -> Object -> XPure Object
eval_MULT a b = (xpure a * xpure b) <|> typeMismatchError MULT a b

eval_DIV :: Object -> Object -> XPure Object
eval_DIV a b = do
  let { xa = xpure a; xb = xpure b; }
  (div xa xb <|> xa/xb) <|> typeMismatchError DIV a b

eval_MOD :: Object -> Object -> XPure Object
eval_MOD a b = do
  let { xa = xpure a; xb = xpure b; }
  (mod xa xb) <|> typeMismatchError MOD a b

eval_POW :: Object -> Object -> XPure Object
eval_POW a b = do
  let { xa = xpure a; xb = xpure b; }
  xa^^xb <|> xa**xb <|> typeMismatchError POW a b

eval_ORB :: Object -> Object -> XPure Object
eval_ORB a b = do
  let { xa = xpure a; xb = xpure b; }
  (xa.|.xb) <|> typeMismatchError ORB a b

eval_ANDB :: Object -> Object -> XPure Object
eval_ANDB a b = do
  let { xa = xpure a; xb = xpure b; }
  (xa.&.xb) <|> typeMismatchError ANDB a b

eval_XORB :: Object -> Object -> XPure Object
eval_XORB a b = do
  let { xa = xpure a; xb = xpure b; }
  (xor xa xb) <|> typeMismatchError XORB a b

eval_EQUL :: Object -> Object -> XPure Object
eval_EQUL a b = return $ obj $ xpure a == xpure b

eval_NEQUL :: Object -> Object -> XPure Object
eval_NEQUL a b = return $ obj $ xpure a /= xpure b

eval_GTN :: Object -> Object -> XPure Object
eval_GTN a b = return $ obj $ xpure a > xpure b

eval_LTN :: Object -> Object -> XPure Object
eval_LTN a b = return $ obj $ xpure a < xpure b

eval_GTEQ :: Object -> Object -> XPure Object
eval_GTEQ a b = return $ obj $ xpure a >= xpure b

eval_LTEQ :: Object -> Object -> XPure Object
eval_LTEQ a b = return $ obj $ xpure a <= xpure b

eval_SHR :: Object -> Object -> XPure Object
eval_SHR a b = shiftRight a b

eval_SHL :: Object -> Object -> XPure Object
eval_SHL a b = shiftLeft a b

eval_NEG :: Object -> XPure Object
eval_NEG = _evalNumOp1 negate

eval_INVB :: Object -> XPure Object
eval_INVB = complement . xpure

eval_NOT :: Object -> XPure Object
eval_NOT = fmap (obj . not) . objToBool

objToBool :: Object -> XPure Bool
objToBool o = case o of
  OHaskell (Hata ifc d) -> case objNullTest ifc of
    Nothing   -> throwBadTypeError "cannot be used as a boolean value" o [(assertFailed, o)]
    Just test -> return (test d)
  o -> return $ not $ testNull o

-- | Traverse the entire object, returning a list of all 'OString' elements.
extractStringElems :: Object -> [UStr]
extractStringElems o = case o of
  OString  o   -> [o]
  OList    o   -> concatMap extractStringElems o
  _            -> []

-- | Useful for building 'DaoFunc' objects, checks every parameter in a list of 'Object's to be a
-- string, and throws an exception if one of the 'Object's is not a string.
requireAllStringArgs :: String -> [Object] -> Exec [UStr]
requireAllStringArgs msg ox = case mapM check (zip [1..] ox) of
  OK      obj -> return obj
  Backtrack   -> fail msg
  PFail   err -> throwError err
  where
    check (i, o) = case o of
      OString o -> return o
      _         -> throwBadTypeError msg o [(argNum, OInt i)]

----------------------------------------------------------------------------------------------------

_updateToInfixOp :: UpdateOp -> InfixOp
_updateToInfixOp = (arr!) where
  arr :: Array UpdateOp InfixOp
  arr = array (UADD, maxBound) $
    [ (UADD  , ADD )
    , (USUB  , SUB )
    , (UMULT , MULT)
    , (UDIV  , DIV )
    , (UMOD  , MOD )
    , (UPOW  , POW )
    , (UORB  , ORB )
    , (UANDB , ANDB)
    , (UXORB , XORB)
    , (USHL  , SHL )
    , (USHR  , SHR )
    ]

instance ToDaoStructClass UpdateOp where { toDaoStruct = putNullaryUsingShow }

instance FromDaoStructClass UpdateOp where { fromDaoStruct = getNullaryWithRead }

instance ObjectClass UpdateOp where { obj=new; fromObj=objFromHata; }

instance HataClass UpdateOp where
  haskellDataInterface = interface "UpdateOperator" $ do
    autoDefEquality >> autoDefOrdering >> autoDefBinaryFmt
    autoDefToStruct >> autoDefFromStruct

----------------------------------------------------------------------------------------------------

instance ToDaoStructClass RefPfxOp where { toDaoStruct = putNullaryUsingShow }

instance FromDaoStructClass RefPfxOp where { fromDaoStruct = getNullaryWithRead }

instance ObjectClass RefPfxOp where { obj=new; fromObj=objFromHata; }

instance HataClass RefPfxOp where
  haskellDataInterface = interface "ReferenceOperator" $ do
    autoDefEquality >> autoDefOrdering
    autoDefToStruct >> autoDefFromStruct

----------------------------------------------------------------------------------------------------

instance ToDaoStructClass ArithPfxOp where { toDaoStruct = putNullaryUsingShow }

instance FromDaoStructClass ArithPfxOp where { fromDaoStruct = getNullaryWithRead }

instance ObjectClass ArithPfxOp where { obj=new; fromObj=objFromHata; }

instance HataClass ArithPfxOp where
  haskellDataInterface = interface "ArithmeticPrefixOperator" $ do
    autoDefEquality >> autoDefOrdering >> autoDefBinaryFmt
    autoDefToStruct >> autoDefFromStruct

----------------------------------------------------------------------------------------------------

instance ToDaoStructClass InfixOp where { toDaoStruct=putNullaryUsingShow; }

instance FromDaoStructClass InfixOp where { fromDaoStruct = getNullaryWithRead }

instance ObjectClass InfixOp where { obj=new; fromObj=objFromHata; }

instance HataClass InfixOp where
  haskellDataInterface = interface "ArithmeticInfixOperator" $ do
    autoDefEquality >> autoDefOrdering >> autoDefBinaryFmt
    autoDefToStruct >> autoDefFromStruct

----------------------------------------------------------------------------------------------------

instance ToDaoStructClass TopLevelEventType where { toDaoStruct = putNullaryUsingShow }

instance FromDaoStructClass TopLevelEventType where { fromDaoStruct = getNullaryWithRead }

instance ObjectClass TopLevelEventType where { obj=new; fromObj=objFromHata; }

instance HataClass TopLevelEventType where
  haskellDataInterface = interface "TopLevelEventType" $ do
    autoDefEquality >> autoDefOrdering
    autoDefToStruct >> autoDefFromStruct

----------------------------------------------------------------------------------------------------

evalArithPrefixOp :: ArithPfxOp -> Object -> XPure Object
evalArithPrefixOp = (_arithPrefixOps!)

_arithPrefixOps :: Array ArithPfxOp (Object -> XPure Object)
_arithPrefixOps = array (minBound, maxBound) $ defaults ++
  [ o NEGTIV eval_NEG
  , o POSTIV return
  , o INVB   eval_INVB
  , o NOT    eval_NOT
  ]
  where
    o = (,)
    defaults = flip map [minBound..maxBound] $ \op ->
      (op, \_ -> error $ "no builtin function for prefix "++show op++" operator")

evalInfixOp :: InfixOp -> Object -> Object -> XPure Object
evalInfixOp op a b = msum $ f a ++ f b ++ [(_infixOps!op) a b] where
  f = maybe [] return . (fromObj >=> getOp)
  getOp (Hata ifc a) = (\f -> f op a b) <$> (objInfixOpTable ifc >>= (! op))

_infixOps :: Array InfixOp (Object -> Object -> XPure Object)
_infixOps = array (minBound, maxBound) $ defaults ++
  [ o ADD   eval_ADD
  , o SUB   eval_SUB
  , o MULT  eval_MULT
  , o DIV   eval_DIV
  , o MOD   eval_MOD
  , o POW   eval_POW
  , o SHL   eval_SHL
  , o SHR   eval_SHR
  , o ORB   eval_ORB
  , o ANDB  eval_ANDB
  , o XORB  eval_XORB
  , o OR    (error (e "logical-OR" )) -- These probably wont be evaluated. Locgical and/or is a
  , o AND   (error (e "logical-AND")) -- special case to be evaluated in 'evalObjectExprWithLoc'.
  , o EQUL  eval_EQUL
  , o NEQUL eval_NEQUL
  , o GTN   eval_GTN
  , o LTN   eval_LTN
  , o GTEQ  eval_GTEQ
  , o LTEQ  eval_LTEQ
  , o ARROW (error (e "ARROW"))
  ]
  where
    o = (,)
    defaults = flip map [minBound..maxBound] $ \op ->
      (op, \_ _ -> error $ "no builtin function for infix "++show op++" operator")
    e msg = msg ++
      " operator should have been evaluated within the 'execute' function."

-- | Evaluate an 'UpdateOp' operator. Provide an optional 'Reference' indicating the reference
-- location of the value being updated, then the 'UpdateOp' operator, the right-hand side 'Object'
-- value, and finally the current value stored at the 'Reference' location that needs to be updated.
-- If the 'UpdateOp' is 'UCONST', the current value may be 'Prelude.Nothing' as any current value
-- will be overwritten. If the 'UpdateOp' is not 'UCONST' and the current value is
-- 'Prelude.Nothing', this is an error. Otherwise the current value is removed from the
-- 'Prelude.Just' constructor and used as the left-hand operand with the right-hand operand of the
-- appropriate arithmetic function associated with the 'UpdateOp'.
evalUpdateOp :: Maybe Reference -> UpdateOp -> Object -> Maybe Object -> Exec (Maybe Object)
evalUpdateOp qref op newObj oldObj = case op of
  UCONST -> return $ Just newObj
  op     -> case oldObj of
    Nothing     ->
      execThrow "performed update on void value" (ExecUpdateOpError op)
        (maybe [] (\qref -> [(errOfReference, obj qref)]) qref)
    Just oldObj -> Just <$> execute (evalInfixOp (_updateToInfixOp op) oldObj newObj)

_updatingOps :: Array UpdateOp (Object -> Object -> XPure Object)
_updatingOps = let o = (,) in array (minBound, maxBound) $ defaults ++
  [ o UCONST (\_ b -> return b)
  , o UADD   eval_ADD
  , o USUB   eval_SUB
  , o UMULT  eval_MULT
  , o UDIV   eval_DIV
  , o UMOD   eval_MOD
  , o UORB   eval_ORB
  , o UANDB  eval_ANDB
  , o UXORB  eval_XORB
  , o USHL   eval_SHL
  , o USHR   eval_SHR
  ]
  where
    defaults = flip map [minBound..maxBound] $ \op ->
      (op, \_ _ -> error $ "no builtin function for update operator "++show op)

----------------------------------------------------------------------------------------------------

_strObjConcat :: [Object] -> String
_strObjConcat ox = ox >>= \o -> maybe [toUStr $ prettyShow o] return (fromObj o) >>= uchars

makePrintFunc :: (typ -> String -> Exec ()) -> DaoFunc typ
makePrintFunc print =
  daoFunc
  { funcAutoDerefParams = True
  , daoForeignFunc = \typ ox -> print typ (_strObjConcat ox) >> return (Nothing, typ)
  }

builtin_print :: DaoFunc ()
builtin_print   = makePrintFunc (\ () -> liftIO . (putStr >=> evaluate))

builtin_println :: DaoFunc ()
builtin_println = makePrintFunc (\ () -> liftIO . (putStrLn >=> evaluate))

-- join string elements of a container, pretty prints non-strings and joins those as well.
builtin_join :: DaoFunc ()
builtin_join =
  daoFunc
  { funcAutoDerefParams = True
  , daoForeignFunc = \ () ox -> return $ flip (,) () $ Just $ obj $ case ox of
      OString j : ox -> (>>=uchars) $
        intersperse j $ snd (objConcat ox) >>= \o ->
          [maybe (ustr $ prettyShow o) id (fromObj o :: Maybe UStr)]
      ox -> _strObjConcat ox
  }

builtin_str :: DaoFunc ()
builtin_str =
  daoFunc
  { funcAutoDerefParams = True
  , daoForeignFunc = \ () -> return . flip (,) () . Just . obj . _strObjConcat
  }

builtin_quote :: DaoFunc ()
builtin_quote =
  daoFunc
  { funcAutoDerefParams = True
  , daoForeignFunc = \ () -> return . flip (,) () . Just . obj . show . _strObjConcat
  }

builtin_concat :: DaoFunc ()
builtin_concat =
  daoFunc
  { funcAutoDerefParams = True
  , daoForeignFunc = \ () -> return . flip (,) () . Just . obj . fix (\loop ox -> ox >>= \o -> maybe [o] loop (fromObj o))
  }

builtin_concat1 :: DaoFunc ()
builtin_concat1 =
  daoFunc
  { funcAutoDerefParams = True
  , daoForeignFunc = \ () -> return . flip (,) () . Just . obj . snd . objConcat
  }

builtin_reverse :: DaoFunc ()
builtin_reverse =
  daoFunc
  { funcAutoDerefParams = True
  , daoForeignFunc = \ () -> return . flip (,) () . Just . obj . reverse . snd . objConcat
  }

_castNumerical :: String -> (Object -> Exec Object) -> DaoFunc ()
_castNumerical name f = let n = ustr name :: Name in
  daoFunc
  { funcAutoDerefParams = True
  , daoForeignFunc = \ () ox -> case ox of
      [o] -> (flip (,) () . Just <$> f o) <|> throwBadTypeError "cannot cast to numerical type" o []
      ox  -> throwArityError "" 1 ox [(errInFunc, obj $ reference UNQUAL n)]
  }

builtin_int :: DaoFunc ()
builtin_int = _castNumerical "int" $
  fmap OInt . (execute . castToCoreType IntType >=> xmaybe . fromObj)

builtin_long :: DaoFunc ()
builtin_long = _castNumerical "long" $
  fmap OLong . (execute . castToCoreType LongType >=> xmaybe . fromObj)

builtin_ratio :: DaoFunc ()
builtin_ratio = _castNumerical "ratio" $
  fmap ORatio . (execute . castToCoreType RatioType >=> xmaybe . fromObj)

builtin_float :: DaoFunc ()
builtin_float = _castNumerical "float" $
  fmap OFloat . (execute . castToCoreType FloatType >=> xmaybe . fromObj)

builtin_complex :: DaoFunc ()
builtin_complex = _castNumerical "complex" $
  fmap OComplex . (execute . castToCoreType ComplexType >=> xmaybe . fromObj)

builtin_imag :: DaoFunc ()
builtin_imag = _castNumerical "imag" $
  fmap (OFloat . imagPart) . (execute . castToCoreType ComplexType >=> xmaybe . fromObj)

builtin_phase :: DaoFunc ()
builtin_phase = _castNumerical "phase" $
  fmap (OFloat . phase) . (execute . castToCoreType ComplexType >=> xmaybe . fromObj)

builtin_conj :: DaoFunc ()
builtin_conj = _castNumerical "conj" $
  fmap (OComplex . conjugate) . (execute . castToCoreType ComplexType >=> xmaybe . fromObj)

builtin_abs :: DaoFunc ()
builtin_abs = _castNumerical "abs" $ execute . asPositive

builtin_time :: DaoFunc ()
builtin_time = _castNumerical "time" $ \o -> case o of
  ORelTime _ -> return o
  o          -> (ORelTime . fromRational) <$> execute (asRational o)

_funcWithoutParams :: String -> Exec (Maybe Object) -> DaoFunc ()
_funcWithoutParams name f =
  daoFunc
  { daoForeignFunc = \ () ox -> case ox of
      [] -> flip (,) () <$> f
      ox -> throwArityError "function takes no parameters" 0 ox $
        [(errInFunc, obj $ reference UNQUAL (ustr name))]
  }

builtin_now :: DaoFunc ()
builtin_now = _funcWithoutParams "now" $ (Just . obj) <$> liftIO getCurrentTime

builtin_ref :: DaoFunc ()
builtin_ref =
  daoFunc
  { daoForeignFunc = \ () -> fmap (flip (,) () . Just . ORef) . execute . mconcat .
      fmap (\o -> (castToCoreType RefType o) <|>
             (throwBadTypeError "could not convert to reference" o []) >>=
               (castToCoreType RefType >=> xmaybe . fromObj)
           )
  }

builtin_check_if_defined :: DaoFunc ()
builtin_check_if_defined =
  daoFunc
  { funcAutoDerefParams = False
  , daoForeignFunc = \ () args -> fmap (flip (,) () . Just . obj . and) $ forM args $ \arg -> case arg of
      ORef o -> catchError (referenceLookup o >> return True) $ \err -> case err of
        ExecError{ execErrorSubtype=ExecUndefinedRef _ } -> return False
        err                                              -> throwError err
      _      -> return True
  }

builtin_delete :: DaoFunc ()
builtin_delete =
  daoFunc
  { funcAutoDerefParams = False
  , daoForeignFunc = \ () args -> do
      forM_ args $ \arg -> case arg of
        ORef o -> void $ referenceUpdate o True (const $ return Nothing)
        _      -> return ()
      return (Nothing, ())
  }

builtin_typeof :: DaoFunc ()
builtin_typeof =
  daoFunc
  { daoForeignFunc = \ () ox -> return $ flip (,) () $ case ox of
      []  -> Nothing
      [o] -> Just $ OType $ typeOfObj o
      ox  -> Just $ OList $ map (OType . typeOfObj) ox
  }

builtin_sizeof :: DaoFunc ()
builtin_sizeof =
  daoFunc
  { daoForeignFunc = \ () ox -> case ox of
      [o] -> flip (,) () . Just <$> getSizeOf o
      ox  -> throwArityError "" 1 ox [(errInFunc, obj $ reference UNQUAL (ustr "sizeof"))]
  }

builtin_call :: DaoFunc ()
builtin_call =
  daoFunc
  { funcAutoDerefParams = False
  , daoForeignFunc = \ () ox -> case ox of
      [func, params] -> do
        let nonlist_err = fail "second parameter to \"call()\" function is not a list of arguments"
        params <- case params of
          OList params -> return params
          ORef  params -> referenceLookup params >>= \ (_, params) -> case params of
            Nothing     -> fail "second parameter parameter to \"call()\" function evaluated to null"
            Just params -> xmaybe (fromObj params) <|> nonlist_err
          _ -> nonlist_err
        qref <- xmaybe (fromObj func)
          <|> fail "first parameter to \"call()\" function is not a reference to a function"
        (qref, func) <- referenceLookup qref
        case func of
          Nothing   -> fail "first parameter to \"call()\" function evaluated to null"
          Just func -> fmap (const ()) <$> callObject qref func params
      _ -> fail $ unwords $
        [ "the \"call()\" function was evaluated with incorrect arguments."
        , "Expecting a reference to function as first parameter"
        , "and a list of arguments as the second parameter."
        ]
  }

builtin_toHash :: DaoFunc ()
builtin_toHash =
  daoFunc
  { daoForeignFunc = \ () ox -> do
      let qref = reference UNQUAL (ustr "toHash")
      let err  = throwArityError "" 1 ox [(errInFunc, obj qref)]
      case ox of
        [o] -> case o of
          OTree              _  -> return (Just o, ())
          OHaskell (Hata ifc d) -> case objToStruct ifc of
            Just to -> flip (,) () . Just . OTree <$> toDaoStructExec to d
            Nothing -> throwBadTypeError "data type is opaque, cannot do binary conversion for hash" o $
              [(errInFunc, obj qref)]
          _                     -> err
        _   -> err
  }

builtin_fromHash :: DaoFunc ()
builtin_fromHash =
  daoFunc
  { daoForeignFunc = \ () ox -> do
      let qref = reference UNQUAL (ustr "fromHash")
      case ox of
        [o] -> do
          let err = throwBadTypeError "hashed Struct parameter required" o [(errInFunc, obj qref)]
          xmaybe (fromObj o) <|> err >>= fmap (flip (,) () . Just . obj) . fromDaoStructExec 
        ox  -> throwArityError "" 1 ox [(errInFunc, obj qref)]
  }

builtin_tokenize :: DaoFunc ()
builtin_tokenize =
  daoFunc{ daoForeignFunc = \ () -> fmap (flip (,) () . Just . obj . map obj) . runTokenizer }

----------------------------------------------------------------------------------------------------

-- binary 0x42 0x45 RefSuffixExpr-->RefSuffix
instance B.Binary (RefSuffixExpr Object) MTab where
  put o = case o of
    NullRefExpr         -> B.putWord8   0x42
    DotRefExpr    a b c -> B.prefixByte 0x43 $ B.put a >> B.put b >> B.put c
    SubscriptExpr a b   -> B.prefixByte 0x44 $ B.put a >> B.put b
    FuncCallExpr  a b   -> B.prefixByte 0x45 $ B.put a >> B.put b
  get = B.word8PrefixTable <|> fail "expecting RefSuffixExpr"

instance B.HasPrefixTable (RefSuffixExpr Object) B.Byte MTab where
  prefixTable = B.mkPrefixTableWord8 "RefSuffixExpr" 0x42 0x45 $
    [ return NullRefExpr
    , return DotRefExpr    <*> B.get <*> B.get <*> B.get
    , return SubscriptExpr <*> B.get <*> B.get
    , return FuncCallExpr  <*> B.get <*> B.get
    ]

instance Executable (RefSuffixExpr Object) RefSuffix where
  execute o = errLocation o $ case o of
    NullRefExpr              -> return NullRef
    DotRefExpr    name ref _ -> DotRef name <$> execute ref
    SubscriptExpr args ref   -> return Subscript <*> execute args <*> execute ref
    FuncCallExpr  args ref   -> return FuncCall  <*> execute args <*> execute ref

----------------------------------------------------------------------------------------------------

-- | To evaluate an 'Object' value against a type expression, you can store the
-- 'Object' into a 'TyChkExpr' and 'execute' it. This instance of
-- 'execute' evaluates a type checking monad computing over the 'tyChkExpr' in
-- the 'TyChkExpr'. If the type check determines the 'Object' value does not match, this
-- function backtracks. If the type check is successful, the most general type value for the object
-- if that type value is less-general or as-general as the 'TyChkExpr' provided.
instance Executable (TyChkExpr Object Object) Object where
  execute tc = case tc of
    NotTypeChecked _          -> return OTrue -- TODO: this needs to return the 'AnyType', not 'OTrue'.
    TypeChecked    _ _ _      -> return OTrue -- TODO: evaluate the actual type checking algorithm here
    DisableCheck   _ _ rslt _ -> return rslt

-- | Convert an 'ObjectExpr' to an 'Dao.Glob.Glob'.
paramsToGlobExpr :: ObjectExpr Object -> Exec (Glob UStr)
paramsToGlobExpr o = case o of
  ObjLiteralExpr (LiteralExpr (OString str) _) -> return (read (uchars str))
  _ -> fail "does not evaluate to a \"glob\" pattern"

-- | Called by 'callFunction' to match the list of 'Object's passed as arguments to the function.
-- Returns two 'T_dict's: the first is the 'T_dict' to be passed to 'execFuncPushStack', the second
-- is the dictionary of local variables passed by reference. Backtracks if any types do not match,
-- or if there are an incorrect number of parameters. Backtracking is important because of function
-- overloading.
matchFuncParams :: ParamListExpr Object -> [Object] -> Exec T_dict
matchFuncParams (ParamListExpr params _) ox = loop (0::Int) M.empty (tyChkItem params) ox where
  loop i dict params ox = case ox of
    [] | null params -> return dict
    [] -> mzero -- not enough parameters passed to function
    o:ox -> case params of
      [] -> mzero -- too many parameters passed to function
      ParamExpr passByRef tychk _ : params -> do
        let name = tyChkItem tychk
        execute $ fmapCheckedValueExpr (const o) tychk -- execute (TyChkExpr Object)
        o <- if passByRef then (case o of { ORef _ -> return o; _ -> mzero }) else derefObject o
        loop (i+1) (M.insert name o dict) params ox

-- | A guard script is some Dao script that is executed before or after some event, for example, the
-- code found in the @BEGIN@ and @END@ blocks.
execGuardBlock :: [ScriptExpr Object] -> Exec ()
execGuardBlock block = void $
  execFuncPushStack M.empty (mapM_ execute block >> return Nothing) >> return ()

-- | Takes two parameters: first is an error message parameter, the second is the 'Object' to be
-- called. The 'Object' to be called should be an 'OHaskell' constructed value containing a
-- 'Hata' where the 'interface' has defined 'defCallable'. If so, the 'CallableCode' objects
-- returned by 'objCallable' will be returned by this function. If not, 
objToCallable :: Object -> Exec [CallableCode]
objToCallable o = case fromObj o >>= \ (Hata ifc o) -> fmap ($ o) (objCallable ifc) of
  Nothing -> mzero
  Just  f -> f

-- | 'CallableCode' objects are usually stored in lists because of function overloading: e.g. a
-- function with a single name but is defined with multiple parameter lists would have several
-- 'CallableCode' objects associated with that function mame. This function tries to perform a
-- function call with a list of parameters. The parameters are matched to each 'CallableCode'
-- object's 'argsPattern', the first 'argsPattern' that matches without backtracking will evaluate
-- the function body. The value returned is a pair containing the result of the function call as the
-- 'Prelude.fst', and update "this" value as 'Prelude.snd'
callCallables :: Maybe Object -> [CallableCode] -> [Object] -> Exec (Maybe Object, Maybe Object)
callCallables this funcs params = fmap (fmap (M.lookup (ustr "this"))) $ join $
  msum $ flip fmap funcs $ \call -> matchFuncParams (argsPattern call) params >>=
    return . flip execFuncPushStack (execute $ codeSubroutine call) . M.alter (const this) (ustr "this")

-- | This function assumes you have retrieved a callable function-like 'Object' using a 'Reference'.
-- This function evaluates 'callCallables', and extracts the 'CallableCode' from the 'Object'
-- provided as the second parameter using 'objToCallable'. The 'Reference' passed as the first
-- parameter should be the reference used to retrieve the function 'Object'. If the given object
-- provides a 'defCallable' callback, the object can be called with parameters as if it were a
-- function.
callObject :: Reference -> Object -> [Object] -> Exec (Maybe Object, Maybe Object)
callObject qref o params = case o of
  OHaskell (Hata ifc d) -> case fromDynamic d of
    Just func -> fmap (const Nothing) <$> executeDaoFunc func () params -- try calling an ordinary function
    Nothing   -> case objCallable ifc of
      Just getFuncs -> getFuncs d >>= \func -> callCallables (Just o) func params
      Nothing       -> err
  _ -> err
  where { err = throwBadTypeError "not a callable object" o [(errInFunc, obj qref)] }

-- | Evaluate to 'procErr' if the given 'Predicate' is 'Backtrack' or 'PFail'. You must pass a
-- 'Prelude.String' as the message to be used when the given 'Predicate' is 'Backtrack'. You can also
-- pass a list of 'Object's that you are checking, these objects will be included in the
-- 'procErr' value.
--     This function should be used for cases when you have converted 'Object' to a
-- Haskell value, because 'Backtrack' values indicate type exceptions, and 'PFail' values indicate a
-- value error (e.g. out of bounds, or some kind of assert exception), and the messages passed to
-- 'procErr' will indicate this.
checkPredicate :: String -> [Object] -> Exec a -> Exec a
checkPredicate altmsg tried f = do
  pval <- catchPredicate f
  let err = fail (altmsg++" evaulated to void expression")
  case pval of
    OK    a                     -> return a
    Backtrack                   -> err
    PFail (ExecReturn Nothing)  -> err
    PFail  err                  -> throwError $
      err{  execReturnValue = Just $ case execReturnValue err of
              Just (OList ox) -> obj $ tried ++ ox
              Just        o   -> obj $ tried ++ [o]
              Nothing         -> obj tried
         }

-- | 'evalObjectExprExpr' can return 'Data.Maybe.Nothing', and usually this happens when something has
-- failed (e.g. reference lookups), but it is not always an error (e.g. a void list of argument to
-- functions). If you want 'Data.Maybe.Nothing' to cause an error, evaluate your
-- @'Exec' ('Data.Maybe.Maybe' 'Object')@ as a parameter to this function.
checkVoid :: Location -> String -> Maybe a -> Exec a
checkVoid loc msg fn = case fn of
  Nothing -> throwError $
    newError
    { execErrorMessage  = ustr (msg++" evaluated to void")
    , execErrorLocation = loc
    }
  Just  a -> return a

instance ToDaoStructClass (AST_RefSuffix Object) where
  toDaoStruct = ask >>= \o -> case o of
    AST_RefNull                 -> makeNullary "Null"
    AST_DotRef dot name ref loc -> renameConstructor "DotRef" $ do
      "dot" .= dot >> "head" .= name >> "tail" .= ref >> putLocation loc
    AST_Subscript  args ref -> renameConstructor "Subscript" $ do
      "args" .= args >> "tail" .= ref >> return ()
    AST_FuncCall   args ref -> renameConstructor "FuncCall" $ do
      "args" .= args >> "tail" .= ref >> return ()

instance FromDaoStructClass (AST_RefSuffix Object) where
  fromDaoStruct = msum $
    [ constructor "Null"   >> return AST_RefNull
    , constructor "DotRef" >> return AST_DotRef <*> req "dot" <*> req "head" <*> req "tail" <*> location
    , constructor "Subscript" >> return AST_Subscript <*> req "args" <*> req "tail"
    , constructor "FuncCall"  >> return AST_FuncCall  <*> req "args" <*> req "tail"
    ]

instance ObjectClass (AST_RefSuffix Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (AST_RefSuffix Object) where
  haskellDataInterface = interface "RefSuffixExpression" $ do
    autoDefEquality >> autoDefOrdering >> autoDefPPrinter
    autoDefToStruct >> autoDefFromStruct

----------------------------------------------------------------------------------------------------

-- | If an expression is inside of a 'ParenExpr', like it usually is after being parsed as part of
-- an @if@ or @while@ statement, this function evaluates the expression to a 'Prelude.Bool' value
-- used to determine if the conditional expression should be 'execute'd.
evalConditional :: ParenExpr Object -> Exec Bool
evalConditional o =
  (execute o :: Exec (Maybe Object)) >>=
    checkVoid (getLocation o) "conditional expression to if statement" >>= derefObject >>=
      execHandleIO [fmap (const False) execIOHandler] . return . not . testNull

-- binary 0x59 
instance B.Binary (ParenExpr Object) MTab where
  put (ParenExpr a b) = B.prefixByte 0x59 $ B.put a >> B.put b
  get = B.word8PrefixTable <|> fail "expecting ParenExpr"

instance B.HasPrefixTable (ParenExpr Object) B.Byte MTab where
  prefixTable = B.mkPrefixTableWord8 "ParenExpr" 0x59 0x59 $
    [return ParenExpr <*> B.get <*> B.get]

instance Executable (ParenExpr Object) (Maybe Object) where { execute (ParenExpr a _) = execute a }

instance ObjectClass (ParenExpr Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (ParenExpr Object) where
  haskellDataInterface = interface "Parentheses" $ do
    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefBinaryFmt
    -- autoDefToStruct >> autoDefFromStruct

----------------------------------------------------------------------------------------------------

instance ToDaoStructClass (AST_Paren Object) where
  toDaoStruct = renameConstructor "Paren" $ ask >>= \o -> case o of
    AST_Paren paren loc -> "inside" .= paren >> putLocation loc

instance FromDaoStructClass (AST_Paren Object) where
  fromDaoStruct = constructor "Paren" >> return AST_Paren <*> req "inside" <*> location

instance ObjectClass (AST_Paren Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (AST_Paren Object) where
  haskellDataInterface = interface "ParenthesesExpression" $ do
    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter
    autoDefToStruct >> autoDefFromStruct

----------------------------------------------------------------------------------------------------

instance B.Binary (IfExpr Object) MTab where
  put (IfExpr a b c) = B.put a >> B.put b >> B.put c
  get = return IfExpr <*> B.get <*> B.get <*> B.get

instance Executable (IfExpr Object) Bool where
  execute (IfExpr ifn thn _) = execNested_ M.empty $
    evalConditional ifn >>= \test -> when test (execute thn) >> return test

instance ObjectClass (IfExpr Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (IfExpr Object) where
  haskellDataInterface = interface "Conditional" $ do
    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefBinaryFmt

----------------------------------------------------------------------------------------------------

instance ToDaoStructClass (AST_If Object) where
  toDaoStruct = renameConstructor "Conditional" $ ask >>= \o -> case o of
    AST_If ifn thn loc -> "condition" .= ifn >> "action" .= thn >> putLocation loc

instance FromDaoStructClass (AST_If Object) where
  fromDaoStruct = constructor "Conditional" >>
    return AST_If <*> req "condition" <*> req "action" <*> location

instance ObjectClass (AST_If Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (AST_If Object) where
  haskellDataInterface = interface "ConditionalExpression" $ do
    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter
    autoDefToStruct >> autoDefFromStruct

----------------------------------------------------------------------------------------------------

-- binary 0xB6 
instance B.Binary (ElseExpr Object) MTab where
  put (ElseExpr a b) = B.prefixByte 0xB6 $ B.put a >> B.put b
  get = (B.tryWord8 0xB6 $ return ElseExpr <*> B.get <*> B.get) <|> fail "expecting ElseExpr"

instance Executable (ElseExpr Object) Bool where { execute (ElseExpr ifn _) = execute ifn }

instance ObjectClass (ElseExpr Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (ElseExpr Object) where
  haskellDataInterface = interface "Else" $ do
    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefBinaryFmt

----------------------------------------------------------------------------------------------------

instance ToDaoStructClass (AST_Else Object) where
  toDaoStruct = ask >>= \o -> case o of
    AST_Else coms ifn loc -> renameConstructor "ElseIf" $ do
      "comments" .= coms >> "elseIf" .= ifn >> putLocation loc

instance FromDaoStructClass (AST_Else Object) where
  fromDaoStruct = constructor "ElseIf" >>
    return AST_Else <*> req "comments" <*> req "elseIf" <*> location

instance ObjectClass (AST_Else Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (AST_Else Object) where
  haskellDataInterface = interface "ElseExpression" $ do
    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter
    autoDefToStruct >> autoDefFromStruct

----------------------------------------------------------------------------------------------------

-- binary 0xBA 
instance B.Binary (IfElseExpr Object) MTab where
  put (IfElseExpr a b c d) = B.prefixByte 0xBA $ B.put a >> B.put b >> B.put c >> B.put d
  get = B.word8PrefixTable <|> fail "expecting IfElseExpr"

instance B.HasPrefixTable (IfElseExpr Object) B.Byte MTab where
  prefixTable = B.mkPrefixTableWord8 "IfElseExpr" 0xBA 0xBA $
    [return IfElseExpr <*> B.get <*> B.get <*> B.get <*> B.get]

instance Executable (IfElseExpr Object) () where
  execute (IfElseExpr ifn elsx final _loc) = do
    let tryEach elsx = case elsx of
          []       -> return False
          els:elsx -> execute els >>= \ok -> if ok then return ok else tryEach elsx
    (execute ifn >>= \ok ->
      if ok then return Nothing
            else tryEach elsx >>= \ok ->
                 if ok then return Nothing
                       else return final) >>= maybe (return ()) execute

instance ObjectClass (IfElseExpr Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (IfElseExpr Object) where
  haskellDataInterface = interface "IfElse" $ do
    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefBinaryFmt

----------------------------------------------------------------------------------------------------

instance ToDaoStructClass (AST_IfElse Object) where
  toDaoStruct = ask >>= \o -> case o of
    AST_IfElse ifn els block loc -> renameConstructor "If" $ do
      "test" .= ifn >> "alt" .= listToObj els
      maybe (return ()) (void . defObjField "finalElse") block
      putLocation loc

instance FromDaoStructClass (AST_IfElse Object) where
  fromDaoStruct = constructor "If" >>
    return AST_IfElse
      <*> req "test"
      <*> reqList "alt"
      <*> opt "finalElse"
      <*> location

instance ObjectClass (AST_IfElse Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (AST_IfElse Object) where
  haskellDataInterface = interface "IfElseExpression" $ do
    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter
    autoDefToStruct >> autoDefFromStruct

----------------------------------------------------------------------------------------------------

-- binary (not prefixed, always occurs within a list)
instance B.Binary (LastElseExpr Object) MTab where
  put (LastElseExpr a loc) = B.put a >> B.put loc
  get = (return LastElseExpr <*> B.get <*> B.get) <|> fail "expecting LastElseExpr"

instance Executable (LastElseExpr Object) () where { execute (LastElseExpr code _) = execute code }

instance ObjectClass (LastElseExpr Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (LastElseExpr Object) where
  haskellDataInterface = interface "FinalElse" $ do
    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefBinaryFmt

----------------------------------------------------------------------------------------------------

instance ToDaoStructClass (AST_LastElse Object) where
  toDaoStruct = renameConstructor "LastElse" $ do
    (AST_LastElse coms code loc) <- ask
    "comments" .= coms >> "action" .= code >> putLocation loc

instance FromDaoStructClass (AST_LastElse Object) where
  fromDaoStruct = constructor "LastElse" >>
    return AST_LastElse <*> req "comments" <*> req "action" <*> location

instance ObjectClass (AST_LastElse Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (AST_LastElse Object) where
  haskellDataInterface = interface "FinalElseExpression" $ do
    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter
    autoDefToStruct >> autoDefFromStruct

----------------------------------------------------------------------------------------------------

-- binary (not prefixed, always occurs within a list)
instance B.Binary (CatchExpr Object) MTab where
  put (CatchExpr a b loc) = B.put a >> B.put b >> B.put loc
  get = return CatchExpr <*> B.get <*> B.get <*> B.get

instance ObjectClass (CatchExpr Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (CatchExpr Object) where
  haskellDataInterface = interface "CatchExpr" $ do
    autoDefEquality >> autoDefOrdering >> autoDefBinaryFmt

-- | Returns the 'Exec' function to be evaluated if the 'ExecControl' matches the 'CatchExpr' type
-- constraint. If the type constraint does not match, this function evaluates to
-- 'Control.Monad.mzero'.
executeCatchExpr :: ExecControl -> CatchExpr Object -> Exec (Exec ())
executeCatchExpr err (CatchExpr (ParamExpr _refd param _) catch _loc) = case param of -- TODO: do something with _refd
  NotTypeChecked name             -> ex name catch
  TypeChecked    name _check _loc -> ex name catch -- TODO: do something with _check
  DisableCheck   name _  _   _    -> ex name catch
  where
    ex name catch = return $ execNested_ M.empty $ localVarDefine name (new err) >> execute catch

----------------------------------------------------------------------------------------------------

instance ToDaoStructClass (AST_Catch Object) where
  toDaoStruct = ask >>= \ (AST_Catch coms param action loc) -> renameConstructor "Catch" $ do
    "comments" .= coms >> "test" .= param >> "action" .= action >> putLocation loc

instance FromDaoStructClass (AST_Catch Object) where
  fromDaoStruct = constructor "Catch" >>
    return AST_Catch <*> req "comments" <*> req "test" <*> req "action" <*> location

instance ObjectClass (AST_Catch Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (AST_Catch Object) where
  haskellDataInterface = interface "CatchExpression" $ do
    autoDefEquality >> autoDefOrdering >> autoDefPPrinter
    autoDefToStruct >> autoDefFromStruct

----------------------------------------------------------------------------------------------------

-- binary 0x85 
instance B.Binary (WhileExpr Object) MTab where
  put (WhileExpr o) = B.prefixByte 0x85 $ B.put o
  get = B.word8PrefixTable <|> fail "expecting WhileExpr"

instance B.HasPrefixTable (WhileExpr Object) B.Byte MTab where
  prefixTable = B.mkPrefixTableWord8 "WhileExpr" 0x85 0x85 [WhileExpr <$> B.get]

instance Executable (WhileExpr Object) () where
  execute (WhileExpr ifn) = fix $ \loop -> catchLoopCtrl (execute ifn) return >>= flip when loop

instance ObjectClass (WhileExpr Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (WhileExpr Object) where
  haskellDataInterface = interface "While" $ do
    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefBinaryFmt

----------------------------------------------------------------------------------------------------

instance ToDaoStructClass (AST_While Object) where
  toDaoStruct = renameConstructor "While" $ ask >>= \ (AST_While o) -> innerToStruct o

instance FromDaoStructClass (AST_While Object) where
  fromDaoStruct = constructor "While" >> AST_While <$> innerFromStruct "Conditional"

instance ObjectClass (AST_While Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (AST_While Object) where
  haskellDataInterface = interface "WhileExpression" $ do
    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter
    autoDefToStruct >> autoDefFromStruct

----------------------------------------------------------------------------------------------------

-- binary 0xA8 0xAF
instance B.Binary (ScriptExpr Object) MTab where
  put o = case o of
    IfThenElse   a           -> B.put a
    WhileLoop    a           -> B.put a
    RuleFuncExpr a           -> B.put a
    EvalObject   a         z -> B.prefixByte 0xA8 $ B.put a >> B.put z
    TryCatch     a     b c z -> B.prefixByte 0xA9 $ B.put a >> B.put b >> B.put c >> B.put z
    ForLoop      a     b c z -> B.prefixByte 0xAA $ B.put a >> B.put b >> B.put c >> B.put z
    ContinueExpr True  b   z -> B.prefixByte 0xAB $ B.put b >> B.put z
    ContinueExpr False b   z -> B.prefixByte 0xAC $ B.put b >> B.put z
    ReturnExpr   True  b   z -> B.prefixByte 0xAD $ B.put b >> B.put z
    ReturnExpr   False b   z -> B.prefixByte 0xAE $ B.put b >> B.put z
    WithDoc      a     b   z -> B.prefixByte 0xAF $ B.put a >> B.put b >> B.put z
  get = B.word8PrefixTable <|> fail "expecting ScriptExpr"

instance B.HasPrefixTable (ScriptExpr Object) B.Byte MTab where
  prefixTable = mconcat $
    [ fmap IfThenElse B.prefixTable
    , fmap WhileLoop  B.prefixTable
    , fmap RuleFuncExpr B.prefixTable
    , B.mkPrefixTableWord8 "ScriptExpr" 0xA8 0xAF $ -- 0x89 0x8A 0x8B 0x8C 0x8D 0x8E 0x8F 0x90
        [ return EvalObject   <*> B.get <*> B.get
        , return TryCatch     <*> B.get <*> B.get <*> B.get <*> B.get
        , return ForLoop      <*> B.get <*> B.get <*> B.get <*> B.get
        , return (ContinueExpr True ) <*> B.get <*> B.get
        , return (ContinueExpr False) <*> B.get <*> B.get
        , return (ReturnExpr   True ) <*> B.get <*> B.get
        , return (ReturnExpr   False) <*> B.get <*> B.get
        , return WithDoc      <*> B.get <*> B.get <*> B.get
        ]
    ]

-- | Convert a single 'ScriptExpr' into a function of value @'Exec' 'Object'@.
instance Executable (ScriptExpr Object) () where
  execute script = errCurrentModule $ errLocation script $ case script of
    IfThenElse   ifn    -> execute ifn
    WhileLoop    ifn    -> execute ifn
    EvalObject   o _loc -> execute (DerefAssignExpr o) >>= return . maybe () (`seq` ())
    RuleFuncExpr rulfn  -> do
      o <- execute rulfn -- this 'execute' handles function expressions
      let dyn o = case o of
            OHaskell (Hata _ h) -> fromDynamic h
            _ -> Nothing
      let getObj :: (ObjectClass o, Typeable o) => Exec o
          getObj = mplus (xmaybe $ o >>= dyn) $ case o of
            Nothing -> fail "RuleFuncExpr evaluated to void"
            Just  o -> throwBadTypeError "RuleFuncExpr evaluated to object of incorrect data type" o []
      let fsub sub = modify $ \xunit -> xunit{currentCodeBlock=Just sub}
      sub <- gets currentCodeBlock
      case sub of
        Nothing  -> case rulfn of
          LambdaExpr{} -> getObj >>= \o ->
            modify $ \xunit -> xunit{ lambdaSet = lambdaSet xunit ++ o }
          RuleExpr{}   -> do
            newtree <- getObj >>= \p -> execute (p::PatternRule)
            modify $ \xunit -> xunit{ ruleSet=T.unionWith (++) (ruleSet xunit) newtree }
          FuncExpr{}   -> return ()
            -- function expressions are placed in the correct store by the above 'execute'
        Just sub -> case rulfn of
          LambdaExpr{} -> getObj >>= \o -> fsub $ sub{ staticLambdas = staticLambdas sub ++ o }
          RuleExpr{}   -> do
            newtree <- getObj >>= \p -> execute (p::PatternRule)
            fsub $ sub{ staticRules=T.unionWith (++) (staticRules sub) newtree }
          FuncExpr{}   -> return ()
            -- function expressions are placed in the correct store by the above 'execute'
    --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --
    TryCatch try els catchers _loc -> do
      ce <- catchPredicate $ execNested_ M.empty (execute try) <|> msum (fmap execute els)
      case ce of
        OK     () -> return ()
        Backtrack -> mzero
        PFail err -> case err of
          ExecReturn{} -> predicate ce
          ExecError{execErrorSubtype=ExecLoopCtrl{}} -> predicate ce
          ExecError{}  -> join $ msum $ fmap (executeCatchExpr err) catchers
    --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --
    ForLoop varName inObj thn _loc -> do
      let run = void $ execute thn
      let readIter   o = execNested_ (M.singleton varName o) run
      let updateIter o = M.lookup varName . snd <$> execNested (maybe M.empty (M.singleton varName) o) run
      let readLoop   o = void $ readForLoop o readIter
      let updateLoop qref o = void $ fmap snd $
            updateForLoop o updateIter >>= referenceUpdate qref False . const . return . Just
      errLocation inObj $ execute inObj >>= maybeDerefObject >>= \ (qref, iter) -> case iter of
        Nothing   -> fail "iterator of for-loop expression evaluated to void"
        Just iter -> case qref of
          Nothing   -> void $ readLoop iter
          Just qref -> case iter of
            OHaskell (Hata ifc _) -> case objUpdateIterable ifc of
              Just  _ -> void $ updateLoop qref iter
              Nothing -> case objReadIterable ifc of
                Just  _ -> void $ readLoop iter
                Nothing -> throwBadTypeError "data type not iterable" iter [(errOfReference, obj qref)]
            _                     -> void $ updateLoop qref iter
      -- NOTE: the for loop iterator IS NOT passed to the 'referenceUpdate' function to be
      -- evaluated. This is to avoid introducing deadlocks in data types that may store their values
      -- in an MVar. The 'referenceLookup' function first evaluates the reference, creating a copy
      -- in the current thread, the for loop is evaluated, and THEN the 'referenceUpdate' function
      -- is evaluated, in those three discrete steps.  It is not possible to evaluate a for loop in
      -- the dao programming language as an atomic action, so race conditions may occur when
      -- updating MVars -- but deadlocks will not occur.
    --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --
    ContinueExpr a    test   _loc -> do
      test <- execute test
      let signal = execThrow "" (loopCtrl a) []
      case test of
        Nothing -> signal
        Just  o -> derefObject o >>= execute . objToBool >>= flip when signal
    --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --
    ReturnExpr returnStmt o _loc -> do
      o <- (execute o :: Exec (Maybe Object)) >>= maybe (return Nothing) (fmap Just . derefObject)
      if returnStmt then throwError (ExecReturn o) else maybe mzero (flip (execThrow "") [] . ExecThrow) o
    --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --
    WithDoc   expr   thn    _loc -> execute expr >>=
      checkVoid (getLocation expr) "target of \"with\" statement" >>=
        flip execWithWithRefStore (execute thn)
    --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --

instance ObjectClass (ScriptExpr Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (ScriptExpr Object) where
  haskellDataInterface = interface "Script" $ do
    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefBinaryFmt

localVarDefine :: Name -> Object -> Exec (Maybe Object)
localVarDefine name o = fmap (snd . fst) $
  runObjectFocus (updateLocal name NullRef $ modify (const $ Just o) >> get) False (reference UNQUAL name) ()

localVarUpdate :: Name -> (Maybe Object -> Maybe Object) -> Exec (Maybe Object)
localVarUpdate name f = fmap (snd . fst) $
  runObjectFocus (updateLocal name NullRef $ modify f >> get) False (reference UNQUAL name) ()

localVarLookup :: Name -> Exec Object
localVarLookup name = 
  (snd . fst) <$> runObjectFocus (updateLocal name NullRef get) True (reference UNQUAL name) () >>=
    maybe mzero return

-- | Like evaluating 'execute' on a value of 'Reference', except the you are evaluating an
-- 'Object' type. If the value of the 'Object' is not constructed with
-- 'ORef', the object value is returned unmodified.
derefObject :: Object -> Exec Object
derefObject = fmap snd . derefObjectGetReference

-- | Like 'derefObject' but also returns the 'Reference' value that was stored in the 'Object' that
-- was dereferenced, along with the dereferenced value. If the 'Object' is not constructed with
-- 'ORef', 'Prelude.Nothing' is returned instead of a 'Reference'.
derefObjectGetReference :: Object -> Exec (Maybe Reference, Object)
derefObjectGetReference o = maybeDerefObject (Just o) >>= \ (r, derefd) -> case derefd of
  Nothing -> case r of
    Nothing -> throwBadTypeError "dereferenced a non-reference value" o []
    Just  r -> execThrow "reference evaluated to void" r [(errOfReference, o)]
  Just derefd -> return (r, derefd)

-- | Tries to dereference an 'Object'. If the 'Object' is an 'ORef' constructed 'Reference', the
-- reference is de-referenced, which may evaluate to 'Prelude.Nothing'. The dereferenced value is
-- returned in the 'Prelude.snd' of the pair. If the given 'Object' is an 'ORef', regardless of the
-- dereferenced value, the 'Reference' is returned in the 'Prelude.fst' of the pair. If the given
-- 'Object' is not an 'ORef' constructed 'Object', it is returned unmodified along with
-- 'Prelude.Nothing' in the 'Prelude.fst' of the pair.
maybeDerefObject :: Maybe Object -> Exec (Maybe Reference, Maybe Object)
maybeDerefObject = maybe (return (Nothing, Nothing)) $ \o -> case o of
  ORef r -> referenceLookup r >>= \ (r, o) -> case o of
    Nothing -> return (Just r, Nothing)
    Just  o -> return (Just r, Just o)
  o      -> return (Nothing, Just o)

----------------------------------------------------------------------------------------------------

-- | This data type instantates the 'execute' function for use in for-loop expressions.
data ForLoopBlock = ForLoopBlock Name Object (CodeBlock Object)

instance Executable ForLoopBlock (Bool, Maybe Object) where
  execute (ForLoopBlock name o block) = 
    execNested_ (M.singleton name o) $ loop (codeBlock block) where
      done cont = do
        ref <- gets execStack
        newValue <- return $ M.lookup name $ head $ mapList ref
        return (cont, newValue)
      loop ex = case ex of
        []   -> done True
        e:ex -> case e of
          ContinueExpr a cond _loc -> case cond of
            EvalExpr (ObjArithExpr (ObjectExpr VoidExpr)) -> done a
            cond -> execute cond >>= maybe err (execute . objToBool) >>= done . (if a then id else not) where
              err = fail "expression does not evaluate to boolean"
          e -> execute e >> loop ex

----------------------------------------------------------------------------------------------------

instance ToDaoStructClass (AST_Script Object) where
  toDaoStruct = let nm = renameConstructor in ask >>= \o -> case o of
    AST_Comment      a           -> nm "Comment" $ putComments a
    AST_IfThenElse   a           -> innerToStruct a
    AST_WhileLoop    a           -> innerToStruct a
    AST_RuleFunc     a           -> innerToStruct a
    AST_EvalObject   a b     loc -> nm "ObjectExpr" $ "expr" .= a >> putComments b >> putLocation loc
    AST_TryCatch     a b c d loc -> nm "TryCatch" $ do
      "comments" .= a >> "tryBlock" .= b >> "elseBlocks" .= listToObj c
      "catchBlocks" .= listToObj d >> putLocation loc
    AST_ForLoop      a b c loc -> nm "ForLoop" $ do
      "varName" .= a >> "iterate" .= b >> "block" .= c >> putLocation loc
    AST_ContinueExpr a b c     loc -> nm (if a then "Continue" else "Break") $ do
      putComments b >> "condition" .= c >> putLocation loc
    AST_ReturnExpr   a b       loc -> nm (if a then "Return" else "Throw") $ do
      "expr" .= b >> putLocation loc
    AST_WithDoc      a b       loc -> nm "WithDoc" $ "expr" .= a >> "block" .= b >> putLocation loc

instance FromDaoStructClass (AST_Script Object) where
  fromDaoStruct = msum $
    [ constructor "Comment" >> AST_Comment <$> comments
    , AST_IfThenElse <$> fromDaoStruct
    , AST_WhileLoop  <$> fromDaoStruct
    , AST_RuleFunc   <$> fromDaoStruct
    , constructor "ObjectExpr" >> return AST_EvalObject <*> req "expr" <*> comments <*> location
    , constructor "TryCatch" >>
        return AST_TryCatch
          <*> comments
          <*> req "tryBlock"
          <*> reqList "elseBlocks"
          <*> reqList "catchBlocks"
          <*> location
    , constructor "ForLoop" >>
        return AST_ForLoop <*> req "varName" <*> req "iterate" <*> req "block" <*> location
    , constructor "Continue" >>
        return (AST_ContinueExpr True ) <*> comments <*> req "condition" <*> location
    , constructor "Break" >>
        return (AST_ContinueExpr False) <*> comments <*> req "condition" <*> location
    , constructor "Return" >> return (AST_ReturnExpr True ) <*> req "expr" <*> location
    , constructor "Throw"  >> return (AST_ReturnExpr False) <*> req "expr" <*> location
    , constructor "WithDoc" >> return AST_WithDoc <*> req "expr" <*> req "block" <*> location
    ]

instance ObjectClass [AST_Script Object] where { obj=listToObj; fromObj=listFromObj; }

instance ObjectClass (AST_Script Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (AST_Script Object) where
  haskellDataInterface = interface "ScriptExpression" $ do
    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter
    autoDefToStruct >> autoDefFromStruct

----------------------------------------------------------------------------------------------------

-- binary 0x86 
instance B.Binary (ObjListExpr Object) MTab where
  put (ObjListExpr lst loc) = B.prefixByte 0x86 $ B.putUnwrapped lst >> B.put loc
  get = (B.tryWord8 0x86 $ return ObjListExpr <*> B.getUnwrapped <*> B.get) <|> fail "expecting ObjListExpr"

instance Executable (ObjListExpr Object) [Object] where
  execute (ObjListExpr exprs _) = forM (zip exprs [1..]) $ \ (a, i) -> execute a >>= maybe (err i) return where
    err i = execThrow "item in list literal expression evaluates to void" ExecErrorUntyped [(argNum, obj (i::Int))]

instance PPrintable (ObjListExpr Object) where { pPrint = pPrintInterm }

instance ObjectClass (ObjListExpr Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (ObjListExpr Object) where
  haskellDataInterface = interface "ListLiteral" $ do
    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter >> autoDefBinaryFmt

----------------------------------------------------------------------------------------------------

instance ToDaoStructClass (AST_ObjList Object) where
  toDaoStruct = ask >>= \o -> case o of
    AST_ObjList coms lst loc -> renameConstructor "ListLiteralExpression" $ do
      putComments coms >> defObjField "items" (listToObj lst) >> putLocation loc

instance FromDaoStructClass (AST_ObjList Object) where
  fromDaoStruct = constructor "ListLiteralExpression" >>
    return AST_ObjList <*> comments <*> reqList "items" <*> location

instance ObjectClass (AST_ObjList Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (AST_ObjList Object) where
  haskellDataInterface = interface "ListLiteralExpression" $ do
    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter
    autoDefToStruct >> autoDefFromStruct

----------------------------------------------------------------------------------------------------

instance B.Binary (OptObjListExpr Object) MTab where
  put (OptObjListExpr o) = B.put o
  get = OptObjListExpr <$> B.get

instance Executable (OptObjListExpr Object) [Object] where
  execute (OptObjListExpr lst) = maybe (return []) execute lst

instance ObjectClass (OptObjListExpr Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (OptObjListExpr Object) where
  haskellDataInterface = interface "OptionalListLiteral" $ do
    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefBinaryFmt

-- | Evaluate an 'Exec', but if it throws an exception, set record an 'ObjectExpr' where
-- the exception occurred in the exception information.
updateExecError :: (ExecControl -> ExecControl) -> Exec a -> Exec a
updateExecError upd fn = catchError fn (\err -> throwError (upd err))

----------------------------------------------------------------------------------------------------

instance ToDaoStructClass (AST_OptObjList Object) where
  toDaoStruct = ask >>= \o -> case o of
    AST_OptObjList coms o -> renameConstructor "OptObjList" $ "params" .=? o >> putComments coms

instance FromDaoStructClass (AST_OptObjList Object) where
  fromDaoStruct = constructor "OptObjList" >> return AST_OptObjList <*> comments <*> opt "params"

instance ObjectClass (AST_OptObjList Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (AST_OptObjList Object) where
  haskellDataInterface = interface "OptionalListLiteralExpression" $ do
    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter
    autoDefToStruct >> autoDefFromStruct

----------------------------------------------------------------------------------------------------

instance B.Binary (LiteralExpr Object) MTab where
  put (LiteralExpr a loc) = B.put a >> B.put loc
  get = B.word8PrefixTable <|> fail "expecting LiteralExpr"

instance B.HasPrefixTable (LiteralExpr Object) B.Byte MTab where
  prefixTable = B.bindPrefixTable B.prefixTable $ \o -> LiteralExpr o <$> B.get

instance Executable (LiteralExpr Object) (Maybe Object) where { execute (LiteralExpr o _) = return (Just o) }

instance ObjectClass (LiteralExpr Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (LiteralExpr Object) where
  haskellDataInterface = interface "Literal" $ do
    autoDefEquality >> autoDefNullTest >> autoDefBinaryFmt >> defDeref execute

----------------------------------------------------------------------------------------------------

instance ToDaoStructClass (AST_Literal Object) where
  toDaoStruct = ask >>= \o -> case o of
    AST_Literal o loc -> renameConstructor "Literal" $ "obj" .= o >> putLocation loc

instance FromDaoStructClass (AST_Literal Object) where
  fromDaoStruct = constructor "Literal" >> return AST_Literal <*> req "obj" <*> location

instance ObjectClass (AST_Literal Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (AST_Literal Object) where
  haskellDataInterface = interface "LiteralExpression" $ do
    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter
    autoDefToStruct >> autoDefFromStruct

----------------------------------------------------------------------------------------------------

-- binary 0x3C 0x42 ReferenceExpr-->Reference
instance B.Binary (ReferenceExpr Object) MTab where
  put qref = case qref of
    ReferenceExpr q n r loc -> prefix q $ B.put n >> B.put r >> B.put loc where
      prefix q = B.prefixByte $ case q of
        { UNQUAL -> 0x48; LOCAL -> 0x49; CONST -> 0x4A; STATIC -> 0x4B; GLOBAL -> 0x4C; GLODOT -> 0x4D; }
    RefObjectExpr o r loc -> B.putWord8 0x4E >> B.put o >> B.put r >> B.put loc
  get = B.word8PrefixTable <|> fail "expecting Reference"

instance B.HasPrefixTable (ReferenceExpr Object) Word8 MTab where
  prefixTable = B.mkPrefixTableWord8 "ReferenceExpr" 0x48 0x4E $
    [ f UNQUAL, f LOCAL, f CONST, f STATIC, f GLOBAL, f GLODOT
    , return RefObjectExpr <*> B.get <*> B.get <*> B.get
    ] where { f q = return (ReferenceExpr q) <*> B.get <*> B.get <*> B.get }

instance Executable (ReferenceExpr Object) (Maybe Object) where
  execute qref = errLocation qref $ case qref of
    RefObjectExpr o NullRefExpr _ -> execute o
    RefObjectExpr o suf _ -> do
      o <- execute o >>=
        checkVoid (getLocation o) "function call on item in parentheses which evaluated to a void value"
      suf <- execute suf
      return $ Just $ obj $ RefObject o suf
    ReferenceExpr q ref suf _loc -> execute suf >>= return . Just . ORef . Reference q ref

instance ObjectClass (ReferenceExpr Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (ReferenceExpr Object) where
  haskellDataInterface = interface "ReferenceLiteral" $ do
    autoDefEquality >> autoDefNullTest >> autoDefBinaryFmt
    defDeref (execute >=> fmap snd . maybeDerefObject)

----------------------------------------------------------------------------------------------------

instance ToDaoStructClass (AST_Reference Object) where
  toDaoStruct = ask >>= \o -> case o of
    AST_RefObject o           ref loc -> renameConstructor "ParenExpr" $ do
      "paren" .= o >> "suffix" .= ref >> putLocation loc
    AST_Reference  q coms name ref loc -> renameConstructor "Reference" $ do
      "qualifier" .= q >> putComments coms >> "name" .= name >> "suffix" .= ref >> putLocation loc

instance FromDaoStructClass (AST_Reference Object) where
  fromDaoStruct = msum $
    [ constructor "ParenExpr" >>
        return AST_RefObject <*> req "paren" <*> req "suffix" <*> location
    , constructor "Reference" >>
        return AST_Reference <*> req "qualifier"
          <*> comments <*> req "name" <*> req "suffix" <*> location
    ]

instance ObjectClass (AST_Reference Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (AST_Reference Object) where
  haskellDataInterface = interface "ReferenceExpression" $ do
    autoDefEquality >> autoDefOrdering >> autoDefPPrinter
    autoDefToStruct >> autoDefFromStruct
    defDeref (msum . map (execute >=> fmap snd . maybeDerefObject) . toInterm)

----------------------------------------------------------------------------------------------------

-- binary 0x52 0x53
instance B.Binary (RefPrefixExpr Object) MTab where
  put o = case o of
    PlainRefExpr  a     -> B.put a
    RefPrefixExpr a b z -> let f = B.put b >> B.put z in case a of
      REF   -> B.prefixByte 0x52 f
      DEREF -> B.prefixByte 0x53 f
  get = B.word8PrefixTable <|> fail "expecting RefPrefixExpr"

instance B.HasPrefixTable (RefPrefixExpr Object) B.Byte MTab where
  prefixTable = fmap PlainRefExpr B.prefixTable <>
    (B.mkPrefixTableWord8 "RefPrefixExpr" 0x52 0x53 $
      let f q = return (RefPrefixExpr q) <*> B.get <*> B.get in [f REF, f DEREF])

instance Executable (RefPrefixExpr Object) (Maybe Object) where
  execute ref = errLocation ref $ case ref of
    PlainRefExpr     ref     -> execute ref
    RefPrefixExpr op ref loc -> case op of
      REF   -> do
        ref <- execute ref >>= checkVoid loc "operand of referencing operator ($)"
        case ref of
          ORef ref -> return $ Just $ ORef $ RefWrapper ref
          ref      -> return $ Just $ ORef $ RefObject ref NullRef
      DEREF -> execute ref >>= checkVoid loc "operand of dereferencing operator (@)" >>=
        fmap Just . derefObject

instance ObjectClass (RefPrefixExpr Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (RefPrefixExpr Object) where
  haskellDataInterface = interface "RefPrefixLiteral" $ do
    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefBinaryFmt

----------------------------------------------------------------------------------------------------

instance ToDaoStructClass (AST_RefPrefix Object) where
  toDaoStruct = ask >>= \o -> case o of
    AST_PlainRef  a         -> renameConstructor "PlainRef" $ "ref" .= a >> return ()
    AST_RefPrefix a b c loc -> renameConstructor "RefPrefix" $ do
      "op" .= a >> putComments b >> "expr" .= c >> putLocation loc

instance FromDaoStructClass (AST_RefPrefix Object) where
  fromDaoStruct = msum $
    [ constructor "RefPrefix" >>
        return AST_RefPrefix <*> req "op" <*> req "expr" <*> req "expr" <*> location
    , constructor "PlainRef" >> AST_PlainRef <$> req "ref"
    ]

instance ObjectClass (AST_RefPrefix Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (AST_RefPrefix Object) where
  haskellDataInterface = interface "ReferencePrefixExpression" $ do
    autoDefEquality >> autoDefOrdering >> autoDefPPrinter
    autoDefToStruct >> autoDefFromStruct

----------------------------------------------------------------------------------------------------

-- binary 0x74 0x76
instance B.Binary (RuleFuncExpr Object) MTab where
  put o = case o of
    LambdaExpr a b   z -> B.prefixByte 0x74 $ B.put a >> B.put b >> B.put z
    FuncExpr   a b c z -> B.prefixByte 0x75 $ B.put a >> B.put b >> B.put c >> B.put z
    RuleExpr   a b   z -> B.prefixByte 0x76 $ B.put a >> B.put b >> B.put z
  get = B.word8PrefixTable <|> fail "expecting RuleFuncExpr"

instance B.HasPrefixTable (RuleFuncExpr Object) B.Byte MTab where
  prefixTable = B.mkPrefixTableWord8 "RuleFuncExpr" 0x74 0x76 $
    [ return LambdaExpr <*> B.get <*> B.get <*> B.get
    , return FuncExpr   <*> B.get <*> B.get <*> B.get <*> B.get
    , return RuleExpr   <*> B.get <*> B.get <*> B.get
    ]

instance Executable (RuleFuncExpr Object) (Maybe Object) where
  execute o = case o of
    --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --
    LambdaExpr params script _ -> do
      let exec = setupCodeBlock script
      return $ Just $ new $
        [CallableCode{argsPattern=params, codeSubroutine=exec, returnType=nullValue}]
    --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --
    FuncExpr name params script _ -> do
      let exec = setupCodeBlock script
      let callableCode = CallableCode{argsPattern=params, codeSubroutine=exec, returnType=nullValue}
      localVarUpdate name $ \o -> case o>>=fromObj of
        Nothing -> Just $ obj [callableCode]
        Just cc -> Just $ obj $ cc++[callableCode]
      return (Just $ obj [callableCode])
    --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --
    RuleExpr rs script _ -> do
      let sub = setupCodeBlock script
      pats <- execute rs
      return $ Just $ obj $ PatternRule{ rulePatterns=pats, ruleAction=sub }
    --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --

instance ObjectClass (RuleFuncExpr Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (RuleFuncExpr Object) where
  haskellDataInterface = interface "FunctionLiteral" $ do
    autoDefEquality >> autoDefNullTest >> autoDefBinaryFmt >> autoDefPPrinter

----------------------------------------------------------------------------------------------------

instance ToDaoStructClass (AST_RuleFunc Object) where
  toDaoStruct = let nm = renameConstructor in ask >>= \o -> case o of
    AST_Lambda a b     loc -> nm "Lambda"   $ "params" .= a >> "block" .= b >> putLocation loc
    AST_Func   a b c d loc -> nm "Function" $
      putComments a >> "name"  .= b >> "params" .= c >> "block" .= d >> putLocation loc
    AST_Rule   a b     loc -> nm "Rule" $ "params" .= a >> "block" .= b >> putLocation loc

instance FromDaoStructClass (AST_RuleFunc Object) where
  fromDaoStruct = msum $
    [ constructor "Lambda" >> return AST_Lambda <*> req "params" <*> req "block"  <*> location
    , constructor "Function" >>
        return AST_Func <*> comments <*> req "name" <*> req "params" <*> req "block" <*> location
    , constructor "Rule" >> return AST_Rule <*> req "params" <*> req "block" <*> location
    ]

instance ObjectClass (AST_RuleFunc Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (AST_RuleFunc Object) where
  haskellDataInterface = interface "FunctionLiteralExpression" $ do
    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter
    autoDefToStruct >> autoDefFromStruct

----------------------------------------------------------------------------------------------------

-- binary 0x60 0x65
instance B.Binary (ObjectExpr Object) MTab where
  put o = case o of
    ObjSingleExpr   a       -> B.put a
    ObjLiteralExpr  a       -> B.put a
    VoidExpr                -> B.putWord8   0x60
    ArithPfxExpr    a b   z -> B.prefixByte 0x61 $ B.put a >> B.put b >> B.put z
    InitExpr        a b c z -> B.prefixByte 0x62 $ B.put a >> B.put b >> B.put c >> B.put z
    StructExpr      a b   z -> B.prefixByte 0x63 $ B.put a >> B.put b >> B.put z
    MetaEvalExpr    a     z -> B.prefixByte 0x64 $ B.put a >> B.put z
  get = B.word8PrefixTable <|> fail "expecting ObjectExpr"

instance B.HasPrefixTable (ObjectExpr Object) B.Byte MTab where
  prefixTable = mconcat $
    [ ObjLiteralExpr  <$> B.prefixTable
    , ObjSingleExpr   <$> B.prefixTable
    , B.mkPrefixTableWord8 "ObjectExpr" 0x60 0x64 $
        [ return VoidExpr
        , return ArithPfxExpr <*> B.get <*> B.get <*> B.get
        , return InitExpr     <*> B.get <*> B.get <*> B.get <*> B.get
        , return StructExpr   <*> B.get <*> B.get <*> B.get
        , return MetaEvalExpr <*> B.get <*> B.get
        ]
    ]

instance Executable (ObjectExpr Object) (Maybe Object) where
  execute o = errLocation o $ case o of
    --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --
    VoidExpr -> return Nothing
      -- 'VoidExpr's only occur in return statements. Returning 'ONull' where nothing exists is
      -- probably the most intuitive thing to do on an empty return statement.
    --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --
    ObjLiteralExpr  o -> execute o
    --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --
    ObjSingleExpr   o -> execute o
    --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --
    ArithPfxExpr op expr loc -> do
      expr <- execute expr >>= fmap snd . maybeDerefObject >>=
        checkVoid loc ("operand to prefix operator "++show op)
      execute $ fmap Just (evalArithPrefixOp op expr)
    --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --
    InitExpr ref bnds initMap _ -> Just <$> _evalInit (dotLabelToRefExpr ref) bnds initMap
    --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --
    StructExpr name (OptObjListExpr items) _ -> case items of
      Nothing -> return (Just $ OTree $ Nullary{ structName=name })
      Just (ObjListExpr items _) -> execNested_ M.empty $ do
        forM_ items $ \item -> case item of 
          AssignExpr{} -> execute item -- fill the local stack by executing each assignment
          _            -> fail "struct initializer is not an assignment expression"
        stack <- gets execStack
        let items = head $ mapList stack
        return $ Just $ OTree $
          if M.null items
          then Nullary{ structName=name }
          else Struct{ fieldMap=items, structName=name }
    --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --
    MetaEvalExpr expr _ -> return $ Just $ new expr
    --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --

_evalInit :: ReferenceExpr Object -> OptObjListExpr Object -> ObjListExpr Object -> Exec Object
_evalInit ref bnds initMap = do
  ref <- execute ref >>= checkVoid (getLocation ref) "initializer label"
  ref <- case ref of
    ORef (Reference UNQUAL name NullRef) -> pure name
    ref -> throwBadTypeError "cannot use reference as initalizer" ref []
  bnds <- execute bnds >>= mapM derefObject
  let cantUseBounds msg =
        execThrow ("initializer "++msg++" must be defined without bounding parameters")
          ExecErrorUntyped [(assertFailed, OList bnds)]
  let list = case bnds of
        [] -> execNested_ M.empty $ fmap OList $ execute initMap >>= mapM derefObject
        _  -> cantUseBounds "for list constructor"
  let (ObjListExpr items _) = initMap
  let dict = case bnds of
        [] -> (ODict . snd) <$> execNested M.empty (mapM_ assignUnqualifiedOnly items)
        _  -> cantUseBounds "for dict constructor"
  case uchars ref of
    "list"       -> list
    "List"       -> list
    "dict"       -> dict
    "Dict"       -> dict
    "Dictionary" -> dict
    _ -> do
      tab <- execGetObjTable ref
      let qref = Reference UNQUAL ref NullRef
      case tab of
        Nothing  -> execThrow "unknown object constructor" qref []
        Just tab -> execNested_ M.empty $ case objInitializer tab of
          Nothing           -> execThrow "cannot declare constant object of type" qref []
          Just (init, fold) -> do
            o     <- init bnds
            items <- forM items $ \item -> case item of
              AssignExpr a op b _ -> do
                a <- execute a >>= checkVoid (getLocation a) "left-hand side of initializer assignemt"
                b <- execute b >>= checkVoid (getLocation b) "right-hand side of initializer assignment" >>= derefObject
                return $ InitAssign a op b
              EvalExpr arith -> fmap InitSingle $
                execute arith >>= checkVoid (getLocation arith) "initializer item"
            OHaskell . Hata tab <$> fold o items

instance ObjectClass (ObjectExpr Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (ObjectExpr Object) where
  haskellDataInterface = interface "ObjectLiteral" $ do
    autoDefEquality >> autoDefNullTest >> autoDefBinaryFmt
    defDeref execute >> autoDefPPrinter

----------------------------------------------------------------------------------------------------

instance ToDaoStructClass (AST_Object Object) where
  toDaoStruct = let nm = renameConstructor in ask >>= \o -> case o of
    AST_Void                   -> makeNullary "Void"
    AST_ObjLiteral   a         -> innerToStruct a
    AST_ObjSingle    a         -> innerToStruct a
    AST_ArithPfx     a b c loc -> nm "ArithPrefix" $ do
      "op" .= a >> putComments b >> "expr" .= c >> putLocation loc
    AST_Init         a b c loc -> nm "Init" $ do
      "name" .= a >> "params" .= b >> "initList" .= c >> putLocation loc
    AST_Struct       a b   loc -> nm "Struct" $ "name" .= a >> "initList" .= b >> putLocation loc
    AST_MetaEval     a     loc -> nm "MetaEval" $ "block" .= a >> putLocation loc

instance FromDaoStructClass (AST_Object Object) where
  fromDaoStruct = msum $
    [ nullary "Void" >> return AST_Void
    , AST_ObjLiteral  <$> fromDaoStruct
    , AST_ObjSingle   <$> fromDaoStruct
    , constructor "ArithPrefix" >>
        pure AST_ArithPfx <*> req "op" <*> comments <*> req "expr" <*> location
    , constructor "Init" >>
        pure AST_Init     <*> req "name" <*> req "params" <*> req "initList" <*> location
    , constructor "Struct" >> pure AST_Struct <*> req "name" <*> req "initList" <*> location
    , constructor "MetaEval" >> pure AST_MetaEval <*> req "block" <*> location
    ]

instance ObjectClass (AST_Object Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (AST_Object Object) where
  haskellDataInterface = interface "ObjectLiteralExpression" $ do
    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter
    autoDefToStruct >> autoDefFromStruct

----------------------------------------------------------------------------------------------------

-- binary 0x6A 
instance B.Binary (ArithExpr Object) MTab where
  put o = case o of
    ObjectExpr  a     -> B.put a
    ArithExpr a b c z -> B.prefixByte 0x6A $ B.put a >> B.put b >> B.put c >> B.put z
  get = B.word8PrefixTable <|> fail "expecting arithmetic expression"

instance B.HasPrefixTable (ArithExpr Object) B.Byte MTab where
  prefixTable = mappend (ObjectExpr <$> B.prefixTable) $
    B.mkPrefixTableWord8 "ArithExpr" 0x6A 0x6A $
      [pure ArithExpr <*> B.get <*> B.get <*> B.get <*> B.get]

instance Executable (ArithExpr Object) (Maybe Object) where
  execute o = case o of
    ObjectExpr o -> execute o
    ArithExpr left' op right' loc -> do
      let err1 msg = msg++"-hand operand of "++show op++ "operator "
          evalLeft   = execute left'  >>= checkVoid loc (err1 "left" )
          evalRight  = execute right' >>= checkVoid loc (err1 "right")
          derefLeft  = evalLeft  >>= derefObject
          derefRight = evalRight >>= derefObject
          logical isAndOp = fmap Just $ do
            left <- derefLeft >>= execute . objToBool
            if left
              then  if isAndOp then derefRight else return OTrue
              else  if isAndOp then return ONull else derefRight
      case op of
        AND -> logical True
        OR  -> logical False
        op  -> do
          (left, right) <- case op of
            ARROW -> liftM2 (,) derefLeft evalRight
            _     -> liftM2 (,) derefLeft derefRight
          execute (fmap Just $ evalInfixOp op left right)

instance ObjectClass (ArithExpr Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (ArithExpr Object) where
  haskellDataInterface = interface "Arithmetic" $ do
    autoDefEquality >> autoDefNullTest >> autoDefBinaryFmt
    defDeref execute >> autoDefPPrinter

----------------------------------------------------------------------------------------------------

instance ToDaoStructClass (AST_Arith Object) where
  toDaoStruct = ask >>= \o -> case o of
    AST_Object a         -> innerToStruct a
    AST_Arith  a b c loc -> renameConstructor "Arithmetic" $ do
      "left" .= a >> "op" .= b >> "right" .= c >> putLocation loc

instance FromDaoStructClass (AST_Arith Object) where
  fromDaoStruct = msum $
    [ AST_Object <$> fromDaoStruct
    , constructor "Arithmetic" >>
        pure AST_Arith <*> req "left" <*> req "op" <*> req "right" <*> location
    ]

instance ObjectClass (AST_Arith Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (AST_Arith Object) where
  haskellDataInterface = interface "ArithmeticExpression" $ do
    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter
    autoDefToStruct >> autoDefFromStruct

----------------------------------------------------------------------------------------------------

newtype DerefAssignExpr = DerefAssignExpr (AssignExpr Object)
-- ^ This data type instantiates 'Executable' such that the result is always dereference once. This
-- is necessary because an 'AssignExpr' always evaluates to an 'Object' literal expression, meaning
-- if the 'AssignExpr' contains  'ReferenceExpr', it will evaluate to an 'Object' constructing a
-- literal 'Reference' (using the 'ORef' constructor). Sometimes this is desirable, sometimes it is
-- not. It is desirable when evaluating arguments for a function call that requests it's arguments
-- not be dereferenced. It is not desirable when evaluating an arithmetic equation and the integer
-- value stored at a 'Reference' variable is required, and not the 'Reference' value itself.
--     The calling context cannot know what the result will be, or whether or not it is necessary to
-- call 'derefObject' on the result unless the calling context inspects the 'AssignExpr' value with
-- a case statement. By wrapping the 'AssignExpr' in this data type first and then evaluating
-- 'execute', you are guranteed that any 'ReferenceExpr' will evaluate to the value stored at the
-- resulting 'Reference' literal, and not the 'Reference' literal itself.

instance Executable DerefAssignExpr (Maybe Object) where
  execute (DerefAssignExpr o) = case o of
    EvalExpr{}   -> execute o >>= fmap snd . maybeDerefObject
    AssignExpr{} -> execute o

_executeAssignExpr
  :: (Reference -> UpdateOp -> Object -> Exec (Maybe Object))
  -> AssignExpr Object -> Exec (Maybe Object)
_executeAssignExpr update o = case o of
  EvalExpr           expr     -> execute expr
  AssignExpr qref op expr loc -> do
    qref <- execute qref >>=
      checkVoid (getLocation qref) "left-hand side of assignment expression evaluated to void"
    case qref of
      ORef qref -> do
        newObj <- execute expr >>= checkVoid loc "right-hand side of assignment" >>= derefObject 
        update qref op newObj
      _    -> fail "left-hand side of assignment expression is not a reference value"

-- binary 0x6F 
instance B.Binary (AssignExpr Object) MTab where
  put o = case o of
    EvalExpr   a       -> B.put a
    AssignExpr a b c z -> B.prefixByte 0x6F $ B.put a >> B.put b >> B.put c >> B.put z
  get = B.word8PrefixTable <|> fail "expecting AssignExpr"

instance B.HasPrefixTable (AssignExpr Object) B.Byte MTab where
  prefixTable = mappend (EvalExpr <$> B.prefixTable) $
    B.mkPrefixTableWord8 "AssignExpr" 0x6F 0x6F $
      [pure AssignExpr <*> B.get <*> B.get <*> B.get <*> B.get]

instance Executable (AssignExpr Object) (Maybe Object) where
  execute = _executeAssignExpr $ \qref op newObj ->
    snd <$> referenceUpdate qref (op/=UCONST) (evalUpdateOp (Just qref) op newObj)

-- | This function works a bit like how 'execute' works on an 'AssignExpr' data type, but every
-- assignment is checked to make sure it is local or unqualified. Furthurmore, all assignments are
-- forced into the top of the local variable stack, already-defined vairables at higher points in
-- the local variable stack are not updated in place. This function is used to define items in
-- is one important difference: it is specifically modified to work for evaluation of 'InitExpr'
-- data types, for example in the Dao language expression: @a = dict {a=1, b=2};@ Using this
-- function instead of 'execute' will always assign variables in the top of the local variable
-- stack, regardless of whether the variable has been defined before. This makes it possible to
-- write Dao language statements like this: @a=1; a = dict {a=a, b=2};@ which would create a
-- dictionary @a = dict {a=1, b=2};@, because before the "dict{}" expression, "a" had a value of 1.
assignUnqualifiedOnly :: AssignExpr Object -> Exec (Maybe Object)
assignUnqualifiedOnly = _executeAssignExpr $ \qref op newObj -> case qref of
  Reference UNQUAL r NullRef -> do
    store <- gets execStack
    let oldObj = stackLookup r store
    newObj <- evalUpdateOp (Just qref) op newObj oldObj
    (result, store) <- pure $ stackUpdateTop (const (newObj, newObj)) r store
    modify $ \xunit -> xunit{ execStack = store }
    return result
  _ -> execThrow "assignment must be unqualified" ExecErrorUntyped [(errOfReference, obj qref)]

instance ObjectClass (AssignExpr Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (AssignExpr Object) where
  haskellDataInterface = interface "Assignment" $ do
    autoDefNullTest >> autoDefEquality >> autoDefNullTest >> autoDefBinaryFmt
    defDeref execute >> autoDefPPrinter

----------------------------------------------------------------------------------------------------

instance ToDaoStructClass (AST_Assign Object) where
  toDaoStruct = ask >>= \o -> case o of
    AST_Eval o ->  innerToStruct o
    AST_Assign to op from loc -> renameConstructor "Assign" $ do
      "to" .= to >> "op" .= op >> "from" .= from >> putLocation loc

instance FromDaoStructClass (AST_Assign Object) where
  fromDaoStruct = msum $
    [ AST_Eval <$> fromDaoStruct
    , pure AST_Assign <*> req "to" <*> req "op" <*> req "from" <*> location
    ]

instance ObjectClass (AST_Assign Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (AST_Assign Object) where
  haskellDataInterface = interface "AssignmentExpression" $ do
    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter
    autoDefToStruct >> autoDefFromStruct

----------------------------------------------------------------------------------------------------

instance B.Binary (ObjTestExpr Object) MTab where
  put o = case o of
    ObjArithExpr      a -> B.put a
    ObjTestExpr a b c d -> B.prefixByte 0x73 $ B.put a >> B.put b >> B.put c >> B.put d
    ObjRuleFuncExpr a       -> B.put a
  get = B.word8PrefixTable <|> fail "expecting ObjTestExpr"

instance B.HasPrefixTable (ObjTestExpr Object) Word8 MTab where
  prefixTable = mconcat $ 
    [ ObjArithExpr <$> B.prefixTable
    , ObjRuleFuncExpr <$> B.prefixTable
    , B.mkPrefixTableWord8 "ObjTestExpr" 0x73 0x73 $
        [return ObjTestExpr <*> B.get <*> B.get <*> B.get <*> B.get]
    ]

instance Executable (ObjTestExpr Object) (Maybe Object) where
  execute o = errCurrentModule $ case o of
    ObjArithExpr      a -> execute a
    ObjTestExpr a b c _ ->
      execute a >>= checkVoid (getLocation a) "conditional expression evaluates to void" >>= derefObject >>=
        execute . objToBool >>= \ok -> if ok then execute b else execute c
    ObjRuleFuncExpr o -> execute o

instance ObjectClass (ObjTestExpr Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (ObjTestExpr Object) where
  haskellDataInterface = interface "ObjectTest" $ do
    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter

----------------------------------------------------------------------------------------------------

instance ToDaoStructClass (AST_ObjTest Object) where
  toDaoStruct = ask >>= \o -> case o of
    AST_ObjArith  a -> innerToStruct a
    AST_ObjTest a b c d e f -> renameConstructor "ObjTest" $ do
      "condition" .= a
      "quesMarkComs" .= b >> "action" .= c
      "colonComs"    .= d >> "alt"    .= e
      putLocation f
    AST_ObjRuleFunc  a         -> innerToStruct a

instance FromDaoStructClass (AST_ObjTest Object) where
  fromDaoStruct = msum $
    [ AST_ObjArith <$> fromDaoStruct
    , do  constructor "ObjTest"
          return AST_ObjTest
            <*> req "condition" 
            <*> (maybe (Com ()) id <$> opt "quesMarkComs") <*> req "action"
            <*> (maybe (Com ()) id <$> opt "colonComs"   ) <*> req "alt"
            <*> location
    , AST_ObjRuleFunc <$> fromDaoStruct
    ]

instance ObjectClass (AST_ObjTest Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (AST_ObjTest Object) where
  haskellDataInterface = interface "ObjectTestExpression" $ do
    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter
    autoDefToStruct >> autoDefFromStruct

----------------------------------------------------------------------------------------------------

instance ToDaoStructClass AST_Namespace where
  toDaoStruct = ask >>= \a -> case a of
    AST_NoNamespace     -> makeNullary "NoNamespace"
    AST_Namespace n loc -> renameConstructor "Namespace" $ "name" .= n >> putLocation loc

instance FromDaoStructClass AST_Namespace where
  fromDaoStruct = msum $
    [ nullary "NoNamespace" >> return AST_NoNamespace
    , constructor "Namespace" >> return AST_Namespace <*> req "name" <*> location
    ]

instance ObjectClass AST_Namespace where { obj=new; fromObj=objFromHata; }

instance HataClass AST_Namespace where
  haskellDataInterface = interface "NamespaceExpression" $ do
    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter
    autoDefToStruct >> autoDefFromStruct

----------------------------------------------------------------------------------------------------

-- binary 0x81 0x82 -- placed next to with 'DotNameExpr'
instance B.Binary AttributeExpr MTab where
  put o = case o of
    AttribDotNameExpr a     -> B.put a
    AttribStringExpr  a loc -> B.prefixByte 0x82 $ B.put a >> B.put loc
  get = B.word8PrefixTable <|> fail "expecting AttributeExpr"

instance B.HasPrefixTable AttributeExpr Word8 MTab where
  prefixTable = (AttribDotNameExpr <$> B.prefixTable) <>
    B.mkPrefixTableWord8 "AttributeExpr" 0x82 0x82 [return AttribStringExpr <*> B.get <*> B.get]

-- binary 0xE9 0xEE
instance B.Binary (TopLevelExpr Object) MTab where
  put o = case o of
    RequireExpr a               z -> B.prefixByte 0xE9 $ B.put a >> B.put z
    ImportExpr  a             b z -> B.prefixByte 0xEA $ B.put a >> B.put b >> B.put z
    TopScript   a               z -> B.prefixByte 0xEB $ B.put a >> B.put z
    EventExpr   BeginExprType b z -> B.prefixByte 0xEC $ B.put b >> B.put z
    EventExpr   ExitExprType  b z -> B.prefixByte 0xED $ B.put b >> B.put z
    EventExpr   EndExprType   b z -> B.prefixByte 0xEE $ B.put b >> B.put z
  get = B.word8PrefixTable <|> fail "expecting TopLevelExpr"

instance B.HasPrefixTable (TopLevelExpr Object) B.Byte MTab where
  prefixTable = B.mkPrefixTableWord8 "TopLevelExpr" 0xE9 0xEE $
    [ return RequireExpr <*> B.get <*> B.get
    , return ImportExpr  <*> B.get <*> B.get <*> B.get
    , return TopScript   <*> B.get <*> B.get
    , return (EventExpr BeginExprType) <*> B.get <*> B.get
    , return (EventExpr ExitExprType ) <*> B.get <*> B.get
    , return (EventExpr EndExprType  ) <*> B.get <*> B.get
    ]

instance Executable (TopLevelExpr Object) () where
  execute o = errCurrentModule $ case o of
    --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --
    RequireExpr{} -> attrib "require"
    ImportExpr{}  -> attrib "import"
    --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --
    TopScript script _ -> do
      ((), dict) <- execNested mempty $ catchPredicate (execute script) >>= \pval -> case pval of
        OK                _  -> return ()
        PFail (ExecReturn _) -> return ()
        PFail           err  -> throwError err
        Backtrack            -> return () -- do not backtrack at the top-level
      let addIfFuncs a b = maybe b id $ do -- overwrite previously declared variables...
            (a, b) <- Just (,) <*> fromObj a <*> fromObj b
            Just $ obj ((a++b)::[CallableCode]) -- ...unless both variables are [CallableCode]
      modify $ \xunit -> xunit{ globalData = M.unionWith addIfFuncs (globalData xunit) dict }
    --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --
    EventExpr typ script _ -> do
      let exec = setupCodeBlock script
      let f = (++[exec])
      modify $ \xunit -> case typ of
        BeginExprType -> xunit{ preExec      = f (preExec      xunit) }
        EndExprType   -> xunit{ postExec     = f (postExec     xunit) }
        ExitExprType  -> xunit{ quittingTime = f (quittingTime xunit) }
    --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --
    where
      attrib a = fail $ a++" expression must occur only at the top of a dao script file"

instance ObjectClass (TopLevelExpr Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (TopLevelExpr Object) where
  haskellDataInterface = interface "TopLevel" $ do
    autoDefEquality >> autoDefNullTest >> autoDefBinaryFmt >> autoDefPPrinter

----------------------------------------------------------------------------------------------------

instance ToDaoStructClass AST_Attribute where
  toDaoStruct = ask >>= \o -> case o of
    AST_AttribDotName str     -> renameConstructor "AttributeDotName" $ innerToStruct str
    AST_AttribString  str loc ->
      renameConstructor "AttributeString" $ "value" .= str >> putLocation loc

instance FromDaoStructClass AST_Attribute where
  fromDaoStruct = msum $
    [ constructor "AttributeDotName" >> AST_AttribDotName <$> innerFromStruct "DotLabel"
    , constructor "AttributeString"  >> return AST_AttribString  <*> req "value" <*> location
    ]

instance ObjectClass AST_Attribute where { obj=new; fromObj=objFromHata; }

instance HataClass AST_Attribute where
  haskellDataInterface = interface "AttributeExpression" $ do
    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter
    autoDefToStruct >> autoDefFromStruct

instance ToDaoStructClass (AST_TopLevel Object) where
  toDaoStruct = let nm = renameConstructor in ask >>= \o -> case o of
    AST_Require    a     loc -> nm "Require" $ "attribute" .= a >> putLocation loc
    AST_Import     a b   loc -> nm "Import" $ "attribute" .= a >> "namespace" .= b >> putLocation loc
    AST_TopScript  a     loc -> nm "TopLevel" $ "script" .= a >> putLocation loc
    AST_TopComment a         -> nm "Comment" $ putComments a
    AST_Event      a b c loc ->
      nm "Event" $ "type" .= a >> "block" .= c >> putComments b >> putLocation loc

instance FromDaoStructClass (AST_TopLevel Object) where
  fromDaoStruct = msum $
    [ constructor "Import"   >> return AST_Import    <*> req "attribute" <*> req "namespace" <*> location
    , constructor "Require"  >> return AST_Require   <*> req "attribute" <*> location
    , constructor "TopLevel" >> return AST_TopScript <*> req "script"    <*> location
    , constructor "Event"    >> return AST_Event     <*> req "type"      <*> comments <*> req "block" <*> location
    , constructor "Comment"  >> AST_TopComment     <$> comments
    ]

instance ObjectClass (AST_TopLevel Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (AST_TopLevel Object) where
  haskellDataInterface = interface "TopLevelExpression" $ do
    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter
    autoDefToStruct >> autoDefFromStruct

----------------------------------------------------------------------------------------------------

-- the number is encoded by the ASCII encoded string "DaoProg\0"
program_magic_number :: Word64
program_magic_number = 0x44616f50726f6700

instance B.Binary (Program Object) MTab where
  put o = do
    -- place a magic number first, 
    B.putWord64be program_magic_number
    mapM_ B.put $ topLevelExprs o
  get = do
    magic <- B.lookAhead B.getWord64be
    guard (magic == program_magic_number)
    B.getWord64be >> fmap Program B.get

-- | Initialized the current 'ExecUnit' by evaluating all of the 'TopLevel' data in a
-- 'AST.AST_SourceCode'.
instance Executable (Program Object) () where
  execute (Program ast) = do
    ((), localVars) <- execNested mempty $ mapM_ execute (dropWhile isAttribute ast)
    -- Now, the local variables that were defined in the top level need to be moved to the global
    -- variable store.
    modify $ \xunit -> xunit{ globalData = M.union localVars (globalData xunit) }

instance ObjectClass (Program Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (Program Object) where
  haskellDataInterface = interface "ProgramData" $ do
    autoDefEquality >> autoDefNullTest >> autoDefBinaryFmt

----------------------------------------------------------------------------------------------------

_withGlobalKey :: Object -> (H.Index Object -> RefMonad Object Dynamic a) -> Exec a
_withGlobalKey idx f = gets globalMethodTable >>= \mt -> 
  gets runtimeRefTable >>= liftIO . runReaderT (f $ H.hashNewIndex (H.deriveHash128_DaoBinary mt) idx)

-- | Some objects may refer to an object that serves as a unique identifier created by the system,
-- for example objects refereing to file handles. These unique identifying objects should always be
-- stored in this table. The Dao 'Object' wrapper should be used as the index to retrieve the Object
-- in the table. This function takes the object to be stored, a destructor function to be called on
-- releasing the object, and an indexing object used to identify the stored object in the table.
initializeGlobalKey :: Typeable o => o -> (o -> IO ()) -> Object -> Exec (H.Index Object)
initializeGlobalKey o destructor idx = _withGlobalKey idx $ \key ->
  initializeWithKey (toDyn o) (destructor o) key >> return key

-- | Destroy an object that was stored into the global key table using 'initializeGlobalKey'. The
-- destructor function passed to the 'initializeGlobalKey' will be evaluated, and the object will
-- be removed from the table. This function takes an indexing object used to select the stored
-- object from the table.
destroyGlobalKey :: Object -> Exec ()
destroyGlobalKey = flip _withGlobalKey destroyWithKey

----------------------------------------------------------------------------------------------------

instance ToDaoStructClass (AST_SourceCode Object) where
  toDaoStruct = renameConstructor "SourceCode" $ do
    "modified" .=@ sourceModified
    "path"     .=@ sourceFullPath
    asks directives >>= define "code" . listToObj

instance FromDaoStructClass (AST_SourceCode Object) where
  fromDaoStruct = constructor "SourceCode" >>
    return AST_SourceCode <*> req "modified" <*> req "path" <*> reqList "code"

instance ObjectClass (AST_SourceCode Object) where { obj=new; fromObj=objFromHata; }

instance HataClass (AST_SourceCode Object) where
  haskellDataInterface = interface "SourceCode" $ do
    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter
    autoDefToStruct >> autoDefFromStruct

-- | Simply converts an 'Dao.Interpreter.AST_SourceCode' directly to a list of
-- 'Dao.Interpreter.TopLevelExpr's.
evalTopLevelAST :: AST_SourceCode Object -> Exec (Program Object)
evalTopLevelAST ast = case toInterm ast of
  [o] -> return o
  []  -> fail "converting AST_SourceCode to Program by 'toInterm' returned null value"
  _   -> fail "convertnig AST_SourceCode to Program by 'toInterm' returned ambiguous value"

----------------------------------------------------------------------------------------------------
-- $Builtin_object_interfaces
-- The following functions provide object interfaces for essential data types.

instance HataClass () where { haskellDataInterface = interface "HaskellNullValue" (return ()) }

type Get a = B.GGet  MethodTable a
type Put   = B.GPut  MethodTable

-- This is only necessary to shorten the name 'MethodTable' because it is used throughout so many
-- instance declarations and type contexts.
type MTab = MethodTable

----------------------------------------------------------------------------------------------------

newtype MethodTable = MethodTable (M.Map Name (Interface Dynamic))

instance Monoid MethodTable where
  mempty  = MethodTable mempty
  mappend (MethodTable a) (MethodTable b) = let dups = M.intersection a b in
    if M.null dups
    then MethodTable (M.union b a)
    else error ("Namespace conflict when installing built-in data type interfaces: "++show (M.keys dups))

-- | Lookup an 'Interface' by it's name from within the 'Exec' monad.
execGetObjTable :: Name -> Exec (Maybe (Interface Dynamic))
execGetObjTable nm = gets (lookupMethodTable nm . globalMethodTable)

lookupMethodTable :: Name -> MethodTable -> Maybe (Interface Dynamic)
lookupMethodTable nm (MethodTable tab) = M.lookup nm tab

-- not for export, use 'daoClass'
_insertMethodTable :: (Typeable o, HataClass o) => o -> Interface o -> MethodTable -> MethodTable
_insertMethodTable _ ifc = flip mappend $
  MethodTable (M.singleton (objInterfaceName ifc) (interfaceToDynamic ifc))

instance B.HasCoderTable MethodTable where
  getEncoderForType nm mtab = fmap fst $ lookupMethodTable nm mtab >>= objBinaryFormat
  getDecoderForType nm mtab = fmap snd $ lookupMethodTable nm mtab >>= objBinaryFormat

----------------------------------------------------------------------------------------------------

-- | Implements a "for" loop using a 'ReadIterable' item. This function should receive the
-- 'iter' object produced by 'initReadIter' that can be used by this function to extract each
-- 'val' and a function that is evaluated using a 'val' on every iteration of the loop.
-- 'readForLoop' should be defined call the given function as many times as necessary to
-- exaust the 'val's in the 'iter'.
--
-- /NOTE:/ When defining iterators, it is important to use 'execForM' or 'execForM_' to properly
-- handle "break" and "catch" statements.
class ReadIterable iter val | iter -> val where
  readForLoop :: iter -> (val -> Exec ()) -> Exec ()

instance ReadIterable [Object] Object where { readForLoop iter = execForM_ iter }

instance ReadIterable Hata Object where
  readForLoop h@(Hata ifc d) f = case objReadIterable ifc of
    Nothing  -> throwBadTypeError "cannot iterate over object" (obj h) []
    Just for -> for d f

instance ReadIterable Object Object where
  readForLoop o f = case o of
    OList    o -> readForLoop o f
    OHaskell o -> readForLoop o f
    _          -> throwBadTypeError "cannot iterate over object" o []

----------------------------------------------------------------------------------------------------

-- | A class that provides the 'updateForLoop' function, which is a function that will iterate over
-- types which can be read sequentially and modified as they are read.
--
-- /NOTE:/ When defining iterators, it is important to use 'execForM' or 'execForM_' to properly
-- handle "break" and "catch" statements.
class UpdateIterable iter val | iter -> val where
  updateForLoop :: iter -> (val -> Exec val) -> Exec iter

instance UpdateIterable [Object] (Maybe Object) where
  updateForLoop iter f =
    fmap (concatMap $ \o -> maybe [] id $ (o>>=fromObj) <|> fmap return o) (execForM iter $ f . Just)

instance UpdateIterable Hata (Maybe Object) where
  updateForLoop h@(Hata ifc d) f = case objUpdateIterable ifc of
    Nothing  -> throwBadTypeError "cannot iterate over object" (obj h) []
    Just for -> Hata ifc <$> for d f

instance UpdateIterable T_dict (Maybe Object) where
  updateForLoop m f = fmap (M.fromList . concat) $ execForM (M.assocs m) $ \ (i, o) -> do
    p <- f (Just $ obj $ Pair (obj i, o))
    case p of
      Nothing -> return []
      Just  p -> case fromObj p of
        Just (Pair (ref, o)) -> case fromObj ref of
          Just ref -> return [(ref, o)]
          Nothing  -> throwBadTypeError "iterator cannot updte dictionary item" ref []
        Nothing -> throwBadTypeError "a dictionary iterator must store Pair objects" p []

instance UpdateIterable Object (Maybe Object) where
  updateForLoop o f = case o of
    OList    o -> OList    <$> updateForLoop o f
    ODict    o -> ODict    <$> updateForLoop o f
    OHaskell o -> OHaskell <$> updateForLoop o f
    o          -> throwBadTypeError "cannot iterae over object" o []

----------------------------------------------------------------------------------------------------

-- | This class only exists to allow many different Haskell data types to declare their
-- 'Interface' under the same funcion name: 'haskellDataInterface'. Instantiate this function with
-- the help of the 'interface' function.
class HataClass typ where { haskellDataInterface :: Interface typ }

instance HataClass Location where
  haskellDataInterface = interface "Location" $ do
    autoDefEquality >> autoDefOrdering
    autoDefToStruct >> autoDefFromStruct
    autoDefPPrinter

instance HataClass Comment where
  haskellDataInterface = interface "Comment" $ do
    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter
    autoDefToStruct >> autoDefFromStruct

instance HataClass DotNameExpr where
  haskellDataInterface = interface "DotName" $ do
    autoDefEquality >> autoDefBinaryFmt >> autoDefPPrinter

instance HataClass AST_DotName where
  haskellDataInterface = interface "DotNameExpression" $ do
    autoDefEquality >> autoDefPPrinter >> autoDefToStruct >> autoDefFromStruct

instance HataClass DotLabelExpr where
  haskellDataInterface = interface "DotLabel" $ do
    autoDefEquality >> autoDefBinaryFmt >> autoDefPPrinter

instance HataClass AST_DotLabel where
  haskellDataInterface = interface "DotLabelExpression" $ do
    autoDefEquality >> autoDefPPrinter >> autoDefToStruct >> autoDefFromStruct

----------------------------------------------------------------------------------------------------

instance UpdateIterable (H.HashMap Object Object) (Maybe Object) where
  updateForLoop hm f = fmap (H.fromList . concat) $ execForM (H.assocs hm) $ \ (ix, o) -> do
    hash128 <- getObjectHash128
    p <- f (Just $ obj $ Pair (H.indexKey ix, o))
    case p of
      Nothing -> return []
      Just  p -> do
        let badtype = throwBadTypeError "cannot update hash map in iterator with item" p []
        maybe badtype (\ (Pair(a,b)) -> return [(H.hashNewIndex hash128 a, b)]) (fromObj p)

instance ObjectClass (H.HashMap Object Object) where { obj=new; fromObj=objFromHata; }

-- | The hash function for 'Object's relies on the binary serialization of the object, which
-- requires access to the 'MethodTable' of the current 'ExecUnit'. Therefore the hash function must
-- be derived from the 'Exec' monad, the 'Object' data type unfortunately cannot simply derive the
-- 'Data.HashMap.Int128Hashable' class.
getObjectHash128 :: Exec (Object -> H.Hash128)
getObjectHash128 = gets globalMethodTable >>= \mt -> return (H.deriveHash128_DaoBinary mt)

instance HataClass (H.HashMap Object Object) where
  haskellDataInterface = interface "HashMap" $ do
    autoDefEquality >> autoDefOrdering >> autoDefBinaryFmt >> autoDefPPrinter
    autoDefSizeable >> autoDefUpdateIterable
    let un _ a b = xmaybe (fromObj b) >>= \b -> return $ new $ H.union b a
    defInfixOp ADD  un
    defInfixOp ORB  un
    defInfixOp ANDB $ \ _ a b -> xmaybe (fromObj b) >>= \b -> return $ new $ (H.intersection b a :: H.HashMap Object Object)
    defInfixOp SUB  $ \ _ a b -> xmaybe (fromObj b) >>= \b -> return $ new $ (H.difference b a :: H.HashMap Object Object)
    let initItems hmap ox = do
          hash128 <- getObjectHash128
          let f hmap o = case o of
                InitSingle o -> do
                  let idx = H.hashNewIndex hash128 o
                  return $ H.hashInsert idx o hmap
                InitAssign i op o -> do
                  i <- derefObject i
                  let idx = H.hashNewIndex hash128 i
                  let ref = Just (RefObject i NullRef) <|> fromObj i
                  o <- evalUpdateOp ref op o (H.hashLookup idx hmap)
                  return $ case o of
                    Nothing -> H.hashDelete idx hmap
                    Just  o -> H.hashInsert idx o hmap
          foldM f hmap ox
    defInitializer hashMapFromList initItems
    let single_index :: Monad m => (Object -> m a) -> [Object] -> m a
        single_index f ix = case ix of
          [i] -> f i
          []  -> fail "no index value provided in subscript to HashMap data type"
          _   -> fail "HashMap is a one-dimensional data type, indexed with multi-dimesional subscript"
    defIndexer $ \hm -> single_index $ \i -> do
      hash128 <- getObjectHash128
      i <- derefObject i
      xmaybe (H.hashLookup (H.hashNewIndex hash128 i) hm)
    defIndexUpdater $ \ix upd -> flip single_index ix $ \i -> do
      hash128 <- focusLiftExec getObjectHash128
      i <- focusLiftExec $ derefObject i
      i <- pure (H.hashNewIndex hash128 i)
      hm <- get
      (result, (changed, o)) <- withInnerLens (H.hashLookup i hm) upd
      when changed (put $ H.hashAlter (const o) i hm)
      return result

hashMapFromList :: [Object] -> Exec (H.HashMap Object Object)
hashMapFromList ox = do
  hash128 <- getObjectHash128
  let fromDict = fmap (\ (i, o) -> (H.hashNewIndex hash128 (obj i), o)) . M.assocs
      f (a, o) = case o of
        OList ox -> case mapM (\ (i, o) -> maybe (Left (i, o)) Right (fromObj o)) (zip [0..] ox) of
          Left (i, t) -> throwBadTypeError "list item in hash map initializer" t $
            [(errInInitzr, OInt a), (ustr "listIndex", OInt i)]
          Right ox -> return $ fmap (\ (Pair(a,b)) -> (H.hashNewIndex hash128 a, b)) ox
        OTree (Struct{fieldMap=ox}) -> return $ fromDict ox
        ODict   ox -> return $ fromDict ox
        o -> do
          let badtype = throwBadTypeError "hash map initializer from list" o [(errInInitzr, OInt a)]
          maybe badtype return $ msum $
            [ fromObj o >>= \ (Pair(a,b)) -> Just [(H.hashNewIndex hash128 a, b)]
            , H.assocs <$> fromObj o
            ]
  H.fromList . concat <$> mapM f (zip [1..] ox)

builtin_HashMap :: DaoFunc ()
builtin_HashMap =
  daoFunc{ daoForeignFunc = \ () -> fmap (flip (,) () . Just . obj) . hashMapFromList }

----------------------------------------------------------------------------------------------------

-- | When defining the function used by the Dao interpreter to construct your object from an
-- initializer statement, a statement which looks like the following code:
-- > MyObj(0, a) { item = 1, item += 3, x, y };
-- you will need to receive the list of items expressed in curly-brackets, which could be an
-- assignment operation, or a single object value expression. This data type provides the necessary
-- data to your initializer function.
data InitItem
  = InitSingle Object
  | InitAssign Object UpdateOp Object
  deriving (Eq, Ord, Typeable)

----------------------------------------------------------------------------------------------------

-- | This is all of the functions used by the "Dao.Evaluator" when manipulating objects in a Dao
-- program. Behavior of objects when they are used in "for" statements or "with" statements, or when
-- they are dereferenced using the "@" operator, or when they are used in equations are all defined
-- here.
-- 
-- So this table is the reason you instantiate 'HataClass'.
-- 
-- @obj@ specifies the container type that will wrap-up data of type @typ@. @obj@ is the type used
-- throughout the runtime system to symbolize the basic unit of information operated on by
-- computations.
-- 
-- @typ@ specifies the type that you want to wrap-up into an @obj@ constructor. When you want to,
-- for example, check for equality between object of type @typ@, you can define a function for
-- 'objEquality'. All of the other polymorphic types are bound to the @typ@ types by the functional
-- dependencies mechanism of the Haskell language.
-- 
-- @exec@ specifies a monad in which to evaluate functions which may need to cause side-effects.
-- This should usually be a 'Control.Monad.Monad'ic type like @IO@ or 'Exec'.
data Interface typ =
  Interface
  { objInterfaceName   :: Name
  , objHaskellType     :: TypeRep -- ^ this type is deduced from the initial value provided to the 'interface'.
  , objCastFrom        :: Maybe (Object -> typ)                                                      -- ^ defined by 'defCastFrom'
  , objEquality        :: Maybe (typ -> typ -> Bool)                                                 -- ^ defined by 'defEquality'
  , objOrdering        :: Maybe (typ -> typ -> Ordering)                                             -- ^ defined by 'defOrdering'
  , objBinaryFormat    :: Maybe (typ -> Put, Get typ)                                                -- ^ defined by 'defBinaryFmt'
  , objNullTest        :: Maybe (typ -> Bool)                                                        -- ^ defined by 'defNullTest'
  , objPPrinter        :: Maybe (typ -> PPrint)                                                      -- ^ defined by 'defPPrinter'
  , objReadIterable    :: Maybe (typ -> (Object -> Exec ()) -> Exec ())                              -- ^ defined by 'defReadIterator'
  , objUpdateIterable  :: Maybe (typ -> (Maybe Object -> Exec (Maybe Object)) -> Exec typ)           -- ^ defined by 'defUpdateIterator'
  , objIndexer         :: Maybe (typ -> [Object] -> Exec Object)                                     -- ^ defined by 'defIndexer'
  , objIndexUpdater    :: Maybe (ObjectUpdate typ [Object])                                          -- ^ defined by 'defIndexUpdater'
  , objSizer           :: Maybe (typ -> Exec Object)                                                 -- ^ defined by 'defSizer'
  , objToStruct        :: Maybe (ToDaoStruct typ ())                                                 -- ^ defined by 'defStructFormat'
  , objFromStruct      :: Maybe (FromDaoStruct typ)                                                  -- ^ defined by 'defStructFormat'
  , objInitializer     :: Maybe ([Object] -> Exec typ, typ -> [InitItem] -> Exec typ)                -- ^ defined by 'defDictInit'
  , objTraverse        :: Maybe (ObjectTraverse typ [Object])                                        -- ^ defined by 'defTraverse'
  , objInfixOpTable    :: Maybe (Array InfixOp  (Maybe (InfixOp  -> typ -> Object -> XPure Object))) -- ^ defined by 'defInfixOp'
  , objArithPfxOpTable :: Maybe (Array ArithPfxOp (Maybe (ArithPfxOp -> typ -> XPure Object)))       -- ^ defined by 'defPrefixOp'
  , objCallable        :: Maybe (typ -> Exec [CallableCode])                                         -- ^ defined by 'defCallable'
  , objDereferencer    :: Maybe (typ -> Exec (Maybe Object))
  , objMethodTable     :: M.Map Name (DaoFunc typ)
  }
  deriving Typeable

instance Eq  (Interface typ) where { a==b = objHaskellType a == objHaskellType b }

instance Ord (Interface typ) where { compare a b = compare (objHaskellType a) (objHaskellType b) }

-- | This function works a bit like 'Data.Functor.fmap', but maps an 'Interface' from one type
-- to another. This requires two functions: one that can cast from the given type to the adapted
-- type (to convert outputs of functions), and one that can cast back from the adapted type to the
-- original type (to convert inputs of functions). Each coversion function takes a string as it's
-- first parameter, this is a string containing the name of the function that is currently making
-- use of the conversion operation. Should you need to use 'Prelude.error' or 'newError', this
-- string will allow you to throw more informative error messages. WARNING: this function leaves
-- 'objHaskellType' unchanged because the original type value should usually be preserved.
interfaceAdapter
  :: (Typeable typ_a, Typeable typ_b)
  => (String -> typ_a -> typ_b)
  -> (String -> typ_b -> typ_a)
  -> Interface typ_a
  -> Interface typ_b
interfaceAdapter a2b b2a ifc = 
  ifc
  { objCastFrom        = let n="objCastFrom"       in fmap (fmap (a2b n)) (objCastFrom ifc)
  , objEquality        = let n="objEquality"       in fmap (\eq  a b -> eq  (b2a n a) (b2a n b)) (objEquality ifc)
  , objOrdering        = let n="objOrdering"       in fmap (\ord a b -> ord (b2a n a) (b2a n b)) (objOrdering ifc)
  , objBinaryFormat    = let n="objBinaryFormat"   in fmap (\ (toBin , fromBin) -> (toBin . b2a n, fmap (a2b n) fromBin)) (objBinaryFormat ifc)
  , objNullTest        = let n="objNullTest"       in fmap (\null b -> null (b2a n b)) (objNullTest ifc)
  , objPPrinter        = let n="objPPrinter"       in fmap (\eval -> eval . b2a n) (objPPrinter ifc)
  , objReadIterable    = let n="objReadIterable"   in fmap (\for t -> for (b2a n t)) (objReadIterable ifc)
  , objUpdateIterable  = let n="objUpdateIterable" in fmap (\for t -> fmap (a2b n) . for (b2a n t)) (objUpdateIterable ifc)
  , objIndexer         = let n="objIndexer"        in fmap (\f i -> f (b2a n i)) (objIndexer ifc)
  , objIndexUpdater    = let n="objIndexUpdater"   in fmap (\upd i f -> convertFocus (a2b n) (b2a n) (upd i f)) (objIndexUpdater ifc)
  , objSizer           = let n="objSizer"          in fmap (\f o -> f (b2a n o)) (objSizer ifc)
  , objToStruct        = let n="objToStruct"       in fmap (fmapHaskDataToStruct (a2b n) (b2a n)) (objToStruct ifc)
  , objFromStruct      = let n="objFromStruct"     in fmap (fmap (a2b n)) (objFromStruct ifc)
  , objInitializer     = let n="objInitializer"    in fmap (\ (init, eval) -> (\ox -> fmap (a2b n) (init ox), \typ ox -> fmap (a2b n) (eval (b2a n typ) ox))) (objInitializer ifc)
  , objTraverse        = let n="objTraverse"       in fmap (\focus f -> convertFocus (a2b n) (b2a n) (focus f)) (objTraverse ifc)
  , objInfixOpTable    = let n="objInfixOpTable"   in fmap (fmap (fmap (\infx op b -> infx op (b2a n b)))) (objInfixOpTable  ifc)
  , objArithPfxOpTable = let n="objPrefixOpTable"  in fmap (fmap (fmap (\prfx op b -> prfx op (b2a n b)))) (objArithPfxOpTable ifc)
  , objMethodTable     = let n="objMethodTable"    in fmap (\func -> func{ daoForeignFunc = \t -> fmap (fmap (a2b n)) . daoForeignFunc func (b2a n t) }) (objMethodTable ifc)
  , objCallable        = let n="objCallable"       in fmap (\eval -> eval . b2a n) (objCallable ifc)
  , objDereferencer    = let n="objDerferencer"    in fmap (\eval -> eval . b2a n) (objDereferencer ifc)
  }

interfaceToDynamic :: Typeable typ => Interface typ -> Interface Dynamic
interfaceToDynamic oi = interfaceAdapter (\ _ -> toDyn) (from oi) oi where
  from :: Typeable typ => Interface typ -> String -> Dynamic -> typ
  from oi msg dyn = fromDyn dyn (dynErr oi msg dyn)
  dynErr :: Typeable typ => Interface typ -> String -> Dynamic -> typ
  dynErr oi msg dyn = error $ concat $
    [ "The '", msg
    , "' function defined for objects of type ", show (objHaskellType oi)
    , " was evaluated on an object of type ", show (dynTypeRep dyn)
    ]

-- Used to construct an 'Interface' in a "Control.Monad.State"-ful way. Instantiates
-- 'Data.Monoid.Monoid' to provide 'Data.Monoid.mempty' an allows multiple inheritence by use of the
-- 'Data.Monoid.mappend' function in the same way as
data HDIfcBuilder typ =
  HDIfcBuilder
  { objIfcHaskellType    :: TypeRep
  , objIfcCastFrom       :: Maybe (Object -> typ)
  , objIfcEquality       :: Maybe (typ -> typ -> Bool)
  , objIfcOrdering       :: Maybe (typ -> typ -> Ordering)
  , objIfcBinaryFormat   :: Maybe (typ -> Put, Get typ)
  , objIfcNullTest       :: Maybe (typ -> Bool)
  , objIfcPPrinter       :: Maybe (typ -> PPrint)
  , objIfcReadIterable   :: Maybe (typ -> (Object -> Exec ()) -> Exec ())
  , objIfcUpdateIterable :: Maybe (typ -> (Maybe Object -> Exec (Maybe Object)) -> Exec typ)
  , objIfcIndexer        :: Maybe (typ -> [Object] -> Exec Object)
  , objIfcIndexUpdater   :: Maybe (ObjectUpdate typ [Object])
  , objIfcSizer          :: Maybe (typ -> Exec Object)
  , objIfcToStruct       :: Maybe (ToDaoStruct typ ())
  , objIfcFromStruct     :: Maybe (FromDaoStruct typ)
  , objIfcInitializer    :: Maybe ([Object] -> Exec typ, typ -> [InitItem] -> Exec typ)
  , objIfcTraverse       :: Maybe (ObjectTraverse typ [Object])
  , objIfcInfixOpTable   :: [(InfixOp , InfixOp  -> typ -> Object -> XPure Object)]
  , objIfcPrefixOpTable  :: [(ArithPfxOp, ArithPfxOp -> typ -> XPure Object)]
  , objIfcMethodTable    :: M.Map Name (DaoFunc typ)
  , objIfcCallable       :: Maybe (typ -> Exec [CallableCode])
  , objIfcDerefer        :: Maybe (typ -> Exec (Maybe Object))
  }

initHDIfcBuilder :: TypeRep -> HDIfcBuilder typ
initHDIfcBuilder typ =
  HDIfcBuilder
  { objIfcHaskellType    = typ
  , objIfcCastFrom       = Nothing
  , objIfcEquality       = Nothing
  , objIfcOrdering       = Nothing
  , objIfcBinaryFormat   = Nothing
  , objIfcNullTest       = Nothing
  , objIfcPPrinter       = Nothing
  , objIfcReadIterable   = Nothing
  , objIfcUpdateIterable = Nothing
  , objIfcIndexer        = Nothing
  , objIfcIndexUpdater   = Nothing
  , objIfcSizer          = Nothing
  , objIfcToStruct       = Nothing
  , objIfcFromStruct     = Nothing
  , objIfcInitializer    = Nothing
  , objIfcTraverse       = Nothing
  , objIfcInfixOpTable   = []
  , objIfcPrefixOpTable  = []
  , objIfcMethodTable    = mempty
  , objIfcCallable       = Nothing
  , objIfcDerefer        = Nothing
  }

-- | A handy monadic interface for defining an 'Interface' using nice, clean procedural
-- syntax.
type    DaoClassDef typ = DaoClassDefM typ ()
newtype DaoClassDefM typ a = DaoClassDefM { daoClassDefState :: State (HDIfcBuilder typ) a }
instance Typeable typ => Functor (DaoClassDefM typ) where
  fmap f (DaoClassDefM m) = DaoClassDefM (fmap f m)
instance Typeable typ => Monad (DaoClassDefM typ) where
  return = DaoClassDefM . return
  (DaoClassDefM m) >>= f = DaoClassDefM (m >>= daoClassDefState . f)
instance Typeable typ => Applicative (DaoClassDefM typ) where { pure=return; (<*>)=ap; }

_updHDIfcBuilder :: Typeable typ => (HDIfcBuilder typ -> HDIfcBuilder typ) -> DaoClassDefM typ ()
_updHDIfcBuilder = DaoClassDefM . modify

-- | The callback function defined here is used when objects of your @typ@ can be constructed from
-- some other 'Object'. This function is used to convert an 'Object' of another types to an data
-- type of your @typ@ when it is necessary to do so (for example, evaluating the @==@ or @!=@
-- operator).
defCastFrom :: Typeable typ => (Object -> typ) -> DaoClassDefM typ ()
defCastFrom fn = _updHDIfcBuilder(\st->st{objIfcCastFrom=Just fn})

-- | The callback function defined here is used where objects of your @typ@ might be compared to
-- other objects using the @==@ and @!=@ operators in Dao programs. However using this is slightly
-- different than simply overriding the @==@ or @!=@ operators. Defining an equality reliation with
-- this function also allows Haskell language programs to compare your object to other objects
-- without unwrapping them from the 'Object' wrapper.
--
-- This function automatically define an equality operation over your @typ@ using the
-- instantiation of 'Prelude.Eq' and the function you have provided to the 'defCastFrom' function.
-- The 'defCastFrom' function is used to cast 'Object's to a value of your @typ@, and then the
-- @Prelude.==@ function is evaluated. If you eventually never define a type casting funcion using
-- 'defCastFrom', this function will fail, but it will fail lazily and at runtime, perhaps when you
-- least expect it, so be sure to define 'defCastFrom' at some point.
autoDefEquality :: (Typeable typ, Eq typ) => DaoClassDefM typ ()
autoDefEquality = defEquality (==)

-- | The callback function defined here is used where objects of your @typ@ might be compared to
-- other objects using the @==@ and @!=@ operators in Dao programs. However using this is slightly
-- different than simply overriding the @==@ or @!=@ operators. Defining an equality relation with
-- this function also allows Haskell language programs to compare your object to other objects
-- without unwrapping them from the 'Object' wrapper.
--
-- This function differs from 'autoDefEquality' because you must provide a customized equality
-- relation for your @typ@, if the 'autoDefEquality' and 'defCastFrom' functions are to be avoided
-- for some reason.
defEquality :: (Typeable typ, Eq typ) => (typ -> typ -> Bool) -> DaoClassDefM typ ()
defEquality fn = _updHDIfcBuilder(\st->st{objIfcEquality=Just fn})

-- | The callback function defined here is used where objects of your @typ@ might be compared to
-- other objects using the @<@, @>@, @<=@, and @>=@ operators in Dao programs. However using this is
-- slightly different than simply overriding the @<@, @>@, @<=@, or @>=@ operators. Defining an
-- equality relation with this function also allows Haskell language programs to compare your obejct
-- to other objects without unwrapping them from the 'Object' wrapper.
-- 
-- Automatically define an ordering for your @typ@ using the instantiation of
-- 'Prelude.Eq' and the function you have provided to the 'defCastFrom' function. The 'defCastFrom'
-- function is used to cast 'Object's to a value of your @typ@, and then the @Prelude.==@ function
-- is evaluated. If you eventually never define a type casting funcion using 'defCastFrom', this
-- function will fail, but it will fail lazily and at runtime, perhaps when you least expect it, so
-- be sure to define 'defCastFrom' at some point.
autoDefOrdering :: (Typeable typ, Ord typ) => DaoClassDefM typ ()
autoDefOrdering = defOrdering compare

-- | The callback function defined here is used where objects of your @typ@ might be compared to
-- other objects using the @<@, @>@, @<=@, and @>=@ operators in Dao programs. However using this is
-- slightly different than simply overriding the @<@, @>@, @<=@, or @>=@ operators. Defining an
-- equality relation with this function also allows Haskell language programs to compare your obejct
-- to other objects without unwrapping them from the 'Object' wrapper.
-- 
-- Define a customized ordering for your @typ@, if the 'autoDefEquality' and 'defCastFrom'
-- functions are to be avoided for some reason.
defOrdering :: (Typeable typ) => (typ -> typ -> Ordering) -> DaoClassDefM typ ()
defOrdering fn = _updHDIfcBuilder(\st->st{objIfcOrdering=Just fn})

-- | The callback function defined here is used if an object of your @typ@ should ever need to be
-- stored into a binary file in persistent storage (like your filesystem) or sent across a channel
-- (like a UNIX pipe or a socket).
-- 
-- It automatically define the binary encoder and decoder using the 'Data.Binary.Binary' class
-- instantiation for this @typ@.
autoDefBinaryFmt :: (Typeable typ, B.Binary typ MethodTable) => DaoClassDefM typ ()
autoDefBinaryFmt = defBinaryFmt B.put B.get

-- | This function is used if an object of your @typ@ should ever need to be stored into a binary
-- file in persistent storage (like your filesystem) or sent across a channel (like a UNIX pipe or a
-- socket).
-- 
-- If you have binary coding and decoding methods for your @typ@ but for some silly reason not
-- instantiated your @typ@ into the 'Data.Binary.Binary' class, your @typ@ can still be used as a
-- binary formatted object by the Dao system if you define the encoder and decoder using this
-- function. However, it would be better if you instantiated 'Data.Binary.Binary' and used
-- 'autoDefBinaryFmt' instead.
defBinaryFmt :: (Typeable typ) => (typ -> Put) -> Get typ -> DaoClassDefM typ ()
defBinaryFmt put get = _updHDIfcBuilder(\st->st{objIfcBinaryFormat=Just(put,get)})

autoDefNullTest :: (Typeable typ, HasNullValue typ) => DaoClassDefM typ ()
autoDefNullTest = defNullTest testNull

-- | The callback function defined here is used if an object of your @typ@ is ever used in an @if@
-- or @while@ statement in a Dao program. This function will return @Prelude.True@ if the object is
-- of a null value, which will cause the @if@ or @while@ test to fail and execution of the Dao
-- program will branch accordingly. There is no default method for this function so it must be
-- defined by this function, otherwise your object cannot be tested by @if@ or @while@ statements.
defNullTest :: Typeable typ => (typ -> Bool) -> DaoClassDefM typ ()
defNullTest fn = _updHDIfcBuilder(\st->st{objIfcNullTest=Just fn})

-- | The callback function to be called when the "print" built-in function is used.
defPPrinter :: Typeable typ => (typ -> PPrint) -> DaoClassDefM typ ()
defPPrinter fn = _updHDIfcBuilder(\st->st{objIfcPPrinter=Just fn})

-- | The callback function to be called when the "print" built-in function is used.
autoDefPPrinter :: (Typeable typ, PPrintable typ) => DaoClassDefM typ ()
autoDefPPrinter = defPPrinter pPrint

-- | The callback function defined here is used if an object of your @typ@ is ever used in a @for@
-- statement in a Dao program. However it is much better to instantiate your @typ@ into the
-- 'ReadIterable' class and use 'autoDefIterator' instead. If 'defUpdateIterator' is also defined,
-- the function defined here will never be used.
--
-- /NOTE:/ When defining iterators, it is important to use 'execForM' or 'execForM_' to properly
-- handle "break" and "catch" statements.
defReadIterable :: Typeable typ => (typ -> (Object -> Exec ()) -> Exec ()) -> DaoClassDefM typ ()
defReadIterable iter = _updHDIfcBuilder $ \st -> st{ objIfcReadIterable=Just iter }

-- | Define 'defReadIterable' automatically using the instance of @typ@ in the 'ReadIterable' class.
--
-- /NOTE:/ When defining iterators, it is important to use 'execForM' or 'execForM_' to properly
-- handle "break" and "catch" statements.
autoDefReadIterable :: (Typeable typ, ReadIterable typ Object) => DaoClassDefM typ ()
autoDefReadIterable = defReadIterable readForLoop

-- | The callback function defined here is used if an object of your @typ@ is ever used in a @for@
-- statement in a Dao program. However it is much better to instantiate your @typ@ into the
-- 'UpdateIterable' class and use 'autoDefIterator' instead. If 'defReadIterator' is also defined,
-- the read iterator is always ignored in favor of this function.
--
-- /NOTE:/ When defining iterators, it is important to use 'execForM' or 'execForM_' to properly
-- handle "break" and "catch" statements.
defUpdateIterable :: Typeable typ => (typ -> (Maybe Object -> Exec (Maybe Object)) -> Exec typ) -> DaoClassDefM typ ()
defUpdateIterable iter = _updHDIfcBuilder(\st->st{objIfcUpdateIterable=Just iter})

-- | Define 'defUpdateIterable' automatically using the instance of @typ@ in the 'ReadIterable'
-- class.
--
-- /NOTE:/ When defining iterators, it is important to use 'execForM' or 'execForM_' to properly
-- handle "break" and "catch" statements.
autoDefUpdateIterable :: (Typeable typ, UpdateIterable typ (Maybe Object)) => DaoClassDefM typ ()
autoDefUpdateIterable = defUpdateIterable updateForLoop

-- | The callback function defined here is used at any point in a Dao program where an expression
-- containing your object typ is subscripted with square brackets, for example in the statement:
-- @x = t[0][A][B];@ The object passed to your callback function is the object containing the
-- subscript value. So in the above example, if the local variable @t@ is a value of
-- your @typ@, this callback function will be evaluated three times:
-- 1.  with the given 'Object' parameter being @('OInt' 0)@ and the @typ@ parameter as the value
--     stored in the local variable @y@.
-- 2.  once with the 'Object' parameter being the result of dereferencing the local varaible @A@ and
--     the @typ@ parameter as the value stored in the local variable @y@.
-- 3.  once the given 'Object' parameter being the result of dereferencing the local variable @B@ and
--     the @typ@ parameter as the value stored in the local variable @y@.
-- 
-- Statements like this:
-- > ... = a[0,1,2]
-- access a single multi-dimensional index, in this case 3-dimensions with the tuple [0,1,2].
-- > ... = a[0][1][2]
-- accesses a sequence of single-dimensional elements, each element being accessed by the next
-- snigle-dimensional index in the sequence. Although this is one method of programming
-- multi-dimensional data types, it is evaluated differently than an index expressed as a tuple.
defIndexer :: Typeable typ => (typ -> [Object] -> Exec Object) -> DaoClassDefM typ ()
defIndexer fn = _updHDIfcBuilder(\st->st{objIfcIndexer=Just fn})

-- | The callback function defined here is used at any point in a Dao program where an expression
-- containing your object typ is subscripted with square brackets on the left-hand side of an
-- assignment expression:
-- @x[0][A][B] = t;@
-- This function must take the original object of your @typ@ and return the updated object along
-- with the value used to updated it.  The object passed to your callback function is the object
-- containing the subscript value. So in the above example, if the local variables @x@ is a value of
-- your @typ@, this callback function will be evaluated three times:
-- 1.  with the given 'Object' parameter being @('OInt' 0)@ and the @typ@ parameter as the value
--     stored in the local variable @y@.
-- 2.  once with the 'Object' parameter being the result of dereferencing the local varaible @A@ and
--     the @typ@ parameter as the value stored in the local variable @y@.
-- 3.  once the given 'Object' parameter being the result of dereferencing the local variable @B@ and
--     the @typ@ parameter as the value stored in the local variable @y@.
-- 
-- Statements like this:
-- > a[0,1,2] = ...
-- access a single multi-dimensional index, in this case 3-dimensions with the tuple [0,1,2].
-- > a[0][1][2] = ...
-- accesses a sequence of single-dimensional elements, each element being accessed by the next
-- snigle-dimensional index in the sequence. Although this is one method of programming
-- multi-dimensional data types, it is evaluated differently than an index expressed as a tuple.
defIndexUpdater :: Typeable typ => ObjectUpdate typ [Object] -> DaoClassDefM typ ()
defIndexUpdater fn = _updHDIfcBuilder(\st->st{ objIfcIndexUpdater=Just fn })

-- | Define a function used by the built-in "size()" function to return an value indicating the size
-- of your @typ@ object.
defSizer :: Typeable typ => (typ -> Exec Object) -> DaoClassDefM typ ()
defSizer fn = _updHDIfcBuilder(\st->st{objIfcSizer=Just fn})

autoDefSizeable :: (Typeable typ, Sizeable typ) => DaoClassDefM typ ()
autoDefSizeable = defSizer getSizeOf

-- | Use your data type's instantiation of 'ToDaoStructClass' to call 'defToStruct'.
autoDefToStruct :: forall typ . (Typeable typ, ToDaoStructClass typ) => DaoClassDefM typ ()
autoDefToStruct = defToStruct toDaoStruct

-- | When a label referencing your object has a field record accessed, for example:
-- > c = a.b;
-- if your object is referenced by @a@ and the script expression wants to access a record called @b@
-- from within it, then function defined here will be used.
defToStruct :: Typeable typ => ToDaoStruct typ () -> DaoClassDefM typ ()
defToStruct encode = _updHDIfcBuilder (\st -> st{ objIfcToStruct=Just encode })

-- | When a label referencing your object has a field record updated, for example:
-- > a.b = c;
-- if your object is referenced by @a@ and the script expression wants to update a record called @b@
-- within it by assigning it the value referenced by @c@, then the function defined here will be
-- used.
autoDefFromStruct :: (Typeable typ, FromDaoStructClass typ) => DaoClassDefM typ ()
autoDefFromStruct = defFromStruct fromDaoStruct

-- | If for some reason you need to define a tree encoder and decoder for the 'Interface' of your
-- @typ@ without instnatiating 'ToDaoStructClass' or 'FromDaoStructClass', use
-- this function to define the tree encoder an decoder directly
defFromStruct :: Typeable typ => FromDaoStruct typ -> DaoClassDefM typ ()
defFromStruct decode = _updHDIfcBuilder (\st -> st{ objIfcFromStruct=Just decode })

-- | The callback defined here is used when a Dao program makes use of the static initialization
-- syntax of the Dao programming language, which are expression of this form:
-- > a = MyType { paramA=initA, paramB=initB, .... };
-- > a = MyType(param1, param2, ...., paramN) { paramA=initA, paramB=initB, .... };
-- When the interpreter sees this form of expression, it looks up the 'Interface' for your
-- @typ@ and checks if a callback has been defined by 'defDictInit'. If so, then the callback is
-- evaluated with a list of object values passed as the first parameter which contain the object
-- values written in the parentheses, and a list of 'InitItem's as the second parameter containing
-- the contents of the curly-brackets.
defInitializer :: Typeable typ => ([Object] -> Exec typ) -> (typ -> [InitItem] -> Exec typ) -> DaoClassDefM typ ()
defInitializer fa fb = _updHDIfcBuilder(\st->st{objIfcInitializer=Just (fa, fb)})

-- | Data structures in the Dao programming language can be traversed if you provide a function that
-- can update every 'Object' contained wihtin the data structure.
defTraverse :: Typeable typ => (([Object] -> Object -> ObjectFocus [([Object], Object)] ()) -> ObjectFocus typ ()) -> DaoClassDefM typ ()
defTraverse f = _updHDIfcBuilder(\st->st{objIfcTraverse=Just f})

-- | Define the 'defTraverse' function using the instance of 'objectFMap' for your @typ@ in the
-- @('ObjectFunctor' ['Object'] typ)@ class.
autoDefTraverse :: (Typeable typ, ObjectFunctor typ [Object]) => DaoClassDefM typ ()
autoDefTraverse = defTraverse objectFMap

-- | Overload infix operators in the Dao programming language, for example @+@, @*@, or @<<@.
-- 
-- Like with C++, the operator prescedence and associativity is permanently defined by the parser
-- and cannot be changed by the overloading mechanism. You can only change how the operator behaves
-- based on the type of it's left and right hand parameters.
--
-- If you define two callbacks for the same 'UpdateOp', this will result in a runtime error,
-- hopefully the error will occur during the Dao runtime's object loading phase, and not while
-- actually executing a program.
defInfixOp :: Typeable typ => InfixOp -> (InfixOp -> typ -> Object -> XPure Object) -> DaoClassDefM typ ()
defInfixOp op fn = _updHDIfcBuilder $ \st -> st{objIfcInfixOpTable  = objIfcInfixOpTable  st ++ [(op, fn)] }

-- | Overload prefix operators in the Dao programming language, for example @!@, @~@, @-@, and @+@.
-- 
-- Like with C++, the operator prescedence and associativity is permanently defined by the parser
-- and cannot be changed by the overloading mechanism. You can only change how the operator behaves
-- based on the type of it's left and right hand parameters.
-- 
-- If you define two callbacks for the same 'UpdateOp', this will result in a runtime error,
-- hopefully the error will occur during the Dao runtime's object loading phase, and not while
-- actually executing a program.
defPrefixOp :: Typeable typ => ArithPfxOp -> (ArithPfxOp -> typ -> XPure Object) -> DaoClassDefM typ ()
defPrefixOp op fn = _updHDIfcBuilder $ \st -> st{objIfcPrefixOpTable = objIfcPrefixOpTable st ++ [(op, fn)] }

defCallable :: Typeable typ => (typ -> Exec [CallableCode]) -> DaoClassDefM typ ()
defCallable fn = _updHDIfcBuilder (\st -> st{objIfcCallable=Just fn})

defDeref :: Typeable typ => (typ -> Exec (Maybe Object)) -> DaoClassDefM typ ()
defDeref  fn = _updHDIfcBuilder (\st -> st{objIfcDerefer=Just fn})

defMethod :: (UStrType name, Typeable typ) => name -> DaoFunc typ -> DaoClassDefM typ ()
defMethod inname infn = do
  let name = fromUStr $ toUStr inname
  let fn = infn{ daoFuncName=name }
  let dupname st _  = error $ concat $ 
        [ "Internal error: duplicate method name \"", show name
        , "\" for data type ", show (objIfcHaskellType st)
        ] 
  _updHDIfcBuilder $ \st ->
    st{ objIfcMethodTable = M.alter (maybe (Just fn) (dupname st)) name $ objIfcMethodTable st }

-- | Like 'detMethod' but creates a function that takes no parameters.
defMethod0 :: (UStrType name, Typeable this) => name -> (this -> Exec (Maybe Object, this)) -> DaoClassDefM this ()
defMethod0 name f = defMethod name $
  daoFunc
  { funcAutoDerefParams = False
  , daoForeignFunc = \this ox -> case ox of
      [] -> f this
      ox -> throwArityError "" 0 ox [(errInFunc, obj $ reference UNQUAL (fromUStr $ toUStr name))]
  }

-- | Rocket. Yeah. Sail away with you.
defLeppard :: Typeable typ => rocket -> yeah -> DaoClassDefM typ ()
defLeppard _ _ = return ()

-- | This is the Dao 'Object' interface to the Haskell language. Every function in this data type
-- allows you to customize the behavior of the Dao evaluator for a particular Haskell data type
-- @typ@. In order for your type to be useful, it must be possible to pass your data type to the
-- 'OHaskell' constructor, which requires a data type of 'Data.Dynamic.Dynamic', which means your
-- @typ@ must derive a class instance for 'Data.Typeable.Typeable'. The first parameter of type
-- @typ@ is not used except to retrieve it's 'Data.Typeable.TypeRep' using the
-- 'Data.Typealble.typeOf' function, it is safe to pass any data constructor with all of it's fields
-- 'Prelude.undefined', just the constructor itself must not be 'Prelude.undefined'.
-- 
-- The @'DaoClassDefM'@ parameter you pass to this function is a monadic function so you can simply
-- declare the functionality you would like to include in this object one line at a time using
-- the procedural coding style. Each line in the "procedure" will be one of the @def*@ functions,
-- for example 'autoDefEquality' or 'autoDefOrdering'.
interface :: (UStrType name, Typeable typ) => name -> DaoClassDefM typ ig -> Interface typ
interface nm defIfc = let name = toUStr nm in case maybeFromUStr name of
  Nothing   -> error $
    "Failed to install built-in data type interface, invalid type name provided: "++uchars nm
  Just name ->
    Interface
    { objHaskellType     = typ
    , objInterfaceName   = name
    , objCastFrom        = objIfcCastFrom       ifc
    , objEquality        = objIfcEquality       ifc
    , objOrdering        = objIfcOrdering       ifc
    , objBinaryFormat    = objIfcBinaryFormat   ifc
    , objNullTest        = objIfcNullTest       ifc
    , objPPrinter        = objIfcPPrinter       ifc
    , objReadIterable    = objIfcReadIterable   ifc
    , objUpdateIterable  = objIfcUpdateIterable ifc
    , objIndexer         = objIfcIndexer        ifc
    , objIndexUpdater    = objIfcIndexUpdater   ifc
    , objSizer           = objIfcSizer          ifc
    , objToStruct        = objIfcToStruct       ifc
    , objFromStruct      = objIfcFromStruct     ifc
    , objInitializer     = objIfcInitializer    ifc
    , objTraverse        = objIfcTraverse       ifc
    , objCallable        = objIfcCallable       ifc
    , objDereferencer    = objIfcDerefer        ifc
    , objInfixOpTable    = mkArray "defInfixOp"  $ objIfcInfixOpTable  ifc
    , objArithPfxOpTable = mkArray "defPrefixOp" $ objIfcPrefixOpTable ifc
    , objMethodTable     = objIfcMethodTable    ifc
    }
  where
    mktyp :: Typeable typ => DaoClassDefM typ ig -> typ -> TypeRep
    mktyp _ undefd = typeOf undefd
    typ = mktyp defIfc $
      error "'Dao.Interpreter.interface' evaluated 'Data.Typeable.typeOf' on undefined value"
    ifc = execState (daoClassDefState defIfc) (initHDIfcBuilder typ)
    mkArray oiName elems =
      minAccumArray (onlyOnce oiName) Nothing $ map (\ (i, e) -> (i, (i, Just e))) elems
    onlyOnce oiName a (i, b)  = case a of
      Nothing -> b
      Just  _ -> conflict oiName ("the "++show i++" operator")
    conflict oiName funcName = error $ concat $
      [ "'", oiName
      , "' has conflicting functions for ", funcName
      , " for the 'HataClass' instantiation of the '", show typ
      , "' Haskell data type."
      ]