Pugs 6.2.13.6 → 6.2.13.7
raw patch · 7 files changed
+1988/−2218 lines, 7 files
Files
- Pugs.cabal +5/−3
- src/Pugs/AST/Functions.hs +236/−0
- src/Pugs/AST/Internals.hs +1260/−2209
- src/Pugs/AST/Internals.hs-boot +28/−3
- src/Pugs/AST/Types.hs +457/−0
- src/Pugs/AST/Utils.hs +0/−1
- src/Pugs/Version.hs +2/−2
Pugs.cabal view
@@ -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
+ src/Pugs/AST/Functions.hs view
@@ -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)+
src/Pugs/AST/Internals.hs view
@@ -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--{- <DrIFT> Imports for the DrIFT-import Pugs.AST.Scope-import Pugs.AST.Pos-import Pugs.AST.Prag-import Pugs.AST.SIO-import Pugs.Types-import Pugs.Internals-import Pugs.Embed.Perl5-import qualified Data.Set as Set-import qualified Data.Map as Map-import qualified Pugs.Val as Val--import qualified Data.HashTable as H- </DrIFT> -}- -#include "../Types/Array.hs"-#include "../Types/Handle.hs"-#include "../Types/Hash.hs"-#include "../Types/Scalar.hs"-#include "../Types/Code.hs"-#include "../Types/Thunk.hs"-#include "../Types/Rule.hs"-#include "../Types/Pair.hs"-#include "../Types/Object.hs"---catchT :: ((Val -> Eval b) -> Eval Val) -> Eval Val-catchT action = tryT (action retShift)--{-|-Return the appropriate 'empty' value for the current context -- either-an empty list ('VList' []), or undef ('VUndef').--}-retEmpty :: Eval Val-retEmpty = do- ifListContext- (return $ VList [])- (return VUndef)--evalValType :: Val -> Eval Type-evalValType (VRef (MkRef (IScalar sv))) = scalar_type sv-evalValType (VRef r) = return $ refType r-evalValType (VType t) = return t-evalValType val = return $ valType val--{-|-Check whether a 'Val' is of the specified type. Based on the result,-either the first or the second evaluation should be performed.--}-ifValTypeIsa :: Val -- ^ Value to check the type of- -> String -- ^ Name of the type to check against- -> (Eval a) -- ^ The @then@ case- -> (Eval a) -- ^ The @else@ case- -> Eval a-ifValTypeIsa v (':':typ) trueM falseM = ifValTypeIsa v typ trueM falseM-ifValTypeIsa v typ trueM falseM = do- vt <- evalValType v- if isaType typ vt- then trueM- else falseM--{-|-Collapse a junction value into a single boolean value.--Works by recursively casting the junction members to booleans, then performing-the actual junction test.--}-juncToBool :: VJunc -> Eval Bool-juncToBool (MkJunc JAny _ vs) = do- bools <- mapM valToBool (Set.elems vs)- return . isJust $ find id bools-juncToBool (MkJunc JAll _ vs) = do- bools <- mapM valToBool (Set.elems vs)- return . isNothing $ find not bools-juncToBool (MkJunc JNone _ vs) = do- bools <- mapM valToBool (Set.elems vs)- return . isNothing $ find id bools-juncToBool (MkJunc JOne ds vs) = do- bools <- mapM valToBool (Set.elems ds)- if isJust (find id bools) then return False else do- bools <- mapM valToBool (Set.elems vs)- return $ 1 == (length $ filter id bools)--instance Show JuncType where- show JAny = "any"- show JAll = "all"- show JNone = "none"- show JOne = "one"--instance Show VJunc where- show (MkJunc jtype _ set) =- (show jtype) ++ "(" ++- (foldl (\x y ->- if x == "" then show y- else x ++ "," ++ show y)- "" $ Set.elems set) ++ ")"--{-|-Typeclass indicating types that can be converted to\/from 'Val's.--Not to be confused with 'Val' itself, or the 'Exp' constructor @Val@.--}-class (Typeable n, Show n, Ord n) => Value n where- fromVal :: Val -> Eval n- fromVal = fromVal'- doCast :: Val -> Eval n-{- doCast v = castFailM v "default implementation of doCast" -}- fromVV :: Val.Val -> Eval n- fromVV v = do- str <- Val.asStr v- fail $ "Cannot cast from VV (" ++ cast str ++ ") to " ++ errType (undefined :: n)- fromSV :: PerlSV -> Eval n- fromSV sv = do- str <- io $ svToVStr sv- fail $ "Cannot cast from SV (" ++ str ++ ") to " ++ errType (undefined :: n)- castV :: n -> Val- castV x = VOpaque (MkOpaque x) -- error $ "Cannot cast into Val"--#ifndef HADDOCK-data VOpaque where- MkOpaque :: Value a => !a -> VOpaque-#endif--fromVal' :: (Value a) => Val -> Eval a-fromVal' (VRef r) = do- v <- readRef r- fromVal v-fromVal' (VList vs) | any isRef vs = do- vs <- forM vs $ \v -> case v of { VRef r -> readRef r; _ -> return v }- fromVal $ VList vs- where- isRef VRef{} = True- isRef _ = False-fromVal' (PerlSV sv) = do- v <- io $ svToVal sv- case v of- PerlSV sv' -> fromSV sv' -- it was a SV- VV vv- | Just sv <- Val.castVal vv -> fromSV sv- | Just v <- Val.castVal vv -> fromVal v- val -> fromVal val -- it was a Val-fromVal' (VV vv) = do- v' <- vvToVal vv- case v' of- VV vv'' -> fromVV vv''- PerlSV sv -> fromSV sv- _ -> fromVal v'-fromVal' v = doCast v---- XXX - This is makeshift until all our native types are in VV.-vvToVal :: Val.Val -> Eval Val-vvToVal x- | Just sv <- Val.castVal x = do- rv <- io (svToVal sv)- case rv of- VV vv- | Just sv <- Val.castVal vv -> return (PerlSV sv)- | Just v <- Val.castVal vv -> return v- _ -> return rv- | Just v <- Val.castVal x = return v- | Just x' <- Val.castVal x = return . VStr $ (cast :: Val.PureStr -> String) x'- | Just x' <- Val.castVal x = return . VInt $ (cast :: Val.PureInt -> Integer) x'- | Just x' <- Val.castVal x = return . VNum $ (cast :: Val.PureNum -> Double) x'- | Just x' <- Val.castVal x = return (VStr x')- | Just x' <- Val.castVal x = return (VInt x')- | Just x' <- Val.castVal x = return (VNum x')- | Just x' <- Val.castVal x = return (VBool x')- | Just () <- Val.castVal x = return VUndef- | otherwise = return (VV x)--getArrayIndex :: Int -> Maybe (IVar VScalar) -> Eval IArray -> Maybe (Eval b) -> Eval (IVar VScalar)-getArrayIndex idx def getArr _ | idx < 0 = do- -- first, check if the list is at least abs(idx) long- MkIArray iv <- getArr- a <- stm $ readTVar iv- let size = a_size a- if size > abs (idx+1)- then return (a !: (idx `mod` size))- else errIndex def idx--- now we are all positive; either extend or return-getArrayIndex idx def getArr ext = do- MkIArray iv <- getArr- a <- stm $ readTVar iv- let size = a_size a- if size > idx- then return (a !: idx)- else case ext of- Just doExt -> do { doExt; getArrayIndex idx def getArr Nothing }- Nothing -> errIndex def idx--createObjectRaw :: (MonadSTM m)- => ObjectId -> Maybe Dynamic -> VType -> [(VStr, Val)] -> m VObject-createObjectRaw uniq opaq typ attrList = do- attrs <- stm . unsafeIOToSTM . H.fromList H.hashString $ map (\(a,b) -> (a, lazyScalar b)) attrList- return $ MkObject- { objType = typ- , objId = uniq- , objAttrs = attrs- , objOpaque = opaq- }--instance Value (IVar VScalar) where- fromVal (VRef (MkRef v@(IScalar _))) = return v- fromVal (VRef r) = fromVal =<< readRef r- fromVal v = return $ constScalar v- doCast v = castFailM v "IVar VScalar"--instance Value VType where- fromVal (VType t) = return t- fromVal v@(VObject obj) | objType obj == (mkType "Class") = do- meta <- readRef =<< fromVal v- fetch <- doHash meta hash_fetchVal- str <- fromVal =<< fetch "name"- return $ mkType str- fromVal v = evalValType v- doCast v = castFailM v "VType"--instance Value VMatch where- fromVal (VRef r) = fromVal =<< readRef r- fromVal (VMatch m) = return m- fromVal (VList (x:_)) = fromVal x- fromVal _ = return $ mkMatchFail- doCast v = castFailM v "VMatch"--instance Value VRef where- fromVal (VRef r) = return $ r- fromVal (VList vs) = return $ arrayRef vs- fromVal (VCode c) = return $ codeRef c- fromVal v = return $ scalarRef v- castV = VRef- doCast v = castFailM v "VRef"--instance Value [Int] where- fromVal v = do- vlist <- fromVal v- mapM fromVal vlist- doCast v = castFailM v "[Int]"--instance Value [VStr] where- castV = VList . map VStr- fromVal v = do- vlist <- fromVal v- mapM fromVal vlist- doCast v = castFailM v "[VStr]"--instance Value VPair where- castV pv = VRef $ pairRef pv- fromVal VUndef = return (VUndef, VUndef)- fromVal v = join $ doPair v pair_fetch- doCast v = castFailM v "VPair"--instance Value [(VStr, Val)] where- fromVal v = do- list <- fromVal v- forM list $ \(k, v) -> do- str <- fromVal k- return (str, v)- doCast v = castFailM v "[(VStr, Val)]"--instance Value VObject where- fromVal (VObject o) = return o- fromVal v@(VRef _) = fromVal' v- fromVal v = do- fail $ "Cannot cast from " ++ show v ++ " to Object"- doCast v = castFailM v "VObject"--instance Value VHash where- fromVal (VObject o) = do- l <- io $ H.toList (objAttrs o)- fmap Map.fromList . forM l $ \(k, ivar) -> do- v <- readIVar ivar- return (k, v)- fromVal VType{} = return Map.empty -- ::Hash<foo>- fromVal (VRef r) = fromVal =<< readRef r- fromVal v = do- list <- fromVal v- fmap Map.fromList $ forM list $ \(k, v) -> do- str <- fromVal k- return (str, v)- doCast v = castFailM v "VHash"--instance Value [VPair] where- fromVal VUndef = return []- fromVal v = do- list <- fromVals v- doFrom $ concat list- where- doFrom :: [Val] -> Eval [VPair]- doFrom [] = return []- doFrom [_] = fail $ "Odd number of elements found where hash expected: " ++ show v- doFrom (k:v:list) = do- rest <- doFrom list- return ((k, v):rest)- doCast v = castFailM v "Hash"--instance Value VCode where- castV = VCode- fromSV sv = return $ mkPrim- { subName = cast "<anon>"- , subParams = [defaultArrayParam]- , subReturns = mkType "Scalar::Perl5"- , subBody = Prim $ \(args:_) -> do- svs <- fromVals args- runInvokePerl5 sv nullSV svs- }- doCast (VCode b) = return b- doCast (VType t) = return $ mkPrim- { subName = cast t- , subParams = [buildParam "Any" "*" "@?0" (Val VUndef), buildParam "Any" "*" "%?0" (Val VUndef)]- , subReturns = mkType "Scalar::Perl5"- , subBody = Prim $ \(p:n:_) -> do- evl <- asks envEval- evl (App (_Var "&new") (Just $ Val (VType t)) [Syn "|" [Val p], Syn "|" [Val n]])- }- doCast (VList [VCode b]) = return b -- XXX Wrong- doCast v = castFailM v "VCode"--runInvokePerl5 :: PerlSV -> PerlSV -> [PerlSV] -> Eval Val-runInvokePerl5 sub inv args = do - env <- ask- rv <- io $ do- envSV <- mkEnv env- invokePerl5 sub inv args envSV (enumCxt $ envContext env)- case rv of- Perl5ReturnValues [x] -> io $ svToVal x- Perl5ReturnValues xs -> io $ fmap VList (mapM svToVal xs)- Perl5ErrorString str -> fail str- Perl5ErrorObject err -> throwError (PerlSV err)--anyFromVal :: forall a. Typeable a => Val -> a-anyFromVal v = case fromTypeable (fromVal v :: Eval PerlSV) of- Just f -> f :: a- _ -> error "anyFromVal failed!"--anyToVal :: (Show a, Typeable a) => a -> Val-anyToVal x- | Just v <- fromTypeable x = v- | Just v <- fromTypeable x = PerlSV v- | Just v <- fromTypeable x = VStr v- | Just v <- fromTypeable x = VInt v- | Just v <- fromTypeable x = VNum v- | Just () <- fromTypeable x = VUndef- | otherwise = error (show x)--instance Value VBool where- castV = VBool- fromSV sv = io $ svToVBool sv- fromVV vv = fmap cast (Val.asBit vv)- doCast (VJunc j) = juncToBool j- doCast (VMatch m) = return $ matchOk m- doCast (VBool b) = return $ b- doCast VUndef = return $ False- doCast VType{} = return $ False- doCast (VStr "") = return $ False- doCast (VStr "0") = return $ False- doCast (VInt 0) = return $ False- doCast (VRat 0) = return $ False- doCast (VNum 0) = return $ False- doCast (VList []) = return $ False- doCast _ = return $ True---instance Value VInt where- castV = VInt- fromVV vv = fmap cast (Val.asInt vv)- fromSV sv = io $ svToVInt sv- doCast (VInt i) = return $ i- doCast x = fmap truncate (fromVal x :: Eval VRat)--instance Value VRat where- castV = VRat- fromSV sv = io $ svToVNum sv- doCast (VInt i) = return $ i % 1- doCast (VRat r) = return $ r- doCast (VBool b) = return $ if b then 1 % 1 else 0 % 1- doCast (VList l) = return $ genericLength l- doCast (VStr s) | not (null s) , isSpace $ last s = do- str <- fromVal (VStr $ init s)- return str- doCast (VStr s) | not (null s) , isSpace $ head s = do - str <- fromVal (VStr $ tail s)- return str- doCast (VStr s) = return $- case ( parseNatOrRat s ) of- Left _ -> 0 % 1- Right rv -> case rv of- Left i -> i % 1- Right d -> d- doCast x = fmap toRational (fromVal x :: Eval VNum)--instance Value VNum where- castV = VNum- fromVV vv = fmap cast (Val.asNum vv)- fromSV sv = io $ svToVNum sv- doCast VUndef = return $ 0- doCast VType{} = return $ 0- doCast (VBool b) = return $ if b then 1 else 0- doCast (VInt i) = return $ fromIntegral i- doCast (VRat r) = return $ realToFrac r- doCast (VNum n) = return $ n- doCast (VComplex (r :+ _)) = return $ r- doCast (VStr s) | not (null s) , isSpace $ last s = do- str <- fromVal (VStr $ init s)- return str- doCast (VStr s) | not (null s) , isSpace $ head s = do- str <- fromVal (VStr $ tail s)- return str- doCast (VStr "Inf") = return $ 1/0- doCast (VStr "-Inf") = return $ -1/0- doCast (VStr "NaN") = return $ 0/0- doCast (VStr s) = return $- case ( parseNatOrRat s ) of- Left _ -> 0- Right rv -> case rv of- Left i -> fromIntegral i- Right d -> realToFrac d- doCast (VList l) = return $ genericLength l- doCast t@VThread{} = fmap read (fromVal t)- doCast (VMatch m) = fromVal (VStr $ matchStr m)- doCast v = castFailM v "VNum"--instance Value Ordering where- castV x = VInt $ case x of- LT -> -1- EQ -> 0- GT -> 1- doCast x = do- n <- fromVal x :: Eval VInt- return $ case signum n of- -1 -> LT- 0 -> EQ- 1 -> GT- _ -> error "signum: impossible"--instance Value VComplex where- castV = VComplex- doCast (VComplex x) = return x- doCast x = fmap (:+ 0) (fromVal x :: Eval VNum)--instance Value ID where- castV = VStr . cast- fromSV sv = fmap cast (io $ svToVStr sv)- fromVV vv = fmap cast (Val.asStr vv)- fromVal = fmap (cast :: VStr -> ID) . fromVal- doCast = fmap (cast :: VStr -> ID) . doCast--instance Value VStr where- castV = VStr- fromSV sv = io $ svToVStr sv- fromVV vv = fmap cast (Val.asStr vv)- fromVal (VList l) = return . unwords =<< mapM fromVal l- fromVal v@(PerlSV _) = fromVal' v- fromVal VUndef = return ""- fromVal (VType t) = return (showType t)- fromVal v = do- vt <- evalValType v- case showType vt of- "Pair" -> do- -- Special case for pairs: "$pair" eq- -- "$pair.key()\t$pair.value()"- (k, v) <- join $ doPair v pair_fetch- k' <- fromVal k- v' <- fromVal v- return $ k' ++ "\t" ++ v'- "Hash" -> do- --- XXX special case for Hash -- need to Objectify- hv <- join $ doHash v hash_fetch- lns <- forM (Map.assocs hv) $ \(k, v) -> do- str <- fromVal v- return $ k ++ "\t" ++ str- return $ unlines lns- _ -> fromVal' v- doCast VUndef = return ""- doCast VType{} = return ""- doCast (VStr s) = return s- doCast (VBool b) = return $ if b then "1" else ""- doCast (VInt i) = return $ show i- doCast (VRat r) = return $ showRat r- doCast (VNum n) = return $ showNum n- doCast (VComplex (r :+ i)) = return $ showNum r ++ " + " ++ showNum i ++ "i"- doCast (VList l) = fmap unwords (mapM fromVal l)- doCast (VCode s) = return $ "<" ++ show (subType s) ++ "(" ++ cast (subName s) ++ ")>"- doCast (VJunc j) = return $ show j- doCast (VThread t) = return $ takeWhile isDigit $ dropWhile (not . isDigit) $ show t- doCast (VHandle h) = return $ "<" ++ "VHandle (" ++ (show h) ++ ">"- doCast (VMatch m) = return $ matchStr m- -- doCast (VType typ) = return $ showType typ -- "::" ++ showType typ- doCast (VObject o) = return $ "<obj:" ++ showType (objType o) ++ ">"- doCast x = return $ "<" ++ showType (valType x) ++ ">"---instance Value [PerlSV] where- fromVal = fromVals- doCast v = castFailM v "[PerlSV]"--instance Value PerlSV where- fromVal val = io $ newSVval val- doCast v = castFailM v "PerlSV"--newSVval :: Val -> IO PerlSV-newSVval val = case val of- PerlSV sv -> return sv- VStr str -> vstrToSV str- VType typ -> vstrToSV (showType typ)- VBool bool -> vintToSV (fromEnum bool)- VInt int -> vintToSV int- VRat rat -> vnumToSV rat- VNum num -> vnumToSV num-{-- VRef ref@(MkRef (IArray a)) -> case fromTypeable a of- Just (MkIArray iv@(I.IntMap fp) _) -> do- sv <- vrefToSV ref- sptr <- newStablePtr fp- warn "Fin: SPTR" fp- let fin = do- warn "Fin: FPTR" (sptr == sptr)- touchForeignPtr fp- modifyIORef _GlobalFinalizer (>> fin)- addFinalizer sv fin- return sv- _ -> vrefToSV ref--}- VRef ref -> vrefToSV ref- VCode{} -> mkValRef val "Code"- VBlock{} -> mkValRef val "Code"- VHandle{} -> mkValRef val "Handle"- VSocket{} -> mkValRef val "Socket"- VList{} -> mkValRef val "Array"- VUndef -> svUndef- VError{} -> svUndef- _ -> mkValRef val ""--vrefToSV :: VRef -> IO PerlSV-vrefToSV ref = mkValRef (VRef ref) $ case ref of- MkRef IScalar{} -> "Scalar"- MkRef IArray{} -> "Array"- MkRef IHash{} -> "Hash"- MkRef ICode{} -> "Code"- MkRef IHandle{} -> "Handle"- MkRef IRule{} -> "Rule"- MkRef IThunk{} -> "Thunk"- MkRef IPair{} -> "Pair"- MkRef (IVal v) -> show (valType v)--valToStr :: Val -> Eval VStr-valToStr = fromVal--instance Value VList where- castV = VList- fromSV sv = return [PerlSV sv]- fromVV = cast . fmap (map VV . cast) . Val.listVal- fromVal (VRef r) = do- v <- readRef r- case v of- (VList vs) -> return vs- _ -> return [v]- fromVal (VList vs) = return vs- fromVal v = fromVal' v- doCast (VList l) = return $ l- doCast (VUndef) = return $ [VUndef]- doCast v = return $ [v]--instance Value VHandle where- castV = VHandle- doCast (VHandle x) = return $ x- doCast v = castFailM v "VHandle"--instance Value VSocket where- castV = VSocket- doCast (VSocket x) = return $ x- doCast v = castFailM v "VSocket"--instance Value VThread where- castV = VThread- doCast (VThread x) = return $ x- doCast v = castFailM v "VThread"--instance Value VProcess where- castV = VProcess- doCast (VProcess x) = return $ x- doCast v = castFailM v "VProcess"--instance Value Int where- fromSV sv = io $ svToVInt sv- doCast x = intCast x- castV = VInt . fromIntegral-instance Value Word where - fromVal x = intCast x- doCast v = castFailM v "Word"-instance Value Word8 where - fromVal x = intCast x- doCast v = castFailM v "Word8"-instance Value [Word8] where- fromVal val = fmap (map (toEnum . ord)) (fromVal val)- doCast v = castFailM v "[Word8]"--type VScalar = Val--instance Value VScalar where- fromSV = return . PerlSV- fromVV = cast . fmap VV . Val.itemVal- fromVal (VRef r) = fromVal =<< readRef r- fromVal v = return v- doCast v = return v- castV = id -- XXX not really correct; need to referencify things--intCast :: Num b => Val -> Eval b-intCast x = fmap fromIntegral (fromVal x :: Eval VInt)---- | Uses Haskell's underlying representation for threads.-data VThread = MkThread- { threadId :: ThreadId- , threadLock :: TMVar Val- }- deriving (Show, Eq, Ord, Typeable)--type VList = [Val]-data VSubst- = MkSubst- { substRegex :: !VRule- , substExp :: !Exp- }- | MkTrans- { transFrom :: !VStr- , transTo :: !VStr- }- deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}-type VArray = [Val]-type VHash = Map VStr Val--data VThunk = MkThunk- { thunkExp :: Eval Val- , thunkType :: VType- }- deriving (Typeable) {-!derive: YAML_Pos!-}--newtype VProcess = MkProcess (ProcessHandle)- deriving (Typeable) {-!derive: YAML_Pos!-}--type VPair = (Val, Val)-type VType = Type--{-|-Representation for rules (i.e. regexes).--Currently there are two types of rules: Perl 5 rules, implemented with PCRE,-and Perl 6 rules, implemented with PGE.--}-data VRule- -- | Perl5-compatible regular expression- = MkRulePCRE- { rxRegex :: !Regex -- ^ The \'regular\' expression (as a PCRE- -- 'Regex' object)- , rxGlobal :: !Bool -- ^ Flag indicating \'global\' (match-all)- , rxNumSubs :: !Int -- ^ The number of subpatterns present.- , rxStringify :: !Bool- , rxRuleStr :: !String -- ^ The rule string, for user reference.- , rxAdverbs :: !Val- }- -- | Parrot Grammar Engine rule- | MkRulePGE- { rxRule :: !String -- ^ The rule string- , rxGlobal :: !Bool -- ^ Flag indicating \'global\' (match-all)- , rxStringify :: !Bool- , rxAdverbs :: !Val- }- deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}--instance Show Regex where- show _ = "<regex>"--instance Ord Regex where- compare x y = compare (addressOf x) (addressOf y)--instance Eq Regex where- x == y = addressOf x == addressOf y--showVal :: Val -> String-showVal = show--errStr :: VStr -> Val-errStr str = VError (VStr str) []--errStrPos :: VStr -> Pos -> Val-errStrPos str pos = VError (VStr str) [pos]--errValPos :: Val -> Pos -> Val-errValPos val pos = VError val [pos]--enterAtomicEnv :: Env -> Env-enterAtomicEnv env = env{ envAtomic = True }--{-|-Represents a value.--Note that 'Val' is also a constructor for 'Exp' (i.e. an expression containing -a value), so don't confuse the two. Similarly, all the constructors for -@data 'Val'@ are themselves puns on the types of values they contain.--}-data Val- = VUndef -- ^ Undefined value- | VBool !VBool -- ^ Boolean value- | VInt !VInt -- ^ Integer value- | VRat !VRat -- ^ Rational number value- | VNum !VNum -- ^ Number (i.e. a double)- | VComplex !VComplex -- ^ Complex number value- | VStr !VStr -- ^ String value- | VList !VList -- ^ List value- | VType !VType -- ^ Type value (e.g. @Int@ or @Type@)- | VJunc !VJunc -- ^ Junction value- | VError !Val ![Pos] -- ^ Error- | VControl !VControl----------------------------------------------------------------------- The following are runtime-only values (VRef is negotiable)- | VRef !VRef -- ^ Reference value- | VCode !VCode -- ^ A code object- | VBlock !VBlock- | VHandle !VHandle -- ^ File handle- | VSocket !VSocket -- ^ Socket handle- | VThread !VThread- | VProcess !VProcess -- ^ PID value- | VRule !VRule -- ^ Rule\/regex value- | VSubst !VSubst -- ^ Substitution value (correct?)- | VMatch !VMatch -- ^ Match value- | VObject !VObject -- ^ Object- | VOpaque !VOpaque- | PerlSV !PerlSV- | VV !Val.Val- deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}--{-|-Find the 'Type' of the value contained by a 'Val'.--See "Pugs.Types" for info on types.--}-valType :: Val -> Type-valType VUndef = mkType "Scalar"-valType (VRef v) = refType v-valType (VBool _) = mkType "Bool"-valType (VInt _) = mkType "Int"-valType (VRat _) = mkType "Rat"-valType (VNum _) = mkType "Num"-valType (VComplex _) = mkType "Complex"-valType (VStr _) = mkType "Str"--- valType (VList _) = mkType "List"-valType (VList _) = mkType "Array"-valType (VCode c) = code_iType c-valType (VBlock _) = mkType "Block"-valType (VJunc _) = mkType "Junction"-valType (VError _ _) = mkType "Error"-valType (VHandle _) = mkType "IO"-valType (VSocket _) = mkType "Socket"-valType (VThread _) = mkType "Thread"-valType (VProcess _) = mkType "Process"-valType (VControl _) = mkType "Control"-valType (VRule _) = mkType "Regex"-valType (VSubst _) = mkType "Subst"-valType (VMatch _) = mkType "Match"-valType (VType t) = t-valType (VObject o) = objType o-valType (VOpaque _) = mkType "Object"-valType (PerlSV _) = mkType "Scalar::Perl5"-valType (VV _) = mkType "Scalar::Perl5" -- (cast $ Val.valMeta v)--valToBool :: Val -> Eval VBool-valToBool = fromVal--type VBlock = Exp-data VControl- = ControlExit !ExitCode- | ControlContinuation- { ccEnv :: !Env- , ccVal :: !Val- , ccCont :: !(Val -> Eval Val)- }- | ControlLoop !ControlLoop- | ControlWhen !ControlWhen- | ControlLeave- { leaveType :: !(SubType -> Bool)- , leaveDepth :: !Int- , leaveValue :: !Val- }--- \| ControlLeave !(Env -> Eval Bool) !Val- deriving (Show, Eq, Ord, Typeable) -- don't derive YAML for now--data ControlLoop- = LoopNext- | LoopRedo- | LoopLast- deriving (Show, Eq, Ord, Typeable) -- don't derive YAML for now--data ControlWhen- = WhenContinue- | WhenBreak- deriving (Show, Eq, Ord, Typeable) -- don't derive YAML for now--{-|-Each 'VCode' structure has a 'SubType' indicating what \'level\' of-callable item it is. 'doApply' uses this to figure out how to enter-the proper scope and 'Env' when the sub is called.--Note that this is the \'type\' of a \'sub\', and has nothing to do with-subtyping.--}-data SubType = SubMethod -- ^ Method- | SubCoroutine -- ^ Coroutine- | SubMacro -- ^ Macro- | SubRoutine -- ^ Regular subroutine- | SubBlock -- ^ Bare block- | SubPointy -- ^ Pointy block- | SubPrim -- ^ Built-in primitive operator (see "Pugs.Prim")- deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos, JSON, Perl5!-}--isSlurpy :: Param -> Bool-isSlurpy param = isSlurpyCxt $ paramContext param--{-|-A formal parameter of a sub (or other callable).--These represent declared parameters; don't confuse them with actual parameter -values, which are henceforth termed "arguments".--}-data Param = MkOldParam -- "Old" because Pugs.Val.Code defined a new one- { isInvocant :: !Bool -- ^ Is it in invocant slot?- , isOptional :: !Bool -- ^ Is it optional?- , isNamed :: !Bool -- ^ Is it named-only?- , isLValue :: !Bool -- ^ Is it lvalue (i.e. not `is copy`)?- , isWritable :: !Bool -- ^ Is it writable (i.e. `is rw`)?- , isLazy :: !Bool -- ^ Is it call-by-name (short-circuit)?- , paramName :: !Var -- ^ Parameter name- , paramContext :: !Cxt -- ^ Parameter context: slurpiness and type- , paramDefault :: !Exp -- ^ Default expression (to evaluate to)- -- when omitted- }- deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos, Perl5, JSON!-}---- | A list of formal parameters.-type Params = [Param]--instance ((:>:) String) Params where- cast = show . paramsToSig--paramToValParam :: Param -> Val.SigParam-paramToValParam param = ret- where - ret = Val.MkParam - { Val.p_variable = paramName param- , Val.p_types = []- , Val.p_constraints = []- , Val.p_unpacking = Nothing- , Val.p_default = Val.MkParamDefault Nothing -- XXX Exp incompatibility- , Val.p_label = v_name $ paramName param -- XXX sigility- , Val.p_slots = Map.empty- , Val.p_hasAccess = case param of- MkOldParam { isLValue = True, isWritable = False } -> Val.AccessRO- MkOldParam { isLValue = True, isWritable = True } -> Val.AccessRW- MkOldParam { isLValue = False } -> Val.AccessCopy- , Val.p_isRef = Val.p_hasAccess ret == Val.AccessRW- , Val.p_isLazy = isLazy param- , Val.p_isContext = False -- XXX - not yet handled- }--paramsToSig :: Params -> Val.Sig-paramsToSig params = - Val.MkSig- { Val.s_invocant = Nothing- , Val.s_requiredPositionalCount =- length $ filter (\x -> not (isNamed x) && not (isOptional x)) params- , Val.s_requiredNames =- Set.fromList $ map (v_name . paramName) $ filter (not . isOptional) params- , Val.s_positionalList = map paramToValParam $ filter (not . isNamed) params- , Val.s_namedSet = Map.fromList $ - map (\p -> (v_name (paramName p), paramToValParam p)) $ - filter isNamed params- , Val.s_slurpyScalarList = [] -- XXX unimplemented- , Val.s_slurpyArray = Nothing -- XXX ditto- , Val.s_slurpyHash = Nothing -- XXX yep- , Val.s_slurpyCode = Nothing -- XXX all right- , Val.s_slurpyCapture = Nothing -- this one is okay as it is ;-)- } --{-|-A list of bindings from formal parameters ('Param') to actual parameter-expressions ('Exp').--}-type Bindings = [(Param, Exp)]-{-|-A sub that has a non-empty 'SlurpLimit' is a bound (or partially bound) sub-that has a finite number of slurpy scalar params bound, and no slurpy array-param bound (see 'VCode' and "Pugs.Bind").--Each list entry consists of the number of slurpable args expected, and an-expression that will evaluate to the actual list of slurpable args.-When the sub is called (see 'Pugs.Eval.apply'), the expression is evaluated.-If it evaluates to /too many/ args, the call will fail.--This needs to be a list (rather than a @Maybe@) because Perl 6's @.assuming@-(i.e. explicit currying) means that a sub can have its arguments bound in-separate stages, and each of the bindings needs to be checked.-->[12:02] <autrijus> scook0: .assuming will impose multiple limits->[12:02] <autrijus> because you can assume (curry) multiple times->[12:02] <scook0> ah->[12:02] <scook0> I'll have to write that in the docs then->[12:03] <scook0> Am I correct in that they only apply to subs that take a finite number of slurpy scalars?->[12:04] <scook0> Slurpy array params seem to nuke the SlurpLimit->[12:04] <scook0> because slurpy arrays can take any number of args->[12:07] <autrijus> scook0: yes, and yes.--}-type SlurpLimit = [(VInt, Exp)]--data SubAssoc- = ANil | AIrrelevantToParsing | A_left | A_right | A_non | A_chain | A_list - deriving (Show, Eq, Ord, Typeable, Data) {-!derive: YAML_Pos, JSON, Perl5 !-}--instance Monoid SubAssoc where- mempty = ANil- mappend ANil y = y- mappend x _ = x--data MPad = MkMPad { mp_id :: !Word, mp_pad :: !(TVar Pad) }- deriving (Show, Typeable, Data) {-!derive: YAML_Pos, JSON, Perl5 !-}--instance Eq MPad where- x == y = mp_id x == mp_id y--instance Ord MPad where- x `compare` y = mp_id x `compare` mp_id y---- | Represents a sub, method, closure etc. -- basically anything callable.-data VCode = MkCode- { isMulti :: !Bool -- ^ Is this a multi sub\/method?- , subName :: !ByteString -- ^ Name of the closure- , subType :: !SubType -- ^ Type of the closure- , subOuterPads :: !LexPads -- ^ Lexical pads for this scope- , subInnerPad :: !Pad -- ^ Inner lexical pad (immutable)--- , subLexical :: !Pad -- ^ Cached merged pads- , subPackage :: !Pkg -- ^ Package of the subroutine- , subAssoc :: !SubAssoc -- ^ Associativity- , subParams :: !Params -- ^ Parameters list- , subBindings :: !Bindings -- ^ Currently assumed bindings- , subSlurpLimit :: !SlurpLimit -- ^ Max. number of slurpy arguments- , subReturns :: !Type -- ^ Return type- , subLValue :: !Bool -- ^ Is this a lvalue sub?- , subBody :: !Exp -- ^ Body of the closure- , subCont :: !(Maybe (TVar VThunk)) -- ^ Coroutine re-entry point- , subStarted :: !(Maybe (TVar Bool)) -- ^ Whether START was run- , subTraitBlocks :: !TraitBlocks- }- deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}--data TraitBlocks = MkTraitBlocks- { subPreBlocks :: ![VCode]- , subPostBlocks :: ![VCode]- , subFirstBlocks :: ![VCode]- , subLastBlocks :: ![VCode]- , subNextBlocks :: ![VCode]- , subKeepBlocks :: ![VCode]- , subUndoBlocks :: ![VCode]- , subEnterBlocks :: ![VCode]- , subLeaveBlocks :: ![VCode]- , subControlBlocks :: ![VCode]- , subCatchBlocks :: ![VCode]- }- deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}--emptyTraitBlocks :: TraitBlocks-emptyTraitBlocks = MkTraitBlocks [] [] [] [] [] [] [] [] [] [] []--{-|-Construct a 'VCode' representing a built-in primitive operator.--See "Pugs.Prim" for more info.--}-mkPrim :: VCode-mkPrim = MkCode- { isMulti = True- , subName = cast "&"- , subType = SubPrim- , subOuterPads = []- , subInnerPad = emptyPad--- , subLexical = emptyPad- , subPackage = emptyPkg- , subAssoc = ANil- , subParams = []- , subBindings = []- , subSlurpLimit = []- , subReturns = anyType- , subBody = emptyExp- , subLValue = False- , subCont = Nothing- , subStarted = Nothing- , subTraitBlocks = emptyTraitBlocks- }--mkSub :: VCode-mkSub = MkCode- { isMulti = False- , subName = cast "&"- , subType = SubBlock- , subOuterPads = []- , subInnerPad = emptyPad--- , subLexical = emptyPad- , subPackage = emptyPkg- , subAssoc = ANil- , subParams = []- , subBindings = []- , subSlurpLimit = []- , subReturns = anyType- , subBody = emptyExp- , subLValue = False- , subCont = Nothing- , subStarted = Nothing- , subTraitBlocks = emptyTraitBlocks- }--mkCode :: VCode-mkCode = MkCode- { isMulti = False- , subName = cast "&"- , subType = SubBlock- , subOuterPads = []- , subInnerPad = emptyPad--- , subLexical = emptyPad- , subPackage = emptyPkg- , subAssoc = ANil- , subParams = []- , subBindings = []- , subSlurpLimit = []- , subReturns = anyType- , subBody = emptyExp- , subLValue = False- , subCont = Nothing- , subStarted = Nothing- , subTraitBlocks = emptyTraitBlocks- } --instance Ord VComplex where- compare (a :+ ai) (b :+ bi) = compare (a, ai) (b, bi)--instance Show (TVar a) where- show = showAddressOf "ref"--instance Show (IORef a) where- show = showAddressOf "ref"--{- Expression annotation--}-data Ann- = Cxt !Cxt -- ^ Context- | Pos !Pos -- ^ Position- | Prag ![Pragma] -- ^ Lexical pragmas- | Decl !Scope -- ^ Within an declarator- | Parens -- ^ Parenthesized- deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}--{- Expressions- "App" represents function application, e.g. myfun($invocant: $arg)-- "Syn" represents a structure that cannot be represented by an App.- For example, Syn "block" [...block body...]- Syn "=" [lhs, rhs]- ... or class definitions, where traits may be assigned either in- the signature or inside the body.-- There is no top-level marker, like unix filesystems don't have- volume letters.--}---- | Represents an expression tree.-data Exp- = Noop -- ^ No-op- | App !Exp !(Maybe Exp) ![Exp] -- ^ Function application- -- e.g. myfun($invocant: $arg)- | Syn !String ![Exp] -- ^ Syntactic construct that cannot- -- be represented by 'App'.- | Ann !Ann !Exp -- ^ Annotation (see @Ann@)--- | Pad !Scope !Pad !Exp -- ^ Lexical pad- | Sym !Scope !Var !EntryFlags !Exp !Exp -- ^ Symbol declaration- | Stmts !Exp !Exp -- ^ Multiple statements- | Prim !([Val] -> Eval Val) -- ^ Primitive- | Val !Val -- ^ Value- | Var !Var -- ^ Variable- | NonTerm !Pos -- ^ Parse error- deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}--_Sym :: Scope -> String -> EntryFlags -> Exp -> Exp -> Exp-_Sym scope str flags init rest = Sym scope (cast str) flags init rest--_Var :: String -> Exp-_Var str = Var (possiblyFixOperatorName (cast str))--instance Value Exp where- {- Val -> Eval Exp -}- fromVal val = do- obj <- fromVal val- return $ fromObject obj- {- Exp -> Val -}- {- castV exp = VObject (createObject (mkType "Code::Exp") [("theexp", exp)]) -}- doCast v = castFailM v "Exp"---- Recursively apply a transformation to an Exp structure-transformExp :: (Monad m) => (Exp -> m Exp) -> Exp -> m Exp-transformExp f (App a b cs) = do- a' <- transformExp f a- b' <- case b of- Just e -> liftM Just $ transformExp f e- Nothing -> return Nothing- cs' <- mapM (transformExp f) cs- f $ App a' b' cs'-transformExp f (Syn t es) = f =<< liftM (Syn t) (mapM (transformExp f) es)-transformExp f (Ann a e) = f =<< liftM (Ann a) (transformExp f e)--- transformExp f (Pad s p e) = f =<< liftM (Pad s p) (transformExp f e)-transformExp f (Sym s v c i e) = f =<< liftM (Sym s v c i) (transformExp f e)-transformExp f (Stmts e1 e2) = do - e1' <- transformExp f e1- e2' <- transformExp f e2- f $ Stmts e1' e2'-transformExp f e = f e--fromObject :: (Typeable a) => VObject -> a-fromObject obj = case objOpaque obj of- Nothing -> castFail obj "VObject without opaque"- Just dyn -> case fromDynamic dyn of- Nothing -> castFail obj "VObject's opaque not valueable"- Just x -> x--{- FIXME: Figure out how to get this working without a monad, and make it castV -}-expToEvalVal :: Exp -> Eval Val-expToEvalVal exp = do- obj <- createObject (mkType "Code::Exp") []- return $ VObject obj{ objOpaque = Just $ toDyn exp }--instance Unwrap [Exp] where- unwrap = map unwrap--instance Unwrap Exp where- unwrap (Ann _ exp) = unwrap exp- -- unwrap (Pad _ _ exp) = unwrap exp- unwrap (Sym _ _ _ _ exp)= unwrap exp- unwrap x = x--fromVals :: (Value n) => Val -> Eval [n]-fromVals v = mapM fromVal =<< fromVal v--instance Show VThunk where- show _ = "<thunk>"-instance Eq VThunk-instance Ord VThunk where- compare _ _ = EQ--instance Show VProcess where- show _ = "<process>"-instance Eq VProcess-instance Ord VProcess where- compare _ _ = EQ--extractPlaceholderVarsExp :: Exp -> ([Exp], Set Var) -> ([Exp], Set Var)-extractPlaceholderVarsExp ex (exps, vs) = (ex':exps, vs')- where- (ex', vs') = extractPlaceholderVars ex vs--{-| Deduce the placeholder vars ($^a, $^x etc.) used by a block). -}-extractPlaceholderVars :: Exp -> Set Var -> (Exp, Set Var)-extractPlaceholderVars (App n invs args) vs = (App n' invs' args', vs''')- where- (n', vs') = extractPlaceholderVars n vs- (invs', vs'') = maybe (invs, vs') (\inv -> let (x, y) = extractPlaceholderVars inv vs' in (Just x, y)) invs- (args', vs''') = foldr extractPlaceholderVarsExp ([], vs'') args-extractPlaceholderVars (Stmts exp1 exp2) vs = (Stmts exp1' exp2', vs'')- where- (exp1', vs') = extractPlaceholderVars exp1 vs- (exp2', vs'') = extractPlaceholderVars exp2 vs'-extractPlaceholderVars (Syn n exps) vs = (Syn n exps', vs'')- where- (exps', vs') = foldr extractPlaceholderVarsExp ([], vs) exps- vs'' = case n of- "when" -> Set.insert (cast "$_") vs'- "given" -> Set.delete (cast "$_") vs'- _ -> vs'-extractPlaceholderVars (Var var) vs- | TImplicit <- v_twigil var- , var' <- var{ v_twigil = TNil }- = (Var var', Set.insert var' vs)- | var == cast "$_"- = (Var var, Set.insert var vs)- | otherwise- = (Var var, vs)-extractPlaceholderVars (Ann ann ex) vs = ((Ann ann ex'), vs')- where- (ex', vs') = extractPlaceholderVars ex vs--- extractPlaceholderVars (Pad scope pad ex) vs = ((Pad scope pad ex'), vs')--- where--- (ex', vs') = extractPlaceholderVars ex vs-extractPlaceholderVars (Sym scope var flags ini ex) vs = ((Sym scope var flags ini ex'), vs')- where- (ex', vs') = extractPlaceholderVars ex vs-extractPlaceholderVars exp vs = (exp, vs)--buildParam :: String -- ^ Type of the parameter- -> String -- ^ Parameter-sigil (@:@, @!:@, @?@, @!@, etc.)- -> String -- ^ Name of the parameter (including primary sigil)- -> Exp -- ^ Expression for the param's default value- -> Param-buildParam typ sigil name e = MkOldParam- { isInvocant = False- , isOptional = '?' `elem` sigil- , isNamed = ':' `elem` sigil- , isLValue = True- , isWritable = (name == "$_")- , isLazy = False- , paramName = cast name- , paramContext = if '*' `elem` sigil- then CxtSlurpy typ'- else CxtItem typ'- , paramDefault = e- }- where- typ' = if null typ then anyType else mkType typ--defaultArrayParam :: Param-defaultHashParam :: Param-defaultScalarParam :: Param--defaultArrayParam = buildParam "" "*" "@_" (Val VUndef)-defaultHashParam = buildParam "" "*" "%_" (Val VUndef)-defaultScalarParam = buildParam "" "?" "$_" (Var $ cast "$OUTER::_")--type DebugInfo = Maybe (TVar (Map ID String))--newDebugInfo :: IO DebugInfo-newDebugInfo = fmap Just (io $ newTVarIO Map.empty)--type LexPads = [LexPad]-data LexPad- = PRuntime { pr_pad :: !Pad }- | PCompiling { pc_pad :: !MPad }- deriving (Show, Eq, Ord, Typeable)--{-|-Evaluation environment.--The current environment is stored in the @Reader@ monad inside the current -'Eval' monad, and can be retrieved using @ask@ for the whole 'Env', or @asks@ -if you just want a single field.--}-data Env = MkEnv- { envContext :: !Cxt -- ^ Current context- -- ('CxtVoid', 'CxtItem' or 'CxtSlurpy')- , envLValue :: !Bool -- ^ Are we in an LValue context?- , envLexical :: !Pad -- ^ Cached lexical pad for variable lookup- , envLexPads :: !LexPads -- ^ Current lexical pads; MY is leftmost, OUTER is next, etc- , envCaller :: !(Maybe Env) -- ^ CALLER pads- , envCompPad :: !(Maybe MPad) -- ^ Current COMPILING pad- , envGlobal :: !MPad -- ^ Global pad for variable lookup- , envPackage :: !Pkg -- ^ Current package- , envEval :: !(Exp -> Eval Val) -- ^ Active evaluator- , envBody :: !Exp -- ^ Current AST expression- , envFrames :: !(Set Frame) -- ^ Special-markers in the dynamic path- , envDebug :: !DebugInfo -- ^ Debug info map- , envPos :: !Pos -- ^ Source position range- , envPragmas :: ![Pragma] -- ^ List of pragmas in effect- , envInitDat :: !(TVar InitDat) -- ^ BEGIN result information- , envMaxId :: !(TVar ObjectId) -- ^ Current max object id- , envAtomic :: !Bool -- ^ Are we in an atomic transaction?- } - deriving (Show, Eq, Ord, Typeable) -- don't derive YAML for now--data Frame- = FrameLoop- | FrameWhen- | FrameGather- | FrameRoutine- deriving (Show, Eq, Ord, Typeable) -- don't derive YAML for now--envPos' :: Env -> Pos-envPos' = envPos--{-|-Module initialization information.--When a module is loaded and initialized (i.e., its &import routine is-called), it may need to communicate information back to the parser. -This information is held in a TVar to which the parser has access.-Currently we use this for keeping track of lexical pragma change-requests, but the possiblyExit mechanism may be refactored to use-this as well.--}-newtype InitDat = MkInitDat- { initPragmas :: [Pragma] -- ^ Pragma values being installed- } deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}--envWant :: Env -> String-envWant env =- showCxt (envContext env) ++ (if envLValue env then ", LValue" else "")- where- showCxt CxtVoid = "Void"- showCxt (CxtItem typ) = "Scalar (" ++ showType typ ++ ")"- showCxt (CxtSlurpy typ) = "List (" ++ showType typ ++ ")"--{- Pad -}-{-|-A 'Pad' keeps track of the names of all currently-bound symbols, and-associates them with the things they actually represent.--It is represented as a mapping from names to /lists/ of bound items.-This is to allow for multi subs, because we will need to keep-/multiple/ subs associated with one symbol. In other cases, the list-should just contain a single value. See 'Pugs.AST.genSym' and 'Pugs.AST.genMultiSym' for-more details.--@TVar@ indicates that the mapped-to items are STM transactional variables.--The @Bool@ is a \'freshness\' flag used to ensure that @my@ variable slots-are re-generated each time we enter their scope; see the-'Pugs.Eval.reduce' entry for ('Pad' 'SMy' ...).--The current global and lexical pads are stored in the current 'Env', which-is stored in the @Reader@-monad component of the current 'Eval' monad.--}--newtype Pad = MkPad { padEntries :: Map Var PadEntry }- deriving (Eq, Ord, Typeable)--{-|-An empty Pad with no symbols.--}--emptyPad :: Pad-emptyPad = MkPad Map.empty--newtype EntryFlags = MkEntryFlags { ef_isContext :: Bool }- deriving (Show, Eq, Ord, Typeable)--instance Monoid EntryFlags where- mempty = MkEntryFlags False- mappend (MkEntryFlags x) (MkEntryFlags y) = MkEntryFlags (x || y)--data PadEntry- = PELexical { pe_type :: !Type, pe_proto :: !VRef, pe_flags :: !EntryFlags, pe_store :: !(TVar VRef) } -- pe_fresh :: !(TVar Bool) }- | PEStatic { pe_type :: !Type, pe_proto :: !VRef, pe_flags :: !EntryFlags, pe_store :: !(TVar VRef) }- | PEConstant { pe_type :: !Type, pe_proto :: !VRef, pe_flags :: !EntryFlags }- deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}--data IHashEnv = MkHashEnv deriving (Show, Typeable) {-!derive: YAML_Pos!-}-data IScalarCwd = MkScalarCwd deriving (Show, Typeable) {-!derive: YAML_Pos!-}--{-# SPECIALISE readPadEntry :: PadEntry -> Eval VRef #-}-{-# SPECIALISE readPadEntry :: PadEntry -> STM VRef #-}-readPadEntry :: MonadSTM m => PadEntry -> m VRef-readPadEntry PEConstant{ pe_proto = v } = return v-readPadEntry x = stm (readTVar (pe_store x))--{-# SPECIALISE writePadEntry :: PadEntry -> VRef -> Eval () #-}-{-# SPECIALISE writePadEntry :: PadEntry -> VRef -> STM () #-}-writePadEntry :: MonadSTM m => PadEntry -> VRef -> m ()-writePadEntry x@PEConstant{} _ = die "Cannot rebind constant" x-writePadEntry x v = stm (writeTVar (pe_store x) v)--refreshPad :: Pad -> Eval Pad-refreshPad pad = do- fmap listToPad $ forM (padToList pad) $ \(name, entry) -> do- -- warn "Refreshing pad entry" (name, entry)- entry' <- case entry of- PELexical{ pe_proto = proto } -> stm $ do- ref <- cloneRef proto- tvar' <- newTVar ref- return entry{ pe_store = tvar' }- _ -> return entry- return (name, entry')--newtype ObjectId = MkObjectId { unObjectId :: Int }- deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}--data VObject = MkObject- { objType :: !VType- , objAttrs :: !IHash- , objOpaque :: !(Maybe Dynamic)- , objId :: !ObjectId- }- deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}---- | A '$/' object, the return of a rx match operation.-data VMatch = MkMatch- { matchOk :: !VBool -- success?- , matchFrom :: !Int -- .from- , matchTo :: !Int -- .to- , matchStr :: !VStr -- captured str- , matchSubPos :: !VList -- positional submatches- , matchSubNamed :: !VHash -- named submatches- }- deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}---instance Show Pad where- show pad = "MkPad (padToList " ++ show (padToList pad) ++ ")"--findSymRef :: Var -> Pad -> Eval VRef-findSymRef name pad = stm $ join (findSym name pad)--{-# SPECIALISE findSym :: Var -> Pad -> Eval (STM VRef) #-}-{-# SPECIALISE findSym :: Var -> Pad -> Maybe (STM VRef) #-}-findSym :: Monad m => Var -> Pad -> m (STM VRef)-findSym name pad = case lookupPad name pad of- Just PEConstant{ pe_proto = v } -> return (return v)- Just x -> return (readTVar (pe_store x))- _ -> fail $ "Cannot find variable: " ++ show name---- | Look up a symbol in a 'Pad', returning the ref it is bound to.-lookupPad :: Var -- ^ Symbol to look for- -> Pad -- ^ Pad to look in- -> Maybe PadEntry -- ^ Might return 'Nothing' if var is not found--{-- We (may) have to fix the name, as the user can write things like- &::("infix:<+>")(2, 3)- which, without fixName, wouldn't work, as all operators are currently- stored as &infix:+, i.e. without the brackets.--}--lookupPad key (MkPad pad) = Map.lookup key pad--{-|-Transform a pad into a flat list of bindings. The inverse of 'mkPad'.--Note that @Data.Map.assocs@ returns a list of mappings in ascending key order.--}-padToList :: Pad -> [(Var, PadEntry)]-padToList (MkPad pad) = Map.assocs pad--listToPad :: [(Var, PadEntry)] -> Pad-listToPad entries = MkPad (Map.fromList entries)---- | type for a function introducing a change to a Pad-type PadMutator = (Pad -> Pad)--{-|-Serializable compilation unit--See: docs/notes/precompilation_cache.pod--}-data CompUnit = MkCompUnit- { ver :: Int -- a version number, see compUnitVersion- , desc :: String -- e.g., the name of the contained module- , pad :: Pad -- pad for unit Env- , ast :: Exp -- AST of unit- } deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos !-}--mkCompUnit :: String -> Pad -> Exp -> CompUnit-mkCompUnit = MkCompUnit compUnitVersion--{-# NOINLINE compUnitVersion #-}-compUnitVersion :: Int-compUnitVersion = 18--{-|-Retrieve the global 'Pad' from the current evaluation environment.--'Env' stores the global 'Pad' in an STM variable, so we have to @asks@-'Eval'\'s @ReaderT@ for the variable, then extract the pad itself from the-STM var.--}-askGlobal :: Eval Pad-askGlobal = do- glob <- asks (mp_pad . envGlobal)- stm $ readTVar glob--writeVar :: Var -> Val -> Eval ()-writeVar var val- | isLexicalVar var = doWriteVar (asks envLexical)- | otherwise = doWriteVar askGlobal- where- doWriteVar askPad = do- pad <- askPad- case lookupPad var pad of- Just PEConstant{} -> fail $ "Cannot rebind constant: " ++ show var- Just c -> do- ref <- stm $ readTVar (pe_store c)- writeRef ref val- _ -> fail $ "Cannot bind to non-existing variable: " ++ show var--readVar :: Var -> Eval Val-readVar var- | isLexicalVar var = do- lex <- asks envLexical- case findSym var lex of- Just action -> stm action >>= readRef- _ -> return undef- | otherwise = do- glob <- askGlobal- case findSym var glob of- Just action -> stm action >>= readRef- _ -> return undef--{-|-The \'empty expression\' is just a no-op ('Noop').--}-emptyExp :: Exp-emptyExp = Noop--retControl :: VControl -> Eval a-retControl = retShift . VControl--retShift :: Val -> Eval a--- retShift = shiftT . const . return-retShift = EvalT . return . RException--retShiftEmpty :: Eval a--- retShiftEmpty = shiftT (const retEmpty)-retShiftEmpty = retShift =<< retEmpty--defined :: VScalar -> Bool-defined VUndef = False-defined VType{} = False-defined _ = True--- | Produce an undefined Perl 6 value (i.e. 'VUndef').-undef :: VScalar-undef = VUndef--forceRef :: VRef -> Eval Val-forceRef (MkRef (IScalar sv)) = forceRef =<< fromVal =<< scalar_fetch sv-forceRef (MkRef (IThunk tv)) = thunk_force tv-forceRef r = die "Cannot forceRef" r--dumpRef :: VRef -> Eval Val-dumpRef (MkRef (ICode cv)) = do- vsub <- code_fetch cv- return (VStr $ "(MkRef (ICode $ " ++ show vsub ++ "))")-dumpRef (MkRef (IScalar sv)) | scalar_iType sv == mkType "Scalar::Const" = do- sv <- scalar_fetch sv- return (VStr $ "(MkRef (IScalar $ " ++ show sv ++ "))")-dumpRef ref = return (VStr $ "(unsafePerformIO . newObject $ mkType \"" ++ showType (refType ref) ++ "\")")---- Reduce a VRef in rvalue context. -readRef :: VRef -> Eval Val-readRef (MkRef (IScalar sv)) = scalar_fetch sv-readRef (MkRef (ICode cv)) = do- vsub <- code_fetch cv- return $ VCode vsub-readRef (MkRef (IHash hv)) = do- pairs <- hash_fetch hv- return $ VList $ map (\(k, v) -> castV (castV k, v)) (Map.assocs pairs)-readRef (MkRef (IArray av)) = do- vals <- array_fetch av- return $ VList vals---- XXX - This case is entirely bogus; but no time to fix it now.-readRef (MkRef (IPair pv)) = do- (k, v) <- pair_fetch pv- return $ VList [k, v]--readRef (MkRef (IHandle io)) = return . VHandle =<< handle_fetch io-readRef (MkRef (IRule rx)) = return . VRule =<< rule_fetch rx-readRef (MkRef (IThunk tv)) = readRef =<< fromVal =<< thunk_force tv-readRef (MkRef (IVal v)) = do- cxt <- asks envContext- v ./ cxt--retIVar :: (Typeable a) => IVar a -> Eval Val-retIVar = return . VRef . MkRef--fromVList :: Val -> Eval VArray-fromVList (VList v) = return v-fromVList x = return [x]--fromVHash :: Val -> Eval VHash-fromVHash = fromVal--writeRef :: VRef -> Val -> Eval ()-writeRef (MkRef (IScalar s)) (VList vals) = do- av <- newArray vals- scalar_store s (VRef $ MkRef av)-writeRef (MkRef (IScalar s)) val = scalar_store s val-writeRef (MkRef (IArray s)) val = array_store s =<< fromVList val-writeRef (MkRef (IHash s)) val = hash_store s =<< fromVHash val-writeRef (MkRef (ICode s)) val = code_store s =<< fromVal val-writeRef (MkRef (IPair s)) val = pair_storeVal s val-writeRef (MkRef (IThunk tv)) val = (`writeRef` val) =<< fromVal =<< thunk_force tv-writeRef r _ = die "Cannot writeRef" r--cloneRef :: VRef -> STM VRef-cloneRef (MkRef x) = fmap MkRef (cloneIVar x)--clearRef :: VRef -> Eval ()-clearRef (MkRef (IScalar s)) = scalar_store s undef-clearRef (MkRef (IArray s)) = array_clear s-clearRef (MkRef (IHash s)) = hash_clear s-clearRef (MkRef (IPair s)) = pair_storeVal s undef-clearRef (MkRef (IThunk tv)) = clearRef =<< fromVal =<< thunk_force tv-clearRef r = die "Cannot clearRef" r--{-# SPECIALISE newObject :: Type -> Eval VRef #-}-{-# SPECIALISE newObject :: Type -> IO VRef #-}-newObject :: (MonadSTM m, MonadIO m) => Type -> m VRef-newObject typ = case showType typ of- "Any" -> io $ fmap scalarRef $ newTVarIO undef- "Item" -> io $ fmap scalarRef $ newTVarIO undef- "Scalar" -> io $ fmap scalarRef $ newTVarIO undef- "Array" -> io $ do- iv <- newTVarIO [::]- return $ arrayRef (MkIArray iv)- "Hash" -> do- h <- io (H.new (==) H.hashString)- return $ hashRef (h :: IHash)- "Sub" -> newObject $ mkType "Code"- "Routine" -> newObject $ mkType "Code"- "Method" -> newObject $ mkType "Code"- "Submethod" -> newObject $ mkType "Code"- "Code" -> return $! codeRef $ mkPrim- { subAssoc = AIrrelevantToParsing- , subBody = Prim . const $ fail "Cannot use Undef as a Code object"- }- "Type" -> io $ fmap scalarRef $ newTVarIO undef- "Pair" -> do- key <- newObject (mkType "Scalar")- val <- newObject (mkType "Scalar")- return $ MkRef (IPair (VRef key, VRef val))- "Regex" -> io $ fmap scalarRef $ newTVarIO undef -- XXX Wrong- "Capture" -> io $ fmap scalarRef $ newTVarIO undef -- XXX Wrong- _ -> fail ("Class prototype occured where its instance object expected: " ++ showType typ)--doPair :: Val -> (forall a. PairClass a => a -> b) -> Eval b-doPair (VRef (MkRef (IPair pv))) f = return $ f pv-doPair (VRef (MkRef (IHash hv))) f = do- vals <- hash_fetch hv- let [(k, v)] = Map.toList vals- return $ f (VStr k, v)-doPair (VRef (MkRef (IArray av))) f = do- vals <- array_fetch av- let [k, v] = take 2 (vals ++ repeat undef)- return $ f (k, v)-doPair (VRef (MkRef (IScalar sv))) f = do- val <- scalar_fetch sv- case val of- VUndef -> do- ref@(MkRef (IPair pv)) <- newObject (mkType "Pair")- scalar_store sv (VRef ref)- return $ f pv- _ -> doPair val f-doPair (VRef x) _ = die "Cannot cast into Pair" x-doPair val f = do- vs <- fromVal val- case (vs :: VList) of- [x, y] -> return $ f (x, y)- _ -> do- pv <- castFailM val "Confusing pair?"- return $ f (pv :: VPair)---- XXX: Refactor doHash and doArray into one -- also see Eval's [] and {}-doHash :: Val -> (forall a. HashClass a => a -> b) -> Eval b-doHash (PerlSV sv) f = return $ f sv-doHash (VRef (MkRef (IHash hv))) f = return $ f hv-doHash (VRef (MkRef (IScalar sv))) f = do- val <- scalar_fetch sv- case val of- VUndef -> do- ref@(MkRef (IHash hv)) <- newObject (mkType "Hash")- scalar_store sv (VRef ref)- return $ f hv- _ -> doHash val f-doHash (VRef (MkRef p@(IPair _))) f = return $ f p-doHash (VObject o) f = return $ f (objAttrs o)-doHash (VMatch m) f = do- return $ f (matchSubNamed m)-doHash val@(VRef _) _ = die "Cannot cast into Hash" val-doHash val f = do- hv <- fromVal val- return $ f (hv :: VHash)---- can be factored out-doArray :: Val -> (forall a. ArrayClass a => a -> b) -> Eval b-doArray (PerlSV sv) f = return $ f sv-doArray (VRef (MkRef (IArray av))) f = return $ f av-doArray (VRef (MkRef (IScalar sv))) f = do- val <- scalar_fetch sv- if defined val- then doArray val f- else do- ref@(MkRef (IArray hv)) <- newObject (mkType "Array")- scalar_store sv (VRef ref)- return $ f hv-doArray (VRef (MkRef p@(IPair _))) f = return $ f p-doArray val@(VRef (MkRef IHash{})) f = do- av <- fromVal val- return $ f (av :: VArray)-doArray val@(VRef _) _ = die "Cannot cast into Array" val-doArray (VMatch m) f = do- return $ f (matchSubPos m)-doArray val f = do- av <- fromVal val- return $ f (av :: VArray)---- Haddock doesn't seem to like data/instance declarations with a where clause.-#ifndef HADDOCK--data IVar v where- IScalar :: ScalarClass a => !a -> IVar VScalar- IArray :: ArrayClass a => !a -> IVar VArray- IHash :: HashClass a => !a -> IVar VHash- ICode :: CodeClass a => !a -> IVar VCode- IHandle :: HandleClass a => !a -> IVar VHandle- IRule :: RuleClass a => !a -> IVar VRule- IThunk :: ThunkClass a => !a -> IVar VThunk- IPair :: PairClass a => !a -> IVar VPair- IVal :: !Val -> IVar Val---- | An empty failed match-mkMatchFail :: VMatch-mkMatchFail = MkMatch False 0 0 "" [] Map.empty---- | Makes a successful match-mkMatchOk :: Int -> Int -> VStr -> VList -> VHash -> VMatch-mkMatchOk = MkMatch True--instance Eq VOpaque where- (MkOpaque x) == (MkOpaque y) = castV x == castV y--instance Typeable VOpaque where- typeOf (MkOpaque x) = typeOf x--instance Ord VOpaque where- compare x y = castV x `compare` castV y--instance Show VOpaque where- show (MkOpaque x) = show x--instance Value VOpaque where- fromVal (VOpaque o) = return o- fromVal v = return $ MkOpaque v- castV (MkOpaque x) = castV x- doCast v = castFailM v "VOpaque"-#endif--readIVar :: IVar v -> Eval v-readIVar (IScalar x) = scalar_fetch x-readIVar (IPair x) = pair_fetch x-readIVar (IArray x) = array_fetch x-readIVar (IHash x) = hash_fetch x-readIVar _ = fail "readIVar"--cloneIVar :: IVar v -> STM (IVar v)-cloneIVar (IScalar x) = fmap IScalar $ scalar_clone x-cloneIVar (IArray x) = fmap IArray $ array_clone x-cloneIVar (IHash x) = fmap IHash $ hash_clone x-cloneIVar (ICode x) = fmap ICode $ code_clone x-cloneIVar x = return x--writeIVar :: IVar v -> v -> Eval ()-writeIVar (IScalar x) = scalar_store x-writeIVar (IArray x) = array_store x-writeIVar (IHash x) = hash_store x-writeIVar _ = fail "writeIVar"--refType :: VRef -> Type-refType (MkRef x) = object_iType x---- Haddock doesn't seem to like data/instance declarations with a where clause.-#ifndef HADDOCK-instance Eq IHash where- x == y = addressOf x == addressOf y-instance Ord IHash where- compare x y = compare (addressOf x) (addressOf y)-instance Show IHash where- show = showAddressOf "Hash"-instance Typeable2 H.HashTable where- typeOf2 _ = mkTyConApp (mkTyCon "HashTable") []--instance Eq VRef where- x == y = addressOf x == addressOf y-instance Ord VRef where- compare x y = compare (addressOf x) (addressOf y)-instance Show VRef where- show ref@(MkRef ivar) = case ivar of- IScalar x -> showAddr x- IArray x -> showAddr x- IHash x -> showAddr x- ICode x -> showAddr x- IHandle x -> showAddr x- IRule x -> showAddr x- IThunk x -> showAddr x- IPair x -> showAddr x- IVal x -> show x- where- showAddr x = showAddressOf (showType (refType ref)) x--instance Typeable a => Show (IVar a) where- show ivar = show (MkRef ivar)--instance Eq (IVar a) where- x == y = addressOf x == addressOf y-instance Ord (IVar a) where- compare x y = compare (addressOf x) (addressOf y)-instance Ord (TVar a) where- compare x y = compare (addressOf x) (addressOf y)-instance Ord (IORef a) where- compare x y = compare (addressOf x) (addressOf y)-#endif--scalarRef :: ScalarClass a=> a -> VRef-scalarRef x = MkRef (IScalar x)-codeRef :: CodeClass a => a -> VRef-codeRef x = MkRef (ICode x)-arrayRef :: ArrayClass a => a -> VRef-arrayRef x = MkRef (IArray x)-hashRef :: HashClass a => a -> VRef-hashRef x = MkRef (IHash x)-thunkRef :: ThunkClass a => a -> VRef-thunkRef x = MkRef (IThunk x)-pairRef :: PairClass a => a -> VRef-pairRef x = MkRef (IPair x)--newScalar :: (MonadSTM m) => VScalar -> m (IVar VScalar)-newScalar = stm . (fmap IScalar) . newTVar--newArray :: (MonadSTM m) => VArray -> m (IVar VArray)-newArray vals = stm $ do- tvs <- mapM newScalar vals- iv <- newTVar (toP tvs)- return $ IArray (MkIArray iv)--newHash :: (MonadSTM m) => VHash -> m (IVar VHash)-newHash hash = do- --stm $ unsafeIOToSTM $ putStrLn "new hash"- ihash <- stm . unsafeIOToSTM $ H.fromList H.hashString (map (\(a,b) -> (a, lazyScalar b)) (Map.toList hash))- return $ IHash ihash--newHandle :: (MonadSTM m) => VHandle -> m (IVar VHandle)-newHandle = return . IHandle--proxyScalar :: Eval VScalar -> (VScalar -> Eval ()) -> IVar VScalar-proxyScalar fetch store = IScalar (fetch, store)--constScalar :: VScalar -> IVar VScalar-constScalar = IScalar--lazyScalar :: VScalar -> IVar VScalar-lazyScalar = IScalar . Just--lazyUndef :: IVar VScalar-lazyUndef = IScalar (Nothing :: IScalarLazy)--constArray :: VArray -> IVar VArray-constArray = IArray--retConstError :: VScalar -> Eval b-retConstError val = die "Can't modify constant item" val----- Haddock doesn't like these; not sure why ...-#ifndef HADDOCK--{--instance A.MArray IArray ArrayIndex STM where- getBounds (MkIArray iv) = do- a <- readTVar iv- return (bounds a)- newArray b e = do- a <- replicateM (rangeSize b) (newTVar e)- iv <- newTVar (A.listArray b a)- return $ MkIArray iv- newArray_ b = do- a <- replicateM (rangeSize b) (newTVar A.arrEleBottom)- iv <- newTVar (A.listArray b a)- return $ MkIArray iv- unsafeRead (MkIArray iv) i = do- a <- readTVar iv- readTVar $ A.unsafeAt a i- unsafeWrite (MkIArray iv) i e = do- a <- readTVar iv- writeTVar (A.unsafeAt a i) e--}--newtype IArray = MkIArray (TVar [:IVar VScalar:])- deriving (Typeable)--type IArraySlice = [IVar VScalar]-type IHash = H.HashTable VStr (IVar VScalar) -- XXX UTF8 handled at Types/Hash.hs-type IScalar = TVar Val-type IScalarProxy = (Eval VScalar, (VScalar -> Eval ()))-type IScalarLazy = Maybe VScalar-type IPairHashSlice = (VStr, IVar VScalar)--data VMultiCode = MkMultiCode- { mc_type :: !Type- , mc_subtype :: !SubType- , mc_assoc :: !SubAssoc- , mc_signature :: !Params- , mc_variants :: !(Set Var)- }- deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}---- these implementation allows no destructions-type IRule = VRule-type IHandle = VHandle -- XXX maybe TVar?---- GADTs, here we come!-data VRef where- MkRef :: (Typeable a) => !(IVar a) -> VRef--instance Typeable VRef where- typeOf (MkRef x) = typeOf x--instance Typeable1 IVar where- typeOf1 (IScalar x) = typeOf x- typeOf1 (IArray x) = typeOf x- typeOf1 (IHash x) = typeOf x- typeOf1 (ICode x) = typeOf x- typeOf1 (IHandle x) = typeOf x- typeOf1 (IRule x) = typeOf x- typeOf1 (IThunk x) = typeOf x- typeOf1 (IPair x) = typeOf x- typeOf1 (IVal x) = typeOf x-#endif--{- <DrIFT> -- Do NOT delete! These are valuable instances!--{-# NOINLINE _FakeEnv #-}-_FakeEnv :: Env-_FakeEnv = unsafePerformIO $ stm $ do- glob <- newTVar $ MkPad Map.empty- ref <- newTVar Map.empty- init <- newTVar $ MkInitDat { initPragmas=[] }- maxi <- newTVar $ MkObjectId 1- return $ MkEnv- { envContext = CxtVoid- , envLexical = emptyPad- , envLexPads = []- , envCaller = Nothing- , envCompPad = Nothing- , envLValue = False- , envGlobal = MkMPad (addressOf glob) glob- , envPackage = cast "Main"- , envEval = const (return VUndef)- , envFrames = Set.empty- , envBody = Val undef- , envDebug = Just ref -- Set to "Nothing" to disable debugging- , envPos = MkPos (__"<null>") 1 1 1 1- , envPragmas = []- , envInitDat = init- , envMaxId = maxi- , envAtomic = False- }--fakeEval :: MonadIO m => Eval Val -> m Val-fakeEval = io . runEvalIO _FakeEnv--instance YAML Val.Val--instance YAML LexPads where- asYAML _ = return nilNode- fromYAML _ = return []--instance YAML ([Val] -> Eval Val) where- asYAML _ = return nilNode- fromYAML _ = return (const $ return VUndef)-instance YAML (Maybe Env) where- asYAML _ = return nilNode- fromYAML _ = return Nothing-instance YAML (Eval Val) where- asYAML x = asYAML =<< fakeEval x- fromYAML x = return =<< fromYAML x-instance (Ord a, YAML a) => YAML (Set a) where- asYAML x = do- x' <- mapM asYAML (Set.toAscList x)- (return . mkTagNode "Set" . ESeq) x'- fromYAML node = do- fmap Set.fromDistinctAscList (fromYAMLseq node)--instance YAML a => YAML (Map String a) where- asYAML x = asYAMLmap "Map" $ Map.toAscList (Map.map asYAML x)- fromYAML node = fmap Map.fromList (fromYAMLmap node)-instance YAML a => YAML (Map Var a) where- asYAML x = asYAMLmap "Map" . sortBy (\x y -> fst x `compare` fst y) $- [ (cast k, asYAML v) | (k, v) <- Map.toList x ]- fromYAML node = do- list <- fromYAMLmapBuf node- return (Map.fromList [ (cast k, v) | (k, v) <- list ])-instance Typeable a => YAML (IVar a) where- asYAML x = asYAML (MkRef x)-instance YAML VRef where- asYAML (MkRef (ICode cv))- | Just (mc :: VMultiCode) <- fromTypeable cv = do- mcC <- asYAML (mc :: VMultiCode)- return $ mkTagNode (tagHs "VMultiCode") $ ESeq [mcC]- | otherwise = do- VCode vsub <- fakeEval $ fmap VCode (code_fetch cv)- vsubC <- asYAML vsub- return $ mkTagNode (tagHs "VCode") $ ESeq [vsubC]- asYAML (MkRef (IScalar sv)) = do- val <- fakeEval $ scalar_fetch sv- svC <- asYAML val- let tag = if scalar_iType sv == mkType "Scalar::Const"- then "VScalar" else "IScalar"- return $ mkTagNode (tagHs tag) $ ESeq [svC]- asYAML (MkRef (IArray av)) = do- VList vals <- fakeEval $ fmap VList (array_fetch av)- avC <- asYAML vals- return $ mkTagNode (tagHs "Array") $ ESeq [avC]- asYAML (MkRef (IHash hv)) = do- VMatch MkMatch{ matchSubNamed = hv } <- fakeEval $ fmap (VMatch . MkMatch False 0 0 "" []) (hash_fetch hv)- hvC <- asYAML hv- return $ mkTagNode (tagHs "Hash") $ ESeq [hvC]- asYAML (MkRef (IPair pv)) = do- VList [k, v] <- fakeEval $ fmap (\(k, v) -> VList [k, v]) (pair_fetch pv)- avC <- asYAML (k, v)- return $ mkTagNode (tagHs "Pair") $ ESeq [avC]- asYAML ref = do- val <- fakeEval $ readRef ref- svC <- asYAML val- io $ print "====>"- io $ print svC- fail ("Not implemented: asYAML \"" ++ showType (refType ref) ++ "\"")- fromYAML MkNode{n_tag=Just s, n_elem=ESeq [node]}- | s == packBuf "tag:hs:VMultiCode" =- fmap (MkRef . ICode) (fromYAML node :: IO VMultiCode)- | s == packBuf "tag:hs:VCode" =- fmap (MkRef . ICode) (fromYAML node :: IO VCode)- | s == packBuf "tag:hs:VScalar" =- fmap (MkRef . IScalar) (fromYAML node :: IO VScalar)- | s == packBuf "tag:hs:Pair" =- fmap pairRef (fromYAML node :: IO VPair)- | s == packBuf "tag:hs:IScalar" = newV newScalar- | s == packBuf "tag:hs:Array" = newV newArray- | s == packBuf "tag:hs:Hash" = newV newHash- where newV f = fmap MkRef (f =<< fromYAML node)- fromYAML node = fail $ "Unhandled YAML node: " ++ show node-instance YAML IHash where- asYAML x = do- l <- io $ H.toList x- asYAMLmap "IHash" (map (\(k, v) -> (k, asYAML v)) l)- fromYAML node = do- l <- fromYAMLmap node- l' <- H.fromList H.hashString l- return l'--instance YAML ID where- asYAML x = asYAML (idBuf x)- fromYAML x = do- buf <- fromYAML x- return $ bufToID buf- -instance Perl5 ID where- showPerl5 x = showPerl5 (cast x :: ByteString)-instance JSON ID where- showJSON x = showJSON (cast x :: ByteString)--instance YAML Pkg where- asYAML x = asYAML (cast x :: ByteString)- fromYAML = fmap (cast :: ByteString -> Pkg) . fromYAML--instance YAML Var where- asYAML x = asYAML (cast x :: ByteString)- fromYAML = fmap (cast :: ByteString -> Var) . fromYAML--instance YAML EntryFlags where- asYAML (MkEntryFlags x) = asYAML x- fromYAML = fmap MkEntryFlags . fromYAML- -instance Perl5 Var where- showPerl5 x = showPerl5 (cast x :: String)-instance JSON Var where- showJSON x = showJSON (cast x :: String)--instance YAML (Set Val) where- asYAML = asYAML . Set.toAscList- fromYAML = fmap Set.fromAscList . fromYAML --instance YAML VControl-instance YAML VThread-instance YAML ClassTree-instance YAML Dynamic-instance YAML ProcessHandle-instance YAML Regex-instance YAML Unique-instance YAML VComplex-instance YAML VHandle-instance YAML VOpaque-instance YAML VSocket-instance YAML PerlSV--instance Perl5 Exp where- showPerl5 _ = "(undef)"-instance JSON Exp where- showJSON _ = "null"---- Non-canonical serialization... needs work-instance (Show (TVar a)) => Perl5 (TVar a) where- showPerl5 _ = "(warn '<ref>')"-instance (Show (TVar a)) => JSON (TVar a) where- showJSON _ = "null"--instance Perl5 Val where- showPerl5 (VUndef) = showP5Class "VUndef"- showPerl5 (VBool aa) = showP5ArrayObj "VBool" [showPerl5 aa]- showPerl5 (VInt aa) = showP5ArrayObj "VInt" [showPerl5 aa]- showPerl5 (VRat aa) = showP5ArrayObj "VRat" [showPerl5 aa]- showPerl5 (VNum aa) = showP5ArrayObj "VNum" [showPerl5 aa]- showPerl5 (VStr aa) = showP5ArrayObj "VStr" [showPerl5 aa]- showPerl5 (VList aa) = showP5ArrayObj "VList" [showPerl5 aa]- showPerl5 (VType aa) = showP5ArrayObj "VType" [showPerl5 aa]- showPerl5 (VCode{}) = showP5Class "VUndef"--</DrIFT> Do NOT delete! These instances are your friends! -}--instance Typeable Unique where typeOf _ = mkTyConApp (mkTyCon "Unique") []-instance Typeable ProcessHandle where typeOf _ = mkTyConApp (mkTyCon "ProcessHandle") []-instance Typeable Regex where typeOf _ = mkTyConApp (mkTyCon "Regex") []---instance Eq VJunc where- (MkJunc aa ab ac) == (MkJunc aa' ab' ac') = aa == aa' && ab == ab'- && ac == ac'--instance Ord VJunc where- compare (MkJunc aa ab ac) (MkJunc aa' ab' ac') =- foldl (\x y -> if x == EQ then compare y EQ else x) EQ- [compare aa aa',compare ab ab',compare ac ac']--{- !!! For DrIFT -- Don't delete !!!--data VJunc = MkJunc- { juncType :: !JuncType- , juncDup :: !(Set Val)- , juncSet :: !(Set Val)- } deriving (Typeable) {-!derive: YAML_Pos!-}--data JuncType = JAny | JAll | JNone | JOne- deriving (Eq, Ord, Typeable) {-!derive: YAML_Pos!-}--data Scope = SState | SConstant | SHas | SMy | SOur- {-!derive: YAML_Pos, JSON, Perl5!-}--data Pad = MkPad { padEntries :: Map Var PadEntry }- {-!derive: YAML_Pos!-}--data Pos = MkPos- { posName :: !String, posBeginLine :: !Int- , posBeginColumn :: !Int- , posEndLine :: !Int- , posEndColumn :: !Int- }- {-!derive: YAML_Pos, JSON, Perl5!-}--data Type- = MkType !String -- ^ A regular type- | TypeOr !Type !Type -- ^ The disjunction (|) of two types- | TypeAnd !Type !Type -- ^ The conjunction (&) of two types- {-!derive: YAML_Pos, JSON, Perl5!-}--data Cxt = CxtVoid | CxtItem !Type | CxtSlurpy !Type- {-!derive: YAML_Pos, JSON, Perl5!-}--data Val- = VUndef -- ^ Undefined value- | VBool !VBool -- ^ Boolean value- | VInt !VInt -- ^ Integer value- | VRat !VRat -- ^ Rational number value- | VNum !VNum -- ^ Number (i.e. a double)- | VStr !VStr -- ^ String value- | VList !VList -- ^ List value- | VType !VType -- ^ Type value (e.g. @Int@ or @Type@)- {-!derive: JSON!-}--data Pragma = MkPrag- { pragName :: !String -- ^ Name of pragma- , pragDat :: !Int -- ^ (lexically scoped) pragmatic data- -- This element is subject to change;- -- we don't necessarily want to limit- -- ourselves to 32 bit ints.- }- {-!derive: YAML_Pos, JSON, Perl5!-}---}--------------------------------------------------------------------------+ 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<foo>+ fromVal (VRef r) = fromVal =<< readRef r+ fromVal v = do+ list <- fromVal v+ fmap Map.fromList $ forM list $ \(k, v) -> do+ str <- fromVal k+ return (str, v)+ doCast v = castFailM v "VHash"++instance Value [VPair] where+ fromVal VUndef = return []+ fromVal v = do+ list <- fromVals v+ doFrom $ concat list+ where+ doFrom :: [Val] -> Eval [VPair]+ doFrom [] = return []+ doFrom [_] = fail $ "Odd number of elements found where hash expected: " ++ show v+ doFrom (k:v:list) = do+ rest <- doFrom list+ return ((k, v):rest)+ doCast v = castFailM v "Hash"++instance Value VCode where+ castV = VCode+ fromSV sv = return $ mkPrim+ { subName = cast "<anon>"+ , subParams = [defaultArrayParam]+ , subReturns = mkType "Scalar::Perl5"+ , subBody = Prim $ \(args:_) -> do+ svs <- fromVals args+ runInvokePerl5 sv nullSV svs+ }+ doCast (VCode b) = return b+ doCast (VType t) = return $ mkPrim+ { subName = cast t+ , subParams = [buildParam "Any" "*" "@?0" (Val VUndef), buildParam "Any" "*" "%?0" (Val VUndef)]+ , subReturns = mkType "Scalar::Perl5"+ , subBody = Prim $ \(p:n:_) -> do+ evl <- asks envEval+ evl (App (_Var "&new") (Just $ Val (VType t)) [Syn "|" [Val p], Syn "|" [Val n]])+ }+ doCast (VList [VCode b]) = return b -- XXX Wrong+ doCast v = castFailM v "VCode"++instance Value VBool where+ castV = VBool+ fromSV sv = io $ svToVBool sv+ fromVV vv = fmap cast (Val.asBit vv)+ doCast (VJunc j) = juncToBool j+ doCast (VMatch m) = return $ matchOk m+ doCast (VBool b) = return $ b+ doCast VUndef = return $ False+ doCast VType{} = return $ False+ doCast (VStr "") = return $ False+ doCast (VStr "0") = return $ False+ doCast (VInt 0) = return $ False+ doCast (VRat 0) = return $ False+ doCast (VNum 0) = return $ False+ doCast (VList []) = return $ False+ doCast _ = return $ True+++instance Value VInt where+ castV = VInt+ fromVV vv = fmap cast (Val.asInt vv)+ fromSV sv = io $ svToVInt sv+ doCast (VInt i) = return $ i+ doCast x = fmap truncate (fromVal x :: Eval VRat)++instance Value VRat where+ castV = VRat+ fromSV sv = io $ svToVNum sv+ doCast (VInt i) = return $ i % 1+ doCast (VRat r) = return $ r+ doCast (VBool b) = return $ if b then 1 % 1 else 0 % 1+ doCast (VList l) = return $ genericLength l+ doCast (VStr s) | not (null s) , isSpace $ last s = do+ str <- fromVal (VStr $ init s)+ return str+ doCast (VStr s) | not (null s) , isSpace $ head s = do + str <- fromVal (VStr $ tail s)+ return str+ doCast (VStr s) = return $+ case ( parseNatOrRat s ) of+ Left _ -> 0 % 1+ Right rv -> case rv of+ Left i -> i % 1+ Right d -> d+ doCast x = fmap toRational (fromVal x :: Eval VNum)++instance Value VNum where+ castV = VNum+ fromVV vv = fmap cast (Val.asNum vv)+ fromSV sv = io $ svToVNum sv+ doCast VUndef = return $ 0+ doCast VType{} = return $ 0+ doCast (VBool b) = return $ if b then 1 else 0+ doCast (VInt i) = return $ fromIntegral i+ doCast (VRat r) = return $ realToFrac r+ doCast (VNum n) = return $ n+ doCast (VComplex (r :+ _)) = return $ r+ doCast (VStr s) | not (null s) , isSpace $ last s = do+ str <- fromVal (VStr $ init s)+ return str+ doCast (VStr s) | not (null s) , isSpace $ head s = do+ str <- fromVal (VStr $ tail s)+ return str+ doCast (VStr "Inf") = return $ 1/0+ doCast (VStr "-Inf") = return $ -1/0+ doCast (VStr "NaN") = return $ 0/0+ doCast (VStr s) = return $+ case ( parseNatOrRat s ) of+ Left _ -> 0+ Right rv -> case rv of+ Left i -> fromIntegral i+ Right d -> realToFrac d+ doCast (VList l) = return $ genericLength l+ doCast t@VThread{} = fmap read (fromVal t)+ doCast (VMatch m) = fromVal (VStr $ matchStr m)+ doCast v = castFailM v "VNum"++instance Value Ordering where+ castV x = VInt $ case x of+ LT -> -1+ EQ -> 0+ GT -> 1+ doCast x = do+ n <- fromVal x :: Eval VInt+ return $ case signum n of+ -1 -> LT+ 0 -> EQ+ 1 -> GT+ _ -> error "signum: impossible"++instance Value VComplex where+ castV = VComplex+ doCast (VComplex x) = return x+ doCast x = fmap (:+ 0) (fromVal x :: Eval VNum)++instance Value ID where+ castV = VStr . cast+ fromSV sv = fmap cast (io $ svToVStr sv)+ fromVV vv = fmap cast (Val.asStr vv)+ fromVal = fmap (cast :: VStr -> ID) . fromVal+ doCast = fmap (cast :: VStr -> ID) . doCast++instance Value VStr where+ castV = VStr+ fromSV sv = io $ svToVStr sv+ fromVV vv = fmap cast (Val.asStr vv)+ fromVal (VList l) = return . unwords =<< mapM fromVal l+ fromVal v@(PerlSV _) = fromVal' v+ fromVal VUndef = return ""+ fromVal (VType t) = return (showType t)+ fromVal v = do+ vt <- evalValType v+ case showType vt of+ "Pair" -> do+ -- Special case for pairs: "$pair" eq+ -- "$pair.key()\t$pair.value()"+ (k, v) <- join $ doPair v pair_fetch+ k' <- fromVal k+ v' <- fromVal v+ return $ k' ++ "\t" ++ v'+ "Hash" -> do+ --- XXX special case for Hash -- need to Objectify+ hv <- join $ doHash v hash_fetch+ lns <- forM (Map.assocs hv) $ \(k, v) -> do+ str <- fromVal v+ return $ k ++ "\t" ++ str+ return $ unlines lns+ _ -> fromVal' v+ doCast VUndef = return ""+ doCast VType{} = return ""+ doCast (VStr s) = return s+ doCast (VBool b) = return $ if b then "1" else ""+ doCast (VInt i) = return $ show i+ doCast (VRat r) = return $ showRat r+ doCast (VNum n) = return $ showNum n+ doCast (VComplex (r :+ i)) = return $ showNum r ++ " + " ++ showNum i ++ "i"+ doCast (VList l) = fmap unwords (mapM fromVal l)+ doCast (VCode s) = return $ "<" ++ show (subType s) ++ "(" ++ cast (subName s) ++ ")>"+ doCast (VJunc j) = return $ show j+ doCast (VThread t) = return $ takeWhile isDigit $ dropWhile (not . isDigit) $ show t+ doCast (VHandle h) = return $ "<" ++ "VHandle (" ++ (show h) ++ ">"+ doCast (VMatch m) = return $ matchStr m+ -- doCast (VType typ) = return $ showType typ -- "::" ++ showType typ+ doCast (VObject o) = return $ "<obj:" ++ showType (objType o) ++ ">"+ doCast x = return $ "<" ++ showType (valType x) ++ ">"+++instance Value [PerlSV] where+ fromVal = fromVals+ doCast v = castFailM v "[PerlSV]"++instance Value PerlSV where+ fromVal val = io $ newSVval val+ doCast v = castFailM v "PerlSV"++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)
src/Pugs/AST/Internals.hs-boot view
@@ -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
+ src/Pugs/AST/Types.hs view
@@ -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] <autrijus> scook0: .assuming will impose multiple limits+>[12:02] <autrijus> because you can assume (curry) multiple times+>[12:02] <scook0> ah+>[12:02] <scook0> I'll have to write that in the docs then+>[12:03] <scook0> Am I correct in that they only apply to subs that take a finite number of slurpy scalars?+>[12:04] <scook0> Slurpy array params seem to nuke the SlurpLimit+>[12:04] <scook0> because slurpy arrays can take any number of args+>[12:07] <autrijus> scook0: yes, and yes.+-}+type SlurpLimit = [(VInt, Exp)]++data SubAssoc+ = ANil | AIrrelevantToParsing | A_left | A_right | A_non | A_chain | A_list + deriving (Show, Eq, Ord, Typeable, Data) {-!derive: YAML_Pos, JSON, Perl5 !-}++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 _ = "<regex>"++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 _ = "<thunk>"+instance Eq VThunk+instance Ord VThunk where+ compare _ _ = EQ++instance Show VProcess where+ show _ = "<process>"+instance Eq VProcess+instance Ord VProcess where+ compare _ _ = EQ++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!-}
src/Pugs/AST/Utils.hs view
@@ -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
src/Pugs/Version.hs view
@@ -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