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