{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans -fallow-overlapping-instances -fallow-undecidable-instances -fparr #-}

module Pugs.AST.Internals (
    Eval(..),      -- uses Val, Env, SIO
    Ann(..),   -- Cxt, Pos, Prag
    Exp(..),   -- uses Pad, Eval, Val
    Env(..),   -- uses Pad, TVar, Exp, Eval, Val
    Val(..),   -- uses V.* (which ones?)
    Value(..), -- uses Val, Eval
    InitDat(..),
    SubAssoc(..), TraitBlocks(..), emptyTraitBlocks,

    MPad(..), LexPad(..), LexPads, Pad(..), PadEntry(..), EntryFlags(..), PadMutator, -- uses Var, TVar, VRef
    Param(..), -- uses Cxt, Exp
    Params, -- uses Param
    Bindings, -- uses Param, Exp
    SlurpLimit, -- VInt, Exp
    
    emptyPad,

    VRef(..), -- uses IVar
    VOpaque(..), -- uses Value
    VControl(..), -- uses Env, Eval, Val
    ControlLoop(..), ControlWhen(..), Frame(..),
    VScalar, -- uses Val
    VPair, -- uses Val
    VList, -- uses Val
    VThread(..), -- uses Val
    VSubst(..),  -- uses VRule, VStr, Exp
    VArray, -- uses Val
    VHash, -- uses VStr, Val
    VThunk(..), -- uses Eval, Val
    VProcess(..),
    VMatch(..), mkMatchFail, mkMatchOk, -- uses VList, VHash
    VCode(..), SubType(..), -- uses Pad, Exp, Type
    VJunc(..), JuncType(..), -- uss Val
    VObject(..), -- uses VType, IHash, Unique
    ObjectId(..),
    VType, -- uses Type
    VRule(..), -- uses Val
    VMultiCode(..),

    IVar(..), -- uses *Class and V*
    IArray(..), IArraySlice, IHash, IScalar, IScalarProxy,
    IScalarLazy, IPairHashSlice, IRule, IHandle, IHashEnv(..),
    IScalarCwd(..),

    ArrayClass(..), CodeClass(..), HandleClass(..), HashClass(..),
    ObjectClass(..), PairClass(..), RuleClass(..), ScalarClass(..),
    ThunkClass(..),

    CompUnit(..), mkCompUnit, compUnitVersion,

    -- MonadEval(..),

    transformExp,

    runEvalSTM, runEvalIO, callCC, tryT, resetT, shiftT, catchT,
    undef, defined, tryIO, guardSTM, guardIO, guardIOexcept,
    readRef, writeRef, clearRef, dumpRef, forceRef,
    askGlobal, writeVar, readVar,
    findSymRef, findSym, valType,
    ifListContext, ifValTypeIsa, evalValType, fromVal',
    scalarRef, codeRef, arrayRef, hashRef, thunkRef, pairRef,
    newScalar, newArray, newHash, newHandle, newObject,

    cloneRef, cloneIVar,

    proxyScalar, constScalar, lazyScalar, lazyUndef, constArray,
    retControl, retShift, retShiftEmpty, retEmpty, retIVar, readIVar, writeIVar,
    fromVals, refType,
    readPadEntry, writePadEntry, refreshPad, lookupPad, padToList, listToPad,
    mkPrim, mkSub, mkCode, showRat, showTrueRat,
    cxtOfSigil, cxtOfSigilVar, typeOfSigil, typeOfSigilVar,
    buildParam, defaultArrayParam, defaultHashParam, defaultScalarParam,
    paramsToSig,
    emptyExp,
    isSlurpy, envWant,
    extractPlaceholderVars, fromObject, createObject, createObjectRaw,
    doPair, doHash, doArray,
    unwrap, -- Unwrap(..) -- not used in this file, suitable for factoring out
    newObjectId, runInvokePerl5,
    
    showVal, errStr, errStrPos, errValPos, enterAtomicEnv, valToBool, envPos', -- for circularity
    expToEvalVal, -- Hack, should be removed once it's figured out how

    newSVval, -- used in Run.Perl5

    anyToVal, vvToVal, anyFromVal, -- for circularity

    DebugInfo, newDebugInfo, _Sym, _Var -- String -> ByteString constructors
) where

import Pugs.Internals
import Pugs.Types
import qualified Data.Set       as Set
import qualified Data.Map       as Map

import qualified Data.HashTable    as H
import GHC.Conc (unsafeIOToSTM)

import Pugs.Cont (callCC)
import Pugs.Parser.Number
import Pugs.AST.Eval
import Pugs.AST.Utils
import Pugs.AST.Prag
import Pugs.AST.Pos
import Pugs.AST.Scope
import Pugs.AST.SIO
import Pugs.Embed.Perl5
import qualified Pugs.Val as Val
import GHC.PArr
import {-# SOURCE #-} Pugs.AST

{- <DrIFT> Imports for the DrIFT
import Pugs.AST.Scope
import Pugs.AST.Pos
import Pugs.AST.Prag
import Pugs.AST.SIO
import Pugs.Types
import Pugs.Internals
import Pugs.Embed.Perl5
import qualified Data.Set       as Set
import qualified Data.Map       as Map
import qualified Pugs.Val       as Val

import qualified Data.HashTable    as H
 </DrIFT> -}
 
#include "../Types/Array.hs"
#include "../Types/Handle.hs"
#include "../Types/Hash.hs"
#include "../Types/Scalar.hs"
#include "../Types/Code.hs"
#include "../Types/Thunk.hs"
#include "../Types/Rule.hs"
#include "../Types/Pair.hs"
#include "../Types/Object.hs"


catchT :: ((Val -> Eval b) -> Eval Val) -> Eval Val
catchT action = tryT (action retShift)

{-|
Return the appropriate 'empty' value for the current context -- either
an empty list ('VList' []), or undef ('VUndef').
-}
retEmpty :: Eval Val
retEmpty = do
    ifListContext
        (return $ VList [])
        (return VUndef)

evalValType :: Val -> Eval Type
evalValType (VRef (MkRef (IScalar sv))) = scalar_type sv
evalValType (VRef r) = return $ refType r
evalValType (VType t) = return t
evalValType val = return $ valType val

{-|
Check whether a 'Val' is of the specified type. Based on the result,
either the first or the second evaluation should be performed.
-}
ifValTypeIsa :: Val      -- ^ Value to check the type of
             -> String   -- ^ Name of the type to check against
             -> (Eval a) -- ^ The @then@ case
             -> (Eval a) -- ^ The @else@ case
             -> Eval a
ifValTypeIsa v (':':typ) trueM falseM = ifValTypeIsa v typ trueM falseM
ifValTypeIsa v typ trueM falseM = do
    vt  <- evalValType v
    if isaType typ vt
        then trueM
        else falseM

{-|
Collapse a junction value into a single boolean value.

Works by recursively casting the junction members to booleans, then performing
the actual junction test.
-}
juncToBool :: VJunc -> Eval Bool
juncToBool (MkJunc JAny  _  vs) = do
    bools <- mapM valToBool (Set.elems vs)
    return . isJust $ find id bools
juncToBool (MkJunc JAll  _  vs) = do
    bools <- mapM valToBool (Set.elems vs)
    return . isNothing $ find not bools
juncToBool (MkJunc JNone _  vs) = do
    bools <- mapM valToBool (Set.elems vs)
    return . isNothing $ find id bools
juncToBool (MkJunc JOne ds vs) = do
    bools <- mapM valToBool (Set.elems ds)
    if isJust (find id bools) then return False else do
    bools <- mapM valToBool (Set.elems vs)
    return $ 1 == (length $ filter id bools)

instance Show JuncType where
    show JAny  = "any"
    show JAll  = "all"
    show JNone = "none"
    show JOne  = "one"

instance Show VJunc where
    show (MkJunc jtype _ set) =
        (show jtype) ++ "(" ++
            (foldl (\x y ->
                if x == "" then show y
                else x ++ "," ++ show y)
            "" $ Set.elems set) ++ ")"

{-|
Typeclass indicating types that can be converted to\/from 'Val's.

Not to be confused with 'Val' itself, or the 'Exp' constructor @Val@.
-}
class (Typeable n, Show n, Ord n) => Value n where
    fromVal :: Val -> Eval n
    fromVal = fromVal'
    doCast :: Val -> Eval n
{-    doCast v = castFailM v "default implementation of doCast" -}
    fromVV :: Val.Val -> Eval n
    fromVV v = do
        str <- Val.asStr v
        fail $ "Cannot cast from VV (" ++ cast str ++ ") to " ++ errType (undefined :: n)
    fromSV :: PerlSV -> Eval n
    fromSV sv = do
        str <- io $ svToVStr sv
        fail $ "Cannot cast from SV (" ++ str ++ ") to " ++ errType (undefined :: n)
    castV :: n -> Val
    castV x = VOpaque (MkOpaque x) -- error $ "Cannot cast into Val"

#ifndef HADDOCK
data VOpaque where
    MkOpaque :: Value a => !a -> VOpaque
#endif

fromVal' :: (Value a) => Val -> Eval a
fromVal' (VRef r) = do
    v <- readRef r
    fromVal v
fromVal' (VList vs) | any isRef vs = do
    vs <- forM vs $ \v -> case v of { VRef r -> readRef r; _ -> return v }
    fromVal $ VList vs
    where
    isRef VRef{}    = True
    isRef _         = False
fromVal' (PerlSV sv) = do
    v <- io $ svToVal sv
    case v of
        PerlSV sv'  -> fromSV sv'   -- it was a SV
        VV vv
            | Just sv  <- Val.castVal vv -> fromSV sv
            | Just v   <- Val.castVal vv -> fromVal v
        val         -> fromVal val  -- it was a Val
fromVal' (VV vv) = do
    v' <- vvToVal vv
    case v' of
        VV vv''     -> fromVV vv''
        PerlSV sv   -> fromSV sv
        _           -> fromVal v'
fromVal' v = doCast v

-- XXX - This is makeshift until all our native types are in VV.
vvToVal :: Val.Val -> Eval Val
vvToVal x
    | Just sv <- Val.castVal x  = do
        rv <- io (svToVal sv)
        case rv of
            VV vv
                | Just sv  <- Val.castVal vv -> return (PerlSV sv)
                | Just v   <- Val.castVal vv -> return v
            _ -> return rv
    | Just v  <- Val.castVal x  = return v
    | Just x' <- Val.castVal x  = return . VStr $ (cast :: Val.PureStr -> String)  x'
    | Just x' <- Val.castVal x  = return . VInt $ (cast :: Val.PureInt -> Integer) x'
    | Just x' <- Val.castVal x  = return . VNum $ (cast :: Val.PureNum -> Double)  x'
    | Just x' <- Val.castVal x  = return (VStr x')
    | Just x' <- Val.castVal x  = return (VInt x')
    | Just x' <- Val.castVal x  = return (VNum x')
    | Just x' <- Val.castVal x  = return (VBool x')
    | Just () <- Val.castVal x  = return VUndef
    | otherwise                 = return (VV x)

getArrayIndex :: Int -> Maybe (IVar VScalar) -> Eval IArray -> Maybe (Eval b) -> Eval (IVar VScalar)
getArrayIndex idx def getArr _ | idx < 0 = do
    -- first, check if the list is at least abs(idx) long
    MkIArray iv <- getArr
    a   <- stm $ readTVar iv
    let size = a_size a
    if size > abs (idx+1)
        then return (a !: (idx `mod` size))
        else errIndex def idx
