{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances -fallow-overlapping-instances -fno-warn-missing-methods -cpp #-} {-| Perl 6 Values. > There beryl, pearl, and opal pale, > And metal wrought like fishes' mail, > Buckler and corslet, axe and sword, > And shining spears were laid in hoard... -} module Pugs.Val ( module Pugs.Val, module Pugs.Val.Code, module Pugs.Val.Capture, Val, Call, ) where import Pugs.Class import Pugs.Val.Base () import Pugs.Val.Code import Pugs.Val.Capture import Pugs.Internals import Text.PrettyPrint asStr :: Val -> Eval PureStr asStr (MkInvocant x _) = return (cast (show x)) asBit :: Val -> Eval PureBit asBit _ = return (cast True) asInt :: Val -> Eval PureInt asInt _ = return (cast (0 :: Int)) asNum :: Val -> Eval PureNum asNum _ = return (cast (0 :: Double)) listVal :: Val -> Eval PureList listVal = return . (:[]) itemVal :: Val -> Eval Val itemVal = return valMeta :: Val -> PureStr valMeta _ = cast "Object" valShow :: Val -> PureStr valShow _ = cast "" formatVal :: Val -> Doc formatVal (MkInvocant x _) = text (show x) castVal :: forall a m . (Monad m, Typeable a) => Val -> m a castVal (MkInvocant v _) = fromTypeable v instance ((:>:) PureNum) Rational where cast = NRational instance ((:<:) PureNum) Rational where castBack (NDouble x) = toRational x castBack (NRational x) = x instance ((:>:) PureNum) Double where cast = NDouble instance ((:<:) PureNum) Double where castBack (NDouble x) = x castBack (NRational x) = fromRational x instance ((:>:) PureInt) Integer where cast = IFinite instance ((:<:) PureInt) Integer where castBack (IFinite i) = i castBack INotANumber = error "NaN" castBack (IInfinite SPositive) = error "+Infinity" castBack (IInfinite SNegative) = error "-Infinity" instance ((:>:) PureInt) Int where cast = IFinite . toInteger instance ((:<:) PureInt) Int where castBack (IFinite i) = fromInteger i castBack INotANumber = error "NaN" castBack (IInfinite SPositive) = error "+Infinity" castBack (IInfinite SNegative) = error "-Infinity" type PureList = [Val] -- Seq (Either PureSeq PureRange) -- XXX - *very bogus* newtype PureBit = MkBit Bool deriving (Typeable, Show, Eq, Ord, Data, (:>:) Bool, (:<:) Bool) type PureStr = ByteString data PureInt = IFinite !Integer | IInfinite !Sign | INotANumber deriving (Typeable, Show, Eq, Ord, Data) data PureNum = NDouble !Double -- change to "!NativeDouble" | NRational !Rational deriving (Typeable, Show, Eq, Ord, Data) data Sign = SPositive | SNegative deriving (Show, Eq, Ord, Data, Typeable) -- | L data ValUndef = UUndef -- ^ "my $x" | UWhatever -- ^ "my $x = *" | UFailure { f_err :: !ID } -- ^ "my $x = fail 'oops'" | UProto { p_meta :: !ID } -- ^ "my $x = Dog" deriving (Show, Eq, Ord, Data, Typeable) instance Boxable ValUndef instance Boxable PureInt instance Boxable PureNum instance Boxable PureSig instance Boxable PureBit instance Boxable ValCapt instance Boxable Int {- module Pugs.Val ( IValue(..), Val(..), ValUndef(..), ValNative, P, ICoercible(..), WHICH, castVal, formatVal, PureBit, PureBool, PureInt, PureNum, PureStr, PureList, itemVal, listVal, Table, Var(..), -- From Code Sig(..), SigParam(..), ParamAccess(..), ParamDefault(..), Capt(..), Feed(..), emptyFeed, Code(..), ValCapt, ValFeed, ) where import Pugs.Internals import Pugs.Class import GHC.Exts import Data.Generics.Basics hiding (cast) import qualified Data.Typeable as Typeable import qualified Data.ByteString as Buf import qualified Data.Map as Map import qualified Data.Set as Set import Data.Monoid import Pugs.AST.SIO import Pugs.Val.Base --import Pugs.Val.Sig --import Pugs.Val.Code --import Pugs.Exp import {-# SOURCE #-} Pugs.Exp import qualified Pugs.Types as Types import Pugs.Types (Var(..)) import Text.PrettyPrint -- move to Pugs.Val.Pretty? -- XXX - Once GHC 6.6 is released with bindists, change #include to .hs-boot! #include "Val/Code.hs" {-| This module contains the definition of the five variants for a Perl 6 value. However, the actual constructors for each variant are abstract, and this module does not provide concrete data type definitions beyond those five. -} -- | 'Val' represents what an unconstrained scalar container can hold. data Val = VUndef !ValUndef -- ^ Values that are false on .defined (WHICH = undef) | VNative !ValNative -- ^ Values that can fit into an UArray (WHICH = impl.dep.) | forall a. Pure a => VPure !a -- ^ Values that are immutable (WHICH = pureId) | forall a. Mut a => VMut !a -- ^ In-memory mutable structures (WHICH = memory addr) | forall a. Ext a => VExt !a -- ^ Input/Ouput handles (WHICH = memory addr) deriving (Typeable) castVal :: forall a m . (Monad m, Typeable a) => Val -> m a --castVal = gmapQi 0 fromTypeable -- when we have 6.6, and can make all Val in Data. castVal (VUndef v) = fromTypeable v castVal (VNative v) = fromTypeable v castVal (VPure v) = fromTypeable v castVal (VMut v) = fromTypeable v castVal (VExt v) = fromTypeable v -- | Value view. Contains methods for inspecting values: getting -- their metaclass, ids, stringification and so on. class ICoercible m a => IValue m a where -- | lift an ASTish leaf type to a value. Using this convenience method -- you can say "val (NInt 42)" instead of "Val (VNative (NInt 42))". val :: a -> Val -- | retrieve metaclass instance of a value. valMeta :: a -> Class valMeta = cast . takeTypeName "" . reverse . show . typeOf where -- Here we intuit "Str" from "Pugs.Val.Str.PureStr". takeTypeName acc [] = acc takeTypeName acc (x:xs) | isLower x = takeTypeName (x:acc) xs | otherwise = x:acc -- | Stringification of arbitrary values. valShow :: a -> PureStr valShow _ = cast "" -- | Identity. valId :: a -> WHICH valId x = cast (NUint (W# (unsafeCoerce# x))) -- | Comparison. valCompare :: a -> a -> Ordering valCompare x y = valId x `compare` valId y instance ICoercible SIO Val where -- XXX - have to invent a generic map somehow -- DrIFT anyone? asBit VUndef{} = cast False asBit (VNative x) = cast $ asBit x asBit (VPure x) = cast $ asBit x asBit (VMut x) = cast $ asBit x asInt (VPure x) = cast $ asInt x asNum (VPure x) = cast $ asNum x asStr (VPure x) = cast $ asStr x asItem = Just . itemVal asList = Just . listVal asNative (VPure x) = cast $ asNative x -- evaluate a Val in Item context, a.k.a. rvalue, a.k.a. "is readonly" itemVal :: Val -> SIO Val itemVal v@(VPure x) = f v x asItem itemVal v@(VMut x) = f v x asItem itemVal v@(VExt x) = f v x asItem itemVal v = return v -- evaluate a Val in List context, a.k.a. flattening, a.k.a. "is slurpy" listVal :: Val -> SIO PureList listVal v@(VPure x) = f v x asList listVal v@(VMut x) = f v x asList listVal v@(VExt x) = f v x asList listVal v = cast v f v x g = maybe (cast v) cast (g x) instance ((:>:) PureList) Val where cast = singleton -- . Left . singleton instance IValue SIO Val where val = id valId VUndef{} = cast (NBit False) valId (VNative x) = Just x valId (VPure x) = valId x valId (VMut x) = valId x valId (VExt x) = valId x valCompare = compare valMeta (VUndef x) = cast . show . typeOf $ x valMeta (VNative x) = valMeta x valMeta (VPure x) = valMeta x valMeta (VMut x) = valMeta x valMeta (VExt x) = valMeta x valShow = cast . show -- instance Pure PureStr where -- pureId x = cast (cast x :: ByteString) instance ((:>:) WHICH) NativeBuf where cast = cast . NBuf instance ICoercible P ValNative where asNative = return . id instance IValue P ValNative where val = VNative valMeta NBit{} = cast "bit" valMeta NInt{} = cast "int" valMeta NUint{} = cast "uint" valMeta NBuf{} = cast "buf" valMeta NNum{} = cast "num" valMeta NComplex{} = cast "complex" valCompare = compare valShow = cast . show valId x = cast x -- | 'WHICH' is an unique ID that distinguishes two @Val@s of the same type from each other. type WHICH = Maybe ValNative instance ((:>:) WHICH) ValNative where cast = Just -------------------------------------------------------------------------------------- -- | L data ValUndef = UUndef -- ^ "my $x" | UWhatever -- ^ "my $x = *" | UFailure { f_err :: !WHICH } -- ^ "my $x = fail 'oops'" | UProto { p_meta :: !WHICH } -- ^ "my $x = Dog" deriving (Show, Eq, Ord, Data, Typeable) -------------------------------------------------------------------------------------- -- | Unboxed values. data ValNative = NBit !NativeBit -- ^ 0 | NInt !NativeInt -- ^ -3 | NUint !NativeUint -- ^ 7 | NBuf !NativeBuf -- ^ (a raw chunk of ints or uints) | NNum !NativeNum -- ^ 4.2 | NComplex !NativeComplex -- ^ (45 - 9i) deriving (Show, Eq, Ord, Data, Typeable) type NativeBit = Bool type NativeInt = Int type NativeUint = Word type NativeBuf = ByteString type NativeNum = Float -- Haskell's Complex type does not instantiate Ord and Data. newtype NativeComplex = MkNComplex { unComplex :: Complex NativeNum } deriving (Show, Eq, Typeable) instance Ord NativeComplex where compare = error "NativeComplex numbers cannot be ordered" instance Data NativeComplex where -- gunfold = error "gunfold NativeComplex" toConstr = error "toConstr NativeComplex" dataTypeOf = error "dataTypeOf NativeComplex" -------------------------------------------------------------------------------------- -- | L -- | Pure values need not be in a monad, but we put them in the trivial -- Identity so that they are at the same monadic depth as Mut and Ext. type P = Identity instance Typeable1 P class (ICoercible P a, Ord a, Show a) => Pure a where purePretty :: a -> Doc purePretty = text . show instance (ICoercible P a, Ord a, Show a) => Pure a where {} liftP :: Monad m => P a -> m a liftP = return . runIdentity instance Pure a => IValue P a where val = VPure valId = liftP . asNative valShow = cast . show valCompare = compare instance Mut a => IValue STM a where val = VMut instance Ext a => IValue SIO a where val = VExt class ICoercible STM a => Mut a where {} instance ICoercible STM a => Mut a where {} class ICoercible SIO a => Ext a where {} instance ICoercible SIO a => Ext a where {} -- type Class = PureStr -- XXX - Wrong dynEq :: (Typeable a, Typeable b, Eq a) => a -> b -> Bool dynEq x y = case Typeable.cast y of Just y' -> x == y' Nothing -> False dynCompare :: forall a b ma mb. (IValue ma a, IValue mb b) => a -> b -> Ordering dynCompare x y = case Typeable.cast y of Just y' -> valCompare x y' Nothing -> compare (show $ typeOf x) (show $ typeOf y) {- = PBit !PureBit | PInt !PureInt | PStr !PureStr | PNum !PureNum | PComplex !PureComplex | PBool !PureBool | PException !PureException -- XXX | PCode !PureCode | PBlock !PureCode -- XXX: or more primitive type? | PList !PureList | PSeq !PureSeq | PRange !PureRange | PSet !PureSet | PJunc !PureJunc | PPair !PurePair | PMap !PureMap | PSig !PureSig | PCap !PureCap deriving (Show, Eq, Ord, Data, Typeable) {-!derive: YAML_Pos, Perl6Class, MooseClass!-} -} type PureBool = Bool type PureException = () -- XXX *very* bogus type PureCode = () -- XXX *very* bogus type PureCap = () type PureSet = Set Val type PureSeq = Seq Val type PureComplex = () type PureRange = () type PureJunc = () type PurePair = () type PureMap = () {- -------------------------------------------------------------------------------------- -- | L minus IO types -- Computations on these types take place in the STM monad. data ValMut = MScalar !MutScalar | MArray !MutArray | MHash !MutHash | MBuf !MutBuf | MRoutine !MutRoutine | MSub !MutRoutine -- ? | MMethod !MutRoutine -- ? | MSubmethod !MutRoutine -- ? | MMacro -- ??? | MRegex !MutVRule -- XXX: maybe move to pure | MMatch !MutVMatch | MPackage !MutPackage | MModule !MutModule | MClass !MutClass | MRole !MutRole | MGrammar !MutGrammar | MObject !MutObject -- ? or ObjectId? | MForeign !MutDynamic -- ...? deriving (Show, Eq, Ord, Data, Typeable) {-!derive: YAML_Pos, Perl6Class, MooseClass!-} -} -------------------------------------------------------------------------------------- {- -- | Obviously side-effectual types such as file handles. -- Computations on these types must take place in the IO monad. data ValExt = IFile !ExtFile -- ^ File handle | ISocket !ExtSocket -- ^ Socket handle | IThread !ExtThread -- ^ Thread handle | IProcess !ExtProcess -- ^ Process handle deriving (Show, Eq, Ord, Data, Typeable) {-!derive: YAML_Pos, Perl6Class, MooseClass!-} -} type ExtFile = () type ExtSocket = () type ExtThread = () type ExtProcess = () -------------------------------------------------------------------------------------- -- | General purpose mapping from identifiers to values. type Table = Map.Map ID Val {- 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. Pads are stored in the current 'Code', and lexical lookups proceed through progressively outer scopes until an item is found. For dynamic variables (e.g., "our"), the pad holding the items is located in the package. -} newtype Pad = MkPad { padEntries :: Map.Map Var PadEntry } deriving (Show, Eq, Ord, Data, Typeable) {-!derive: YAML_Pos, Perl6Class, MooseClass!-} newtype EntryStorage = MkStorage { s_cell :: TVar Val } deriving (Data, Typeable) {-!derive: YAML_Pos, Perl6Class, MooseClass!-} instance Show EntryStorage where show _ = error "can't show EntryStorage" instance Ord EntryStorage where compare _ = error "can't compare EntryStorage" instance Eq EntryStorage where (==) = error "can't equate EntryStorage" data EntryDeclarator = DeclMy | DeclOur | DeclHas | DeclState | DeclConstant deriving (Show, Eq, Ord, Data, Typeable) {-!derive: YAML_Pos, Perl6Class, MooseClass!-} data PadEntry = MkEntry { e_declarator :: EntryDeclarator -- ^ my etc. , e_storage :: EntryStorage -- ^ stored value } deriving (Show, Eq, Ord, Data, Typeable) {-!derive: YAML_Pos, Perl6Class, MooseClass!-} -------------------------------------------------------------------------------------- -- type Var = Types.Var {- Variable specification. This belongs in an AST .hs file, not here but until - it finds its home we will give it boarding. - XXX - Augment Pugs.Types.Var to reason about caller/outer, not here! -} {- data Var = VarLexical { v_name :: ID , v_callerCount :: Int , v_outerCount :: Int } | VarDynamic { v_name :: ID , v_packageName :: [ID] } | VarMagic { v_magic :: Magic } deriving (Show, Eq, Ord, Data, Typeable) {-!derive: YAML_Pos, Perl6Class, MooseClass!-} -} data Magic = MOS -- ^ $?OS Which os am I compiled for? | MOSVer -- ^ $?OSVER Which os version am I compiled for? | MPerlVer -- ^ $?PERLVER Which Perl version am I compiled for? | MFile -- ^ $?FILE Which file am I in? | MLine -- ^ $?LINE Which line am I at? | MScalarPackage -- ^ $?PACKAGE Which package am I in? | MArrayPackages -- ^ @?PACKAGE Which packages am I in? | MScalarModule -- ^ $?MODULE Which module am I in? | MArrayModules -- ^ @?MODULE Which modules am I in? | MScalarClass -- ^ $?CLASS Which class am I in? (as variable) | MArrayClasses -- ^ @?CLASS Which classes am I in? | MScalarRole -- ^ $?ROLE Which role am I in? (as variable) | MArrayRoles -- ^ @?ROLE Which roles am I in? | MScalarGrammar -- ^ $?GRAMMAR Which grammar am I in? | MArrayGrammars -- ^ @?GRAMMAR Which grammars am I in? | MParser -- ^ $?PARSER Which Perl grammar was used to -- ^ parse this statement? | MScalarRoutine -- ^ &?ROUTINE Which routine am I in? | MArrayRoutines -- ^ @?ROUTINE Which routines am I in? | MScalarBlock -- ^ &?BLOCK Which block am I in? | MArrayBlocks -- ^ @?BLOCK Which blocks am I in? deriving (Show, Eq, Ord, Data, Typeable) {-!derive: YAML_Pos, Perl6Class, MooseClass!-} -------------------------------------------------------------------------------------- formatVal :: Val -> Doc formatVal (VUndef v) = text $ case v of (UUndef) -> "undef" (UWhatever) -> "{whatever}" (UFailure x) -> "{failure:" ++ (show x) ++ "}" -- what we really want is to port Pretty to fps (UProto x) -> "{proto:" ++ (show x) ++ "}" formatVal (VNative v) = text $ case v of (NBit x) -> if x then "True" else "False" (NInt x) -> show x (NUint x) -> show x (NBuf _) -> "{Buf}" (NNum x) -> show x (NComplex (MkNComplex x)) -> (show "(") ++ (show $ realPart x) ++ " " ++ (if (0 >) (imagPart x) then "- " ++ (show $ 0 - imagPart x) else "+ " ++ (show $ imagPart x)) ++ "*Math::i)" formatVal (VPure v) = purePretty v formatVal x = text $ show x -- (NComplex r i(s@i')) -> "(" ++ (show r) ++ " " ++ -- (if s == '-' then ("- " ++ show i') else ("+ " ++ show i)) ++ "*i)" --formatVal (VPure v) = runIdentity -------------------------------------------------------------------------------------- {-* Generated by DrIFT : Look, but Don't Touch. *-} instance Show Val where showsPrec d (VUndef aa) = showParen (d >= 10) (showString "VUndef" . showChar ' ' . showsPrec 10 aa) showsPrec d (VNative aa) = showParen (d >= 10) (showString "VNative" . showChar ' ' . showsPrec 10 aa) showsPrec d (VPure aa) = showParen (d >= 10) (showString "VPure (" . showsPrec 10 aa . showChar ')') showsPrec d (VMut aa) = showParen (d >= 10) (showString "VMut (" . (cast(valShow aa) ++) . showChar ')') showsPrec d (VExt aa) = showParen (d >= 10) (showString "VExt (" . (cast(valShow aa) ++) . showChar ')') instance Eq Val where (VUndef aa) == (VUndef aa') = aa == aa' (VNative aa) == (VNative aa') = aa == aa' (VPure aa) == (VPure aa') = dynEq aa aa' (VMut aa) == (VMut aa') = valId aa == valId aa' (VExt aa) == (VExt aa') = valId aa == valId aa' _ == _ = False instance Ord Val where compare (VUndef aa) (VUndef aa') = compare aa aa' compare (VUndef _) (VNative _) = LT compare (VUndef _) (VPure _) = LT compare (VUndef _) (VMut _) = LT compare (VUndef _) (VExt _) = LT compare (VNative _) (VUndef _) = GT compare (VNative aa) (VNative aa') = compare aa aa' compare (VNative _) (VPure _) = LT compare (VNative _) (VMut _) = LT compare (VNative _) (VExt _) = LT compare (VPure _) (VUndef _) = GT compare (VPure _) (VNative _) = GT compare (VPure aa) (VPure aa') = dynCompare aa aa' compare (VPure _) (VMut _) = LT compare (VPure _) (VExt _) = LT compare (VMut _) (VUndef _) = GT compare (VMut _) (VNative _) = GT compare (VMut _) (VPure _) = GT compare (VMut aa) (VMut aa') = dynCompare aa aa' compare (VMut _) (VExt _) = LT compare (VExt _) (VUndef _) = GT compare (VExt _) (VNative _) = GT compare (VExt _) (VPure _) = GT compare (VExt _) (VMut _) = GT compare (VExt aa) (VExt aa') = dynCompare aa aa' -}