Changeset 15374

Show
Ignore:
Timestamp:
02/28/07 00:25:27 (21 months ago)
Author:
audreyt
Message:

* Adapt existing newVal implementation in Pugs.Val to MO.

A "Val" is now simply an invocant within the Eval monad.

Location:
src
Files:
13 modified

Legend:

Unmodified
Added
Removed

  • src/MO/Base.hs

    r14697 r15374  
    55import Data.Maybe 
    66import Data.Typeable 
    7 import MO.Util 
    8  
    97 
    108-- | open type to represent Code 
    11 class Monad m => Code m c where 
     9class Monad m => Codeable m c where 
    1210    run :: c -> Arguments m -> m (Invocant m) 
    1311 
    … …  
    1513newtype NoCode m = NoCode (Invocant m) 
    1614 
    17 instance (Typeable (NoCode m), Monad m) => Code m (NoCode m) where 
     15instance (Typeable (NoCode m), Monad m) => Codeable m (NoCode m) where 
    1816    run (NoCode obj) _ = return obj 
    1917instance Show (NoCode m) where 
    … …  
    2321newtype PureCode = PureCode (forall m. (Typeable1 m, Monad m) => Arguments m -> Invocant m) 
    2422 
    25 instance (Typeable1 m, Monad m) => Code m PureCode where 
     23instance (Typeable1 m, Monad m) => Codeable m PureCode where 
    2624    run (PureCode f) a = return (f a) 
    2725instance Show PureCode where 
    … …  
    3129newtype Monad m => HsCode m = HsCode (Arguments m -> m (Invocant m)) 
    3230 
    33 instance (Typeable1 m, Monad m) => Code m (HsCode m) where 
     31instance (Typeable1 m, Monad m) => Codeable m (HsCode m) where 
    3432    run (HsCode f) a = f a 
    3533instance Show (HsCode m) where 

  • src/MO/Compile.hs

    r14723 r15374  
    4242 
    4343data MethodCompiled m 
    44     = forall c. Code m c => MkMethodCompiled c 
     44    = forall c. Codeable m c => MkMethodCompiled c 
    4545 
    46 -- NOTE: Maybe I should instantiate MethodCompiled for Code? :P 
     46-- NOTE: Maybe I should instantiate MethodCompiled for Codeable? :P 
    4747runMC :: MethodCompiled m -> Arguments m -> m (Invocant m) 
    4848runMC (MkMethodCompiled c) = run c 

  • src/Pugs/AST.hs

    r15297 r15374  
    3939import Pugs.AST.SIO 
    4040import Pugs.AST.Pad 
    41 import Pugs.Val (val, castVal, formatVal, PureBit, PureBool, PureStr, PureInt, PureNum, Capt(..), ValCapt, Feed(..), ValFeed, emptyFeed, Sig(..), SigParam(..), ParamAccess(..), ParamDefault(..)) 
     41import Pugs.Val hiding (Val, Param, listVal) -- (val, castVal, formatVal, PureBit, PureBool, PureStr, PureInt, PureNum, Capt(..), ValCapt, Feed(..), ValFeed, emptyFeed, Sig(..), SigParam(..), ParamAccess(..), ParamDefault(..)) 
    4242 
    4343{-| 

  • src/Pugs/AST/Eval.hs

    r15297 r15374  
    1010 
    1111{- Eval Monad -} 
    12 type Eval = EvalT (ReaderT Env SIO) 
    13 newtype EvalT m a = EvalT { runEvalT :: ContT (EvalResult Val) m (EvalResult a) } 
     12 
     13newtype Eval a = EvalT { runEvalT :: ContT (EvalResult Val) (ReaderT Env SIO) (EvalResult a) } 
     14    deriving (Typeable) 
    1415 
    1516data EvalResult a 
    … …  
    3132 
    3233tryIO :: a -> IO a -> Eval a 
    33 tryIO err = lift . liftIO . (`catchIO` (const $ return err)) 
     34tryIO err = liftEval . liftIO . (`catchIO` (const $ return err)) 
    3435 
    3536{-| 
    … …  
    116117    strMsg = errStr 
    117118 
     119liftEval m = EvalT $ do 
     120    a <- ContT (m >>=) 
     121    return (RNormal a) 
     122 
     123{- 
    118124instance MonadTrans EvalT where 
    119125    lift m = EvalT $ do 
    120126        a <- ContT (m >>=) 
    121127        return (RNormal a) 
     128-} 
    122129 
    123130instance Functor Eval where 
    … …  
    129136 
    130137instance MonadIO Eval where 
    131     liftIO = lift . liftIO 
     138    liftIO = liftEval . liftIO 
    132139 
    133140instance MonadError Val Eval where 
    … …  
    185192 
    186193instance MonadReader Env Eval where 
    187     ask       = lift ask 
     194    ask       = liftEval ask 
    188195    local f m = EvalT $ local f (runEvalT m) 
    189196 

  • src/Pugs/AST/Internals.hs

    r15297 r15374  
    22 
    33module Pugs.AST.Internals ( 
    4     Eval,      -- uses Val, Env, SIO 
     4    Eval(..),      -- uses Val, Env, SIO 
    55    Ann(..),   -- Cxt, Pos, Prag 
    66    Exp(..),   -- uses Pad, Eval, Val 
    … …  
    99    Value(..), -- uses Val, Eval 
    1010    InitDat(..), 
    11  
    12     EvalT(..), SubAssoc(..), 
     11    SubAssoc(..), 
    1312 
    1413    Pad(..), PadEntry(..), PadMutator, -- uses Var, TVar, VRef 
    … …  
    216215    fromVV :: Val.Val -> Eval n 
    217216    fromVV v = do 
    218         str <- liftSIO (Val.asStr v) 
     217        str <- Val.asStr v 
    219218        fail $ "Cannot cast from VV (" ++ cast str ++ ") to " ++ errType (undefined :: n) 
    220219    toVV :: n -> Eval Val 
    … …  
    249248 
    250249toVV' :: Val -> Eval Val 
    251 toVV' VUndef   = return $ VV $ Val.val $ Val.VUndef $ Val.UUndef 
    252 toVV' (VBool v) = return $ VV $ Val.val $ ((cast v) :: Val.PureBit) 
     250toVV' VUndef   = return $ VV $ Val.val $ () 
     251toVV' (VBool v)= return $ VV $ Val.val $ ((cast v) :: Val.PureBit) 
    253252toVV' (VInt v) = return $ VV $ Val.val $ ((cast v) :: Val.PureInt) 
    254253toVV' (VNum v) = return $ VV $ Val.val $ ((cast v) :: Val.PureNum) 
    … …  
    419418    castV = VBool 
    420419    fromSV sv = liftIO $ svToVBool sv 
    421     fromVV vv = liftSIO $ fmap cast (Val.asBit vv) 
     420    fromVV vv = fmap cast (Val.asBit vv) 
    422421    doCast (VJunc j)   = juncToBool j 
    423422    doCast (VMatch m)  = return $ matchOk m 
    … …  
    436435instance Value VInt where 
    437436    castV = VInt 
    438     fromVV vv = liftSIO $ fmap cast (Val.asInt vv) 
     437    fromVV vv = fmap cast (Val.asInt vv) 
    439438    fromSV sv = liftIO $ svToVInt sv 
    440439    doCast (VInt i)     = return $ i 
    … …  
    464463instance Value VNum where 
    465464    castV = VNum 
    466     fromVV vv = liftSIO $ fmap cast (Val.asNum vv) 
     465    fromVV vv = fmap cast (Val.asNum vv) 
    467466    fromSV sv = liftIO $ svToVNum sv 
    468467    doCast VUndef       = return $ 0 
    … …  
    514513    castV = VStr . cast 
    515514    fromSV sv = fmap cast (liftIO $ svToVStr sv) 
    516     fromVV vv = liftSIO $ cast (Val.asStr vv) 
     515    fromVV vv = cast (Val.asStr vv) 
    517516    fromVal = fmap (cast :: VStr -> ID) . fromVal 
    518517    doCast = fmap (cast :: VStr -> ID) . doCast 
    … …  
    521520    castV = VStr 
    522521    fromSV sv = liftIO $ svToVStr sv 
    523     fromVV vv = liftSIO $ cast (Val.asStr vv) 
     522    fromVV vv = cast (Val.asStr vv) 
    524523    fromVal (VList l)    = return . unwords =<< mapM fromVal l 
    525524    fromVal v@(PerlSV _) = fromVal' v 
    … …  
    19251924instance Typeable VRef where 
    19261925    typeOf (MkRef x) = typeOf x 
    1927  
    1928 instance Typeable1 (EvalT (ReaderT Env SIO)) where 
    1929     typeOf1 _ = typeOf () 
    19301926 
    19311927instance Typeable1 IVar where 

  • src/Pugs/AST/SIO.hs

    r12324 r15374  
    1717 
    1818data SIO a = MkSTM !(STM a) | MkIO !(IO a) | MkSIO !a 
     19    deriving (Typeable) 
    1920 
    2021{-# INLINE runSIO #-} 

  • src/Pugs/Class.hs

    r15373 r15374  
    2626 
    2727class (Typeable a, Ord a, Typeable1 m, Monad m) => Boxable m a | a -> m where 
    28     classOfBox :: a -> MI m 
    29     fromObjBox :: Invocant m -> m a 
     28    classOf :: a -> MI m 
     29    classOf o = mkBoxClass ty ([] :: [(String, String -> m (Invocant m))]) 
     30        where 
     31        ty = takeTypeName "" . reverse . show $ typeOf o 
     32        -- Here we intuit "Str" from "Pugs.Val.Str.PureStr". 
     33        takeTypeName acc [] = acc 
     34        takeTypeName acc (x:xs) 
     35            | isLower x = takeTypeName (x:acc) xs 
     36            | otherwise = x:acc 
     37 
     38    fromObj :: Invocant m -> m a 
     39    fromObj (MkInvocant x _) = fromTypeable x 
    3040 
    3141(...) :: forall t a b (m :: * -> *). (Show b, Boxable m b) => t -> (a -> b) -> (t, a -> m (Invocant m)) 
    … …  
    3646 
    3747mkObj :: (Show a, Boxable m a) => a -> m (Invocant m) 
    38 mkObj x = return $ MkInvocant x (class_interface (classOfBox x)) 
     48mkObj x = return $ MkInvocant x (class_interface (classOf x)) 
    3949 
    4050mkObjM :: (Show a, Boxable m a) => m a -> m (Invocant m) 
    4151mkObjM x = do 
    4252    x' <- x 
    43     return $ MkInvocant x' (class_interface (classOfBox x')) 
     53    return $ MkInvocant x' (class_interface (classOf x')) 
    4454 
    4555mkBoxClass :: forall t (m :: * -> *) (m1 :: * -> *). 
    4656    ( Method m1 (AnyMethod m1) 
    47     , Code m1 (HsCode m) 
     57    , Codeable m1 (HsCode m) 
    4858    , Typeable t 
    4959    , Typeable1 m 
    … …  
    6373mkBoxMethod :: forall t (m1 :: * -> *) (m :: * -> *). 
    6474    ( Method m (SimpleMethod m) 
    65     , Code m (HsCode m1) 
     75    , Codeable m (HsCode m1) 
    6676    , Typeable t 
    6777    , Typeable1 m1 

  • src/Pugs/Eval/Var.hs

    r15373 r15374  
    237237                -- callMethod methName [] 
    238238                -- inv ./ meth = ivDispatch inv $ MkMethodInvocation meth (mkArgs []) 
    239                 case invVV of 
    240                     Val.VPure p -> return . runIdentity $ do 
    241                         obj <- mkObj p 
    242                         res <- fromObjBox =<< obj ./ cast methName 
    243                         return . castV $ Val.VPure (res `asTypeOf` p) 
    244                     _       -> do 
    245                         return . castV $ "CCall " ++ show methName ++ " " ++ show capt 
     239                resVV <- invVV ./ cast methName 
     240                return . castV $ resVV 
    246241            } 
    247242 

  • src/Pugs/Exp.hs

    r13496 r15374  
    1111import Pugs.Internals 
    1212import Pugs.Val 
     13import Pugs.Types (Var) 
    1314import qualified Pugs.AST.Internals (Exp) 
    1415 

  • src/Pugs/Val.hs

    r15297 r15374  
    11{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances -fallow-overlapping-instances -fno-warn-missing-methods -cpp #-} 
    2 {-! global : YAML_Pos, Perl6Class, MooseClass !-} 
    32{-| 
    43    Perl 6 Values. 
    … …  
    98>   And shining spears were laid in hoard... 
    109-} 
     10 
     11module Pugs.Val ( 
     12    module Pugs.Val, 
     13    module Pugs.Val.Code, 
     14) where 
     15import Pugs.Class 
     16import Pugs.AST.Eval 
     17import Pugs.Val.Code 
     18import Pugs.Internals 
     19import Text.PrettyPrint 
     20import qualified Data.ByteString.Char8 as Str 
     21 
     22type Val = Invocant Eval 
     23 
     24asStr :: Val -> Eval PureStr 
     25asStr (MkInvocant x _) = return (cast (show x)) 
     26asBit :: Val -> Eval PureBit 
     27asBit _ = return (cast True) 
     28asInt :: Val -> Eval PureInt 
     29asInt _ = return (cast (0 :: Int)) 
     30asNum :: Val -> Eval PureNum 
     31asNum _ = return (cast (0 :: Double)) 
     32listVal :: Val -> Eval PureList 
     33listVal = return . (:[]) 
     34itemVal :: Val -> Eval Val 
     35itemVal = return 
     36 
     37valMeta :: Val -> PureStr 
     38valMeta _ = cast "Object" 
     39 
     40valShow :: Val -> PureStr 
     41valShow = cast "<opaque>" 
     42 
     43val :: (Show a, Boxable m a) => a -> (Invocant m) 
     44val x = MkInvocant x (class_interface (classOf x)) 
     45 
     46formatVal :: Val -> Doc 
     47formatVal (MkInvocant x _) = text (show x) 
     48 
     49castVal :: forall a m . (Monad m, Typeable a) => Val -> m a 
     50castVal (MkInvocant v _)  = fromTypeable v 
     51 
     52instance ((:>:) PureNum) Rational where cast = NRational 
     53instance ((:<:) PureNum) Rational where 
     54    castBack (NDouble   x) = toRational x 
     55    castBack (NRational x) = x 
     56instance ((:>:) PureNum) Double where cast = NDouble 
     57instance ((:<:) PureNum) Double where 
     58    castBack (NDouble   x) = x 
     59    castBack (NRational x) = fromRational x 
     60 
     61instance ((:>:) PureInt) Integer where cast = IFinite 
     62instance ((:<:) PureInt) Integer where 
     63    castBack (IFinite i) = i 
     64    castBack INotANumber = error "NaN" 
     65    castBack (IInfinite SPositive) = error "+Infinity" 
     66    castBack (IInfinite SNegative) = error "-Infinity" 
     67 
     68instance ((:>:) PureInt) Int where cast = IFinite . toInteger  
     69instance ((:<:) PureInt) Int where 
     70    castBack (IFinite i) = fromInteger i 
     71    castBack INotANumber = error "NaN" 
     72    castBack (IInfinite SPositive) = error "+Infinity" 
     73    castBack (IInfinite SNegative) = error "-Infinity" 
     74type PureList = [Val] -- Seq (Either PureSeq PureRange) -- XXX - *very bogus* 
     75 
     76newtype PureBit = MkBit Bool 
     77    deriving (Typeable, Show, Eq, Ord, Data, (:>:) Bool, (:<:) Bool) 
     78 
     79newtype PureStr = MkStr { unStr :: ByteString } deriving 
     80    ( Typeable, Show, Eq, Ord, Data 
     81    , (:>:) ID, (:<:) ID 
     82    , (:>:) String, (:<:) String 
     83    , (:>:) ByteString, (:<:) ByteString 
     84    ) 
     85 
     86data PureInt 
     87    = IFinite      !Integer 
     88    | IInfinite    !Sign 
     89    | INotANumber 
     90    deriving (Typeable, Show, Eq, Ord, Data) 
     91 
     92data PureNum 
     93    = NDouble   !Double              -- change to "!NativeDouble" 
     94    | NRational !Rational 
     95    deriving (Typeable, Show, Eq, Ord, Data) 
     96 
     97data Sign 
     98    = SPositive 
     99    | SNegative 
     100    deriving (Show, Eq, Ord, Data, Typeable) 
     101 
     102instance Boxable Eval () 
     103instance Boxable Eval PureInt 
     104instance Boxable Eval PureNum 
     105instance Boxable Eval PureSig 
     106instance Boxable Eval PureBit 
     107instance Boxable Eval ValCapt 
     108 
     109instance Boxable Eval PureStr where 
     110    classOf _ = mkBoxClass "Str" 
     111        [ "reverse"    ... (MkStr . Str.reverse . unStr) 
     112        ] 
     113 
     114{- 
    11115module Pugs.Val ( 
    12116    IValue(..), Val(..), ValUndef(..), ValNative, P, 
    … …  
    22126) where 
    23127import Pugs.Internals 
     128import Pugs.Class 
    24129import GHC.Exts 
    25130import Data.Generics.Basics hiding (cast) 
    … …  
    241346instance ICoercible SIO a => Ext a where {} 
    242347 
    243 type Class = PureStr -- XXX - Wrong 
     348-- type Class = PureStr -- XXX - Wrong 
    244349 
    245350dynEq :: (Typeable a, Typeable b, Eq a) => a -> b -> Bool 
    … …  
    499604    compare (VExt aa) (VExt aa') = dynCompare aa aa' 
    500605 
     606 
     607-} 

  • src/Pugs/Val.hs-boot

    r15096 r15374  
    22 
    33module Pugs.Val where 
     4import Pugs.Class 
     5import Pugs.AST.Eval 
    46 
    5 import Pugs.Types (Var(..)) 
    6 import Pugs.Internals 
    7 import qualified Data.ByteString as Buf 
     7type Val = Invocant Eval 
    88 
    9 data Val 
     9{- 
     10newtype Pad = MkPad { padEntries :: Map Var PadEntry } 
     11type Table = Map ID Val 
     12data PadEntry 
     13 
     14instance Show Pad 
     15instance Show Val 
     16 
    1017data ValNative 
    1118    = NBit      !NativeBit 
    … …  
    2532type P = Identity 
    2633instance Typeable1 P 
    27 type Table = Map ID Val 
    28 newtype Pad = MkPad { padEntries :: Map Var PadEntry } 
    29 data PadEntry 
    3034--data Stmt 
     35-} 

  • src/Pugs/Val/Base.hs

    r15373 r15374  
    88import Pugs.Class 
    99import {-# SOURCE #-} Pugs.Val 
     10 
     11{- 
    1012 
    1113 
    … …  
    136138        ] 
    137139 
     140 
     141-} 

  • src/Pugs/Val/Code.hs

    r15297 r15374  
    1 {- 
    2  - {-# OPTIONS_GHC -fglasgow-exts -fallow-overlapping-instances #-} 
     1{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances -fallow-overlapping-instances -fno-warn-missing-methods #-} 
    32module Pugs.Val.Code where 
    43import Pugs.Internals 
    54import Pugs.Types 
    6  
     5import Data.Monoid 
     6import qualified Data.Map as Map 
     7import qualified Data.Set as Set 
     8import qualified Pugs.Types as Types 
     9 
     10import {-# SOURCE #-} Pugs.Exp 
    711import {-# SOURCE #-} Pugs.Val 
    8 --import {-# SOURCE #-} Pugs.Val.Sig 
    9 -} 
    10  
     12 
     13 
     14type Code = () 
     15type Table = Map ID Val 
     16 
     17{- 
    1118-- | AST for a primitive Code object 
    1219data Code 
    … …  
    5865 
    5966-------------------------------------------------------------------------------------- 
     67-} 
    6068 
    6169-- | AST for function signature. Separated to method and function variants 
    … …  
    139147    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos, Perl6Class, MooseClass!-} 
    140148 
     149{- 
    141150instance ICoercible P Sig where 
    142151    asStr = return . cast . render . purePretty 
    143152 
    144153instance Pure Sig where 
    145     purePretty s = colon <> (parens $ prettySig s) 
    146      
     154-} 
     155{- 
     156purePretty s = colon <> (parens $ prettySig s) 
     157 
    147158prettySig :: Sig -> Doc 
    148159prettySig s@(SigMethSingle {}) = invocant <> colon `invSpace` (prettySubSig s) 
    … …  
    188199    debugDump   = if True then empty else braces $ text $ show p -- XXX delme 
    189200-------------------------------------------------------------------------------------- 
     201-} 
    190202 
    191203-- | a Capture is a frozen version of the arguments to an application. 
    … …  
    222234type ValFeed = Feed Val 
    223235 
    224 instance ICoercible P ValCapt where 
    225         asStr _ = return (cast "<capt>") -- XXX 
    226