-- now we are all positive; either extend or return
getArrayIndex idx def getArr ext = do
    MkIArray iv <- getArr
    a   <- stm $ readTVar iv
    let size = a_size a
    if size > idx
        then return (a !: idx)
        else case ext of
            Just doExt -> do { doExt; getArrayIndex idx def getArr Nothing }
            Nothing    -> errIndex def idx

createObjectRaw :: (MonadSTM m)
    => ObjectId -> Maybe Dynamic -> VType -> [(VStr, Val)] -> m VObject
createObjectRaw uniq opaq typ attrList = do
    attrs   <- stm . unsafeIOToSTM . H.fromList H.hashString $ map (\(a,b) -> (a, lazyScalar b)) attrList
    return $ MkObject
        { objType   = typ
        , objId     = uniq
        , objAttrs  = attrs
        , objOpaque = opaq
        }

instance Value (IVar VScalar) where
    fromVal (VRef (MkRef v@(IScalar _))) = return v
    fromVal (VRef r) = fromVal =<< readRef r
    fromVal v = return $ constScalar v
    doCast v = castFailM v "IVar VScalar"

instance Value VType where
    fromVal (VType t)   = return t
    fromVal v@(VObject obj) | objType obj == (mkType "Class") = do
        meta    <- readRef =<< fromVal v
        fetch   <- doHash meta hash_fetchVal
        str     <- fromVal =<< fetch "name"
        return $ mkType str
    fromVal v           = evalValType v
    doCast v = castFailM v "VType"

instance Value VMatch where
    fromVal (VRef r) = fromVal =<< readRef r
    fromVal (VMatch m) = return m
    fromVal (VList (x:_)) = fromVal x
    fromVal _ = return $ mkMatchFail
    doCast v = castFailM v "VMatch"

instance Value VRef where
    fromVal (VRef r)   = return $ r
    fromVal (VList vs) = return $ arrayRef vs
    fromVal (VCode c)  = return $ codeRef c
    fromVal v          = return $ scalarRef v
    castV = VRef
    doCast v = castFailM v "VRef"

instance Value [Int] where
    fromVal v = do
        vlist <- fromVal v
        mapM fromVal vlist
    doCast v = castFailM v "[Int]"

instance Value [VStr] where
    castV = VList . map VStr
    fromVal v = do
        vlist <- fromVal v
        mapM fromVal vlist
    doCast v = castFailM v "[VStr]"

instance Value VPair where
    castV pv = VRef $ pairRef pv
    fromVal VUndef  = return (VUndef, VUndef)
    fromVal v       = join $ doPair v pair_fetch
    doCast v = castFailM v "VPair"

instance Value [(VStr, Val)] where
    fromVal v = do
        list <- fromVal v
        forM list $ \(k, v) -> do
            str <- fromVal k
            return (str, v)
    doCast v = castFailM v "[(VStr, Val)]"

instance Value VObject where
    fromVal (VObject o) = return o
    fromVal v@(VRef _) = fromVal' v
    fromVal v = do
        fail $ "Cannot cast from " ++ show v ++ " to Object"
    doCast v = castFailM v "VObject"

instance Value VHash where
    fromVal (VObject o) = do
        l <- io $ H.toList (objAttrs o)
        fmap Map.fromList . forM l $ \(k, ivar) -> do
            v <- readIVar ivar
            return (k, v)
    fromVal VType{} = return Map.empty -- ::Hash<foo>
    fromVal (VRef r) = fromVal =<< readRef r
    fromVal v = do
        list <- fromVal v
        fmap Map.fromList $ forM list $ \(k, v) -> do
            str <- fromVal k
            return (str, v)
    doCast v = castFailM v "VHash"

instance Value [VPair] where
    fromVal VUndef = return []
    fromVal v = do
        list <- fromVals v
        doFrom $ concat list
        where
        doFrom :: [Val] -> Eval [VPair]
        doFrom [] = return []
        doFrom [_] = fail $ "Odd number of elements found where hash expected: " ++ show v
        doFrom (k:v:list) = do
            rest <- doFrom list
            return ((k, v):rest)
    doCast v = castFailM v "Hash"

instance Value VCode where
    castV = VCode
    fromSV sv = return $ mkPrim
        { subName     = cast "<anon>"
        , subParams   = [defaultArrayParam]
        , subReturns  = mkType "Scalar::Perl5"
        , subBody     = Prim $ \(args:_) -> do
            svs     <- fromVals args
            runInvokePerl5 sv nullSV svs
        }
    doCast (VCode b) = return b
    doCast (VType t) = return $ mkPrim
        { subName     = cast t
        , subParams   = [buildParam "Any" "*" "@?0" (Val VUndef), buildParam "Any" "*" "%?0" (Val VUndef)]
        , subReturns  = mkType "Scalar::Perl5"
        , subBody     = Prim $ \(p:n:_) -> do
            evl <- asks envEval
            evl (App (_Var "&new") (Just $ Val (VType t)) [Syn "|" [Val p], Syn "|" [Val n]])
        }
    doCast (VList [VCode b]) = return b -- XXX Wrong
    doCast v = castFailM v "VCode"

runInvokePerl5 :: PerlSV -> PerlSV -> [PerlSV] -> Eval Val
runInvokePerl5 sub inv args = do 
    env     <- ask
    rv      <- io $ do
        envSV   <- mkEnv env
        invokePerl5 sub inv args envSV (enumCxt $ envContext env)
    case rv of
        Perl5ReturnValues [x]   -> io $ svToVal x
        Perl5ReturnValues xs    -> io $ fmap VList (mapM svToVal xs)
        Perl5ErrorString str    -> fail str
        Perl5ErrorObject err    -> throwError (PerlSV err)

anyFromVal :: forall a. Typeable a => Val -> a
anyFromVal v = case fromTypeable (fromVal v :: Eval PerlSV) of
    Just f  -> f :: a
    _       -> error "anyFromVal failed!"

anyToVal :: (Show a, Typeable a) => a -> Val
anyToVal x
    | Just v <- fromTypeable x      = v
    | Just v <- fromTypeable x      = PerlSV v
    | Just v <- fromTypeable x      = VStr v
    | Just v <- fromTypeable x      = VInt v
    | Just v <- fromTypeable x      = VNum v
    | Just () <- fromTypeable x     = VUndef
    | otherwise                     = error (show x)

instance Value VBool where
    castV = VBool
    fromSV sv = io $ svToVBool sv
    fromVV vv = fmap cast (Val.asBit vv)
    doCast (VJunc j)   = juncToBool j
    doCast (VMatch m)  = return $ matchOk m
    doCast (VBool b)   = return $ b
    doCast VUndef      = return $ False
    doCast VType{}     = return $ False
    doCast (VStr "")   = return $ False
    doCast (VStr "0")  = return $ False
    doCast (VInt 0)    = return $ False
    doCast (VRat 0)    = return $ False
    doCast (VNum 0)    = return $ False
    doCast (VList [])  = return $ False
    doCast _           = return $ True


instance Value VInt where
    castV = VInt
    fromVV vv = fmap cast (Val.asInt vv)
    fromSV sv = io $ svToVInt sv
    doCast (VInt i)     = return $ i
    doCast x            = fmap truncate (fromVal x :: Eval VRat)

instance Value VRat where
    castV = VRat
    fromSV sv = io $ svToVNum sv
    doCast (VInt i)     = return $ i % 1
    doCast (VRat r)     = return $ r
    doCast (VBool b)    = return $ if b then 1 % 1 else 0 % 1
    doCast (VList l)    = return $ genericLength l
    doCast (VStr s) | not (null s) , isSpace $ last s = do
        str <- fromVal (VStr $ init s)
        return str
    doCast (VStr s) | not (null s) , isSpace $ head s = do 
        str <- fromVal (VStr $ tail s)
        return str
    doCast (VStr s)     = return $
        case ( parseNatOrRat s ) of
            Left _   -> 0 % 1
            Right rv -> case rv of
                Left  i -> i % 1
                Right d -> d
    doCast x            = fmap toRational (fromVal x :: Eval VNum)

instance Value VNum where
    castV = VNum
    fromVV vv = fmap cast (Val.asNum vv)
    fromSV sv = io $ svToVNum sv
    doCast VUndef       = return $ 0
    doCast VType{}      = return $ 0
    doCast (VBool b)    = return $ if b then 1 else 0
    doCast (VInt i)     = return $ fromIntegral i
    doCast (VRat r)     = return $ realToFrac r
    doCast (VNum n)     = return $ n
    doCast (VComplex (r :+ _)) = return $ r
    doCast (VStr s) | not (null s) , isSpace $ last s = do
        str <- fromVal (VStr $ init s)
        return str
    doCast (VStr s) | not (null s) , isSpace $ head s = do
        str <- fromVal (VStr $ tail s)
        return str
    doCast (VStr "Inf") = return $ 1/0
    doCast (VStr "-Inf") = return $ -1/0
    doCast (VStr "NaN") = return $ 0/0
    doCast (VStr s)     = return $
        case ( parseNatOrRat s ) of
            Left _   -> 0
            Right rv -> case rv of
                Left  i -> fromIntegral i
                Right d -> realToFrac d
    doCast (VList l)     = return $ genericLength l
    doCast t@VThread{}   = fmap read (fromVal t)
    doCast (VMatch m)    = fromVal (VStr $ matchStr m)
    doCast v = castFailM v "VNum"

instance Value Ordering where
    castV x = VInt $ case x of
        LT -> -1
        EQ -> 0
        GT -> 1
    doCast x = do
        n <- fromVal x :: Eval VInt
        return $ case signum n of
            -1  -> LT
            0   -> EQ
            1   -> GT
            _   -> error "signum: impossible"

instance Value VComplex where
    castV = VComplex
    doCast (VComplex x) = return x
    doCast x            = fmap (:+ 0) (fromVal x :: Eval VNum)

instance Value ID where
    castV = VStr . cast
    fromSV sv = fmap cast (io $ svToVStr sv)
    fromVV vv = fmap cast (Val.asStr vv)
    fromVal = fmap (cast :: VStr -> ID) . fromVal
    doCast = fmap (cast :: VStr -> ID) . doCast

instance Value VStr where
    castV = VStr
    fromSV sv = io $ svToVStr sv
    fromVV vv = fmap cast (Val.asStr vv)
    fromVal (VList l)    = return . unwords =<< mapM fromVal l
    fromVal v@(PerlSV _) = fromVal' v
    fromVal VUndef       = return ""
    fromVal (VType t)    = return (showType t)
    fromVal v = do
        vt  <- evalValType v
        case showType vt of
            "Pair" -> do
                -- Special case for pairs: "$pair" eq
                -- "$pair.key()\t$pair.value()"
                (k, v)  <- join $ doPair v pair_fetch
                k'      <- fromVal k
                v'      <- fromVal v
                return $ k' ++ "\t" ++ v'
            "Hash" -> do
                --- XXX special case for Hash -- need to Objectify
                hv      <- join $ doHash v hash_fetch
                lns     <- forM (Map.assocs hv) $ \(k, v) -> do
                    str <- fromVal v
                    return $ k ++ "\t" ++ str
                return $ unlines lns
            _ -> fromVal' v
    doCast VUndef        = return ""
    doCast VType{}       = return ""
    doCast (VStr s)      = return s
    doCast (VBool b)     = return $ if b then "1" else ""
    doCast (VInt i)      = return $ show i
    doCast (VRat r)      = return $ showRat r
    doCast (VNum n)      = return $ showNum n
    doCast (VComplex (r :+ i)) = return $ showNum r ++ " + " ++ showNum i ++ "i"
    doCast (VList l)     = fmap unwords (mapM fromVal l)
    doCast (VCode s)     = return $ "<" ++ show (subType s) ++ "(" ++ cast (subName s) ++ ")>"
    doCast (VJunc j)     = return $ show j
    doCast (VThread t)   = return $ takeWhile isDigit $ dropWhile (not . isDigit) $ show t
    doCast (VHandle h)   = return $ "<" ++ "VHandle (" ++ (show h) ++ ">"
    doCast (VMatch m)    = return $ matchStr m
 -- doCast (VType typ)   = return $ showType typ -- "::" ++ showType typ
    doCast (VObject o)   = return $ "<obj:" ++ showType (objType o) ++ ">"
    doCast x             = return $ "<" ++ showType (valType x) ++ ">"


