root/src/Pugs/AST/Internals.hs

Revision 21673, 45.0 kB (checked in by audreyt, 4 months ago)

* Import Pugs 6.2.13.11 from Hackage into our source tree.
* Highlights:

  • Much faster startup time
  • Slightly faster compilation time (mostly due to refactored Pugs.AST.Internals)
  • Portable-to-Win32 readline thanks to Haskeline
  • Property svn:mime-type set to text/plain; charset=UTF-8
  • Property svn:eol-style set to native
Line 
1{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans -fallow-overlapping-instances -fallow-undecidable-instances -fparr #-}
2
3module Pugs.AST.Internals (
4    Eval(..),      -- uses Val, Env, SIO
5    Ann(..),   -- Cxt, Pos, Prag
6    Exp(..),   -- uses Pad, Eval, Val
7    Env(..),   -- uses Pad, TVar, Exp, Eval, Val
8    Val(..),   -- uses V.* (which ones?)
9    Value(..), -- uses Val, Eval
10    InitDat(..),
11    SubAssoc(..), TraitBlocks(..), emptyTraitBlocks,
12
13    MPad(..), LexPad(..), LexPads, Pad(..), PadEntry(..), EntryFlags(..), PadMutator, -- uses Var, TVar, VRef
14    Param(..), -- uses Cxt, Exp
15    Params, -- uses Param
16    Bindings, -- uses Param, Exp
17    SlurpLimit, -- VInt, Exp
18   
19    emptyPad,
20
21    VRef(..), -- uses IVar
22    VOpaque(..), -- uses Value
23    VControl(..), -- uses Env, Eval, Val
24    ControlLoop(..), ControlWhen(..), Frame(..),
25    VScalar, -- uses Val
26    VPair, -- uses Val
27    VList, -- uses Val
28    VThread(..), -- uses Val
29    VSubst(..),  -- uses VRule, VStr, Exp
30    VArray, -- uses Val
31    VHash, -- uses VStr, Val
32    VThunk(..), -- uses Eval, Val
33    VProcess(..),
34    VMatch(..), mkMatchFail, mkMatchOk, -- uses VList, VHash
35    VCode(..), SubType(..), -- uses Pad, Exp, Type
36    VJunc(..), JuncType(..), -- uss Val
37    VObject(..), -- uses VType, IHash, Unique
38    ObjectId(..),
39    VType, -- uses Type
40    VRule(..), -- uses Val
41    VMultiCode(..),
42
43    IVar(..), -- uses *Class and V*
44    IArray(..), IArraySlice, IHash, IScalar, IScalarProxy,
45    IScalarLazy, IPairHashSlice, IRule, IHandle, IHashEnv(..),
46    IScalarCwd(..),
47
48    ArrayClass(..), CodeClass(..), HandleClass(..), HashClass(..),
49    ObjectClass(..), PairClass(..), RuleClass(..), ScalarClass(..),
50    ThunkClass(..),
51
52    CompUnit(..), mkCompUnit, compUnitVersion,
53
54    -- MonadEval(..),
55
56    transformExp,
57
58    runEvalSTM, runEvalIO, callCC, tryT, resetT, shiftT, catchT,
59    undef, defined, tryIO, guardSTM, guardIO, guardIOexcept,
60    readRef, writeRef, clearRef, dumpRef, forceRef,
61    askGlobal, writeVar, readVar,
62    findSymRef, findSym, valType,
63    ifListContext, ifValTypeIsa, evalValType, fromVal',
64    scalarRef, codeRef, arrayRef, hashRef, thunkRef, pairRef,
65    newScalar, newArray, newHash, newHandle, newObject,
66
67    cloneRef, cloneIVar,
68
69    proxyScalar, constScalar, lazyScalar, lazyUndef, constArray,
70    retControl, retShift, retShiftEmpty, retEmpty, retIVar, readIVar, writeIVar,
71    fromVals, refType,
72    readPadEntry, writePadEntry, refreshPad, lookupPad, padToList, listToPad,
73    mkPrim, mkSub, mkCode, showRat, showTrueRat,
74    cxtOfSigil, cxtOfSigilVar, typeOfSigil, typeOfSigilVar,
75    buildParam, defaultArrayParam, defaultHashParam, defaultScalarParam,
76    paramsToSig,
77    emptyExp,
78    isSlurpy, envWant,
79    extractPlaceholderVars, fromObject, createObject, createObjectRaw,
80    doPair, doHash, doArray,
81    unwrap,
82    newObjectId, runInvokePerl5,
83   
84    showVal, errStr, errStrPos, errValPos, enterAtomicEnv, valToBool, envPos', -- for circularity
85    expToEvalVal, -- Hack, should be removed once it's figured out how
86
87    newSVval, -- used in Run.Perl5
88
89    anyToVal, vvToVal, anyFromVal, -- for circularity
90
91    DebugInfo, newDebugInfo, _Sym, _Var -- String -> ByteString constructors
92) where
93
94import Pugs.Internals
95import Pugs.Types
96import qualified Data.Set       as Set
97import qualified Data.Map       as Map
98
99import qualified Data.HashTable    as H
100import GHC.Conc (unsafeIOToSTM)
101
102import Pugs.Cont (callCC)
103import Pugs.Parser.Number
104import Pugs.AST.Types
105import Pugs.AST.Functions
106import Pugs.AST.Eval
107import Pugs.AST.Utils
108import Pugs.AST.Prag
109import Pugs.AST.Pos
110import Pugs.AST.Scope
111import Pugs.AST.SIO
112import Pugs.Embed.Perl5
113import qualified Pugs.Val as Val
114import GHC.PArr
115import {-# SOURCE #-} Pugs.AST
116
117-- CPP Includes
118
119#include "../Types/Array.hs"
120#include "../Types/Handle.hs"
121#include "../Types/Hash.hs"
122#include "../Types/Scalar.hs"
123#include "../Types/Code.hs"
124#include "../Types/Thunk.hs"
125#include "../Types/Rule.hs"
126#include "../Types/Pair.hs"
127#include "../Types/Object.hs"
128
129-- Data Definitions
130
131{-|
132Represents a value.
133
134Note that 'Val' is also a constructor for 'Exp' (i.e. an expression containing
135a value), so don't confuse the two. Similarly, all the constructors for
136@data 'Val'@ are themselves puns on the types of values they contain.
137-}
138data Val
139    = VUndef                 -- ^ Undefined value
140    | VBool     !VBool       -- ^ Boolean value
141    | VInt      !VInt        -- ^ Integer value
142    | VRat      !VRat        -- ^ Rational number value
143    | VNum      !VNum        -- ^ Number (i.e. a double)
144    | VComplex  !VComplex    -- ^ Complex number value
145    | VStr      !VStr        -- ^ String value
146    | VList     !VList       -- ^ List value
147    | VType     !VType       -- ^ Type value (e.g. @Int@ or @Type@)
148    | VJunc     !VJunc       -- ^ Junction value
149    | VError    !Val ![Pos]  -- ^ Error
150    | VControl  !VControl
151-------------------------------------------------------------------
152-- The following are runtime-only values (VRef is negotiable)
153    | VRef      !VRef        -- ^ Reference value
154    | VCode     !VCode       -- ^ A code object
155    | VBlock    !VBlock
156    | VHandle   !VHandle     -- ^ File handle
157    | VSocket   !VSocket     -- ^ Socket handle
158    | VThread   !VThread
159    | VProcess  !VProcess    -- ^ PID value
160    | VRule     !VRule       -- ^ Rule\/regex value
161    | VSubst    !VSubst      -- ^ Substitution value (correct?)
162    | VMatch    !VMatch      -- ^ Match value
163    | VObject   !VObject     -- ^ Object
164    | VOpaque   !VOpaque
165    | PerlSV    !PerlSV
166    | VV        !Val.Val
167    deriving (Show, Eq, Ord, Typeable)
168
169{-|
170Evaluation environment.
171
172The current environment is stored in the @Reader@ monad inside the current
173'Eval' monad, and can be retrieved using @ask@ for the whole 'Env', or @asks@
174if you just want a single field.
175-}
176data Env = MkEnv
177    { envContext :: !Cxt                -- ^ Current context
178                                        -- ('CxtVoid', 'CxtItem' or 'CxtSlurpy')
179    , envLValue  :: !Bool               -- ^ Are we in an LValue context?
180    , envLexical :: !Pad                -- ^ Cached lexical pad for variable lookup
181    , envLexPads :: !LexPads            -- ^ Current lexical pads; MY is leftmost, OUTER is next, etc
182    , envCaller  :: !(Maybe Env)        -- ^ CALLER pads
183    , envCompPad :: !(Maybe MPad)       -- ^ Current COMPILING pad
184    , envGlobal  :: !MPad               -- ^ Global pad for variable lookup
185    , envPackage :: !Pkg                -- ^ Current package
186    , envEval    :: !(Exp -> Eval Val)  -- ^ Active evaluator
187    , envBody    :: !Exp                -- ^ Current AST expression
188    , envFrames  :: !(Set Frame)        -- ^ Special-markers in the dynamic path
189    , envDebug   :: !DebugInfo          -- ^ Debug info map
190    , envPos     :: !Pos                -- ^ Source position range
191    , envPragmas :: ![Pragma]           -- ^ List of pragmas in effect
192    , envInitDat :: !(TVar InitDat)     -- ^ BEGIN result information
193    , envMaxId   :: !(TVar ObjectId)    -- ^ Current max object id
194    , envAtomic  :: !Bool               -- ^ Are we in an atomic transaction?
195    }
196    deriving (Show, Eq, Ord, Typeable) -- don't derive YAML for now
197
198data IVar v where
199    IScalar :: ScalarClass a => !a -> IVar VScalar
200    IArray  :: ArrayClass  a => !a -> IVar VArray
201    IHash   :: HashClass   a => !a -> IVar VHash
202    ICode   :: CodeClass   a => !a -> IVar VCode
203    IHandle :: HandleClass a => !a -> IVar VHandle
204    IRule   :: RuleClass   a => !a -> IVar VRule
205    IThunk  :: ThunkClass  a => !a -> IVar VThunk
206    IPair   :: PairClass   a => !a -> IVar VPair
207    IVal    ::                !Val -> IVar Val
208
209data VOpaque where
210    MkOpaque :: Value a => !a -> VOpaque
211
212-- GADTs, here we come!
213data VRef where
214    MkRef   :: (Typeable a) => !(IVar a) -> VRef
215
216data VObject = MkObject
217    { objType   :: !VType
218    , objAttrs  :: !IHash
219    , objOpaque :: !(Maybe Dynamic)
220    , objId     :: !ObjectId
221    }
222    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}
223
224-- | Represents an expression tree.
225data Exp
226    = Noop                              -- ^ No-op
227    | App !Exp !(Maybe Exp) ![Exp]      -- ^ Function application
228                                        --     e.g. myfun($invocant: $arg)
229    | Syn !String ![Exp]                -- ^ Syntactic construct that cannot
230                                        --     be represented by 'App'.
231    | Ann !Ann !Exp                     -- ^ Annotation (see @Ann@)
232--  | Pad !Scope !Pad !Exp              -- ^ Lexical pad
233    | Sym !Scope !Var !EntryFlags !Exp !Exp -- ^ Symbol declaration
234    | Stmts !Exp !Exp                   -- ^ Multiple statements
235    | Prim !([Val] -> Eval Val)         -- ^ Primitive
236    | Val !Val                          -- ^ Value
237    | Var !Var                          -- ^ Variable
238    | NonTerm !Pos                      -- ^ Parse error
239    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}
240
241newtype ObjectId = MkObjectId { unObjectId :: Int }
242    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}
243
244-- Type Synonyms
245
246type VType = Type
247type VArray = [Val]
248type VHash = Map VStr Val
249type VList = [Val]
250
251-- Functions
252
253{-|
254Return the appropriate 'empty' value for the current context -- either
255an empty list ('VList' []), or undef ('VUndef').
256-}
257retEmpty :: Eval Val
258retEmpty = do
259    ifListContext
260        (return $ VList [])
261        (return VUndef)
262
263retShiftEmpty :: Eval a
264retShiftEmpty = retShift =<< retEmpty
265
266evalValType :: Val -> Eval Type
267evalValType (VRef (MkRef (IScalar sv))) = scalar_type sv
268evalValType (VRef r) = return $ refType r
269evalValType (VType t) = return t
270evalValType val = return $ valType val
271
272{-|
273Check whether a 'Val' is of the specified type. Based on the result,
274either the first or the second evaluation should be performed.
275-}
276ifValTypeIsa :: Val      -- ^ Value to check the type of
277             -> String   -- ^ Name of the type to check against
278             -> (Eval a) -- ^ The @then@ case
279             -> (Eval a) -- ^ The @else@ case
280             -> Eval a
281ifValTypeIsa v (':':typ) trueM falseM = ifValTypeIsa v typ trueM falseM
282ifValTypeIsa v typ trueM falseM = do
283    vt  <- evalValType v
284    if isaType typ vt
285        then trueM
286        else falseM
287
288{-|
289Collapse a junction value into a single boolean value.
290
291Works by recursively casting the junction members to booleans, then performing
292the actual junction test.
293-}
294juncToBool :: VJunc -> Eval Bool
295juncToBool (MkJunc JAny  _  vs) = do
296    bools <- mapM valToBool (Set.elems vs)
297    return . isJust $ find id bools
298juncToBool (MkJunc JAll  _  vs) = do
299    bools <- mapM valToBool (Set.elems vs)
300    return . isNothing $ find not bools
301juncToBool (MkJunc JNone _  vs) = do
302    bools <- mapM valToBool (Set.elems vs)
303    return . isNothing $ find id bools
304juncToBool (MkJunc JOne ds vs) = do
305    bools <- mapM valToBool (Set.elems ds)
306    if isJust (find id bools) then return False else do
307    bools <- mapM valToBool (Set.elems vs)
308    return $ 1 == (length $ filter id bools)
309
310fromVal' :: (Value a) => Val -> Eval a
311fromVal' (VRef r) = do
312    v <- readRef r
313    fromVal v
314fromVal' (VList vs) | any isRef vs = do
315    vs <- forM vs $ \v -> case v of { VRef r -> readRef r; _ -> return v }
316    fromVal $ VList vs
317    where
318    isRef VRef{}    = True
319    isRef _         = False
320fromVal' (PerlSV sv) = do
321    v <- io $ svToVal sv
322    case v of
323        PerlSV sv'  -> fromSV sv'   -- it was a SV
324        VV vv
325            | Just sv  <- Val.castVal vv -> fromSV sv
326            | Just v   <- Val.castVal vv -> fromVal v
327        val         -> fromVal val  -- it was a Val
328fromVal' (VV vv) = do
329    v' <- vvToVal vv
330    case v' of
331        VV vv''     -> fromVV vv''
332        PerlSV sv   -> fromSV sv
333        _           -> fromVal v'
334fromVal' v = doCast v
335
336-- XXX - This is makeshift until all our native types are in VV.
337vvToVal :: Val.Val -> Eval Val
338vvToVal x
339    | Just sv <- Val.castVal x  = do
340        rv <- io (svToVal sv)
341        case rv of
342            VV vv
343                | Just sv  <- Val.castVal vv -> return (PerlSV sv)
344                | Just v   <- Val.castVal vv -> return v
345            _ -> return rv
346    | Just v  <- Val.castVal x  = return v
347    | Just x' <- Val.castVal x  = return . VStr $ (cast :: Val.PureStr -> String)  x'
348    | Just x' <- Val.castVal x  = return . VInt $ (cast :: Val.PureInt -> Integer) x'
349    | Just x' <- Val.castVal x  = return . VNum $ (cast :: Val.PureNum -> Double)  x'
350    | Just x' <- Val.castVal x  = return (VStr x')
351    | Just x' <- Val.castVal x  = return (VInt x')
352    | Just x' <- Val.castVal x  = return (VNum x')
353    | Just x' <- Val.castVal x  = return (VBool x')
354    | Just () <- Val.castVal x  = return VUndef
355    | otherwise                 = return (VV x)
356
357getArrayIndex :: Int -> Maybe (IVar VScalar) -> Eval IArray -> Maybe (Eval b) -> Eval (IVar VScalar)
358getArrayIndex idx def getArr _ | idx < 0 = do
359    -- first, check if the list is at least abs(idx) long
360    MkIArray iv <- getArr
361    a   <- stm $ readTVar iv
362    let size = a_size a
363    if size > abs (idx+1)
364        then return (a !: (idx `mod` size))
365        else errIndex def idx
366-- now we are all positive; either extend or return
367getArrayIndex idx def getArr ext = do
368    MkIArray iv <- getArr
369    a   <- stm $ readTVar iv
370    let size = a_size a
371    if size > idx
372        then return (a !: idx)
373        else case ext of
374            Just doExt -> do { doExt; getArrayIndex idx def getArr Nothing }
375            Nothing    -> errIndex def idx
376
377createObjectRaw :: (MonadSTM m)
378    => ObjectId -> Maybe Dynamic -> VType -> [(VStr, Val)] -> m VObject
379createObjectRaw uniq opaq typ attrList = do
380    attrs   <- stm . unsafeIOToSTM . H.fromList H.hashString $ map (\(a,b) -> (a, lazyScalar b)) attrList
381    return $ MkObject
382        { objType   = typ
383        , objId     = uniq
384        , objAttrs  = attrs
385        , objOpaque = opaq
386        }
387
388
389runInvokePerl5 :: PerlSV -> PerlSV -> [PerlSV] -> Eval Val
390runInvokePerl5 sub inv args = do
391    env     <- ask
392    rv      <- io $ do
393        envSV   <- mkEnv env
394        invokePerl5 sub inv args envSV (enumCxt $ envContext env)
395    case rv of
396        Perl5ReturnValues [x]   -> io $ svToVal x
397        Perl5ReturnValues xs    -> io $ fmap VList (mapM svToVal xs)
398        Perl5ErrorString str    -> fail str
399        Perl5ErrorObject err    -> throwError (PerlSV err)
400
401anyToVal :: (Show a, Typeable a) => a -> Val
402anyToVal x
403    | Just v <- fromTypeable x      = v
404    | Just v <- fromTypeable x      = PerlSV v
405    | Just v <- fromTypeable x      = VStr v
406    | Just v <- fromTypeable x      = VInt v
407    | Just v <- fromTypeable x      = VNum v
408    | Just () <- fromTypeable x     = VUndef
409    | otherwise                     = error (show x)
410
411newSVval :: Val -> IO PerlSV
412newSVval val = case val of
413    PerlSV sv   -> return sv
414    VStr str    -> vstrToSV str
415    VType typ   -> vstrToSV (showType typ)
416    VBool bool  -> vintToSV (fromEnum bool)
417    VInt int    -> vintToSV int
418    VRat rat    -> vnumToSV rat
419    VNum num    -> vnumToSV num
420    VRef ref    -> vrefToSV ref
421    VCode{}     -> mkValRef val "Code"
422    VBlock{}    -> mkValRef val "Code"
423    VHandle{}   -> mkValRef val "Handle"
424    VSocket{}   -> mkValRef val "Socket"
425    VList{}     -> mkValRef val "Array"
426    VUndef      -> svUndef
427    VError{}    -> svUndef
428    _           -> mkValRef val ""
429
430vrefToSV :: VRef -> IO PerlSV
431vrefToSV ref = mkValRef (VRef ref) $ case ref of
432    MkRef IScalar{}   -> "Scalar"
433    MkRef IArray{}    -> "Array"
434    MkRef IHash{}     -> "Hash"
435    MkRef ICode{}     -> "Code"
436    MkRef IHandle{}   -> "Handle"
437    MkRef IRule{}     -> "Rule"
438    MkRef IThunk{}    -> "Thunk"
439    MkRef IPair{}     -> "Pair"
440    MkRef (IVal v)    -> show (valType v)
441
442valToStr :: Val -> Eval VStr
443valToStr = fromVal
444
445
446errStr :: VStr -> Val
447errStr str = VError (VStr str) []
448
449errStrPos :: VStr -> Pos -> Val
450errStrPos str pos = VError (VStr str) [pos]
451
452errValPos :: Val -> Pos -> Val
453errValPos val pos = VError val [pos]
454
455enterAtomicEnv :: Env -> Env
456enterAtomicEnv env = env{ envAtomic = True }
457
458{-|
459Find the 'Type' of the value contained by a 'Val'.
460
461See "Pugs.Types" for info on types.
462-}
463valType :: Val -> Type
464valType VUndef          = mkType "Scalar"
465valType (VRef v)        = refType v
466valType (VBool    _)    = mkType "Bool"
467valType (VInt     _)    = mkType "Int"
468valType (VRat     _)    = mkType "Rat"
469valType (VNum     _)    = mkType "Num"
470valType (VComplex _)    = mkType "Complex"
471valType (VStr     _)    = mkType "Str"
472-- valType (VList    _)    = mkType "List"
473valType (VList    _)    = mkType "Array"
474valType (VCode    c)    = code_iType c
475valType (VBlock   _)    = mkType "Block"
476valType (VJunc    _)    = mkType "Junction"
477valType (VError _ _)    = mkType "Error"
478valType (VHandle  _)    = mkType "IO"
479valType (VSocket  _)    = mkType "Socket"
480valType (VThread  _)    = mkType "Thread"
481valType (VProcess _)    = mkType "Process"
482valType (VControl _)    = mkType "Control"
483valType (VRule    _)    = mkType "Regex"
484valType (VSubst   _)    = mkType "Subst"
485valType (VMatch   _)    = mkType "Match"
486valType (VType    t)    = t
487valType (VObject  o)    = objType o
488valType (VOpaque  _)    = mkType "Object"
489valType (PerlSV   _)    = mkType "Scalar::Perl5"
490valType (VV       _)    = mkType "Scalar::Perl5" -- (cast $ Val.valMeta v)
491
492valToBool :: Val -> Eval VBool
493valToBool = fromVal
494
495_Sym :: Scope -> String -> EntryFlags -> Exp -> Exp -> Exp
496_Sym scope str flags init rest = Sym scope (cast str) flags init rest
497
498_Var :: String -> Exp
499_Var str = Var (possiblyFixOperatorName (cast str))
500
501-- Recursively apply a transformation to an Exp structure
502transformExp :: (Monad m) => (Exp -> m Exp) -> Exp -> m Exp
503transformExp f (App a b cs) = do
504    a' <- transformExp f a
505    b' <- case b of
506        Just e -> liftM Just $ transformExp f e
507        Nothing -> return Nothing
508    cs' <- mapM (transformExp f) cs
509    f $ App a' b' cs'
510transformExp f (Syn t es) = f =<< liftM (Syn t) (mapM (transformExp f) es)
511transformExp f (Ann a e) = f =<< liftM (Ann a) (transformExp f e)
512-- transformExp f (Pad s p e) = f =<< liftM (Pad s p) (transformExp f e)
513transformExp f (Sym s v c i e) = f =<< liftM (Sym s v c i) (transformExp f e)
514transformExp f (Stmts e1 e2) = do
515    e1' <- transformExp f e1
516    e2' <- transformExp f e2
517    f $ Stmts e1' e2'
518transformExp f e = f e
519
520{- FIXME: Figure out how to get this working without a monad, and make it castV -}
521expToEvalVal :: Exp -> Eval Val
522expToEvalVal exp = do
523    obj <- createObject (mkType "Code::Exp") []
524    return $ VObject obj{ objOpaque = Just $ toDyn exp }
525
526fromVals :: (Value n) => Val -> Eval [n]
527fromVals v = mapM fromVal =<< fromVal v
528
529extractPlaceholderVarsExp :: Exp -> ([Exp], Set Var) -> ([Exp], Set Var)
530extractPlaceholderVarsExp ex (exps, vs) = (ex':exps, vs')
531    where
532    (ex', vs') = extractPlaceholderVars ex vs
533
534{-| Deduce the placeholder vars ($^a, $^x etc.) used by a block). -}
535extractPlaceholderVars :: Exp -> Set Var -> (Exp, Set Var)
536extractPlaceholderVars (App n invs args) vs = (App n' invs' args', vs''')
537    where
538    (n', vs')      = extractPlaceholderVars n vs
539    (invs', vs'')  = maybe (invs, vs') (\inv -> let (x, y) = extractPlaceholderVars inv vs' in (Just x, y)) invs
540    (args', vs''') = foldr extractPlaceholderVarsExp ([], vs'') args
541extractPlaceholderVars (Stmts exp1 exp2) vs = (Stmts exp1' exp2', vs'')
542    where
543    (exp1', vs')  = extractPlaceholderVars exp1 vs
544    (exp2', vs'') = extractPlaceholderVars exp2 vs'
545extractPlaceholderVars (Syn n exps) vs = (Syn n exps', vs'')
546    where
547    (exps', vs') = foldr extractPlaceholderVarsExp ([], vs) exps
548    vs'' = case n of
549        "when"  -> Set.insert (cast "$_") vs'
550        "given" -> Set.delete (cast "$_") vs'
551        _       -> vs'
552extractPlaceholderVars (Var var) vs
553    | TImplicit <- v_twigil var
554    , var' <- var{ v_twigil = TNil }
555    = (Var var', Set.insert var' vs)
556    | var == cast "$_"
557    = (Var var, Set.insert var vs)
558    | otherwise
559    = (Var var, vs)
560extractPlaceholderVars (Ann ann ex) vs = ((Ann ann ex'), vs')
561    where
562    (ex', vs') = extractPlaceholderVars ex vs
563-- extractPlaceholderVars (Pad scope pad ex) vs = ((Pad scope pad ex'), vs')
564--     where
565--     (ex', vs') = extractPlaceholderVars ex vs
566extractPlaceholderVars (Sym scope var flags ini ex) vs = ((Sym scope var flags ini ex'), vs')
567    where
568    (ex', vs') = extractPlaceholderVars ex vs
569extractPlaceholderVars exp vs = (exp, vs)
570
571envPos' :: Env -> Pos
572envPos' = envPos
573
574envWant :: Env -> String
575envWant env =
576    showCxt (envContext env) ++ (if envLValue env then ", LValue" else "")
577    where
578    showCxt CxtVoid         = "Void"
579    showCxt (CxtItem typ)   = "Scalar (" ++ showType typ ++ ")"
580    showCxt (CxtSlurpy typ) = "List (" ++ showType typ ++ ")"
581
582refreshPad :: Pad -> Eval Pad
583refreshPad pad = do
584    fmap listToPad $ forM (padToList pad) $ \(name, entry) -> do
585        -- warn "Refreshing pad entry" (name, entry)
586        entry' <- case entry of
587            PELexical{ pe_proto = proto } -> stm $ do
588                ref     <- cloneRef proto
589                tvar'   <- newTVar ref
590                return entry{ pe_store = tvar' }
591            _ -> return entry
592        return (name, entry')
593
594{-|
595Retrieve the global 'Pad' from the current evaluation environment.
596
597'Env' stores the global 'Pad' in an STM variable, so we have to @asks@
598'Eval'\'s @ReaderT@ for the variable, then extract the pad itself from the
599STM var.
600-}
601askGlobal :: Eval Pad
602askGlobal = do
603    glob <- asks (mp_pad . envGlobal)
604    stm $ readTVar glob
605
606writeVar :: Var -> Val -> Eval ()
607writeVar var val
608    | isLexicalVar var  = doWriteVar (asks envLexical)
609    | otherwise         = doWriteVar askGlobal
610    where
611    doWriteVar askPad = do
612        pad <- askPad
613        case lookupPad var pad of
614            Just PEConstant{} -> fail $ "Cannot rebind constant: " ++ show var
615            Just c -> do
616                ref <- stm $ readTVar (pe_store c)
617                writeRef ref val
618            _  -> fail $ "Cannot bind to non-existing variable: " ++ show var
619
620readVar :: Var -> Eval Val
621readVar var
622    | isLexicalVar var = do
623        lex <- asks envLexical
624        case findSym var lex of
625            Just action -> stm action >>= readRef
626            _           -> return undef
627    | otherwise = do
628        glob <- askGlobal
629        case findSym var glob of
630            Just action -> stm action >>= readRef
631            _           -> return undef
632
633{-|
634The \'empty expression\' is just a no-op ('Noop').
635-}
636emptyExp :: Exp
637emptyExp = Noop
638
639retControl :: VControl -> Eval a
640retControl = retShift . VControl
641
642defined :: VScalar -> Bool
643defined VUndef  = False
644defined VType{} = False
645defined _       = True
646-- | Produce an undefined Perl 6 value (i.e. 'VUndef').
647undef :: VScalar
648undef = VUndef
649
650forceRef :: VRef -> Eval Val
651forceRef (MkRef (IScalar sv)) = forceRef =<< fromVal =<< scalar_fetch sv
652forceRef (MkRef (IThunk tv)) = thunk_force tv
653forceRef r = die "Cannot forceRef" r
654
655dumpRef :: VRef -> Eval Val
656dumpRef (MkRef (ICode cv)) = do
657    vsub <- code_fetch cv
658    return (VStr $ "(MkRef (ICode $ " ++ show vsub ++ "))")
659dumpRef (MkRef (IScalar sv)) | scalar_iType sv == mkType "Scalar::Const" = do
660    sv <- scalar_fetch sv
661    return (VStr $ "(MkRef (IScalar $ " ++ show sv ++ "))")
662dumpRef ref = return (VStr $ "(unsafePerformIO . newObject $ mkType \"" ++ showType (refType ref) ++ "\")")
663
664-- Reduce a VRef in rvalue context.
665readRef :: VRef -> Eval Val
666readRef (MkRef (IScalar sv)) = scalar_fetch sv
667readRef (MkRef (ICode cv)) = do
668    vsub <- code_fetch cv
669    return $ VCode vsub
670readRef (MkRef (IHash hv)) = do
671    pairs <- hash_fetch hv
672    return $ VList $ map (\(k, v) -> castV (castV k, v)) (Map.assocs pairs)
673readRef (MkRef (IArray av)) = do
674    vals <- array_fetch av
675    return $ VList vals
676
677-- XXX - This case is entirely bogus; but no time to fix it now.
678readRef (MkRef (IPair pv)) = do
679    (k, v) <- pair_fetch pv
680    return $ VList [k, v]
681
682readRef (MkRef (IHandle io)) = return . VHandle =<< handle_fetch io
683readRef (MkRef (IRule rx)) = return . VRule =<< rule_fetch rx
684readRef (MkRef (IThunk tv)) = readRef =<< fromVal =<< thunk_force tv
685readRef (MkRef (IVal v)) = do
686    cxt <- asks envContext
687    v ./ cxt
688
689retIVar :: (Typeable a) => IVar a -> Eval Val
690retIVar = return . VRef . MkRef
691
692fromVList :: Val -> Eval VArray
693fromVList (VList v) = return v
694fromVList x = return [x]
695
696fromVHash :: Val -> Eval VHash
697fromVHash = fromVal
698
699writeRef :: VRef -> Val -> Eval ()
700writeRef (MkRef (IScalar s)) (VList vals) = do
701    av <- newArray vals
702    scalar_store s (VRef $ MkRef av)
703writeRef (MkRef (IScalar s)) val = scalar_store s val
704writeRef (MkRef (IArray s)) val  = array_store s =<< fromVList val
705writeRef (MkRef (IHash s)) val   = hash_store s =<< fromVHash val
706writeRef (MkRef (ICode s)) val   = code_store s =<< fromVal val
707writeRef (MkRef (IPair s)) val   = pair_storeVal s val
708writeRef (MkRef (IThunk tv)) val = (`writeRef` val) =<< fromVal =<< thunk_force tv
709writeRef r _ = die "Cannot writeRef" r
710
711cloneRef :: VRef -> STM VRef
712cloneRef (MkRef x) = fmap MkRef (cloneIVar x)
713
714clearRef :: VRef -> Eval ()
715clearRef (MkRef (IScalar s)) = scalar_store s undef
716clearRef (MkRef (IArray s))  = array_clear s
717clearRef (MkRef (IHash s))   = hash_clear s
718clearRef (MkRef (IPair s))   = pair_storeVal s undef
719clearRef (MkRef (IThunk tv)) = clearRef =<< fromVal =<< thunk_force tv
720clearRef r = die "Cannot clearRef" r
721
722{-# SPECIALISE newObject :: Type -> Eval VRef #-}
723{-# SPECIALISE newObject :: Type -> IO VRef #-}
724newObject :: (MonadSTM m, MonadIO m) => Type -> m VRef
725newObject typ = case showType typ of
726    "Any"       -> io $ fmap scalarRef $ newTVarIO undef
727    "Item"      -> io $ fmap scalarRef $ newTVarIO undef
728    "Scalar"    -> io $ fmap scalarRef $ newTVarIO undef
729    "Array"     -> io $ do
730        iv  <- newTVarIO [::]
731        return $ arrayRef (MkIArray iv)
732    "Hash"      -> do
733        h   <- io (H.new (==) H.hashString)
734        return $ hashRef (h :: IHash)
735    "Sub"       -> newObject $ mkType "Code"
736    "Routine"   -> newObject $ mkType "Code"
737    "Method"    -> newObject $ mkType "Code"
738    "Submethod" -> newObject $ mkType "Code"
739    "Code"      -> return $! codeRef $ mkPrim
740        { subAssoc = AIrrelevantToParsing
741        , subBody  = Prim . const $ fail "Cannot use Undef as a Code object"
742        }
743    "Type"      -> io $ fmap scalarRef $ newTVarIO undef
744    "Pair"      -> do
745        key <- newObject (mkType "Scalar")
746        val <- newObject (mkType "Scalar")
747        return $ MkRef (IPair (VRef key, VRef val))
748    "Regex"     -> io $ fmap scalarRef $ newTVarIO undef -- XXX Wrong
749    "Capture"   -> io $ fmap scalarRef $ newTVarIO undef -- XXX Wrong
750    _           -> fail ("Class prototype occured where its instance object expected: " ++ showType typ)
751
752doPair :: Val -> (forall a. PairClass a => a -> b) -> Eval b
753doPair (VRef (MkRef (IPair pv))) f = return $ f pv
754doPair (VRef (MkRef (IHash hv))) f = do
755    vals <- hash_fetch hv
756    let [(k, v)] = Map.toList vals
757    return $ f (VStr k, v)
758doPair (VRef (MkRef (IArray av))) f = do
759    vals <- array_fetch av
760    let [k, v] = take 2 (vals ++ repeat undef)
761    return $ f (k, v)
762doPair (VRef (MkRef (IScalar sv))) f = do
763    val <- scalar_fetch sv
764    case val of
765        VUndef  -> do
766            ref@(MkRef (IPair pv)) <- newObject (mkType "Pair")
767            scalar_store sv (VRef ref)
768            return $ f pv
769        _  -> doPair val f
770doPair (VRef x) _ = die "Cannot cast into Pair" x
771doPair val f = do
772    vs <- fromVal val
773    case (vs :: VList) of
774        [x, y]  -> return $ f (x, y)
775        _       -> do
776            pv <- castFailM val "Confusing pair?"
777            return $ f (pv :: VPair)
778
779-- XXX: Refactor doHash and doArray into one -- also see Eval's [] and {}
780doHash :: Val -> (forall a. HashClass a => a -> b) -> Eval b
781doHash (PerlSV sv) f = return $ f sv
782doHash (VRef (MkRef (IHash hv))) f = return $ f hv
783doHash (VRef (MkRef (IScalar sv))) f = do
784    val <- scalar_fetch sv
785    case val of
786        VUndef  -> do
787            ref@(MkRef (IHash hv)) <- newObject (mkType "Hash")
788            scalar_store sv (VRef ref)
789            return $ f hv
790        _  -> doHash val f
791doHash (VRef (MkRef p@(IPair _))) f = return $ f p
792doHash (VObject o) f = return $ f (objAttrs o)
793doHash (VMatch m) f = do
794    return $ f (matchSubNamed m)
795doHash val@(VRef _) _ = die "Cannot cast into Hash" val
796doHash val f = do
797    hv  <- fromVal val
798    return $ f (hv :: VHash)
799
800-- can be factored out
801doArray :: Val -> (forall a. ArrayClass a => a -> b) -> Eval b
802doArray (PerlSV sv) f = return $ f sv
803doArray (VRef (MkRef (IArray av))) f = return $ f av
804doArray (VRef (MkRef (IScalar sv))) f = do
805    val <- scalar_fetch sv
806    if defined val
807        then doArray val f
808        else do
809            ref@(MkRef (IArray hv)) <- newObject (mkType "Array")
810            scalar_store sv (VRef ref)
811            return $ f hv
812doArray (VRef (MkRef p@(IPair _))) f = return $ f p
813doArray val@(VRef (MkRef IHash{})) f = do
814    av  <- fromVal val
815    return $ f (av :: VArray)
816doArray val@(VRef _) _ = die "Cannot cast into Array" val
817doArray (VMatch m) f = do
818    return $ f (matchSubPos m)
819doArray val f = do
820    av  <- fromVal val
821    return $ f (av :: VArray)
822
823readIVar :: IVar v -> Eval v
824readIVar (IScalar x) = scalar_fetch x
825readIVar (IPair x)   = pair_fetch x
826readIVar (IArray x)  = array_fetch x
827readIVar (IHash x)   = hash_fetch x
828readIVar _ = fail "readIVar"
829
830cloneIVar :: IVar v -> STM (IVar v)
831cloneIVar (IScalar x) = fmap IScalar $ scalar_clone x
832cloneIVar (IArray x)  = fmap IArray  $ array_clone x
833cloneIVar (IHash x)   = fmap IHash   $ hash_clone x
834cloneIVar (ICode x)   = fmap ICode   $ code_clone x
835cloneIVar x = return x
836
837writeIVar :: IVar v -> v -> Eval ()
838writeIVar (IScalar x) = scalar_store x
839writeIVar (IArray x) = array_store x
840writeIVar (IHash x) = hash_store x
841writeIVar _ = fail "writeIVar"
842
843refType :: VRef -> Type
844refType (MkRef x) = object_iType x
845
846scalarRef   :: ScalarClass a=> a -> VRef
847scalarRef x = MkRef (IScalar x)
848codeRef     :: CodeClass a  => a -> VRef
849codeRef x   = MkRef (ICode x)
850arrayRef    :: ArrayClass a => a -> VRef
851arrayRef x  = MkRef (IArray x)
852hashRef     :: HashClass a  => a -> VRef
853hashRef x   = MkRef (IHash x)
854thunkRef    :: ThunkClass a => a -> VRef
855thunkRef x  = MkRef (IThunk x)
856pairRef     :: PairClass a  => a -> VRef
857pairRef x   = MkRef (IPair x)
858
859newScalar :: (MonadSTM m) => VScalar -> m (IVar VScalar)
860newScalar = stm . (fmap IScalar) . newTVar
861
862newArray :: (MonadSTM m) => VArray -> m (IVar VArray)
863newArray vals = stm $ do
864    tvs <- mapM newScalar vals
865    iv  <- newTVar (toP tvs)
866    return $ IArray (MkIArray iv)
867
868newHash :: (MonadSTM m) => VHash -> m (IVar VHash)
869newHash hash = do
870    --stm $ unsafeIOToSTM $ putStrLn "new hash"
871    ihash <- stm . unsafeIOToSTM $ H.fromList H.hashString (map (\(a,b) -> (a, lazyScalar b)) (Map.toList hash))
872    return $ IHash ihash
873
874newHandle :: (MonadSTM m) => VHandle -> m (IVar VHandle)
875newHandle = return . IHandle
876
877proxyScalar :: Eval VScalar -> (VScalar -> Eval ()) -> IVar VScalar
878proxyScalar fetch store = IScalar (fetch, store)
879
880constScalar :: VScalar -> IVar VScalar
881constScalar = IScalar
882
883lazyScalar :: VScalar -> IVar VScalar
884lazyScalar = IScalar . Just
885
886lazyUndef :: IVar VScalar
887lazyUndef = IScalar (Nothing :: IScalarLazy)
888
889constArray :: VArray -> IVar VArray
890constArray = IArray
891
892------------------------------------------------------------------------
893anyFromVal :: forall a. Typeable a => Val -> a
894anyFromVal v = case fromTypeable (fromVal v :: Eval PerlSV) of
895    Just f  -> f :: a
896    _       -> error "anyFromVal failed!"
897
898intCast :: Num b => Val -> Eval b
899intCast x = fmap fromIntegral (fromVal x :: Eval VInt)
900
901
902showVal :: Val -> String
903showVal = show
904
905defaultArrayParam :: Param
906defaultHashParam :: Param
907defaultScalarParam :: Param
908
909defaultArrayParam   = buildParam "" "*" "@_" (Val VUndef)
910defaultHashParam    = buildParam "" "*" "%_" (Val VUndef)
911defaultScalarParam  = buildParam "" "?" "$_" (Var $ cast "$OUTER::_")
912
913
914-- Class: Value
915
916{-|
917Typeclass indicating types that can be converted to\/from 'Val's.
918
919Not to be confused with 'Val' itself, or the 'Exp' constructor @Val@.
920-}
921class (Typeable n, Show n, Ord n) => Value n where
922    fromVal :: Val -> Eval n
923    fromVal = fromVal'
924    doCast :: Val -> Eval n
925{-    doCast v = castFailM v "default implementation of doCast" -}
926    fromVV :: Val.Val -> Eval n
927    fromVV v = do
928        str <- Val.asStr v
929        fail $ "Cannot cast from VV (" ++ cast str ++ ") to " ++ errType (undefined :: n)
930    fromSV :: PerlSV -> Eval n
931    fromSV sv = do
932        str <- io $ svToVStr sv
933        fail $ "Cannot cast from SV (" ++ str ++ ") to " ++ errType (undefined :: n)
934    castV :: n -> Val
935    castV x = VOpaque (MkOpaque x) -- error $ "Cannot cast into Val"
936
937
938-- Instances: Value
939
940instance Value (IVar VScalar) where
941    fromVal (VRef (MkRef v@(IScalar _))) = return v
942    fromVal (VRef r) = fromVal =<< readRef r
943    fromVal v = return $ constScalar v
944    doCast v = castFailM v "IVar VScalar"
945
946instance Value VType where
947    fromVal (VType t)   = return t
948    fromVal v@(VObject obj) | objType obj == (mkType "Class") = do
949        meta    <- readRef =<< fromVal v
950        fetch   <- doHash meta hash_fetchVal
951        str     <- fromVal =<< fetch "name"
952        return $ mkType str
953    fromVal v           = evalValType v
954    doCast v = castFailM v "VType"
955
956instance Value VMatch where
957    fromVal (VRef r) = fromVal =<< readRef r
958    fromVal (VMatch m) = return m
959    fromVal (VList (x:_)) = fromVal x
960    fromVal _ = return $ mkMatchFail
961    doCast v = castFailM v "VMatch"
962
963instance Value VRef where
964    fromVal (VRef r)   = return $ r
965    fromVal (VList vs) = return $ arrayRef vs
966    fromVal (VCode c)  = return $ codeRef c
967    fromVal v          = return $ scalarRef v
968    castV = VRef
969    doCast v = castFailM v "VRef"
970
971instance Value [Int] where
972    fromVal v = do
973        vlist <- fromVal v
974        mapM fromVal vlist
975    doCast v = castFailM v "[Int]"
976
977instance Value [VStr] where
978    castV = VList . map VStr
979    fromVal v = do
980        vlist <- fromVal v
981        mapM fromVal vlist
982    doCast v = castFailM v "[VStr]"
983
984instance Value VPair where
985    castV pv = VRef $ pairRef pv
986    fromVal VUndef  = return (VUndef, VUndef)
987    fromVal v       = join $ doPair v pair_fetch
988    doCast v = castFailM v "VPair"
989
990instance Value [(VStr, Val)] where
991    fromVal v = do
992        list <- fromVal v
993        forM list $ \(k, v) -> do
994            str <- fromVal k
995            return (str, v)
996    doCast v = castFailM v "[(VStr, Val)]"
997
998instance Value VObject where
999    fromVal (VObject o) = return o
1000    fromVal v@(VRef _) = fromVal' v
1001    fromVal v = do
1002        fail $ "Cannot cast from " ++ show v ++ " to Object"
1003    doCast v = castFailM v "VObject"
1004
1005instance Value VHash where
1006    fromVal (VObject o) = do
1007        l <- io $ H.toList (objAttrs o)
1008        fmap Map.fromList . forM l $ \(k, ivar) -> do
1009            v <- readIVar ivar
1010            return (k, v)
1011    fromVal VType{} = return Map.empty -- ::Hash<foo>
1012    fromVal (VRef r) = fromVal =<< readRef r
1013    fromVal v = do
1014        list <- fromVal v
1015        fmap Map.fromList $ forM list $ \(k, v) -> do
1016            str <- fromVal k
1017            return (str, v)
1018    doCast v = castFailM v "VHash"
1019
1020instance Value [VPair] where
1021    fromVal VUndef = return []
1022    fromVal v = do
1023        list <- fromVals v
1024        doFrom $ concat list
1025        where
1026        doFrom :: [Val] -> Eval [VPair]
1027        doFrom [] = return []
1028        doFrom [_] = fail $ "Odd number of elements found where hash expected: " ++ show v
1029        doFrom (k:v:list) = do
1030            rest <- doFrom list
1031            return ((k, v):rest)
1032    doCast v = castFailM v "Hash"
1033
1034instance Value VCode where
1035    castV = VCode
1036    fromSV sv = return $ mkPrim
1037        { subName     = cast "<anon>"
1038        , subParams   = [defaultArrayParam]
1039        , subReturns  = mkType "Scalar::Perl5"
1040        , subBody     = Prim $ \(args:_) -> do
1041            svs     <- fromVals args
1042            runInvokePerl5 sv nullSV svs
1043        }
1044    doCast (VCode b) = return b
1045    doCast (VType t) = return $ mkPrim
1046        { subName     = cast t
1047        , subParams   = [buildParam "Any" "*" "@?0" (Val VUndef), buildParam "Any" "*" "%?0" (Val VUndef)]
1048        , subReturns  = mkType "Scalar::Perl5"
1049        , subBody     = Prim $ \(p:n:_) -> do
1050            evl <- asks envEval
1051            evl (App (_Var "&new") (Just $ Val (VType t)) [Syn "|" [Val p], Syn "|" [Val n]])
1052        }
1053    doCast (VList [VCode b]) = return b -- XXX Wrong
1054    doCast v = castFailM v "VCode"
1055
1056instance Value VBool where
1057    castV = VBool
1058    fromSV sv = io $ svToVBool sv
1059    fromVV vv = fmap cast (Val.asBit vv)
1060    doCast (VJunc j)   = juncToBool j
1061    doCast (VMatch m)  = return $ matchOk m
1062    doCast (VBool b)   = return $ b
1063    doCast VUndef      = return $ False
1064    doCast VType{}     = return $ False
1065    doCast (VStr "")   = return $ False
1066    doCast (VStr "0")  = return $ False
1067    doCast (VInt 0)    = return $ False
1068    doCast (VRat 0)    = return $ False
1069    doCast (VNum 0)    = return $ False
1070    doCast (VList [])  = return $ False
1071    doCast _           = return $ True
1072
1073
1074instance Value VInt where
1075    castV = VInt
1076    fromVV vv = fmap cast (Val.asInt vv)
1077    fromSV sv = io $ svToVInt sv
1078    doCast (VInt i)     = return $ i
1079    doCast x            = fmap truncate (fromVal x :: Eval VRat)
1080
1081instance Value VRat where
1082    castV = VRat
1083    fromSV sv = io $ svToVNum sv
1084    doCast (VInt i)     = return $ i % 1
1085    doCast (VRat r)     = return $ r
1086    doCast (VBool b)    = return $ if b then 1 % 1 else 0 % 1
1087    doCast (VList l)    = return $ genericLength l
1088    doCast (VStr s) | not (null s) , isSpace $ last s = do
1089        str <- fromVal (VStr $ init s)
1090        return str
1091    doCast (VStr s) | not (null s) , isSpace $ head s = do
1092        str <- fromVal (VStr $ tail s)
1093        return str
1094    doCast (VStr s)     = return $
1095        case ( parseNatOrRat s ) of
1096            Left _   -> 0 % 1
1097            Right rv -> case rv of
1098                Left  i -> i % 1
1099                Right d -> d
1100    doCast x            = fmap toRational (fromVal x :: Eval VNum)
1101
1102instance Value VNum where
1103    castV = VNum
1104    fromVV vv = fmap cast (Val.asNum vv)
1105    fromSV sv = io $ svToVNum sv
1106    doCast VUndef       = return $ 0
1107    doCast VType{}      = return $ 0
1108    doCast (VBool b)    = return $ if b then 1 else 0
1109    doCast (VInt i)     = return $ fromIntegral i
1110    doCast (VRat r)     = return $ realToFrac r
1111    doCast (VNum n)     = return $ n
1112    doCast (VComplex (r :+ _)) = return $ r
1113    doCast (VStr s) | not (null s) , isSpace $ last s = do
1114        str <- fromVal (VStr $ init s)
1115        return str
1116    doCast (VStr s) | not (null s) , isSpace $ head s = do
1117        str <- fromVal (VStr $ tail s)
1118        return str
1119    doCast (VStr "Inf") = return $ 1/0
1120    doCast (VStr "-Inf") = return $ -1/0
1121    doCast (VStr "NaN") = return $ 0/0
1122    doCast (VStr s)     = return $
1123        case ( parseNatOrRat s ) of
1124            Left _   -> 0
1125            Right rv -> case rv of
1126                Left  i -> fromIntegral i
1127                Right d -> realToFrac d
1128    doCast (VList l)     = return $ genericLength l
1129    doCast t@VThread{}   = fmap read (fromVal t)
1130    doCast (VMatch m)    = fromVal (VStr $ matchStr m)
1131    doCast v = castFailM v "VNum"
1132
1133instance Value Ordering where
1134    castV x = VInt $ case x of
1135        LT -> -1
1136        EQ -> 0
1137        GT -> 1
1138    doCast x = do
1139        n <- fromVal x :: Eval VInt
1140        return $ case signum n of
1141            -1  -> LT
1142            0   -> EQ
1143            1   -> GT
1144            _   -> error "signum: impossible"
1145
1146instance Value VComplex where
1147    castV = VComplex
1148    doCast (VComplex x) = return x
1149    doCast x            = fmap (:+ 0) (fromVal x :: Eval VNum)
1150
1151instance Value ID where
1152    castV = VStr . cast
1153    fromSV sv = fmap cast (io $ svToVStr sv)
1154    fromVV vv = fmap cast (Val.asStr vv)
1155    fromVal = fmap (cast :: VStr -> ID) . fromVal
1156    doCast = fmap (cast :: VStr -> ID) . doCast
1157
1158instance Value VStr where
1159    castV = VStr
1160    fromSV sv = io $ svToVStr sv
1161    fromVV vv = fmap cast (Val.asStr vv)
1162    fromVal (VList l)    = return . unwords =<< mapM fromVal l
1163    fromVal v@(PerlSV _) = fromVal' v
1164    fromVal VUndef       = return ""
1165    fromVal (VType t)    = return (showType t)
1166    fromVal v = do
1167        vt  <- evalValType v
1168        case showType vt of
1169            "Pair" -> do
1170                -- Special case for pairs: "$pair" eq
1171                -- "$pair.key()\t$pair.value()"
1172                (k, v)  <- join $ doPair v pair_fetch
1173                k'      <- fromVal k
1174                v'      <- fromVal v
1175                return $ k' ++ "\t" ++ v'
1176            "Hash" -> do
1177                --- XXX special case for Hash -- need to Objectify
1178                hv      <- join $ doHash v hash_fetch
1179                lns     <- forM (Map.assocs hv) $ \(k, v) -> do
1180                    str <- fromVal v
1181                    return $ k ++ "\t" ++ str
1182                return $ unlines lns
1183            _ -> fromVal' v
1184    doCast VUndef        = return ""
1185    doCast VType{}       = return ""
1186    doCast (VStr s)      = return s
1187    doCast (VBool b)     = return $ if b then "1" else ""
1188    doCast (VInt i)      = return $ show i
1189    doCast (VRat r)      = return $ showRat r
1190    doCast (VNum n)      = return $ showNum n
1191    doCast (VComplex (r :+ i)) = return $ showNum r ++ " + " ++ showNum i ++ "i"
1192    doCast (VList l)     = fmap unwords (mapM fromVal l)
1193    doCast (VCode s)     = return $ "<" ++ show (subType s) ++ "(" ++ cast (subName s) ++ ")>"
1194    doCast (VJunc j)     = return $ show j
1195    doCast (VThread t)   = return $ takeWhile isDigit $ dropWhile (not . isDigit) $ show t
1196    doCast (VHandle h)   = return $ "<" ++ "VHandle (" ++ (show h) ++ ">"
1197    doCast (VMatch m)    = return $ matchStr m
1198 -- doCast (VType typ)   = return $ showType typ -- "::" ++ showType typ
1199    doCast (VObject o)   = return $ "<obj:" ++ showType (objType o) ++ ">"
1200    doCast x             = return $ "<" ++ showType (valType x) ++ ">"
1201
1202
1203instance Value [PerlSV] where
1204    fromVal = fromVals
1205    doCast v = castFailM v "[PerlSV]"
1206
1207instance Value PerlSV where
1208    fromVal val = io $ newSVval val
1209    doCast v = castFailM v "PerlSV"
1210
1211instance Value VList where
1212    castV = VList
1213    fromSV sv = return [PerlSV sv]
1214    fromVV = cast . fmap (map VV . cast) . Val.listVal
1215    fromVal (VRef r) = do
1216        v <- readRef r
1217        case v of
1218            (VList vs) -> return vs
1219            _          -> return [v]
1220    fromVal (VList vs) = return vs
1221    fromVal v = fromVal' v
1222    doCast (VList l)     = return $ l
1223    doCast (VUndef)      = return $ [VUndef]
1224    doCast v             = return $ [v]
1225
1226instance Value VHandle where
1227    castV = VHandle
1228    doCast (VHandle x)  = return $ x
1229    doCast v = castFailM v "VHandle"
1230
1231instance Value VSocket where
1232    castV = VSocket
1233    doCast (VSocket x)  = return $ x
1234    doCast v = castFailM v "VSocket"
1235
1236instance Value VThread where
1237    castV = VThread
1238    doCast (VThread x)  = return $ x
1239    doCast v = castFailM v "VThread"
1240
1241instance Value VProcess where
1242    castV = VProcess
1243    doCast (VProcess x)  = return $ x
1244    doCast v = castFailM v "VProcess"
1245
1246instance Value Int where
1247    fromSV sv = io $ svToVInt sv
1248    doCast x = intCast x
1249    castV = VInt . fromIntegral
1250instance Value Word  where
1251    fromVal x = intCast x
1252    doCast v = castFailM v "Word"
1253instance Value Word8 where
1254    fromVal x = intCast x
1255    doCast v = castFailM v "Word8"
1256instance Value [Word8] where
1257    fromVal val = fmap (map (toEnum . ord)) (fromVal val)
1258    doCast v = castFailM v "[Word8]"
1259
1260instance Value VScalar where
1261    fromSV = return . PerlSV
1262    fromVV = cast . fmap VV . Val.itemVal
1263    fromVal (VRef r) = fromVal =<< readRef r
1264    fromVal v = return v
1265    doCast v = return v
1266    castV = id -- XXX not really correct; need to referencify things
1267
1268instance Value Exp where
1269    {- Val -> Eval Exp -}
1270    fromVal val = do
1271        obj <- fromVal val
1272        return $ fromObject obj
1273    {- Exp -> Val -}
1274    {- castV exp = VObject (createObject (mkType "Code::Exp") [("theexp", exp)]) -}
1275    doCast v = castFailM v "Exp"
1276
1277instance Value VOpaque where
1278    fromVal (VOpaque o) = return o
1279    fromVal v = return $ MkOpaque v
1280    castV (MkOpaque x) = castV x
1281    doCast v = castFailM v "VOpaque"