Pugs 6.2.13.20110519 → 6.2.13.20110925
raw patch · 13 files changed
+98/−78 lines, 13 filesdep −haskell98
Dependencies removed: haskell98
Files
- Configure.PL +4/−2
- Pugs.cabal +3/−3
- src/Pugs/AST/Internals.hs +8/−5
- src/Pugs/AST/Internals/Instances.hs +4/−5
- src/Pugs/AST/SIO.hs +0/−3
- src/Pugs/AST/Types.hs +3/−2
- src/Pugs/Class.hs +14/−11
- src/Pugs/Compile/Pugs.hs +5/−2
- src/Pugs/Embed/Perl5.hs +1/−1
- src/Pugs/Eval.hs +27/−19
- src/Pugs/Meta/Perl5.hs +3/−2
- src/Pugs/Types.hs +7/−4
- src/Pugs/Types/Array.hs +19/−19
Configure.PL view
@@ -83,8 +83,10 @@ . # Hack for OSX 10.6-$info =~ s/-arch x86_64 (-arch i386) -arch ppc/$1/g;-$info =~ s/-opt[lc]-arch -opt[lc]x86_64 (-opt[lc]-arch -opt[lc]i386) -opt[lc]-arch -opt[lc]ppc/$1/g;+$info =~ s/-arch x86_64 (-arch i386)(?: -arch ppc)?/$1/g;+$info =~ s/(-arch i386) -arch x86_64(?: -arch ppc)?/$1/g;+$info =~ s/-opt[lc]-arch -opt[lc]x86_64 (-opt[lc]-arch -opt[lc]i386)(?: -opt[lc]-arch -opt[lc]ppc)?/$1/g;+$info =~ s/(-opt[lc]-arch -opt[lc]i386) -opt[lc]-arch -opt[lc]x86_64(?: -opt[lc]-arch -opt[lc]ppc)?/$1/g; open INFO, ">Pugs.buildinfo" or die "Cannot write build info: $!"; print INFO $info;
Pugs.cabal view
@@ -1,5 +1,5 @@ Name : Pugs-Version : 6.2.13.20110519+Version : 6.2.13.20110925 license : BSD3 license-file : LICENSE cabal-version : >= 1.2.3@@ -12,7 +12,7 @@ synopsis : A Perl 6 Implementation description : A Perl 6 Implementation author : Audrey Tang <audreyt@audreyt.org>-Tested-With: GHC==6.8.2, GHC==6.8.3, GHC==6.10.1, GHC==6.12.1+Tested-With: GHC==6.8.2, GHC==6.8.3, GHC==6.10.1, GHC==6.12.1, GHC==7.0.1, GHC==7.2.1 data-files : blib6/pugs/perl5/lib/Parse/Yapp/Driver.pm blib6/pugs/perl5/lib/Parse/Yapp/Grammar.pm@@ -161,7 +161,7 @@ extra-lib-dirs: /usr/lib /opt/local/lib build-depends:- base >= 4 && < 5, haskell98, filepath, mtl < 2.0.0.0, parsec >= 3.0.0.0, network,+ base >= 4 && < 5, filepath, mtl < 2.0.0.0, parsec >= 3.0.0.0, network, pretty, time, random, process, containers, bytestring, array, directory, utf8-string, binary, haskeline >= 0.6.4.0, FindBin, control-timeout >= 0.1.2,
src/Pugs/AST/Internals.hs view
@@ -112,8 +112,11 @@ import Pugs.AST.SIO import Pugs.Embed.Perl5 import qualified Pugs.Val as Val-import GHC.PArr import {-# SOURCE #-} Pugs.AST+import Data.Sequence (Seq, (><), (<|), (|>), fromList)+import Data.Foldable (toList)+import qualified Data.Sequence as Seq+import qualified Data.Foldable as F -- CPP Includes @@ -362,7 +365,7 @@ a <- stm $ readTVar iv let size = a_size a if size > abs (idx+1)- then return (a !: (idx `mod` size))+ then return (a `Seq.index` (idx `mod` size)) else errIndex def idx -- now we are all positive; either extend or return getArrayIndex idx def getArr ext = do@@ -370,7 +373,7 @@ a <- stm $ readTVar iv let size = a_size a if size > idx- then return (a !: idx)+ then return (a `Seq.index` idx) else case ext of Just doExt -> do { doExt; getArrayIndex idx def getArr Nothing } Nothing -> errIndex def idx@@ -728,7 +731,7 @@ "Item" -> io $ fmap scalarRef $ newTVarIO undef "Scalar" -> io $ fmap scalarRef $ newTVarIO undef "Array" -> io $ do- iv <- newTVarIO [::]+ iv <- newTVarIO mempty return $ arrayRef (MkIArray iv) "Hash" -> do h <- io (H.new (==) H.hashString)@@ -863,7 +866,7 @@ newArray :: (MonadSTM m) => VArray -> m (IVar VArray) newArray vals = stm $ do tvs <- mapM newScalar vals- iv <- newTVar (toP tvs)+ iv <- newTVar (fromList tvs) return $ IArray (MkIArray iv) newHash :: (MonadSTM m) => VHash -> m (IVar VHash)
src/Pugs/AST/Internals/Instances.hs view
@@ -50,6 +50,9 @@ import qualified Pugs.Val as Val import qualified Data.HashTable as H+import Data.Sequence (Seq)+import qualified Data.Sequence as Seq+import qualified Data.Foldable as F import Data.Binary import GHC.Exts (unsafeCoerce#)@@ -1397,10 +1400,6 @@ put _ = put () get = return (const $ return VUndef) -instance Binary [a] => Binary [:a:] where- put = put . fromP- get = fmap toP get- instance Binary VRef where put (MkRef (ICode cv)) | Just (mc :: VMultiCode) <- fromTypeable cv = do@@ -1461,7 +1460,7 @@ newArray' :: VArray -> IO (IVar VArray) newArray' vals = do tvs <- mapM newScalar' vals- iv <- newTVarIO (toP tvs)+ iv <- newTVarIO (Seq.fromList tvs) return $ IArray (MkIArray iv) instance Binary Pad where
src/Pugs/AST/SIO.hs view
@@ -53,9 +53,6 @@ class (Monad m, Functor m) => MonadSTM m where liftSIO :: SIO a -> m a liftSIO = fail "liftSIO not detailed for this monad"- {-# SPECIALISE liftSTM :: STM a -> STM a #-}- {-# SPECIALISE liftSTM :: STM a -> IO a #-}- {-# SPECIALISE liftSTM :: STM a -> SIO a #-} liftSTM :: STM a -> m a instance MonadSTM STM where
src/Pugs/AST/Types.hs view
@@ -4,8 +4,9 @@ import Pugs.Types import qualified Data.Set as Set import qualified Data.Map as Map- import qualified Data.HashTable as H+import Data.Sequence (Seq)+import qualified Data.Sequence as Seq import Pugs.AST.Eval import Pugs.AST.Utils@@ -281,7 +282,7 @@ , cu_ast :: !Exp -- AST of unit } deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos !-} -newtype IArray = MkIArray (TVar [:IVar VScalar:])+newtype IArray = MkIArray (TVar (Seq (IVar VScalar))) deriving (Typeable) type IArraySlice = [IVar VScalar]
src/Pugs/Class.hs view
@@ -29,6 +29,9 @@ import Control.Monad.Fix import qualified StringTable.AtomMap as AtomMap import qualified Data.Typeable as Typeable+import Data.Sequence (Seq)+import qualified Data.Sequence as Seq+import qualified Data.Foldable as F type Val = Invocant Eval type Call = MethodInvocation Eval@@ -57,7 +60,7 @@ | isLower x = takeTypeName (x:acc) xs | otherwise = x:acc -type MethodPrim a = (a -> [:Val:] -> Eval Val)+type MethodPrim a = (a -> Seq Val -> Eval Val) class Boxable b => MethodPrimable a b | a -> b where asPrim :: a -> MethodPrim b@@ -82,9 +85,9 @@ asPrim f x _ = fmap mkVal (f x) instance (Boxable a, Boxable z) => MethodPrimable (a -> Val -> Eval z) a where- asPrim f x args = fmap mkVal (f x (args !: 0))+ asPrim f x args = fmap mkVal (f x (args `Seq.index` 0)) -instance (Boxable a, Boxable z) => MethodPrimable (a -> [:Val:] -> Eval z) a where+instance (Boxable a, Boxable z) => MethodPrimable (a -> Seq Val -> Eval z) a where asPrim f x args = fmap mkVal (f x args) instance (Boxable a, Boxable z) => MethodPrimable (a -> [Val] -> Eval z) a where@@ -97,13 +100,13 @@ instance (Boxable a, Boxable b, Boxable z) => MethodPrimable (a -> b -> Eval z) a where asPrim f x args = do- y <- coerceVal (args !: 0)+ y <- coerceVal (args `Seq.index` 0) fmap mkVal (f x y) instance (Boxable a, Boxable b, Boxable c, Boxable z) => MethodPrimable (a -> b -> c -> Eval z) a where asPrim f x args = do- y <- coerceVal (args !: 0)- z <- coerceVal (args !: 1)+ y <- coerceVal (args `Seq.index` 0)+ z <- coerceVal (args `Seq.index` 1) fmap mkVal (f x y z) (...) :: MethodPrimable a b => String -> a -> (ID, MethodPrim b)@@ -147,7 +150,7 @@ { sm_name = meth , sm_definition = MkMethodCompiled $ \args -> do inv <- fromInvocant args :: Eval a- fun inv $ concatMapP f_positionals (c_feeds args)+ fun inv $ F.foldr mappend mempty (fmap f_positionals (c_feeds args)) } type PureClass = MOClass Eval@@ -155,7 +158,7 @@ instance (Show a, Typeable a, Ord a) => Boxable (Maybe a) instance Boxable a => Boxable [a]-instance Boxable a => Boxable [:a:]+instance Boxable a => Boxable (Seq a) instance Boxable ID instance Boxable PureClass where@@ -167,12 +170,12 @@ ] instance ((:>:) Call) String where- cast = (`MkMethodInvocation` CaptSub{ c_feeds = [::] }) . _cast+ cast = (`MkMethodInvocation` CaptSub{ c_feeds = mempty }) . _cast instance ((:>:) Call) ByteString where- cast = (`MkMethodInvocation` CaptSub{ c_feeds = [::] }) . cast+ cast = (`MkMethodInvocation` CaptSub{ c_feeds = mempty }) . cast instance ((:>:) Call (ByteString, [Val], AtomMap Val)) where cast (meth, pos, named) = MkMethodInvocation (cast meth) CaptSub- { c_feeds = [: MkFeed (toP pos) (AtomMap.map (\x -> [:x:]) named) :]}+ { c_feeds = Seq.singleton $ MkFeed (Seq.fromList pos) (AtomMap.map Seq.singleton named)}
src/Pugs/Compile/Pugs.hs view
@@ -9,6 +9,9 @@ import qualified Data.ByteString.Char8 as Str -- XXX import qualified Data.Map as Map import qualified Data.Set as Set+import Data.Sequence (Seq)+import qualified Data.Sequence as Seq+import qualified Data.Foldable as F type Str = Str.ByteString type Comp a = WriterT [a] Eval a@@ -27,8 +30,8 @@ instance (Compile x) => Compile [x] where compile = compileList -instance (Compile x) => Compile [:x:] where- compile xs = compWith "toP" [compileList (fromP xs)]+instance (Compile x) => Compile (Seq x) where+ compile xs = compWith "Seq.fromList" [compileList (F.toList xs)] instance (Compile x) => Compile (Set x) where compile xs = compWith "Set.fromDistinctAscList" [compileList (Set.toAscList xs)]
src/Pugs/Embed/Perl5.hs view
@@ -182,7 +182,7 @@ module Pugs.Embed.Perl5 where import Pugs.Internals-import Foreign+import Foreign (Ptr, withArray, withArray0, deRefStablePtr, newStablePtr, peekArray0, nullPtr, advancePtr, StablePtr) import Foreign.C.Types import Foreign.C.String import {-# SOURCE #-} Pugs.AST.Internals
src/Pugs/Eval.hs view
@@ -44,6 +44,9 @@ import GHC.PArr import qualified Data.ByteString.UTF8 as Str import qualified Data.ByteString.Char8 as Buf+import Data.Sequence (Seq, (|>), (<|), (><))+import qualified Data.Sequence as Seq+import qualified Data.Foldable as F {-|@@ -1034,7 +1037,7 @@ , envPos = envPos caller } vcap <- case args of- [] -> return (CaptSub { c_feeds = [::] })+ [] -> return (CaptSub { c_feeds = mempty }) (x:_) -> castVal =<< fromVal =<< enterRValue (enterEvalContext (cxtItem "Capture") x) local callerEnv $ applyCapture sub vcap , "&assuming" ... \inv args -> do@@ -1044,7 +1047,7 @@ Right curriedSub -> return . castV $ curriedSub , "&infix:=>" ... reduceSyn "=>" , "&circumfix:\\( )" ... \invs args -> do- feeds <- argsFeed [::] Nothing [args]+ feeds <- argsFeed mempty Nothing [args] case invs of Just i' -> do invVal <- reduce i'@@ -1083,20 +1086,20 @@ applyDisplaced sub invs args applyCapture :: VCode -> ValCapt -> Eval Val-applyCapture sub capt = applyDisplaced sub inv (fromP argsPos ++ argsNam)+applyCapture sub capt = applyDisplaced sub inv (F.toList argsPos ++ argsNam) where- argsPos = mapP (Val . castV) (f_positionals feed)- argsNam = [ Syn "named" [Val (VStr (cast k)), Val (castV (vs !: lst))] | (k, vs) <- AtomMap.toList (f_nameds feed), let lst = lengthP vs - 1, lst >= 0 ]+ argsPos = fmap (Val . castV) (f_positionals feed)+ argsNam = [ Syn "named" [Val (VStr (cast k)), Val (castV (vs `Seq.index` lst))] | (k, vs) <- AtomMap.toList (f_nameds feed), let lst = Seq.length vs - 1, lst >= 0 ] feed = concatFeeds (c_feeds capt) inv = case capt of CaptMeth { c_invocant = val } -> Just (Val (castV val)) _ -> Nothing -argsFeed :: [:ValFeed:] -> Maybe ValFeed -> [[Exp]] -> Eval [:ValFeed:]+argsFeed :: (Seq ValFeed) -> Maybe ValFeed -> [[Exp]] -> Eval (Seq ValFeed) argsFeed fAcc Nothing [] = return fAcc argsFeed fAcc Nothing [[]] = return fAcc-argsFeed fAcc (Just x) [] = return $ fAcc +:+ [:x:]-argsFeed fAcc (Just x) [[]] = return $ fAcc +:+ [:x:]+argsFeed fAcc (Just x) [] = return $ fAcc |> x+argsFeed fAcc (Just x) [[]] = return $ fAcc |> x argsFeed fAcc aAcc (argl:als) = do acc <- af aAcc argl argsFeed fAcc (Just acc) als@@ -1111,22 +1114,22 @@ af (Just $ resFeed{ f_nameds = addNamed (f_nameds resFeed) key argVal }) args | Syn "|" (capExp:_) <- unwrapN = do cap <- castVal =<< fromVal =<< enterRValue (enterEvalContext (cxtItem "Capture") capExp)- af (Just (mconcat (resFeed:fromP (c_feeds cap)))) args+ af (Just (mconcat (resFeed:F.toList (c_feeds cap)))) args | App (Var var) Nothing capExps <- unwrapN , var == cast "&prefix:|<<" = do caps <- mapM castVal =<< fromVals =<< (enterRValue $ enterEvalContext (cxtSlurpy "Capture") (Syn "," capExps))- af (Just (mconcat (resFeed:concatMap (fromP . c_feeds) caps))) args+ af (Just (mconcat (resFeed:concatMap (F.toList . c_feeds) caps))) args | otherwise = do argVal <- fromVal =<< reduce n- af (Just resFeed{ f_positionals = (f_positionals resFeed) +:+ [:argVal:] }) args+ af (Just resFeed{ f_positionals = (f_positionals resFeed) |> argVal }) args where unwrapN = unwrap n resFeed = feed res feed res = maybe emptyFeed id res- addNamed :: AtomMap [:a:] -> VStr -> a -> AtomMap [:a:]+ addNamed :: AtomMap (Seq a) -> VStr -> a -> AtomMap (Seq a) addNamed mp k v = let id = cast k in- AtomMap.insertWith (flip (+:+)) id [:v:] mp+ AtomMap.insertWith (flip (><)) id (Seq.singleton v) mp dummyVar :: Var dummyVar = cast "$"@@ -1178,13 +1181,18 @@ interpolateVal (VRef (MkRef (IPair pv))) = do (k, v) <- pair_fetch pv return [ Syn "named" [Val k, Val v] ]-interpolateVal (VV vv) | Just (CaptSub{ c_feeds = feeds } :: ValCapt) <- castVal vv = return . fromP $- [: Val (castV v) | v <- concatMapP f_positionals feeds :]- +:+ [: Syn "named" [Val (VStr $ cast k), Val (concatNamed v)] | (k, v) <- concatMapP (toP . AtomMap.toList . f_nameds) feeds :]- where- concatNamed [:x:] = castV x- concatNamed xs = VList (fromP (mapP castV xs))+interpolateVal (VV vv)+ | Just (CaptSub{ c_feeds = feeds } :: ValCapt) <- castVal vv+ = let posPart = fmap (\v -> Val (castV v)) (concatMapSeq f_positionals feeds)+ kvs = concatMapSeq (Seq.fromList . AtomMap.toList . f_nameds) feeds+ namPart = fmap kvToExp kvs+ in return (F.toList (posPart >< namPart)) interpolateVal val = return [Val val]+kvToExp (k, v) = Syn "named" [Val (VStr $ cast k), Val (concatNamed v)]+concatMapSeq f xs = F.foldr mappend mempty (fmap f xs)+concatNamed xs = case Seq.length xs of+ 1 -> castV (Seq.index xs 0)+ _ -> VList (F.toList (fmap castV xs)) isInterpolated :: Exp -> Bool isInterpolated (Ann _ exp) = isInterpolated exp
src/Pugs/Meta/Perl5.hs view
@@ -8,6 +8,7 @@ import Data.Typeable (Typeable) import qualified Data.Map as Map import qualified StringTable.AtomMap as AtomMap+import qualified Data.Foldable as F import Pugs.AST.Internals (envContext, anyToVal, anyFromVal) import Pugs.Types @@ -40,10 +41,10 @@ | otherwise = do invSV <- coerceVal inv subSV <- liftIO . bufToSV . cast $ meth- posSVs <- mapM coerceVal (fromP $ f_positionals feed)+ posSVs <- mapM coerceVal (F.toList $ f_positionals feed) namSVs <- fmap concat . forM (AtomMap.toList (f_nameds feed)) $ \(key, vals) -> do keySV <- liftIO (bufToSV $ cast key)- fmap concat . forM (fromP vals) $ \v -> do+ fmap concat . forM (F.toList vals) $ \v -> do valSV <- coerceVal v return [keySV, valSV] env <- ask
src/Pugs/Types.hs view
@@ -35,6 +35,9 @@ import qualified Data.IntSet as IntSet import qualified Data.ByteString.Char8 as Buf -- Intentionally not UTF8! import qualified Data.ByteString as B (findSubstring)+import Data.Sequence (Seq)+import qualified Data.Sequence as Seq+import qualified Data.Foldable as F data Type = MkType !ID -- ^ A regular type@@ -357,15 +360,15 @@ TGlobal -> ('*':) -- Cached Categ->ByteString mappings.-catBufMap :: [:ByteString:]-catBufMap = mapP (_cast . drop 2 . show) [:minBound..(maxBound :: VarCateg):]+catBufMap :: Seq ByteString+catBufMap = fmap (_cast . drop 2 . show) (Seq.fromList [minBound..(maxBound :: VarCateg)]) -- Cached ByteString->Categ mappings. bufCatMap :: Map ByteString VarCateg-bufCatMap = Map.fromList (fromP catBufMap `zip` [minBound..(maxBound :: VarCateg)])+bufCatMap = Map.fromList (F.toList catBufMap `zip` [minBound..(maxBound :: VarCateg)]) instance ((:>:) ByteString) VarCateg where- cast categ = catBufMap !: fromEnum categ+ cast categ = catBufMap `Seq.index` fromEnum categ instance ((:>:) (Maybe VarCateg)) ByteString where cast buf = Map.lookup buf bufCatMap
src/Pugs/Types/Array.hs view
@@ -128,61 +128,61 @@ array_storeSize _ _ = return () -- XXX error? array_storeElem _ _ _ = retConstError undef -a_size :: [:IVar VScalar:] -> Int-a_size = lengthP+a_size :: Seq (IVar VScalar) -> Int+a_size = Seq.length -a_update :: Int -> IVar VScalar -> [:IVar VScalar:] -> [:IVar VScalar:]-a_update i x xs = takeP i xs +:+ [:x:] +:+ sliceP (i + 1) (lengthP xs - 1) xs+a_update :: Int -> IVar VScalar -> Seq (IVar VScalar) -> Seq (IVar VScalar)+a_update i x xs = Seq.take i xs >< Seq.singleton x >< Seq.drop (i + 1) xs instance ArrayClass IArray where array_clone (MkIArray iv) = do a <- readTVar iv- tvs <- mapM cloneIVar (fromP a)- fmap MkIArray (newTVar (toP tvs))+ tvs <- mapM cloneIVar (toList a)+ fmap MkIArray (newTVar (fromList tvs)) array_store (MkIArray iv) vals = stm $ do tvs <- mapM newScalar vals- writeTVar iv (toP tvs)+ writeTVar iv (fromList tvs) array_fetchSize (MkIArray iv) = stm $ do a <- readTVar iv return $ a_size a array_storeSize (MkIArray iv) sz = stm $ do a <- readTVar iv case a_size a `compare` sz of- GT -> writeTVar iv (takeP sz a) -- shrink+ GT -> writeTVar iv (Seq.take sz a) -- shrink EQ -> return () LT -> do tvs <- replicateM (sz - a_size a) (newScalar undef)- writeTVar iv (a +:+ toP tvs) -- extend+ writeTVar iv (a >< fromList tvs) -- extend array_shift (MkIArray iv) = join . stm $ do a <- readTVar iv case a_size a of 0 -> return (return undef) l -> do- writeTVar iv (sliceP 1 (l - 1) a)- return (readIVar (a !: 0))+ writeTVar iv (Seq.drop 1 a)+ return (readIVar (a `Seq.index` 0)) array_unshift _ [] = return () array_unshift (MkIArray iv) vals = stm $ do a <- readTVar iv tvs <- mapM newScalar vals- writeTVar iv (toP tvs +:+ a)+ writeTVar iv (fromList tvs >< a) array_pop (MkIArray iv) = join . stm $ do a <- readTVar iv case a_size a of 0 -> return (return undef) sz -> do- writeTVar iv (takeP (sz - 1) a)- return (readIVar (a !: (sz - 1)))+ writeTVar iv (Seq.take (sz - 1) a)+ return (readIVar (a `Seq.index` (sz - 1))) array_push _ [] = return () array_push (MkIArray iv) vals = stm $ do a <- readTVar iv tvs <- mapM newScalar vals- writeTVar iv (a +:+ toP tvs)+ writeTVar iv (a >< fromList tvs) array_extendSize (MkIArray iv) sz = stm $ do a <- readTVar iv case a_size a `compare` sz of LT -> do tvs <- replicateM (sz - a_size a) (newScalar undef)- writeTVar iv (a +:+ toP tvs)+ writeTVar iv (a >< fromList tvs) _ -> return () array_fetchVal arr idx = do rv <- getArrayIndex idx (Just $ constScalar undef)@@ -213,7 +213,7 @@ size = a_size a case (size-1) `compare` idx' of LT -> return ()- EQ -> writeTVar iv (takeP (size-1) a)+ EQ -> writeTVar iv (Seq.take (size-1) a) GT -> do tvar <- newScalar undef writeTVar iv (a_update idx' tvar a)@@ -224,13 +224,13 @@ len' = if len < 0 then len + size - off' else len size = a_size a - let result = mapM readIVar (fromP (sliceP off' (off' + len' - 1) a))+ let result = mapM readIVar (toList (Seq.take (len' - 1) (Seq.drop off' a))) let off = if off' > size then size else off' len = if off + len' > size then size - off else len' tvars <- mapM newScalar vals- writeTVar iv (takeP off a +:+ toP tvars +:+ sliceP (off+len) (size-1) a)+ writeTVar iv (Seq.take off a >< fromList tvars >< Seq.drop (off+len) a) return result instance ArrayClass VArray where