instance Value [PerlSV] where
    fromVal = fromVals
    doCast v = castFailM v "[PerlSV]"

instance Value PerlSV where
    fromVal val = io $ newSVval val
    doCast v = castFailM v "PerlSV"

newSVval :: Val -> IO PerlSV
newSVval val = case val of
    PerlSV sv   -> return sv
    VStr str    -> vstrToSV str
    VType typ   -> vstrToSV (showType typ)
    VBool bool  -> vintToSV (fromEnum bool)
    VInt int    -> vintToSV int
    VRat rat    -> vnumToSV rat
    VNum num    -> vnumToSV num
{-
    VRef ref@(MkRef (IArray a)) -> case fromTypeable a of
        Just (MkIArray iv@(I.IntMap fp) _) -> do
            sv      <- vrefToSV ref
            sptr    <- newStablePtr fp
            warn "Fin: SPTR" fp
            let fin = do
                    warn "Fin: FPTR" (sptr == sptr)
                    touchForeignPtr fp
            modifyIORef _GlobalFinalizer (>> fin)
            addFinalizer sv fin
            return sv
        _ -> vrefToSV ref
-}
    VRef ref    -> vrefToSV ref
    VCode{}     -> mkValRef val "Code"
    VBlock{}    -> mkValRef val "Code"
    VHandle{}   -> mkValRef val "Handle"
    VSocket{}   -> mkValRef val "Socket"
    VList{}     -> mkValRef val "Array"
    VUndef      -> svUndef
    VError{}    -> svUndef
    _           -> mkValRef val ""

vrefToSV :: VRef -> IO PerlSV
vrefToSV ref = mkValRef (VRef ref) $ case ref of
    MkRef IScalar{}   -> "Scalar"
    MkRef IArray{}    -> "Array"
    MkRef IHash{}     -> "Hash"
    MkRef ICode{}     -> "Code"
    MkRef IHandle{}   -> "Handle"
    MkRef IRule{}     -> "Rule"
    MkRef IThunk{}    -> "Thunk"
    MkRef IPair{}     -> "Pair"
    MkRef (IVal v)    -> show (valType v)

valToStr :: Val -> Eval VStr
valToStr = fromVal

instance Value VList where
    castV = VList
    fromSV sv = return [PerlSV sv]
    fromVV = cast . fmap (map VV . cast) . Val.listVal
    fromVal (VRef r) = do
        v <- readRef r
        case v of
            (VList vs) -> return vs
            _          -> return [v]
    fromVal (VList vs) = return vs
    fromVal v = fromVal' v
    doCast (VList l)     = return $ l
    doCast (VUndef)      = return $ [VUndef]
    doCast v             = return $ [v]

instance Value VHandle where
    castV = VHandle
    doCast (VHandle x)  = return $ x
    doCast v = castFailM v "VHandle"

instance Value VSocket where
    castV = VSocket
    doCast (VSocket x)  = return $ x
    doCast v = castFailM v "VSocket"

instance Value VThread where
    castV = VThread
    doCast (VThread x)  = return $ x
    doCast v = castFailM v "VThread"

instance Value VProcess where
    castV = VProcess
    doCast (VProcess x)  = return $ x
    doCast v = castFailM v "VProcess"

instance Value Int where
    fromSV sv = io $ svToVInt sv
    doCast x = intCast x
    castV = VInt . fromIntegral
instance Value Word  where 
    fromVal x = intCast x
    doCast v = castFailM v "Word"
instance Value Word8 where 
    fromVal x = intCast x
    doCast v = castFailM v "Word8"
instance Value [Word8] where
    fromVal val = fmap (map (toEnum . ord)) (fromVal val)
    doCast v = castFailM v "[Word8]"

type VScalar = Val

instance Value VScalar where
    fromSV = return . PerlSV
    fromVV = cast . fmap VV . Val.itemVal
    fromVal (VRef r) = fromVal =<< readRef r
    fromVal v = return v
    doCast v = return v
    castV = id -- XXX not really correct; need to referencify things

intCast :: Num b => Val -> Eval b
intCast x = fmap fromIntegral (fromVal x :: Eval VInt)

-- | Uses Haskell's underlying representation for threads.
data VThread = MkThread
    { threadId      :: ThreadId
    , threadLock    :: TMVar Val
    }
    deriving (Show, Eq, Ord, Typeable)

type VList = [Val]
data VSubst
    = MkSubst
        { substRegex    :: !VRule
        , substExp      :: !Exp
        }
    | MkTrans
        { transFrom     :: !VStr
        , transTo       :: !VStr
        }
    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}
type VArray = [Val]
type VHash = Map VStr Val

data VThunk = MkThunk
    { thunkExp  :: Eval Val
    , thunkType :: VType
    }
    deriving (Typeable) {-!derive: YAML_Pos!-}

newtype VProcess = MkProcess (ProcessHandle)
    deriving (Typeable) {-!derive: YAML_Pos!-}

type VPair = (Val, Val)
type VType = Type

{-|
Representation for rules (i.e. regexes).

Currently there are two types of rules: Perl 5 rules, implemented with PCRE,
and Perl 6 rules, implemented with PGE.
-}
data VRule
    -- | Perl5-compatible regular expression
    = MkRulePCRE
        { rxRegex     :: !Regex -- ^ The \'regular\' expression (as a PCRE
                                --     'Regex' object)
        , rxGlobal    :: !Bool  -- ^ Flag indicating \'global\' (match-all)
        , rxNumSubs   :: !Int   -- ^ The number of subpatterns present.
        , rxStringify :: !Bool
        , rxRuleStr   :: !String -- ^ The rule string, for user reference.
        , rxAdverbs   :: !Val
        }
    -- | Parrot Grammar Engine rule
    | MkRulePGE
        { rxRule      :: !String -- ^ The rule string
        , rxGlobal    :: !Bool   -- ^ Flag indicating \'global\' (match-all)
        , rxStringify :: !Bool
        , rxAdverbs   :: !Val
        }
    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}

instance Show Regex where
    show _ = "<regex>"

instance Ord Regex where
    compare x y = compare (addressOf x) (addressOf y)

instance Eq Regex where
    x == y = addressOf x == addressOf y

showVal :: Val -> String
showVal = show

errStr :: VStr -> Val
errStr str = VError (VStr str) []

errStrPos :: VStr -> Pos -> Val
errStrPos str pos = VError (VStr str) [pos]

errValPos :: Val -> Pos -> Val
errValPos val pos = VError val [pos]

enterAtomicEnv :: Env -> Env
enterAtomicEnv env = env{ envAtomic = True }

{-|
Represents a value.

Note that 'Val' is also a constructor for 'Exp' (i.e. an expression containing 
a value), so don't confuse the two. Similarly, all the constructors for 
@data 'Val'@ are themselves puns on the types of values they contain.
-}
data Val
    = VUndef                 -- ^ Undefined value
    | VBool     !VBool       -- ^ Boolean value
    | VInt      !VInt        -- ^ Integer value
    | VRat      !VRat        -- ^ Rational number value
    | VNum      !VNum        -- ^ Number (i.e. a double)
    | VComplex  !VComplex    -- ^ Complex number value
    | VStr      !VStr        -- ^ String value
    | VList     !VList       -- ^ List value
    | VType     !VType       -- ^ Type value (e.g. @Int@ or @Type@)
    | VJunc     !VJunc       -- ^ Junction value
    | VError    !Val ![Pos]  -- ^ Error
    | VControl  !VControl
-------------------------------------------------------------------
-- The following are runtime-only values (VRef is negotiable)
    | VRef      !VRef        -- ^ Reference value
    | VCode     !VCode       -- ^ A code object
    | VBlock    !VBlock
    | VHandle   !VHandle     -- ^ File handle
    | VSocket   !VSocket     -- ^ Socket handle
    | VThread   !VThread
    | VProcess  !VProcess    -- ^ PID value
    | VRule     !VRule       -- ^ Rule\/regex value
    | VSubst    !VSubst      -- ^ Substitution value (correct?)
    | VMatch    !VMatch      -- ^ Match value
    | VObject   !VObject     -- ^ Object
    | VOpaque   !VOpaque
    | PerlSV    !PerlSV
    | VV        !Val.Val
    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}

{-|
Find the 'Type' of the value contained by a 'Val'.

See "Pugs.Types" for info on types.
-}
valType :: Val -> Type
valType VUndef          = mkType "Scalar"
valType (VRef v)        = refType v
valType (VBool    _)    = mkType "Bool"
valType (VInt     _)    = mkType "Int"
valType (VRat     _)    = mkType "Rat"
valType (VNum     _)    = mkType "Num"
valType (VComplex _)    = mkType "Complex"
valType (VStr     _)    = mkType "Str"
-- valType (VList    _)    = mkType "List"
valType (VList    _)    = mkType "Array"
valType (VCode    c)    = code_iType c
valType (VBlock   _)    = mkType "Block"
valType (VJunc    _)    = mkType "Junction"
valType (VError _ _)    = mkType "Error"
valType (VHandle  _)    = mkType "IO"
valType (VSocket  _)    = mkType "Socket"
valType (VThread  _)    = mkType "Thread"
valType (VProcess _)    = mkType "Process"
valType (VControl _)    = mkType "Control"
valType (VRule    _)    = mkType "Regex"
valType (VSubst   _)    = mkType "Subst"
valType (VMatch   _)    = mkType "Match"
valType (VType    t)    = t
valType (VObject  o)    = objType o
valType (VOpaque  _)    = mkType "Object"
valType (PerlSV   _)    = mkType "Scalar::Perl5"
valType (VV       _)    = mkType "Scalar::Perl5" -- (cast $ Val.valMeta v)

valToBool :: Val -> Eval VBool
valToBool = fromVal

type VBlock = Exp
data VControl
    = ControlExit  !ExitCode
    | ControlContinuation
        { ccEnv     :: !Env
        , ccVal     :: !Val
        , ccCont    :: !(Val -> Eval Val)
        }
    | ControlLoop  !ControlLoop
    | ControlWhen  !ControlWhen
    | ControlLeave
        { leaveType     :: !(SubType -> Bool)
        , leaveDepth    :: !Int
        , leaveValue    :: !Val
        }
-- \| ControlLeave !(Env -> Eval Bool) !Val
    deriving (Show, Eq, Ord, Typeable) -- don't derive YAML for now

data ControlLoop
    = LoopNext
    | LoopRedo
    | LoopLast
    deriving (Show, Eq, Ord, Typeable) -- don't derive YAML for now

