diff --git a/Pugs.cabal b/Pugs.cabal
--- a/Pugs.cabal
+++ b/Pugs.cabal
@@ -1,5 +1,5 @@
Name : Pugs
-Version : 6.2.13.6
+Version : 6.2.13.7
license : BSD3
license-file : LICENSE
cabal-version : >= 1.2
@@ -22,6 +22,7 @@
src/Pugs/AST.hs
src/Pugs/AST.hs-boot
src/Pugs/AST/Eval.hs
+ src/Pugs/AST/Functions.hs
src/Pugs/AST/Internals.hs
src/Pugs/AST/Internals.hs-boot
src/Pugs/AST/Internals/Instances.hs
@@ -31,6 +32,7 @@
src/Pugs/AST/SIO.hs
src/Pugs/AST/Scope.hs
src/Pugs/AST/Utils.hs
+ src/Pugs/AST/Types.hs
src/Pugs/Bind.hs
src/Pugs/Class.hs
src/Pugs/CodeGen.hs
@@ -149,8 +151,8 @@
if flag(Optimize)
ghc-options: -O2
--- if flag(Debug)
--- ghc-options: -prof -auto-all
+ -- if flag(Debug)
+ -- ghc-options: -prof -auto-all
c-sources:
cbits/Prelude_pm.c cbits/Test_pm.c
diff --git a/src/Pugs/AST/Functions.hs b/src/Pugs/AST/Functions.hs
new file mode 100644
--- /dev/null
+++ b/src/Pugs/AST/Functions.hs
@@ -0,0 +1,236 @@
+{-# OPTIONS_GHC -fglasgow-exts -fno-warn-orphans -fallow-overlapping-instances -fallow-undecidable-instances -fparr #-}
+module Pugs.AST.Functions where
+import Pugs.Internals
+import Pugs.Types
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+
+import Pugs.AST.Eval
+import Pugs.AST.Utils
+import Pugs.AST.SIO
+import qualified Pugs.Val as Val
+import {-# SOURCE #-} Pugs.AST.Internals
+import Pugs.AST.Types
+
+
+emptyTraitBlocks :: TraitBlocks
+emptyTraitBlocks = MkTraitBlocks [] [] [] [] [] [] [] [] [] [] []
+
+isSlurpy :: Param -> Bool
+isSlurpy param = isSlurpyCxt $ paramContext param
+
+{-|
+An empty Pad with no symbols.
+-}
+
+emptyPad :: Pad
+emptyPad = MkPad Map.empty
+
+{-# 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)
+
+retShift :: Val -> Eval a
+-- retShift = shiftT . const . return
+retShift = EvalT . return . RException
+
+catchT :: ((Val -> Eval b) -> Eval Val) -> Eval Val
+catchT action = tryT (action retShift)
+
+retConstError :: Val -> Eval b
+retConstError val = die "Can't modify constant item" val
+
+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 ;-)
+ }
+
+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
+ }
+
+instance ((:>:) String) Params where
+ cast = show . paramsToSig
+
+
+{-|
+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
+ }
+
+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
+ }
+
+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
+ }
+
+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
+
+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
+
+mkCompUnit :: String -> Pad -> Exp -> CompUnit
+mkCompUnit = MkCompUnit compUnitVersion
+
+{-# NOINLINE compUnitVersion #-}
+compUnitVersion :: Int
+compUnitVersion = 18
+
+newDebugInfo :: IO DebugInfo
+newDebugInfo = fmap Just (io $ newTVarIO Map.empty)
+
+
+-- | 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
+
+
+{-
+ 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.
+-}
+
+listToPad :: [(Var, PadEntry)] -> Pad
+listToPad entries = MkPad (Map.fromList entries)
+
+-- | 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
+lookupPad key (MkPad pad) = Map.lookup key 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
+
+findSymRef :: Var -> Pad -> Eval VRef
+findSymRef name pad = stm $ join (findSym name pad)
+
diff --git a/src/Pugs/AST/Internals.hs b/src/Pugs/AST/Internals.hs
--- a/src/Pugs/AST/Internals.hs
+++ b/src/Pugs/AST/Internals.hs
@@ -78,2212 +78,1263 @@
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
-
-{- 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
- -}
-
-#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
- 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 ""
- , 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 $ ""
- 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 _ = ""
-
-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] scook0: .assuming will impose multiple limits
->[12:02] because you can assume (curry) multiple times
->[12:02] ah
->[12:02] I'll have to write that in the docs then
->[12:03] Am I correct in that they only apply to subs that take a finite number of slurpy scalars?
->[12:04] Slurpy array params seem to nuke the SlurpLimit
->[12:04] because slurpy arrays can take any number of args
->[12:07] 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 _ = ""
-instance Eq VThunk
-instance Ord VThunk where
- compare _ _ = EQ
-
-instance Show VProcess where
- show _ = ""
-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
-
-{- -- 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 (__"") 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 '[')"
-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"
-
-] 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!-}
-
--}
-
-------------------------------------------------------------------------
+ unwrap,
+ 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.Types
+import Pugs.AST.Functions
+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
+
+-- CPP Includes
+
+#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"
+
+-- Data Definitions
+
+{-|
+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)
+
+{-|
+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 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
+
+data VOpaque where
+ MkOpaque :: Value a => !a -> VOpaque
+
+-- GADTs, here we come!
+data VRef where
+ MkRef :: (Typeable a) => !(IVar a) -> VRef
+
+data VObject = MkObject
+ { objType :: !VType
+ , objAttrs :: !IHash
+ , objOpaque :: !(Maybe Dynamic)
+ , objId :: !ObjectId
+ }
+ deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}
+
+-- | 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!-}
+
+newtype ObjectId = MkObjectId { unObjectId :: Int }
+ deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}
+
+-- Type Synonyms
+
+type VType = Type
+type VArray = [Val]
+type VHash = Map VStr Val
+type VList = [Val]
+
+-- Functions
+
+{-|
+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)
+
+retShiftEmpty :: Eval a
+retShiftEmpty = retShift =<< retEmpty
+
+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)
+
+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
+ }
+
+
+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)
+
+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)
+
+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 -> 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
+
+
+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 }
+
+{-|
+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
+
+_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))
+
+-- 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
+
+{- 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 }
+
+fromVals :: (Value n) => Val -> Eval [n]
+fromVals v = mapM fromVal =<< fromVal v
+
+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)
+
+envPos' :: Env -> Pos
+envPos' = envPos
+
+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 ++ ")"
+
+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')
+
+{-|
+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
+
+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)
+
+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
+
+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
+
+------------------------------------------------------------------------
+anyFromVal :: forall a. Typeable a => Val -> a
+anyFromVal v = case fromTypeable (fromVal v :: Eval PerlSV) of
+ Just f -> f :: a
+ _ -> error "anyFromVal failed!"
+
+intCast :: Num b => Val -> Eval b
+intCast x = fmap fromIntegral (fromVal x :: Eval VInt)
+
+
+showVal :: Val -> String
+showVal = show
+
+defaultArrayParam :: Param
+defaultHashParam :: Param
+defaultScalarParam :: Param
+
+defaultArrayParam = buildParam "" "*" "@_" (Val VUndef)
+defaultHashParam = buildParam "" "*" "%_" (Val VUndef)
+defaultScalarParam = buildParam "" "?" "$_" (Var $ cast "$OUTER::_")
+
+
+-- Class: Value
+
+{-|
+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"
+
+
+-- Instances: Value
+
+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
+ 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 ""
+ , 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"
+
+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 $ ""
+ 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"
+
+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]"
+
+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
+
+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"
+
+instance Value VOpaque where
+ fromVal (VOpaque o) = return o
+ fromVal v = return $ MkOpaque v
+ castV (MkOpaque x) = castV x
+ doCast v = castFailM v "VOpaque"
+
+-- Instances: Others
+
+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
+
+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 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
+
+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 VRef where
+ typeOf (MkRef x) = typeOf x
+
+instance Eq VRef where
+ x == y = addressOf x == addressOf y
+instance Ord VRef where
+ compare x y = compare (addressOf x) (addressOf y)
+
+instance Typeable a => Show (IVar a) where
+ show ivar = show (MkRef ivar)
diff --git a/src/Pugs/AST/Internals.hs-boot b/src/Pugs/AST/Internals.hs-boot
--- a/src/Pugs/AST/Internals.hs-boot
+++ b/src/Pugs/AST/Internals.hs-boot
@@ -12,11 +12,9 @@
data Env
data Val
-data VRef
data VObject
-data PadEntry
data Exp
--- newtype Pad = MkPad { padEntries :: Map Var PadEntry }
+data VRef
newtype ObjectId = MkObjectId { unObjectId :: Int }
type VType = Type
@@ -40,3 +38,30 @@
createObjectRaw :: (MonadSTM m)
=> ObjectId -> Maybe Dynamic -> VType -> [(VStr, Val)] -> m VObject
+
+data IVar v
+data VOpaque
+
+instance Show VOpaque
+instance Eq VOpaque
+instance Ord VOpaque
+
+instance Show Val
+instance Eq Val
+instance Ord Val
+
+instance Show Env
+instance Eq Env
+instance Ord Env
+
+instance Show Exp
+instance Eq Exp
+instance Ord Exp
+
+instance Show VRef
+instance Eq VRef
+instance Ord VRef
+
+emptyExp :: Exp
+
+instance Show VObject
diff --git a/src/Pugs/AST/Types.hs b/src/Pugs/AST/Types.hs
new file mode 100644
--- /dev/null
+++ b/src/Pugs/AST/Types.hs
@@ -0,0 +1,457 @@
+{-# OPTIONS_GHC -fglasgow-exts -fno-warn-orphans -fallow-overlapping-instances -fallow-undecidable-instances -fparr #-}
+module Pugs.AST.Types 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 Pugs.AST.Eval
+import Pugs.AST.Utils
+import Pugs.AST.Prag
+import Pugs.AST.Pos
+import Pugs.AST.Scope
+import Pugs.AST.SIO
+import {-# SOURCE #-} Pugs.AST.Internals (IVar, VRef, Val, Env, Exp)
+
+
+-- | Uses Haskell's underlying representation for threads.
+data VThread = MkThread
+ { threadId :: ThreadId
+ , threadLock :: TMVar Val
+ }
+ deriving (Show, Eq, Ord, Typeable)
+
+data VSubst
+ = MkSubst
+ { substRegex :: !VRule
+ , substExp :: !Exp
+ }
+ | MkTrans
+ { transFrom :: !VStr
+ , transTo :: !VStr
+ }
+ deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}
+
+data VThunk = MkThunk
+ { thunkExp :: Eval Val
+ , thunkType :: Type
+ }
+ deriving (Typeable) {-!derive: YAML_Pos!-}
+
+newtype VProcess = MkProcess (ProcessHandle)
+ deriving (Typeable) {-!derive: YAML_Pos!-}
+
+type VPair = (Val, Val)
+
+{-|
+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!-}
+
+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!-}
+
+{-|
+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]
+
+{-|
+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] scook0: .assuming will impose multiple limits
+>[12:02] because you can assume (curry) multiple times
+>[12:02] ah
+>[12:02] I'll have to write that in the docs then
+>[12:03] Am I correct in that they only apply to subs that take a finite number of slurpy scalars?
+>[12:04] Slurpy array params seem to nuke the SlurpLimit
+>[12:04] because slurpy arrays can take any number of args
+>[12:07] 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 !-}
+
+data MPad = MkMPad { mp_id :: !Word, mp_pad :: !(TVar Pad) }
+ deriving (Show, Typeable, Data) {-!derive: YAML_Pos, JSON, Perl5 !-}
+
+-- | 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!-}
+
+{- 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.
+-}
+
+type DebugInfo = Maybe (TVar (Map ID String))
+
+type LexPads = [LexPad]
+data LexPad
+ = PRuntime { pr_pad :: !Pad }
+ | PCompiling { pc_pad :: !MPad }
+ deriving (Show, Eq, Ord, Typeable)
+
+data Frame
+ = FrameLoop
+ | FrameWhen
+ | FrameGather
+ | FrameRoutine
+ deriving (Show, Eq, Ord, Typeable) -- don't derive YAML for now
+
+data IHashEnv = MkHashEnv deriving (Show, Typeable) {-!derive: YAML_Pos!-}
+data IScalarCwd = MkScalarCwd deriving (Show, 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 :: ![Val] -- positional submatches
+ , matchSubNamed :: !(Map VStr Val) -- named submatches
+ }
+ deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}
+
+-- | 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
+ { cu_ver :: !Int -- a version number, see compUnitVersion
+ , cu_desc :: !String -- e.g., the name of the contained module
+ , cu_pad :: !Pad -- pad for unit Env
+ , cu_ast :: !Exp -- AST of unit
+ } deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos !-}
+
+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?
+
+type VScalar = Val
+
+{-|
+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!-}
+
+{- 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)
+
+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)
+
+instance Show Regex where
+ show _ = ""
+
+instance Ord Regex where
+ compare x y = compare (addressOf x) (addressOf y)
+
+instance Eq Regex where
+ x == y = addressOf x == addressOf y
+
+-- Haddock doesn't seem to like data/instance declarations with a where clause.
+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 (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)
+
+instance Monoid SubAssoc where
+ mempty = ANil
+ mappend ANil y = y
+ mappend x _ = x
+
+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
+
+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"
+
+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) ++ ")"
+
+instance Show VThunk where
+ show _ = ""
+instance Eq VThunk
+instance Ord VThunk where
+ compare _ _ = EQ
+
+instance Show VProcess where
+ show _ = ""
+instance Eq VProcess
+instance Ord VProcess where
+ compare _ _ = EQ
+
+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']
+
+{-|
+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
+
+instance Show Pad where
+ show pad = "MkPad (padToList " ++ show (padToList pad) ++ ")"
+
+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!-}
diff --git a/src/Pugs/AST/Utils.hs b/src/Pugs/AST/Utils.hs
--- a/src/Pugs/AST/Utils.hs
+++ b/src/Pugs/AST/Utils.hs
@@ -4,7 +4,6 @@
import Pugs.Internals
import Pugs.Types
import qualified Data.Set as Set
-import qualified Data.IntMap as IntMap
import Pugs.AST.SIO
import Pugs.AST.Eval
diff --git a/src/Pugs/Version.hs b/src/Pugs/Version.hs
--- a/src/Pugs/Version.hs
+++ b/src/Pugs/Version.hs
@@ -14,10 +14,10 @@
-- #include "pugs_version.h"
#ifndef PUGS_VERSION
-#define PUGS_VERSION "6.2.13.6"
+#define PUGS_VERSION "6.2.13.7"
#endif
#ifndef PUGS_DATE
-#define PUGS_DATE "June 29, 2008"
+#define PUGS_DATE "June 30, 2008"
#endif
#ifndef PUGS_SVN_REVISION
#define PUGS_SVN_REVISION 0