data ControlWhen
    = WhenContinue
    | WhenBreak
    deriving (Show, Eq, Ord, Typeable) -- don't derive YAML for now

{-|
Each 'VCode' structure has a 'SubType' indicating what \'level\' of
callable item it is. 'doApply' uses this to figure out how to enter
the proper scope and 'Env' when the sub is called.

Note that this is the \'type\' of a \'sub\', and has nothing to do with
subtyping.
-}
data SubType = SubMethod    -- ^ Method
             | SubCoroutine -- ^ Coroutine
             | SubMacro     -- ^ Macro
             | SubRoutine   -- ^ Regular subroutine
             | SubBlock     -- ^ Bare block
             | SubPointy    -- ^ Pointy block
             | SubPrim      -- ^ Built-in primitive operator (see "Pugs.Prim")
    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos, JSON, Perl5!-}

isSlurpy :: Param -> Bool
isSlurpy param = isSlurpyCxt $ paramContext param

{-|
A formal parameter of a sub (or other callable).

These represent declared parameters; don't confuse them with actual parameter 
values, which are henceforth termed "arguments".
-}
data Param = MkOldParam -- "Old" because Pugs.Val.Code defined a new one
    { isInvocant    :: !Bool        -- ^ Is it in invocant slot?
    , isOptional    :: !Bool        -- ^ Is it optional?
    , isNamed       :: !Bool        -- ^ Is it named-only?
    , isLValue      :: !Bool        -- ^ Is it lvalue (i.e. not `is copy`)?
    , isWritable    :: !Bool        -- ^ Is it writable (i.e. `is rw`)?
    , isLazy        :: !Bool        -- ^ Is it call-by-name (short-circuit)?
    , paramName     :: !Var         -- ^ Parameter name
    , paramContext  :: !Cxt         -- ^ Parameter context: slurpiness and type
    , paramDefault  :: !Exp         -- ^ Default expression (to evaluate to)
                                    --     when omitted
    }
    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos, Perl5, JSON!-}

-- | A list of formal parameters.
type Params     = [Param]

instance ((:>:) String) Params where
    cast = show . paramsToSig

paramToValParam :: Param -> Val.SigParam
paramToValParam param = ret
    where 
    ret = Val.MkParam 
        { Val.p_variable    = paramName param
        , Val.p_types       = []
        , Val.p_constraints = []
        , Val.p_unpacking   = Nothing
        , Val.p_default     = Val.MkParamDefault Nothing -- XXX Exp incompatibility
        , Val.p_label       = v_name $ paramName param  -- XXX sigility
        , Val.p_slots       = Map.empty
        , Val.p_hasAccess   = case param of
                                  MkOldParam { isLValue = True, isWritable = False } -> Val.AccessRO
                                  MkOldParam { isLValue = True, isWritable = True }  -> Val.AccessRW
                                  MkOldParam { isLValue = False }                    -> Val.AccessCopy
        , Val.p_isRef       = Val.p_hasAccess ret == Val.AccessRW
        , Val.p_isLazy      = isLazy param
        , Val.p_isContext   = False -- XXX - not yet handled
        }

paramsToSig :: Params -> Val.Sig
paramsToSig params = 
    Val.MkSig
        { Val.s_invocant = Nothing
        , Val.s_requiredPositionalCount =
            length $ filter (\x -> not (isNamed x) && not (isOptional x)) params
        , Val.s_requiredNames =
            Set.fromList $ map (v_name . paramName) $ filter (not . isOptional) params
        , Val.s_positionalList = map paramToValParam $ filter (not . isNamed) params
        , Val.s_namedSet = Map.fromList $ 
            map (\p -> (v_name (paramName p), paramToValParam p)) $ 
                filter isNamed params
        , Val.s_slurpyScalarList = []  -- XXX unimplemented
        , Val.s_slurpyArray   = Nothing  -- XXX ditto
        , Val.s_slurpyHash    = Nothing  -- XXX yep
        , Val.s_slurpyCode    = Nothing  -- XXX all right
        , Val.s_slurpyCapture = Nothing -- this one is okay as it is ;-)
        }   

{-|
A list of bindings from formal parameters ('Param') to actual parameter
expressions ('Exp').
-}
type Bindings   = [(Param, Exp)]
{-|
A sub that has a non-empty 'SlurpLimit' is a bound (or partially bound) sub
that has a finite number of slurpy scalar params bound, and no slurpy array
param bound (see 'VCode' and "Pugs.Bind").

Each list entry consists of the number of slurpable args expected, and an
expression that will evaluate to the actual list of slurpable args.
When the sub is called (see 'Pugs.Eval.apply'), the expression is evaluated.
If it evaluates to /too many/ args, the call will fail.

This needs to be a list (rather than a @Maybe@) because Perl 6's @.assuming@
(i.e. explicit currying) means that a sub can have its arguments bound in
separate stages, and each of the bindings needs to be checked.

>[12:02] <autrijus> scook0: .assuming will impose multiple limits
>[12:02] <autrijus> because you can assume (curry) multiple times
>[12:02] <scook0> ah
>[12:02] <scook0> I'll have to write that in the docs then
>[12:03] <scook0> Am I correct in that they only apply to subs that take a finite number of slurpy scalars?
>[12:04] <scook0> Slurpy array params seem to nuke the SlurpLimit
>[12:04] <scook0> because slurpy arrays can take any number of args
>[12:07] <autrijus> scook0: yes, and yes.
-}
type SlurpLimit = [(VInt, Exp)]

data SubAssoc
    = ANil | AIrrelevantToParsing | A_left | A_right | A_non | A_chain | A_list 
    deriving (Show, Eq, Ord, Typeable, Data) {-!derive: YAML_Pos, JSON, Perl5 !-}

instance Monoid SubAssoc where
    mempty = ANil
    mappend ANil y = y
    mappend x    _ = x

data MPad = MkMPad { mp_id :: !Word, mp_pad :: !(TVar Pad) }
    deriving (Show, Typeable, Data) {-!derive: YAML_Pos, JSON, Perl5 !-}

instance Eq MPad where
    x == y = mp_id x == mp_id y

instance Ord MPad where
    x `compare` y = mp_id x `compare` mp_id y

-- | Represents a sub, method, closure etc. -- basically anything callable.
data VCode = MkCode
    { isMulti           :: !Bool                  -- ^ Is this a multi sub\/method?
    , subName           :: !ByteString            -- ^ Name of the closure
    , subType           :: !SubType               -- ^ Type of the closure
    , subOuterPads      :: !LexPads               -- ^ Lexical pads for this scope
    , subInnerPad       :: !Pad                   -- ^ Inner lexical pad (immutable)
--  , subLexical        :: !Pad                   -- ^ Cached merged pads
    , subPackage        :: !Pkg                   -- ^ Package of the subroutine
    , subAssoc          :: !SubAssoc              -- ^ Associativity
    , subParams         :: !Params                -- ^ Parameters list
    , subBindings       :: !Bindings              -- ^ Currently assumed bindings
    , subSlurpLimit     :: !SlurpLimit            -- ^ Max. number of slurpy arguments
    , subReturns        :: !Type                  -- ^ Return type
    , subLValue         :: !Bool                  -- ^ Is this a lvalue sub?
    , subBody           :: !Exp                   -- ^ Body of the closure
    , subCont           :: !(Maybe (TVar VThunk)) -- ^ Coroutine re-entry point
    , subStarted        :: !(Maybe (TVar Bool))   -- ^ Whether START was run
    , subTraitBlocks    :: !TraitBlocks
    }
    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}

data TraitBlocks = MkTraitBlocks
    { subPreBlocks      :: ![VCode]
    , subPostBlocks     :: ![VCode]
    , subFirstBlocks    :: ![VCode]
    , subLastBlocks     :: ![VCode]
    , subNextBlocks     :: ![VCode]
    , subKeepBlocks     :: ![VCode]
    , subUndoBlocks     :: ![VCode]
    , subEnterBlocks    :: ![VCode]
    , subLeaveBlocks    :: ![VCode]
    , subControlBlocks  :: ![VCode]
    , subCatchBlocks    :: ![VCode]
    }
    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}

emptyTraitBlocks :: TraitBlocks
emptyTraitBlocks = MkTraitBlocks [] [] [] [] [] [] [] [] [] [] []

{-|
Construct a 'VCode' representing a built-in primitive operator.

See "Pugs.Prim" for more info.
-}
mkPrim :: VCode
mkPrim = MkCode
    { isMulti        = True
    , subName        = cast "&"
    , subType        = SubPrim
    , subOuterPads   = []
    , subInnerPad    = emptyPad
--  , subLexical     = emptyPad
    , subPackage     = emptyPkg
    , subAssoc       = ANil
    , subParams      = []
    , subBindings    = []
    , subSlurpLimit  = []
    , subReturns     = anyType
    , subBody        = emptyExp
    , subLValue      = False
    , subCont        = Nothing
    , subStarted     = Nothing
    , subTraitBlocks = emptyTraitBlocks
    }

mkSub :: VCode
mkSub = MkCode
    { isMulti        = False
    , subName        = cast "&"
    , subType        = SubBlock
    , subOuterPads   = []
    , subInnerPad    = emptyPad
--  , subLexical     = emptyPad
    , subPackage     = emptyPkg
    , subAssoc       = ANil
    , subParams      = []
    , subBindings    = []
    , subSlurpLimit  = []
    , subReturns     = anyType
    , subBody        = emptyExp
    , subLValue      = False
    , subCont        = Nothing
    , subStarted     = Nothing
    , subTraitBlocks = emptyTraitBlocks
    }

mkCode :: VCode
mkCode = MkCode
    { isMulti        = False
    , subName        = cast "&"
    , subType        = SubBlock
    , subOuterPads   = []
    , subInnerPad    = emptyPad
--  , subLexical     = emptyPad
    , subPackage     = emptyPkg
    , subAssoc       = ANil
    , subParams      = []
    , subBindings    = []
    , subSlurpLimit  = []
    , subReturns     = anyType
    , subBody        = emptyExp
    , subLValue      = False
    , subCont        = Nothing
    , subStarted     = Nothing
    , subTraitBlocks = emptyTraitBlocks
    } 

instance Ord VComplex where
    compare (a :+ ai) (b :+ bi) = compare (a, ai) (b, bi)

instance Show (TVar a) where
    show = showAddressOf "ref"

instance Show (IORef a) where
    show = showAddressOf "ref"

{- Expression annotation
-}
data Ann
    = Cxt !Cxt                -- ^ Context
    | Pos !Pos                -- ^ Position
    | Prag ![Pragma]          -- ^ Lexical pragmas
    | Decl !Scope             -- ^ Within an declarator
    | Parens                  -- ^ Parenthesized
    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}

{- Expressions
   "App" represents function application, e.g. myfun($invocant: $arg)

   "Syn" represents a structure that cannot be represented by an App.
   For example, Syn "block" [...block body...]
                Syn "="     [lhs, rhs]
   ... or class definitions, where traits may be assigned either in
   the signature or inside the body.

   There is no top-level marker, like unix filesystems don't have
   volume letters.
-}

-- | Represents an expression tree.
data Exp
    = Noop                              -- ^ No-op
    | App !Exp !(Maybe Exp) ![Exp]      -- ^ Function application
                                        --     e.g. myfun($invocant: $arg)
    | Syn !String ![Exp]                -- ^ Syntactic construct that cannot
                                        --     be represented by 'App'.
    | Ann !Ann !Exp                     -- ^ Annotation (see @Ann@)
--  | Pad !Scope !Pad !Exp              -- ^ Lexical pad
    | Sym !Scope !Var !EntryFlags !Exp !Exp -- ^ Symbol declaration
    | Stmts !Exp !Exp                   -- ^ Multiple statements
    | Prim !([Val] -> Eval Val)         -- ^ Primitive
    | Val !Val                          -- ^ Value
    | Var !Var                          -- ^ Variable
    | NonTerm !Pos                      -- ^ Parse error
    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}

_Sym :: Scope -> String -> EntryFlags -> Exp -> Exp -> Exp
_Sym scope str flags init rest = Sym scope (cast str) flags init rest

_Var :: String -> Exp
_Var str = Var (possiblyFixOperatorName (cast str))

instance Value Exp where
    {- Val -> Eval Exp -}
    fromVal val = do
        obj <- fromVal val
        return $ fromObject obj
    {- Exp -> Val -}
    {- castV exp = VObject (createObject (mkType "Code::Exp") [("theexp", exp)]) -}
    doCast v = castFailM v "Exp"

-- Recursively apply a transformation to an Exp structure
transformExp :: (Monad m) => (Exp -> m Exp) -> Exp -> m Exp
transformExp f (App a b cs) = do
    a' <- transformExp f a
    b' <- case b of
        Just e -> liftM Just $ transformExp f e
        Nothing -> return Nothing
    cs' <- mapM (transformExp f) cs
    f $ App a' b' cs'
transformExp f (Syn t es) = f =<< liftM (Syn t) (mapM (transformExp f) es)
transformExp f (Ann a e) = f =<< liftM (Ann a) (transformExp f e)
-- transformExp f (Pad s p e) = f =<< liftM (Pad s p) (transformExp f e)
transformExp f (Sym s v c i e) = f =<< liftM (Sym s v c i) (transformExp f e)
transformExp f (Stmts e1 e2) = do 
    e1' <- transformExp f e1
    e2' <- transformExp f e2
    f $ Stmts e1' e2'
transformExp f e = f e

fromObject :: (Typeable a) => VObject -> a
fromObject obj = case objOpaque obj of
    Nothing     -> castFail obj "VObject without opaque"
    Just dyn    -> case fromDynamic dyn of
        Nothing -> castFail obj "VObject's opaque not valueable"
        Just x  -> x

{- FIXME: Figure out how to get this working without a monad, and make it castV -}
expToEvalVal :: Exp -> Eval Val
expToEvalVal exp = do
    obj <- createObject (mkType "Code::Exp") []
    return $ VObject obj{ objOpaque = Just $ toDyn exp }

instance Unwrap [Exp] where
    unwrap = map unwrap

instance Unwrap Exp where
    unwrap (Ann _ exp)      = unwrap exp
    -- unwrap (Pad _ _ exp)    = unwrap exp
    unwrap (Sym _ _ _ _ exp)= unwrap exp
    unwrap x                = x

fromVals :: (Value n) => Val -> Eval [n]
fromVals v = mapM fromVal =<< fromVal v

instance Show VThunk where
    show _ = "<thunk>"
instance Eq VThunk
instance Ord VThunk where
    compare _ _ = EQ

instance Show VProcess where
    show _ = "<process>"
instance Eq VProcess
instance Ord VProcess where
    compare _ _ = EQ

extractPlaceholderVarsExp :: Exp -> ([Exp], Set Var) -> ([Exp], Set Var)
extractPlaceholderVarsExp ex (exps, vs) = (ex':exps, vs')
    where
    (ex', vs') = extractPlaceholderVars ex vs

{-| Deduce the placeholder vars ($^a, $^x etc.) used by a block). -}
extractPlaceholderVars :: Exp -> Set Var -> (Exp, Set Var)
extractPlaceholderVars (App n invs args) vs = (App n' invs' args', vs''')
    where
    (n', vs')      = extractPlaceholderVars n vs
    (invs', vs'')  = maybe (invs, vs') (\inv -> let (x, y) = extractPlaceholderVars inv vs' in (Just x, y)) invs
    (args', vs''') = foldr extractPlaceholderVarsExp ([], vs'') args
extractPlaceholderVars (Stmts exp1 exp2) vs = (Stmts exp1' exp2', vs'')
    where
    (exp1', vs')  = extractPlaceholderVars exp1 vs
    (exp2', vs'') = extractPlaceholderVars exp2 vs'
extractPlaceholderVars (Syn n exps) vs = (Syn n exps', vs'')
    where
    (exps', vs') = foldr extractPlaceholderVarsExp ([], vs) exps
    vs'' = case n of
        "when"  -> Set.insert (cast "$_") vs'
        "given" -> Set.delete (cast "$_") vs'
        _       -> vs'
extractPlaceholderVars (Var var) vs
    | TImplicit <- v_twigil var
    , var' <- var{ v_twigil = TNil }
    = (Var var', Set.insert var' vs)
    | var == cast "$_"
    = (Var var, Set.insert var vs)
    | otherwise
    = (Var var, vs)
extractPlaceholderVars (Ann ann ex) vs = ((Ann ann ex'), vs')
    where
    (ex', vs') = extractPlaceholderVars ex vs
-- extractPlaceholderVars (Pad scope pad ex) vs = ((Pad scope pad ex'), vs')
--     where
--     (ex', vs') = extractPlaceholderVars ex vs
extractPlaceholderVars (Sym scope var flags ini ex) vs = ((Sym scope var flags ini ex'), vs')
    where
    (ex', vs') = extractPlaceholderVars ex vs
extractPlaceholderVars exp vs = (exp, vs)

buildParam :: String -- ^ Type of the parameter
           -> String -- ^ Parameter-sigil (@:@, @!:@, @?@, @!@, etc.)
           -> String -- ^ Name of the parameter (including primary sigil)
           -> Exp    -- ^ Expression for the param's default value
           -> Param
buildParam typ sigil name e = MkOldParam
    { isInvocant    = False
    , isOptional    = '?' `elem` sigil
    , isNamed       = ':' `elem` sigil
    , isLValue      = True
    , isWritable    = (name == "$_")
    , isLazy        = False
    , paramName     = cast name
    , paramContext  = if '*' `elem` sigil
        then CxtSlurpy typ'
        else CxtItem typ'
    , paramDefault  = e
    }
    where
    typ' = if null typ then anyType else mkType typ

defaultArrayParam :: Param
defaultHashParam :: Param
defaultScalarParam :: Param

defaultArrayParam   = buildParam "" "*" "@_" (Val VUndef)
defaultHashParam    = buildParam "" "*" "%_" (Val VUndef)
defaultScalarParam  = buildParam "" "?" "$_" (Var $ cast "$OUTER::_")

type DebugInfo = Maybe (TVar (Map ID String))

newDebugInfo :: IO DebugInfo
newDebugInfo = fmap Just (io $ newTVarIO Map.empty)

type LexPads = [LexPad]
data LexPad
    = PRuntime      { pr_pad :: !Pad }
    | PCompiling    { pc_pad :: !MPad }
    deriving (Show, Eq, Ord, Typeable)

{-|
Evaluation environment.

The current environment is stored in the @Reader@ monad inside the current 
'Eval' monad, and can be retrieved using @ask@ for the whole 'Env', or @asks@ 
if you just want a single field.
-}
data Env = MkEnv
    { envContext :: !Cxt                -- ^ Current context
                                        -- ('CxtVoid', 'CxtItem' or 'CxtSlurpy')
    , envLValue  :: !Bool               -- ^ Are we in an LValue context?
    , envLexical :: !Pad                -- ^ Cached lexical pad for variable lookup
    , envLexPads :: !LexPads            -- ^ Current lexical pads; MY is leftmost, OUTER is next, etc
    , envCaller  :: !(Maybe Env)        -- ^ CALLER pads
    , envCompPad :: !(Maybe MPad)       -- ^ Current COMPILING pad
    , envGlobal  :: !MPad               -- ^ Global pad for variable lookup
    , envPackage :: !Pkg                -- ^ Current package
    , envEval    :: !(Exp -> Eval Val)  -- ^ Active evaluator
    , envBody    :: !Exp                -- ^ Current AST expression
    , envFrames  :: !(Set Frame)        -- ^ Special-markers in the dynamic path
    , envDebug   :: !DebugInfo          -- ^ Debug info map
    , envPos     :: !Pos                -- ^ Source position range
    , envPragmas :: ![Pragma]           -- ^ List of pragmas in effect
    , envInitDat :: !(TVar InitDat)     -- ^ BEGIN result information
    , envMaxId   :: !(TVar ObjectId)    -- ^ Current max object id
    , envAtomic  :: !Bool               -- ^ Are we in an atomic transaction?
    } 
    deriving (Show, Eq, Ord, Typeable) -- don't derive YAML for now

data Frame
    = FrameLoop
    | FrameWhen
    | FrameGather
    | FrameRoutine
    deriving (Show, Eq, Ord, Typeable) -- don't derive YAML for now

envPos' :: Env -> Pos
envPos' = envPos

{-|
Module initialization information.

When a module is loaded and initialized (i.e., its &import routine is
called), it may need to communicate information back to the parser. 
This information is held in a TVar to which the parser has access.
Currently we use this for keeping track of lexical pragma change
requests, but the possiblyExit mechanism may be refactored to use
this as well.
-}
newtype InitDat = MkInitDat
    { initPragmas :: [Pragma]            -- ^ Pragma values being installed
    } deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}

envWant :: Env -> String
envWant env =
    showCxt (envContext env) ++ (if envLValue env then ", LValue" else "")
    where
    showCxt CxtVoid         = "Void"
    showCxt (CxtItem typ)   = "Scalar (" ++ showType typ ++ ")"
    showCxt (CxtSlurpy typ) = "List (" ++ showType typ ++ ")"

{- Pad -}
{-|
A 'Pad' keeps track of the names of all currently-bound symbols, and
associates them with the things they actually represent.

It is represented as a mapping from names to /lists/ of bound items.
This is to allow for multi subs, because we will need to keep
/multiple/ subs associated with one symbol. In other cases, the list
should just contain a single value. See 'Pugs.AST.genSym' and 'Pugs.AST.genMultiSym' for
more details.

@TVar@ indicates that the mapped-to items are STM transactional variables.

The @Bool@ is a \'freshness\' flag used to ensure that @my@ variable slots
are re-generated each time we enter their scope; see the
'Pugs.Eval.reduce' entry for ('Pad' 'SMy' ...).

The current global and lexical pads are stored in the current 'Env', which
is stored in the @Reader@-monad component of the current 'Eval' monad.
-}

newtype Pad = MkPad { padEntries :: Map Var PadEntry }
    deriving (Eq, Ord, Typeable)

{-|
An empty Pad with no symbols.
-}

emptyPad :: Pad
emptyPad = MkPad Map.empty

newtype EntryFlags = MkEntryFlags { ef_isContext :: Bool }
    deriving (Show, Eq, Ord, Typeable)

instance Monoid EntryFlags where
    mempty = MkEntryFlags False
    mappend (MkEntryFlags x) (MkEntryFlags y) = MkEntryFlags (x || y)

data PadEntry
    = PELexical  { pe_type :: !Type, pe_proto :: !VRef, pe_flags :: !EntryFlags, pe_store :: !(TVar VRef) } -- pe_fresh :: !(TVar Bool) }
    | PEStatic   { pe_type :: !Type, pe_proto :: !VRef, pe_flags :: !EntryFlags, pe_store :: !(TVar VRef) }
    | PEConstant { pe_type :: !Type, pe_proto :: !VRef, pe_flags :: !EntryFlags }
    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}

data IHashEnv = MkHashEnv deriving (Show, Typeable) {-!derive: YAML_Pos!-}
data IScalarCwd = MkScalarCwd deriving (Show, Typeable) {-!derive: YAML_Pos!-}

{-# SPECIALISE readPadEntry :: PadEntry -> Eval VRef #-}
{-# SPECIALISE readPadEntry :: PadEntry -> STM VRef #-}
readPadEntry :: MonadSTM m => PadEntry -> m VRef
readPadEntry PEConstant{ pe_proto = v } = return v
readPadEntry x                             = stm (readTVar (pe_store x))

{-# SPECIALISE writePadEntry :: PadEntry -> VRef -> Eval () #-}
{-# SPECIALISE writePadEntry :: PadEntry -> VRef -> STM () #-}
writePadEntry :: MonadSTM m => PadEntry -> VRef -> m ()
writePadEntry x@PEConstant{} _ = die "Cannot rebind constant" x
writePadEntry x                 v = stm (writeTVar (pe_store x) v)

refreshPad :: Pad -> Eval Pad
refreshPad pad = do
    fmap listToPad $ forM (padToList pad) $ \(name, entry) -> do
        -- warn "Refreshing pad entry" (name, entry)
        entry' <- case entry of
            PELexical{ pe_proto = proto } -> stm $ do
                ref     <- cloneRef proto
                tvar'   <- newTVar ref
                return entry{ pe_store = tvar' }
            _ -> return entry
        return (name, entry')

newtype ObjectId = MkObjectId { unObjectId :: Int }
    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}

data VObject = MkObject
    { objType   :: !VType
    , objAttrs  :: !IHash
    , objOpaque :: !(Maybe Dynamic)
    , objId     :: !ObjectId
    }
    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}

-- | A '$/' object, the return of a rx match operation.
data VMatch = MkMatch
    { matchOk           :: !VBool   -- success?
    , matchFrom         :: !Int     -- .from
    , matchTo           :: !Int     -- .to
    , matchStr          :: !VStr    -- captured str
    , matchSubPos       :: !VList   -- positional submatches
    , matchSubNamed     :: !VHash   -- named submatches
    }
    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}


instance Show Pad where
    show pad = "MkPad (padToList " ++ show (padToList pad) ++ ")"

findSymRef :: Var -> Pad -> Eval VRef
findSymRef name pad = stm $ join (findSym name pad)

{-# SPECIALISE findSym :: Var -> Pad -> Eval (STM VRef) #-}
{-# SPECIALISE findSym :: Var -> Pad -> Maybe (STM VRef) #-}
findSym :: Monad m => Var -> Pad -> m (STM VRef)
findSym name pad = case lookupPad name pad of
    Just PEConstant{ pe_proto = v }  -> return (return v)
    Just x                              -> return (readTVar (pe_store x))
    _      -> fail $ "Cannot find variable: " ++ show name

-- | Look up a symbol in a 'Pad', returning the ref it is bound to.
lookupPad :: Var -- ^ Symbol to look for
          -> Pad -- ^ Pad to look in
          -> Maybe PadEntry -- ^ Might return 'Nothing' if var is not found

{-
    We (may) have to fix the name, as the user can write things like
        &::("infix:<+>")(2, 3)
    which, without fixName, wouldn't work, as all operators are currently
    stored as &infix:+, i.e. without the brackets.
-}

lookupPad key (MkPad pad) = Map.lookup key pad

{-|
Transform a pad into a flat list of bindings. The inverse of 'mkPad'.

Note that @Data.Map.assocs@ returns a list of mappings in ascending key order.
-}
padToList :: Pad -> [(Var, PadEntry)]
padToList (MkPad pad) = Map.assocs pad

listToPad :: [(Var, PadEntry)] -> Pad
listToPad entries = MkPad (Map.fromList entries)

-- | type for a function introducing a change to a Pad
type PadMutator = (Pad -> Pad)

{-|
Serializable compilation unit

See: docs/notes/precompilation_cache.pod
-}
data CompUnit = MkCompUnit
    { ver  :: Int        -- a version number, see compUnitVersion
    , desc :: String     -- e.g., the name of the contained module
    , pad  :: Pad        -- pad for unit Env
    , ast  :: Exp        -- AST of unit
    } deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos !-}

mkCompUnit :: String -> Pad -> Exp -> CompUnit
mkCompUnit = MkCompUnit compUnitVersion

{-# NOINLINE compUnitVersion #-}
compUnitVersion :: Int
compUnitVersion = 18

{-|
Retrieve the global 'Pad' from the current evaluation environment.

'Env' stores the global 'Pad' in an STM variable, so we have to @asks@
'Eval'\'s @ReaderT@ for the variable, then extract the pad itself from the
STM var.
-}
askGlobal :: Eval Pad
askGlobal = do
    glob <- asks (mp_pad . envGlobal)
    stm $ readTVar glob

writeVar :: Var -> Val -> Eval ()
writeVar var val
    | isLexicalVar var  = doWriteVar (asks envLexical)
    | otherwise         = doWriteVar askGlobal
    where
    doWriteVar askPad = do
        pad <- askPad
        case lookupPad var pad of
            Just PEConstant{} -> fail $ "Cannot rebind constant: " ++ show var
            Just c -> do
                ref <- stm $ readTVar (pe_store c)
                writeRef ref val
            _  -> fail $ "Cannot bind to non-existing variable: " ++ show var

readVar :: Var -> Eval Val
readVar var
    | isLexicalVar var = do
        lex <- asks envLexical
        case findSym var lex of
            Just action -> stm action >>= readRef
            _           -> return undef
    | otherwise = do
        glob <- askGlobal
        case findSym var glob of
            Just action -> stm action >>= readRef
            _           -> return undef

{-|
The \'empty expression\' is just a no-op ('Noop').
-}
emptyExp :: Exp
emptyExp = Noop

retControl :: VControl -> Eval a
retControl = retShift . VControl

retShift :: Val -> Eval a
-- retShift = shiftT . const . return
retShift = EvalT . return . RException

retShiftEmpty :: Eval a
-- retShiftEmpty = shiftT (const retEmpty)
retShiftEmpty = retShift =<< retEmpty

defined :: VScalar -> Bool
defined VUndef  = False
defined VType{} = False
defined _       = True
-- | Produce an undefined Perl 6 value (i.e. 'VUndef').
undef :: VScalar
undef = VUndef

forceRef :: VRef -> Eval Val
forceRef (MkRef (IScalar sv)) = forceRef =<< fromVal =<< scalar_fetch sv
forceRef (MkRef (IThunk tv)) = thunk_force tv
forceRef r = die "Cannot forceRef" r

dumpRef :: VRef -> Eval Val
dumpRef (MkRef (ICode cv)) = do
    vsub <- code_fetch cv
    return (VStr $ "(MkRef (ICode $ " ++ show vsub ++ "))")
dumpRef (MkRef (IScalar sv)) | scalar_iType sv == mkType "Scalar::Const" = do
    sv <- scalar_fetch sv
    return (VStr $ "(MkRef (IScalar $ " ++ show sv ++ "))")
dumpRef ref = return (VStr $ "(unsafePerformIO . newObject $ mkType \"" ++ showType (refType ref) ++ "\")")

-- Reduce a VRef in rvalue context. 
readRef :: VRef -> Eval Val
readRef (MkRef (IScalar sv)) = scalar_fetch sv
readRef (MkRef (ICode cv)) = do
    vsub <- code_fetch cv
    return $ VCode vsub
readRef (MkRef (IHash hv)) = do
    pairs <- hash_fetch hv
    return $ VList $ map (\(k, v) -> castV (castV k, v)) (Map.assocs pairs)
readRef (MkRef (IArray av)) = do
    vals <- array_fetch av
    return $ VList vals

-- XXX - This case is entirely bogus; but no time to fix it now.
readRef (MkRef (IPair pv)) = do
    (k, v) <- pair_fetch pv
    return $ VList [k, v]

readRef (MkRef (IHandle io)) = return . VHandle =<< handle_fetch io
readRef (MkRef (IRule rx)) = return . VRule =<< rule_fetch rx
readRef (MkRef (IThunk tv)) = readRef =<< fromVal =<< thunk_force tv
readRef (MkRef (IVal v)) = do
    cxt <- asks envContext
    v ./ cxt

retIVar :: (Typeable a) => IVar a -> Eval Val
retIVar = return . VRef . MkRef

fromVList :: Val -> Eval VArray
fromVList (VList v) = return v
fromVList x = return [x]

fromVHash :: Val -> Eval VHash
fromVHash = fromVal

writeRef :: VRef -> Val -> Eval ()
writeRef (MkRef (IScalar s)) (VList vals) = do
    av <- newArray vals
    scalar_store s (VRef $ MkRef av)
writeRef (MkRef (IScalar s)) val = scalar_store s val
writeRef (MkRef (IArray s)) val  = array_store s =<< fromVList val
writeRef (MkRef (IHash s)) val   = hash_store s =<< fromVHash val
writeRef (MkRef (ICode s)) val   = code_store s =<< fromVal val
writeRef (MkRef (IPair s)) val   = pair_storeVal s val
writeRef (MkRef (IThunk tv)) val = (`writeRef` val) =<< fromVal =<< thunk_force tv
writeRef r _ = die "Cannot writeRef" r

cloneRef :: VRef -> STM VRef
cloneRef (MkRef x) = fmap MkRef (cloneIVar x)

clearRef :: VRef -> Eval ()
clearRef (MkRef (IScalar s)) = scalar_store s undef
clearRef (MkRef (IArray s))  = array_clear s
clearRef (MkRef (IHash s))   = hash_clear s
clearRef (MkRef (IPair s))   = pair_storeVal s undef
clearRef (MkRef (IThunk tv)) = clearRef =<< fromVal =<< thunk_force tv
clearRef r = die "Cannot clearRef" r

{-# SPECIALISE newObject :: Type -> Eval VRef #-}
{-# SPECIALISE newObject :: Type -> IO VRef #-}
newObject :: (MonadSTM m, MonadIO m) => Type -> m VRef
newObject typ = case showType typ of
    "Any"       -> io $ fmap scalarRef $ newTVarIO undef
    "Item"      -> io $ fmap scalarRef $ newTVarIO undef
    "Scalar"    -> io $ fmap scalarRef $ newTVarIO undef
    "Array"     -> io $ do
        iv  <- newTVarIO [::]
        return $ arrayRef (MkIArray iv)
    "Hash"      -> do
        h   <- io (H.new (==) H.hashString)
        return $ hashRef (h :: IHash)
    "Sub"       -> newObject $ mkType "Code"
    "Routine"   -> newObject $ mkType "Code"
    "Method"    -> newObject $ mkType "Code"
    "Submethod" -> newObject $ mkType "Code"
    "Code"      -> return $! codeRef $ mkPrim
        { subAssoc = AIrrelevantToParsing
        , subBody  = Prim . const $ fail "Cannot use Undef as a Code object"
        }
    "Type"      -> io $ fmap scalarRef $ newTVarIO undef
    "Pair"      -> do
        key <- newObject (mkType "Scalar")
        val <- newObject (mkType "Scalar")
        return $ MkRef (IPair (VRef key, VRef val))
    "Regex"     -> io $ fmap scalarRef $ newTVarIO undef -- XXX Wrong
    "Capture"   -> io $ fmap scalarRef $ newTVarIO undef -- XXX Wrong
    _           -> fail ("Class prototype occured where its instance object expected: " ++ showType typ)

doPair :: Val -> (forall a. PairClass a => a -> b) -> Eval b
doPair (VRef (MkRef (IPair pv))) f = return $ f pv
doPair (VRef (MkRef (IHash hv))) f = do
    vals <- hash_fetch hv
    let [(k, v)] = Map.toList vals
    return $ f (VStr k, v)
doPair (VRef (MkRef (IArray av))) f = do
    vals <- array_fetch av
    let [k, v] = take 2 (vals ++ repeat undef)
    return $ f (k, v)
doPair (VRef (MkRef (IScalar sv))) f = do
    val <- scalar_fetch sv
    case val of
        VUndef  -> do
            ref@(MkRef (IPair pv)) <- newObject (mkType "Pair")
            scalar_store sv (VRef ref)
            return $ f pv
        _  -> doPair val f
doPair (VRef x) _ = die "Cannot cast into Pair" x
doPair val f = do
    vs <- fromVal val
    case (vs :: VList) of
        [x, y]  -> return $ f (x, y)
        _       -> do
            pv <- castFailM val "Confusing pair?"
            return $ f (pv :: VPair)

-- XXX: Refactor doHash and doArray into one -- also see Eval's [] and {}
doHash :: Val -> (forall a. HashClass a => a -> b) -> Eval b
doHash (PerlSV sv) f = return $ f sv
doHash (VRef (MkRef (IHash hv))) f = return $ f hv
doHash (VRef (MkRef (IScalar sv))) f = do
    val <- scalar_fetch sv
    case val of
        VUndef  -> do
            ref@(MkRef (IHash hv)) <- newObject (mkType "Hash")
            scalar_store sv (VRef ref)
            return $ f hv
        _  -> doHash val f
doHash (VRef (MkRef p@(IPair _))) f = return $ f p
doHash (VObject o) f = return $ f (objAttrs o)
doHash (VMatch m) f = do
    return $ f (matchSubNamed m)
doHash val@(VRef _) _ = die "Cannot cast into Hash" val
doHash val f = do
    hv  <- fromVal val
    return $ f (hv :: VHash)

-- can be factored out
doArray :: Val -> (forall a. ArrayClass a => a -> b) -> Eval b
doArray (PerlSV sv) f = return $ f sv
doArray (VRef (MkRef (IArray av))) f = return $ f av
doArray (VRef (MkRef (IScalar sv))) f = do
    val <- scalar_fetch sv
    if defined val
        then doArray val f
        else do
            ref@(MkRef (IArray hv)) <- newObject (mkType "Array")
            scalar_store sv (VRef ref)
            return $ f hv
doArray (VRef (MkRef p@(IPair _))) f = return $ f p
doArray val@(VRef (MkRef IHash{})) f = do
    av  <- fromVal val
    return $ f (av :: VArray)
doArray val@(VRef _) _ = die "Cannot cast into Array" val
doArray (VMatch m) f = do
    return $ f (matchSubPos m)
doArray val f = do
    av  <- fromVal val
    return $ f (av :: VArray)

-- Haddock doesn't seem to like data/instance declarations with a where clause.
#ifndef HADDOCK

data IVar v where
    IScalar :: ScalarClass a => !a -> IVar VScalar
    IArray  :: ArrayClass  a => !a -> IVar VArray
    IHash   :: HashClass   a => !a -> IVar VHash
    ICode   :: CodeClass   a => !a -> IVar VCode
    IHandle :: HandleClass a => !a -> IVar VHandle
    IRule   :: RuleClass   a => !a -> IVar VRule
    IThunk  :: ThunkClass  a => !a -> IVar VThunk
    IPair   :: PairClass   a => !a -> IVar VPair
    IVal    ::                !Val -> IVar Val

-- | An empty failed match
mkMatchFail :: VMatch
mkMatchFail = MkMatch False 0 0 "" [] Map.empty

-- | Makes a successful match
mkMatchOk :: Int -> Int -> VStr -> VList -> VHash -> VMatch
mkMatchOk   = MkMatch True

instance Eq VOpaque where
    (MkOpaque x) == (MkOpaque y) = castV x == castV y

instance Typeable VOpaque where
    typeOf (MkOpaque x) = typeOf x

instance Ord VOpaque where
    compare x y = castV x `compare` castV y

instance Show VOpaque where
    show (MkOpaque x) = show x

instance Value VOpaque where
    fromVal (VOpaque o) = return o
    fromVal v = return $ MkOpaque v
    castV (MkOpaque x) = castV x
    doCast v = castFailM v "VOpaque"
#endif

readIVar :: IVar v -> Eval v
readIVar (IScalar x) = scalar_fetch x
readIVar (IPair x)   = pair_fetch x
readIVar (IArray x)  = array_fetch x
readIVar (IHash x)   = hash_fetch x
readIVar _ = fail "readIVar"

cloneIVar :: IVar v -> STM (IVar v)
cloneIVar (IScalar x) = fmap IScalar $ scalar_clone x
cloneIVar (IArray x)  = fmap IArray  $ array_clone x
cloneIVar (IHash x)   = fmap IHash   $ hash_clone x
cloneIVar (ICode x)   = fmap ICode   $ code_clone x
cloneIVar x = return x

writeIVar :: IVar v -> v -> Eval ()
writeIVar (IScalar x) = scalar_store x
writeIVar (IArray x) = array_store x
writeIVar (IHash x) = hash_store x
writeIVar _ = fail "writeIVar"

refType :: VRef -> Type
refType (MkRef x) = object_iType x

-- Haddock doesn't seem to like data/instance declarations with a where clause.
#ifndef HADDOCK
instance Eq IHash where
    x == y = addressOf x == addressOf y
instance Ord IHash where
    compare x y = compare (addressOf x) (addressOf y)
instance Show IHash where
    show = showAddressOf "Hash"
instance Typeable2 H.HashTable where
    typeOf2 _ = mkTyConApp (mkTyCon "HashTable") []

instance Eq VRef where
    x == y = addressOf x == addressOf y
instance Ord VRef where
    compare x y = compare (addressOf x) (addressOf y)
instance Show VRef where
    show ref@(MkRef ivar) = case ivar of
        IScalar x -> showAddr x
        IArray  x -> showAddr x
        IHash   x -> showAddr x
        ICode   x -> showAddr x
        IHandle x -> showAddr x
        IRule   x -> showAddr x
        IThunk  x -> showAddr x
        IPair   x -> showAddr x
        IVal    x -> show x
        where
        showAddr x = showAddressOf (showType (refType ref)) x

instance Typeable a => Show (IVar a) where
    show ivar = show (MkRef ivar)

instance Eq (IVar a) where
    x == y = addressOf x == addressOf y
instance Ord (IVar a) where
    compare x y = compare (addressOf x) (addressOf y)
instance Ord (TVar a) where
    compare x y = compare (addressOf x) (addressOf y)
instance Ord (IORef a) where
    compare x y = compare (addressOf x) (addressOf y)
#endif

scalarRef   :: ScalarClass a=> a -> VRef
scalarRef x = MkRef (IScalar x)
codeRef     :: CodeClass a  => a -> VRef
codeRef x   = MkRef (ICode x)
arrayRef    :: ArrayClass a => a -> VRef
arrayRef x  = MkRef (IArray x)
hashRef     :: HashClass a  => a -> VRef
hashRef x   = MkRef (IHash x)
thunkRef    :: ThunkClass a => a -> VRef
thunkRef x  = MkRef (IThunk x)
pairRef     :: PairClass a  => a -> VRef
pairRef x   = MkRef (IPair x)

newScalar :: (MonadSTM m) => VScalar -> m (IVar VScalar)
newScalar = stm . (fmap IScalar) . newTVar

newArray :: (MonadSTM m) => VArray -> m (IVar VArray)
newArray vals = stm $ do
    tvs <- mapM newScalar vals
    iv  <- newTVar (toP tvs)
    return $ IArray (MkIArray iv)

newHash :: (MonadSTM m) => VHash -> m (IVar VHash)
newHash hash = do
    --stm $ unsafeIOToSTM $ putStrLn "new hash"
    ihash <- stm . unsafeIOToSTM $ H.fromList H.hashString (map (\(a,b) -> (a, lazyScalar b)) (Map.toList hash))
    return $ IHash ihash

newHandle :: (MonadSTM m) => VHandle -> m (IVar VHandle)
newHandle = return . IHandle

proxyScalar :: Eval VScalar -> (VScalar -> Eval ()) -> IVar VScalar
proxyScalar fetch store = IScalar (fetch, store)

constScalar :: VScalar -> IVar VScalar
constScalar = IScalar

lazyScalar :: VScalar -> IVar VScalar
lazyScalar = IScalar . Just

lazyUndef :: IVar VScalar
lazyUndef = IScalar (Nothing :: IScalarLazy)

constArray :: VArray -> IVar VArray
constArray = IArray

retConstError :: VScalar -> Eval b
retConstError val = die "Can't modify constant item" val


-- Haddock doesn't like these; not sure why ...
#ifndef HADDOCK

{-
instance A.MArray IArray ArrayIndex STM where
    getBounds (MkIArray iv) = do
        a   <- readTVar iv
        return (bounds a)
    newArray b e = do
        a   <- replicateM (rangeSize b) (newTVar e)
        iv  <- newTVar (A.listArray b a)
        return $ MkIArray iv
    newArray_ b = do
        a   <- replicateM (rangeSize b) (newTVar A.arrEleBottom)
        iv  <- newTVar (A.listArray b a)
        return $ MkIArray iv
    unsafeRead (MkIArray iv) i = do
        a   <- readTVar iv
        readTVar $ A.unsafeAt a i
    unsafeWrite (MkIArray iv) i e = do
        a   <- readTVar iv
        writeTVar (A.unsafeAt a i) e
-}

newtype IArray = MkIArray (TVar [:IVar VScalar:])
    deriving (Typeable)

type IArraySlice        = [IVar VScalar]
type IHash              = H.HashTable VStr (IVar VScalar) -- XXX UTF8 handled at Types/Hash.hs
type IScalar            = TVar Val
type IScalarProxy       = (Eval VScalar, (VScalar -> Eval ()))
type IScalarLazy        = Maybe VScalar
type IPairHashSlice     = (VStr, IVar VScalar)

data VMultiCode = MkMultiCode
    { mc_type       :: !Type
    , mc_subtype    :: !SubType
    , mc_assoc      :: !SubAssoc
    , mc_signature  :: !Params
    , mc_variants   :: !(Set Var)
    }
    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}

-- these implementation allows no destructions
type IRule   = VRule
type IHandle = VHandle -- XXX maybe TVar?

-- GADTs, here we come!
data VRef where
    MkRef   :: (Typeable a) => !(IVar a) -> VRef

instance Typeable VRef where
    typeOf (MkRef x) = typeOf x

instance Typeable1 IVar where
    typeOf1 (IScalar x) = typeOf x
    typeOf1 (IArray  x) = typeOf x
    typeOf1 (IHash   x) = typeOf x
    typeOf1 (ICode   x) = typeOf x
    typeOf1 (IHandle x) = typeOf x
    typeOf1 (IRule   x) = typeOf x
    typeOf1 (IThunk  x) = typeOf x
    typeOf1 (IPair   x) = typeOf x
    typeOf1 (IVal    x) = typeOf x
#endif

{- <DrIFT> -- Do NOT delete! These are valuable instances!

{-# NOINLINE _FakeEnv #-}
_FakeEnv :: Env
_FakeEnv = unsafePerformIO $ stm $ do
    glob <- newTVar $ MkPad Map.empty
    ref  <- newTVar Map.empty
    init <- newTVar $ MkInitDat { initPragmas=[] }
    maxi <- newTVar $ MkObjectId 1
    return $ MkEnv
        { envContext = CxtVoid
        , envLexical = emptyPad
        , envLexPads = []
        , envCaller  = Nothing
        , envCompPad = Nothing
        , envLValue  = False
        , envGlobal  = MkMPad (addressOf glob) glob
        , envPackage = cast "Main"
        , envEval    = const (return VUndef)
        , envFrames  = Set.empty
        , envBody    = Val undef
        , envDebug   = Just ref -- Set to "Nothing" to disable debugging
        , envPos     = MkPos (__"<null>") 1 1 1 1
        , envPragmas = []
        , envInitDat = init
        , envMaxId   = maxi
        , envAtomic  = False
        }

fakeEval :: MonadIO m => Eval Val -> m Val
fakeEval = io . runEvalIO _FakeEnv

instance YAML Val.Val

instance YAML LexPads where
    asYAML _ = return nilNode
    fromYAML _ = return []

instance YAML ([Val] -> Eval Val) where
    asYAML _ = return nilNode
    fromYAML _ = return (const $ return VUndef)
instance YAML (Maybe Env) where
    asYAML _ = return nilNode
    fromYAML _ = return Nothing
instance YAML (Eval Val) where
    asYAML x = asYAML =<< fakeEval x
    fromYAML x = return =<< fromYAML x
instance (Ord a, YAML a) => YAML (Set a) where
    asYAML x = do
        x' <- mapM asYAML (Set.toAscList x)
        (return . mkTagNode "Set" . ESeq) x'
    fromYAML node = do
        fmap Set.fromDistinctAscList (fromYAMLseq node)

instance YAML a => YAML (Map String a) where
    asYAML x = asYAMLmap "Map" $ Map.toAscList (Map.map asYAML x)
    fromYAML node = fmap Map.fromList (fromYAMLmap node)
instance YAML a => YAML (Map Var a) where
    asYAML x = asYAMLmap "Map" . sortBy (\x y -> fst x `compare` fst y) $
        [ (cast k, asYAML v) | (k, v) <- Map.toList x ]
    fromYAML node = do
        list <- fromYAMLmapBuf node
        return (Map.fromList [ (cast k, v) | (k, v) <- list ])
instance Typeable a => YAML (IVar a) where
    asYAML x = asYAML (MkRef x)
instance YAML VRef where
    asYAML (MkRef (ICode cv))
        | Just (mc :: VMultiCode) <- fromTypeable cv = do
            mcC <- asYAML (mc :: VMultiCode)
            return $ mkTagNode (tagHs "VMultiCode") $ ESeq [mcC]
        | otherwise = do
            VCode vsub  <- fakeEval $ fmap VCode (code_fetch cv)
            vsubC       <- asYAML vsub
            return $ mkTagNode (tagHs "VCode") $ ESeq [vsubC]
    asYAML (MkRef (IScalar sv)) = do
        val <- fakeEval $ scalar_fetch sv
        svC <- asYAML val
        let tag = if scalar_iType sv == mkType "Scalar::Const"
                    then "VScalar" else "IScalar"
        return $ mkTagNode (tagHs tag) $ ESeq [svC]
    asYAML (MkRef (IArray av)) = do
        VList vals <- fakeEval $ fmap VList (array_fetch av)
        avC <- asYAML vals
        return $ mkTagNode (tagHs "Array") $ ESeq [avC]
    asYAML (MkRef (IHash hv)) = do
        VMatch MkMatch{ matchSubNamed = hv } <- fakeEval $ fmap (VMatch . MkMatch False 0 0 "" []) (hash_fetch hv)
        hvC <- asYAML hv
        return $ mkTagNode (tagHs "Hash") $ ESeq [hvC]
    asYAML (MkRef (IPair pv)) = do
        VList [k, v] <- fakeEval $ fmap (\(k, v) -> VList [k, v]) (pair_fetch pv)
        avC <- asYAML (k, v)
        return $ mkTagNode (tagHs "Pair") $ ESeq [avC]
    asYAML ref = do
        val <- fakeEval $ readRef ref
        svC <- asYAML val
        io $ print "====>"
        io $ print svC
        fail ("Not implemented: asYAML \"" ++ showType (refType ref) ++ "\"")
    fromYAML MkNode{n_tag=Just s, n_elem=ESeq [node]}
        | s == packBuf "tag:hs:VMultiCode"   =
            fmap (MkRef . ICode) (fromYAML node :: IO VMultiCode)
        | s == packBuf "tag:hs:VCode"   =
            fmap (MkRef . ICode) (fromYAML node :: IO VCode)
        | s == packBuf "tag:hs:VScalar" =
            fmap (MkRef . IScalar) (fromYAML node :: IO VScalar)
        | s == packBuf "tag:hs:Pair"    =
            fmap pairRef (fromYAML node :: IO VPair)
        | s == packBuf "tag:hs:IScalar" = newV newScalar
        | s == packBuf "tag:hs:Array"   = newV newArray
        | s == packBuf "tag:hs:Hash"    = newV newHash
        where newV f = fmap MkRef (f =<< fromYAML node)
    fromYAML node = fail $ "Unhandled YAML node: " ++ show node
instance YAML IHash where
     asYAML x = do
         l      <- io $ H.toList x
         asYAMLmap "IHash" (map (\(k, v) -> (k, asYAML v)) l)
     fromYAML node = do
         l  <- fromYAMLmap node
         l' <- H.fromList H.hashString l
         return l'

instance YAML ID where
    asYAML x = asYAML (idBuf x)
    fromYAML x = do
        buf <- fromYAML x
        return $ bufToID buf
 
instance Perl5 ID where
    showPerl5 x = showPerl5 (cast x :: ByteString)
instance JSON ID where
    showJSON x = showJSON (cast x :: ByteString)

instance YAML Pkg where
    asYAML x = asYAML (cast x :: ByteString)
    fromYAML = fmap (cast :: ByteString -> Pkg) . fromYAML

instance YAML Var where
    asYAML x = asYAML (cast x :: ByteString)
    fromYAML = fmap (cast :: ByteString -> Var) . fromYAML

instance YAML EntryFlags where
    asYAML (MkEntryFlags x) = asYAML x
    fromYAML = fmap MkEntryFlags . fromYAML
 
instance Perl5 Var where
    showPerl5 x = showPerl5 (cast x :: String)
instance JSON Var where
    showJSON x = showJSON (cast x :: String)

instance YAML (Set Val) where
    asYAML = asYAML . Set.toAscList
    fromYAML = fmap Set.fromAscList . fromYAML 

instance YAML VControl
instance YAML VThread
instance YAML ClassTree
instance YAML Dynamic
instance YAML ProcessHandle
instance YAML Regex
instance YAML Unique
instance YAML VComplex
instance YAML VHandle
instance YAML VOpaque
instance YAML VSocket
instance YAML PerlSV

instance Perl5 Exp where
    showPerl5 _ = "(undef)"
instance JSON Exp where
    showJSON _ = "null"

-- Non-canonical serialization... needs work
instance (Show (TVar a)) => Perl5 (TVar a) where
    showPerl5 _ = "(warn '<ref>')"
instance (Show (TVar a)) => JSON (TVar a) where
    showJSON _ = "null"

instance Perl5 Val where
    showPerl5 (VUndef) = showP5Class "VUndef"
    showPerl5 (VBool aa) = showP5ArrayObj "VBool" [showPerl5 aa]
    showPerl5 (VInt aa) = showP5ArrayObj "VInt" [showPerl5 aa]
    showPerl5 (VRat aa) = showP5ArrayObj "VRat" [showPerl5 aa]
    showPerl5 (VNum aa) = showP5ArrayObj "VNum" [showPerl5 aa]
    showPerl5 (VStr aa) = showP5ArrayObj "VStr" [showPerl5 aa]
    showPerl5 (VList aa) = showP5ArrayObj "VList" [showPerl5 aa]
    showPerl5 (VType aa) = showP5ArrayObj "VType" [showPerl5 aa]
    showPerl5 (VCode{}) = showP5Class "VUndef"

</DrIFT> Do NOT delete! These instances are your friends! -}

instance Typeable Unique where typeOf _ = mkTyConApp (mkTyCon "Unique") []
instance Typeable ProcessHandle where typeOf _ = mkTyConApp (mkTyCon "ProcessHandle") []
instance Typeable Regex where typeOf _ = mkTyConApp (mkTyCon "Regex") []


instance Eq VJunc where
    (MkJunc aa ab ac) == (MkJunc aa' ab' ac') = aa == aa' && ab == ab'
                      && ac == ac'

instance Ord VJunc where
    compare (MkJunc aa ab ac) (MkJunc aa' ab' ac') =
            foldl (\x y -> if x == EQ then compare y EQ else x) EQ
            [compare aa aa',compare ab ab',compare ac ac']

{- !!! For DrIFT -- Don't delete !!!

data VJunc = MkJunc
    { juncType :: !JuncType
    , juncDup  :: !(Set Val)
    , juncSet  :: !(Set Val)
    } deriving (Typeable) {-!derive: YAML_Pos!-}

data JuncType = JAny | JAll | JNone | JOne
    deriving (Eq, Ord, Typeable) {-!derive: YAML_Pos!-}

data Scope = SState | SConstant | SHas | SMy | SOur
    {-!derive: YAML_Pos, JSON, Perl5!-}

data Pad = MkPad { padEntries :: Map Var PadEntry }
    {-!derive: YAML_Pos!-}

data Pos = MkPos
    { posName           :: !String, posBeginLine      :: !Int
    , posBeginColumn    :: !Int
    , posEndLine        :: !Int
    , posEndColumn      :: !Int
    }
    {-!derive: YAML_Pos, JSON, Perl5!-}

data Type
    = MkType !String      -- ^ A regular type
    | TypeOr  !Type !Type -- ^ The disjunction (|) of two types
    | TypeAnd !Type !Type -- ^ The conjunction (&) of two types
    {-!derive: YAML_Pos, JSON, Perl5!-}

data Cxt = CxtVoid | CxtItem !Type | CxtSlurpy !Type
    {-!derive: YAML_Pos, JSON, Perl5!-}

data Val
    = VUndef                 -- ^ Undefined value
    | VBool     !VBool       -- ^ Boolean value
    | VInt      !VInt        -- ^ Integer value
    | VRat      !VRat        -- ^ Rational number value
    | VNum      !VNum        -- ^ Number (i.e. a double)
    | VStr      !VStr        -- ^ String value
    | VList     !VList       -- ^ List value
    | VType     !VType       -- ^ Type value (e.g. @Int@ or @Type@)
    {-!derive: JSON!-}

data Pragma = MkPrag
    { pragName           :: !String -- ^ Name of pragma
    , pragDat            :: !Int    -- ^ (lexically scoped) pragmatic data
                                    --     This element is subject to change;
                                    --     we don't necessarily want to limit
                                    --     ourselves to 32 bit ints.
    }
    {-!derive: YAML_Pos, JSON, Perl5!-}

-}

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