Pugs 6.2.13.20130611 → 6.2.13.20150815
raw patch · 27 files changed
+168/−95 lines, 27 filesdep +hashabledep +hashtablesdep +text
Dependencies added: hashable, hashtables, text
Files
- Configure.PL +9/−4
- Pugs.cabal +7/−4
- src/Pugs/AST/Eval.hs +11/−5
- src/Pugs/AST/Internals.hs +9/−22
- src/Pugs/AST/Internals.hs-boot +2/−0
- src/Pugs/AST/Internals/Instances.hs +5/−5
- src/Pugs/AST/Pad.hs +4/−2
- src/Pugs/AST/SIO.hs +6/−0
- src/Pugs/AST/Types.hs +10/−9
- src/Pugs/Class.hs +7/−5
- src/Pugs/CodeGen/PIR/Prelude.hs +1/−1
- src/Pugs/Compile/Pugs.hs +1/−1
- src/Pugs/Embed/Parrot.hs +1/−1
- src/Pugs/Eval.hs +5/−4
- src/Pugs/Monads.hs +13/−0
- src/Pugs/Parser/Charnames.hs +4/−4
- src/Pugs/Parser/Number.hs +1/−0
- src/Pugs/Parser/Operator.hs +7/−3
- src/Pugs/Parser/Types.hs +1/−1
- src/Pugs/Pretty.hs +1/−1
- src/Pugs/Prim.hs +53/−13
- src/Pugs/Prim/List.hs +1/−1
- src/Pugs/Prim/Match.hs +1/−1
- src/Pugs/Prim/Yaml.hs +2/−2
- src/Pugs/Types.hs +2/−2
- src/Pugs/Types/Hash.hs +2/−2
- src/Pugs/Version.hs +2/−2
Configure.PL view
@@ -1,5 +1,10 @@ #!/usr/bin/perl +if ($^O eq 'darwin' and $^X ne '/usr/bin/perl') {+ # Always prefer system perl with embedding Perl5 on OSX.+ exec("/usr/bin/perl" => $0, @ARGV);+}+ use 5.006; use strict; use Cwd;@@ -83,10 +88,10 @@ . # Hack for OSX 10.6-$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;+$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,9 +1,9 @@ Name : Pugs-Version : 6.2.13.20130611+Version : 6.2.13.20150815 license : BSD3 license-file : LICENSE cabal-version : >= 1.2.3-copyright : 2005-2012, The Pugs Contributors+copyright : 2005-2015, The Pugs Contributors maintainer : Audrey Tang <audreyt@audreyt.org> category : Language, Pugs stability : experimental@@ -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, GHC==7.0.1, GHC==7.2.1, GHC==7.4.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, GHC==7.4.1, GHC==7.10.2 data-files : blib6/pugs/perl5/lib/Parse/Yapp/Driver.pm blib6/pugs/perl5/lib/Parse/Yapp/Grammar.pm@@ -162,9 +162,11 @@ build-depends: base >= 4 && < 5, filepath, mtl >= 2.0.0.0, parsec >= 3.0.0.0, network,- pretty, time, random, process, containers, bytestring,+ pretty, time, random, process, containers, bytestring, text, array, directory, utf8-string, binary, haskeline >= 0.6.4.7, FindBin, control-timeout >= 0.1.2,+ hashtables,+ hashable, MetaObject >= 0.0.4, HsParrot >= 0.0.2.20120717,@@ -177,6 +179,7 @@ if flag(Perl5) cpp-options: -DPUGS_HAVE_PERL5=1+ ld-options: -pthread includes: perl5/p5embed.h c-sources:
src/Pugs/AST/Eval.hs view
@@ -3,8 +3,10 @@ module Pugs.AST.Eval where import Pugs.Internals import Pugs.Cont hiding (resetT)-import System.IO.Error (IOError)-import Control.Exception (SomeException, try)+import System.IO.Error (tryIOError, IOError)+import Control.Exception (SomeException)+import Control.Applicative (Applicative(..))+import Control.Monad (ap) import Pugs.AST.SIO import {-# SOURCE #-} Pugs.AST.Internals@@ -113,6 +115,10 @@ pos <- asks envPos' EvalT $ return (RException (errStrPos (cast str) pos)) +instance Applicative Eval where+ pure = return+ (<*>) = ap+ instance Error Val where noMsg = errStr "" strMsg = errStr@@ -154,9 +160,9 @@ -} guardIO :: IO a -> Eval a guardIO x = do- rv <- io $ try x+ rv <- io $ tryIOError x case rv of- Left e -> fail (show (e :: SomeException))+ Left e -> fail (show e) Right v -> return v {-|@@ -167,7 +173,7 @@ -} guardIOexcept :: MonadIO m => [((IOError -> Bool), a)] -> IO a -> m a guardIOexcept safetyNet x = do- rv <- io $ try x+ rv <- io $ tryIOError x case rv of Right v -> return v Left e -> catcher e safetyNet
src/Pugs/AST/Internals.hs view
@@ -97,7 +97,8 @@ import qualified Data.Set as Set import qualified Data.Map as Map -import qualified Data.HashTable as H+import qualified Data.HashTable.IO as H+import Data.Int (Int32) import GHC.Conc (unsafeIOToSTM) import Pugs.Cont (callCC)@@ -209,13 +210,16 @@ IThunk :: ThunkClass a => !a -> IVar VThunk IPair :: PairClass a => !a -> IVar VPair IVal :: !Val -> IVar Val+ deriving Typeable data VOpaque where MkOpaque :: Value a => !a -> VOpaque+ deriving Typeable -- GADTs, here we come! data VRef where MkRef :: (Typeable a) => !(IVar a) -> VRef+ deriving Typeable data VObject = MkObject { objType :: !VType@@ -381,7 +385,7 @@ 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+ attrs <- stm . unsafeIOToSTM . H.fromList $ map (\(a,b) -> (a, lazyScalar b)) attrList return $ MkObject { objType = typ , objId = uniq@@ -734,7 +738,7 @@ iv <- newTVarIO mempty return $ arrayRef (MkIArray iv) "Hash" -> do- h <- io (H.new (==) H.hashString)+ h <- io H.new return $ hashRef (h :: IHash) "Sub" -> newObject $ mkType "Code" "Routine" -> newObject $ mkType "Code"@@ -872,7 +876,7 @@ 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))+ ihash <- stm . unsafeIOToSTM $ H.fromList (map (\(a,b) -> (a, lazyScalar b)) (Map.toList hash)) return $ IHash ihash newHandle :: (MonadSTM m) => VHandle -> m (IVar VHandle)@@ -1166,7 +1170,7 @@ fromVal (VList l) = return . unwords =<< mapM fromVal l fromVal v@(PerlSV _) = fromVal' v fromVal VUndef = return ""- fromVal (VType t) = return (showType t)+ fromVal (VType t) = return ("(" ++ showType t ++ ")") fromVal v = do vt <- evalValType v case showType vt of@@ -1298,26 +1302,12 @@ instance Eq VOpaque where (MkOpaque x) == (MkOpaque y) = castV x == castV y -instance Typeable VOpaque where- typeOf (MkOpaque x) = typeOf x- instance Ord VOpaque where compare x y = castV x `compare` castV y instance Show VOpaque where show (MkOpaque x) = show x -instance Typeable1 IVar where- typeOf1 (IScalar x) = typeOf x- typeOf1 (IArray x) = typeOf x- typeOf1 (IHash x) = typeOf x- typeOf1 (ICode x) = typeOf x- typeOf1 (IHandle x) = typeOf x- typeOf1 (IRule x) = typeOf x- typeOf1 (IThunk x) = typeOf x- typeOf1 (IPair x) = typeOf x- typeOf1 (IVal x) = typeOf x- instance Show VRef where show ref@(MkRef ivar) = case ivar of IScalar x -> showAddressOf (showType (refType ref)) x@@ -1329,9 +1319,6 @@ IThunk x -> showAddressOf (showType (refType ref)) x IPair x -> showAddressOf (showType (refType ref)) x IVal x -> showAddressOf (showType (refType ref)) x--instance Typeable VRef where- typeOf (MkRef x) = typeOf x instance Eq VRef where x == y = addressOf x == addressOf y
src/Pugs/AST/Internals.hs-boot view
@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans -fallow-overlapping-instances -fallow-undecidable-instances #-}+{-# LANGUAGE RoleAnnotations #-} module Pugs.AST.Internals where import Pugs.Types@@ -39,6 +40,7 @@ createObjectRaw :: (MonadSTM m) => ObjectId -> Maybe Dynamic -> VType -> [(VStr, Val)] -> m VObject +type role IVar nominal data IVar v data VOpaque
src/Pugs/AST/Internals/Instances.hs view
@@ -49,7 +49,7 @@ import qualified Data.Map as Map import qualified Pugs.Val as Val -import qualified Data.HashTable as H+import qualified Data.HashTable.IO as H import Data.Sequence (Seq) import qualified Data.Sequence as Seq import qualified Data.Foldable as F@@ -166,13 +166,13 @@ | s == packBuf "tag:hs:Array" = fmap MkRef (newArray =<< fromYAML node) | s == packBuf "tag:hs:Hash" = fmap MkRef (newHash =<< fromYAML node) fromYAML node = fail $ "Unhandled YAML node: " ++ show node-instance YAML IHash where+instance x ~ IHash => YAML x 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+ l' <- H.fromList l return l' instance YAML ID where@@ -1363,13 +1363,13 @@ get = case 0 of 0 -> ap (ap (return MkPrag) get) get -instance Binary IHash where+instance x ~ IHash => Binary x where put x = do let kvs = unsafePerformIO (H.toList x) length kvs `seq` put (kvs :: [(VStr, IVar VScalar)]) get = do (ins :: [(VStr, IVar VScalar)]) <- get- length ins `seq` return (unsafePerformIO $ H.fromList H.hashString ins)+ length ins `seq` return (unsafePerformIO $ H.fromList ins) instance Binary JuncType where put (JAny) = putWord8 0
src/Pugs/AST/Pad.hs view
@@ -48,8 +48,10 @@ newMPad :: MonadSTM m => Pad -> m MPad newMPad p = do- tvar <- stm $ newTVar p- return $ MkMPad (addressOf tvar) tvar+ (tvar, ptr) <- stm $ do+ tvar' <- newTVar p+ return (tvar', addressOf tvar')+ return $ MkMPad ptr tvar {- {-|
src/Pugs/AST/SIO.hs view
@@ -13,6 +13,8 @@ import Control.Concurrent.STM (STM, atomically, TVar, writeTVar, readTVar, newTVarIO, newTVar, readTMVar, newTMVarIO, tryPutTMVar, takeTMVar, newEmptyTMVar)+import Control.Applicative (Applicative(..))+import Control.Monad (ap) instance Monad m => ((:>:) (m a)) (Identity a) where cast = return . runIdentity instance ((:>:) (SIO a)) (STM a) where cast = liftSTM@@ -50,6 +52,10 @@ instance Functor SIO where fmap = liftM++instance Applicative SIO where+ pure = return+ (<*>) = ap -- | Typeclass of monadic types that an @STM@ monad can be lifted to. class (Monad m, Functor m) => MonadSTM m where
src/Pugs/AST/Types.hs view
@@ -1,10 +1,12 @@ {-# OPTIONS_GHC -fglasgow-exts -fno-warn-orphans -fallow-overlapping-instances -fallow-undecidable-instances #-}+{-# LANGUAGE TypeFamilies #-} module Pugs.AST.Types where import Pugs.Internals import Pugs.Types import qualified Data.Set as Set import qualified Data.Map as Map-import qualified Data.HashTable as H+import qualified Data.HashTable.IO as H+import qualified Data.HashTable.ST.Basic import Data.Sequence (Seq) import qualified Data.Sequence as Seq @@ -286,7 +288,7 @@ deriving (Typeable) type IArraySlice = [IVar VScalar]-type IHash = H.HashTable VStr (IVar VScalar) -- XXX UTF8 handled at Types/Hash.hs+type IHash = H.BasicHashTable VStr (IVar VScalar) -- XXX UTF8 handled at Types/Hash.hs type IScalar = TVar Val type IScalarProxy = (Eval VScalar, (VScalar -> Eval ())) type IScalarLazy = Maybe VScalar@@ -362,14 +364,13 @@ x == y = addressOf x == addressOf y -- Haddock doesn't seem to like data/instance declarations with a where clause.-instance Eq IHash where+instance x ~ IHash => Eq x where x == y = addressOf x == addressOf y-instance Ord IHash where+instance x ~ IHash => Ord x where compare x y = compare (addressOf x) (addressOf y)-instance Show IHash where+instance x ~ IHash => Show x where show = showAddressOf "Hash"-instance Typeable2 H.HashTable where- typeOf2 _ = mkTyConApp (mkTyCon "HashTable") []+deriving instance Typeable Data.HashTable.ST.Basic.HashTable instance Eq (IVar a) where x == y = addressOf x == addressOf y@@ -426,8 +427,8 @@ instance Ord VProcess where compare _ _ = EQ -instance Typeable ProcessHandle where typeOf _ = mkTyConApp (mkTyCon "ProcessHandle") []-instance Typeable Regex where typeOf _ = mkTyConApp (mkTyCon "Regex") []+deriving instance Typeable ProcessHandle+deriving instance Typeable Regex instance Eq VJunc where
src/Pugs/Class.hs view
@@ -65,12 +65,14 @@ class Boxable b => MethodPrimable a b | a -> b where asPrim :: a -> MethodPrim b -instance Boxable a => MethodPrimable Val a where- asPrim v _ _ = return v+newtype WrapPrimable a b = WrapPrimable a -instance Boxable a => MethodPrimable Call a where- asPrim f x _ = ivDispatch (mkVal x) f+instance Boxable a => MethodPrimable (WrapPrimable Val a) a where+ asPrim (WrapPrimable v) _ _ = return v +instance Boxable a => MethodPrimable (WrapPrimable Call a) a where+ asPrim (WrapPrimable f) x _ = ivDispatch (mkVal x) f+ -- Auto-generate pure instances from Eval instances instance MethodPrimable (a -> b -> Eval z) a => MethodPrimable (a -> b -> z) a where asPrim f = asPrim ((\x args -> return (f x args)) :: (a -> b -> Eval z))@@ -137,7 +139,7 @@ -- mkPureClass :: (Boxable a) => String -> [(ID, MethodPrim a)] -> PureClass mkPureClass :: Boxable a => String -> [(ID, MethodPrim a)] -> PureClass mkPureClass cls methods = fix . (mkBoxClass cls .) $ \self -> flip (++) methods- [ "" ... mkVal self+ [ "" ... WrapPrimable (mkVal self) , "ITEM" ... id , "LIST" ... id ]
src/Pugs/CodeGen/PIR/Prelude.hs view
@@ -73,7 +73,7 @@ , " lc(substr $str, 0, 1) ~ substr $str, 1, chars($str) - 1;" , "}" , ""- , "sub ucfirst (Str $str) returns Str is builtin is primitive {"+ , "sub tc (Str $str) returns Str is builtin is primitive {" , " uc(substr $str, 0, 1) ~ substr $str, 1, chars($str) - 1;" , "}" , ""
src/Pugs/Compile/Pugs.hs view
@@ -91,7 +91,7 @@ where syms = padToList pad -instance Compile IHash where+instance x ~ IHash => Compile x where compile map = error (show map)
src/Pugs/Embed/Parrot.hs view
@@ -99,7 +99,7 @@ | otherwise = errMsg fail $ "*** Running external 'parrot' failed:\n" ++ msg where- escape = escape . encodeUTF8+ escape = _escape . encodeUTF8 _escape "" = "" _escape ('\\':xs) = "\\\\" ++ _escape xs _escape ('\n':xs) = "\\n" ++ _escape xs
src/Pugs/Eval.hs view
@@ -806,7 +806,7 @@ val <- enterEvalContext (cxtItem "Str") exp str <- fromVal val p5 <- fromAdverb hv ["P5", "Perl5", "perl5"]- p5flags <- fromAdverb hv ["P5", "Perl5", "perl5"]+ p5flags <- fromAdverb hv ["P5", "Perl5", "perl5"] :: Eval String flag_g <- fromAdverb hv ["g", "global"] flag_i <- fromAdverb hv ["i", "ignorecase"] flag_s <- fromAdverb hv ["s", "sigspace"]@@ -884,7 +884,8 @@ when (lang /= "Haskell") $ die "Inline: Unknown language" langVal pkg <- asks envPackage -- full module name here- let file = (`concatMap` cast pkg) $ \v -> case v of+ let pkg' = cast pkg :: String+ file = (`concatMap` pkg') $ \v -> case v of '-' -> "__" _ | isAlphaNum v -> [v] _ -> "_"@@ -1524,7 +1525,7 @@ checkSlurpyLimit :: (VInt, Exp) -> Eval [Val] checkSlurpyLimit (n, exp) = do listVal <- enterLValue $ enterEvalContext (cxtItem "Array") exp- list <- fromVal listVal+ list <- fromVal listVal :: Eval [Val] elms <- mapM fromVal list -- flatten return $ genericDrop n (concat elms :: [Val]) isCollapsed :: Type -> Bool@@ -1547,7 +1548,7 @@ retIVar elm (True, False) -> do -- LValue, List context- idxList <- fetchIdx+ idxList <- fetchIdx :: Eval [Val] elms <- mapM fetchElem idxList retIVar $ IArray elms (False, True) -> do
src/Pugs/Monads.hs view
@@ -31,6 +31,8 @@ import Pugs.Internals import Pugs.AST import Pugs.Types+import qualified Control.Applicative as AP+import Control.Monad (ap) import qualified Data.Set as Set newtype MaybeT m a = MaybeT { runMaybeT :: m (Maybe a) }@@ -40,6 +42,13 @@ MaybeT (mon >>= maybe (return Nothing) (runMaybeT . f)) return = MaybeT . return . Just +instance (Monad m) => AP.Applicative (MaybeT m) where+ pure = return+ (<*>) = ap++instance (Monad m) => Functor (MaybeT m) where+ fmap = liftM+ instance MonadTrans MaybeT where lift mon = MaybeT (mon >>= return . Just) @@ -55,6 +64,10 @@ case ma of Nothing -> b _ -> return ma ++instance (Monad m) => AP.Alternative (MaybeT m) where+ (<|>) = mplus+ empty = mzero {-| Perform the given evaluation in an /LValue/ context.
src/Pugs/Parser/Charnames.hs view
@@ -21,7 +21,7 @@ #else -import qualified Data.HashTable as H+import qualified Data.HashTable.IO as H import Data.ByteString.Unsafe (unsafePackAddressLen) -- If we don't have Perl 5, support for names in the 0x00 - 0xFF range only.@@ -30,7 +30,7 @@ nameToCode name = inlinePerformIO (H.lookup _NameToCode (cast name)) {-# NOINLINE _NameToCode #-}-_NameToCode :: H.HashTable ByteString Int+_NameToCode :: H.BasicHashTable ByteString Int _NameToCode = unsafePerformIO $! hashList =<< mapM compute [ (unsafePackAddressLen 4 "NULL"#, 0x0000) , (unsafePackAddressLen 16 "START OF HEADING"#, 0x0001)@@ -290,8 +290,8 @@ , (unsafePackAddressLen 35 "LATIN SMALL LETTER Y WITH DIAERESIS"#, 0x00FF) ] where- hashList :: [(ByteString, a)] -> IO (H.HashTable ByteString a)- hashList = H.fromList hashByteString+ hashList :: [(ByteString, a)] -> IO (H.BasicHashTable ByteString a)+ hashList = H.fromList compute (f, y) = f >>= \x -> return (x, y) #endif
src/Pugs/Parser/Number.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE UndecidableInstances,FlexibleContexts #-} module Pugs.Parser.Number ( parseNatOrRat,
src/Pugs/Parser/Operator.hs view
@@ -12,7 +12,8 @@ import qualified Data.Map as Map import qualified Data.ByteString.UTF8 as Str import qualified Data.ByteString.Char8 as Buf -- XXX-import qualified Data.HashTable as H+import qualified Data.HashTable.IO as H+import qualified Data.Hashable as H import GHC.Int (Int32(I32#)) import Pugs.Parser.Types@@ -187,8 +188,11 @@ return (length funs `seq` funs) {-# NOINLINE _RefToFunction #-}-_RefToFunction :: H.HashTable PadEntry (Maybe CurrentFunction)-_RefToFunction = unsafePerformIO (H.new (==) hashPadEntry)+_RefToFunction :: H.BasicHashTable PadEntry (Maybe CurrentFunction)+_RefToFunction = unsafePerformIO H.new++instance H.Hashable PadEntry where+ hashWithSalt salt = H.hashWithSalt salt . hashPadEntry hashPadEntry :: PadEntry -> Int32 hashPadEntry PEConstant{ pe_proto = v } = I32# (unsafeCoerce# v)
src/Pugs/Parser/Types.hs view
@@ -21,7 +21,7 @@ import Pugs.Internals import Pugs.Pretty (pretty) import Text.ParserCombinators.Parsec.Pos-import Debug.Trace+import Debug.Trace hiding (traceM) import qualified Data.Map as Map import qualified Data.Set as Set
src/Pugs/Pretty.hs view
@@ -219,7 +219,7 @@ -- return $ pretty val format (VRule _) = text $ "{regex}" format (VSubst _) = text $ "{subst}"- format (VType t) = text $ "::" ++ showType t+ format (VType t) = text $ showType t ++ "()" format (VObject o) = text $ "{obj:" ++ showType (objType o) ++ "}" format (VMatch m) = cat [ text "Match.new("
src/Pugs/Prim.hs view
@@ -53,10 +53,11 @@ import DrIFT.YAML import GHC.Exts (unsafeCoerce#) import GHC.Unicode-import qualified Data.HashTable as H+import qualified Data.HashTable.IO as H import Data.Time.LocalTime import Data.Time.Calendar.OrdinalDate import Data.Time.Calendar.MonthDay+import Data.Text (strip, stripStart, stripEnd, pack, unpack) constMacro :: Exp -> [Val] -> Eval Val constMacro = const . expToEvalVal@@ -67,6 +68,7 @@ op0 "&" = fmap opJuncAll . mapM fromVal op0 "^" = fmap opJuncOne . mapM fromVal op0 "|" = fmap opJuncAny . mapM fromVal+op0 "e" = const . return $ VNum $ exp 1 op0 "want" = const $ fmap VStr (asks (maybe "Item" envWant . envCaller)) op0 "Bool::True" = const . return $ VBool True op0 "Bool::False" = const . return $ VBool False@@ -88,7 +90,6 @@ op0 "File::Spec::tmpdir" = const $ do tmp <- guardIO getTemporaryDirectory return $ VStr tmp-op0 "Pugs::Internals::pi" = const $ return $ VNum pi op0 "self" = const $ expToEvalVal (_Var "$__SELF__") op0 "say" = const $ op1 "IO::say" (VHandle stdout) op0 "print" = const $ op1 "IO::print" (VHandle stdout)@@ -108,7 +109,10 @@ op0 "Int" = const $ return (VType $ mkType "Int") op0 "Num" = const $ return (VType $ mkType "Num") op0 "Rat" = const $ return (VType $ mkType "Rat")+op0 "FatRat" = const $ return (VType $ mkType "FatRat") op0 "Bool" = const $ return (VType $ mkType "Bool")+op0 "Complex" = const $ return (VType $ mkType "Complex")+op0 "Str" = const $ return (VType $ mkType "Str") op0 other = const $ fail ("Unimplemented listOp: " ++ other) -- |Implementation of unary primitive operators and functions@@ -131,8 +135,8 @@ op1 "lc" = op1Cast (VStr . map toLower) op1 "lcfirst" = op1StrFirst toLower op1 "uc" = op1Cast (VStr . map toUpper)-op1 "ucfirst" = op1StrFirst toUpper-op1 "capitalize" = op1Cast $ VStr . (mapEachWord capitalizeWord)+op1 "tc" = op1StrFirst toUpper+op1 "wordcase" = op1Cast $ VStr . (mapEachWord capitalizeWord) where mapEachWord _ [] = [] mapEachWord f str@(c:cs)@@ -159,8 +163,8 @@ op1 "tan" = op1Floating tan op1 "sqrt" = op1Floating sqrt op1 "atan" = op1Floating atan-op1 "acos" = op1Floating cos-op1 "asin" = op1Floating sin+op1 "acos" = op1Floating cos+op1 "asin" = op1Floating sin op1 "post:i" = \x -> do n <- fromVal x return $ VComplex (0 :+ n)@@ -208,9 +212,21 @@ int <- fromVal rv return (int <= (0 :: Int)) retSeq sorted-op1 "Scalar::reverse" = \v -> do+op1 "flip" = \v -> do str <- fromVal v return (VStr $ reverse str)+op1 "Scalar::flip" = \v -> do+ str <- fromVal v+ return (VStr $ reverse str)+op1 "Scalar::trim" = \v -> do+ str <- fromVal v+ return (VStr $ unpack $ strip $ pack str)+op1 "Scalar::trim-leading" = \v -> do+ str <- fromVal v+ return (VStr $ unpack $ stripStart $ pack str)+op1 "Scalar::trim-trailing" = \v -> do+ str <- fromVal v+ return (VStr $ unpack $ stripEnd $ pack str) op1 "List::reverse" = \v -> do vlist <- fromVal v return (VList $ reverse vlist)@@ -225,6 +241,9 @@ op1 "Int" = op1Cast VInt op1 "Num" = op1Cast VNum op1 "Rat" = op1Cast VRat+op1 "FatRat" = op1Cast VRat+op1 "Complex" = op1Cast VComplex+op1 "Str" = op1Cast VStr op1 "+^" = op1Cast (VInt . pred . negate) -- Arbitrary precision complement- 0 ==> -1 / 1 ==> -2 op1 "~^" = op1Cast (VStr . mapStr complement) op1 "?^" = op1 "!"@@ -1347,7 +1366,7 @@ named <- fromVal n defs <- fetchMetaInfo "attrs" (showType typ)- attrs <- io $ H.new (==) H.hashString+ attrs <- io $ H.new writeIVar (IHash attrs) (named `Map.union` defs) uniq <- newObjectId unless (positionals == VList []) (fail "Must only use named arguments to new() constructor\nBe sure to use bareword keys.")@@ -1366,7 +1385,7 @@ named <- fromVal n (VObject o) <- fromVal t attrs <- readIVar (IHash $ objAttrs o)- attrs' <- io $ H.new (==) H.hashString+ attrs' <- io $ H.new uniq <- newObjectId writeIVar (IHash attrs') (named `Map.union` attrs) return $ VObject o{ objAttrs = attrs', objId = uniq }@@ -1888,7 +1907,6 @@ \\n Num pre tan safe (Num)\ \\n Num pre acos safe (Num)\ \\n Num pre asin safe (Num)\-\\n Any pre Pugs::Internals::pi safe ()\ \\n Any pre self safe,macro ()\ \\n Bool pre nothing safe ()\ \\n Num pre exp safe (Num, ?Num)\@@ -1916,6 +1934,14 @@ \\n Num pre Num safe (Num)\ \\n Num pre Num safe (Rat)\ \\n Num pre Num safe (Bool)\+\\n Complex pre Complex safe ()\+\\n Complex pre Complex safe (Int)\+\\n Complex pre Complex safe (Num)\+\\n Complex pre Complex safe (Rat)\+\\n Complex pre Complex safe (Bool)\+\\n Complex pre Complex safe (Complex)\+\\n Str pre Str safe ()\+\\n Str pre Str safe (Str)\ \\n Rat pre Rat safe ()\ \\n Rat pre Rat safe (Int)\ \\n Rat pre Rat safe (Int: Any)\@@ -1925,6 +1951,15 @@ \\n Rat pre Rat safe (Rat: Any)\ \\n Rat pre Rat safe (Bool)\ \\n Rat pre Rat safe (Bool: Any)\+\\n Rat pre FatRat safe ()\+\\n Rat pre FatRat safe (Int)\+\\n Rat pre FatRat safe (Int: Any)\+\\n Rat pre FatRat safe (Num)\+\\n Rat pre FatRat safe (Num: Any)\+\\n Rat pre FatRat safe (Rat)\+\\n Rat pre FatRat safe (Rat: Any)\+\\n Rat pre FatRat safe (Bool)\+\\n Rat pre FatRat safe (Bool: Any)\ \\n Bool pre Bool safe ()\ \\n Bool pre Bool safe (Int)\ \\n Bool pre Bool safe (Num)\@@ -1934,7 +1969,11 @@ \\n Hash pre hash safe (List)\ \\n List pre pair safe (List)\ \\n Scalar pre item safe (Scalar)\-\\n Str pre Scalar::reverse safe (Scalar)\+\\n Str pre flip safe (Scalar)\+\\n Str pre Scalar::flip safe (Scalar)\+\\n Str pre Scalar::trim safe (Scalar)\+\\n Str pre Scalar::trim-leading safe (Scalar)\+\\n Str pre Scalar::trim-trailing safe (Scalar)\ \\n Any pre List::reverse safe (Array)\ \\n Any pre reverse safe (Scalar, List)\ \\n Any pre reverse safe ()\@@ -1960,8 +1999,8 @@ \\n Str pre quotemeta safe (Str)\ \\n Str pre lcfirst safe (Str)\ \\n Str pre uc safe (Str)\-\\n Str pre ucfirst safe (Str)\-\\n Str pre capitalize safe (Str)\+\\n Str pre tc safe (Str)\+\\n Str pre wordcase safe (Str)\ \\n Str pre crypt safe (Str, Str)\ \\n Str post ++ safe (rw!Str)\ \\n Str post -- safe (rw!Str)\@@ -2281,5 +2320,6 @@ \\n Bool pre Pugs::Internals::current_pragma_value safe (Str)\ \\n Bool pre Pugs::Internals::caller_pragma_value safe (Str)\ \\n Num pre Pugs::Internals::base safe (Int, Any)\+\\n Num pre e safe ()\ \\n Any pre vv safe (Any)\ \\n"
src/Pugs/Prim/List.hs view
@@ -92,7 +92,7 @@ op1Sum :: Val -> Eval Val op1Sum list = do- vals <- fromVal list+ vals <- fromVal list :: Eval [Val] foldM (op2Numeric (+)) undef vals op1Min :: Val -> Eval Val
src/Pugs/Prim/Match.hs view
@@ -335,6 +335,6 @@ if ref == undef then return [] else do meta <- readRef =<< fromVal ref fetch <- doHash meta hash_fetchVal- attrs <- fromVal =<< fetch "is"+ attrs <- fromVal =<< fetch "is" :: Eval [VStr] pkgs <- mapM pkgParentClasses attrs return $ nub (pkg:concat pkgs)
src/Pugs/Prim/Yaml.hs view
@@ -12,7 +12,7 @@ import qualified Data.Map as Map import qualified Data.IntSet as IntSet import qualified Data.ByteString as Str-import qualified Data.HashTable as H+import qualified Data.HashTable.IO as H import DrIFT.YAML evalYaml :: Val -> Eval Val@@ -35,7 +35,7 @@ key <- fromVal =<< fromYaml keyNode val <- newScalar =<< fromYaml valNode return (key, val)- hv <- io $ (H.fromList H.hashString vals :: IO IHash)+ hv <- io $ (H.fromList vals :: IO IHash) return $ VRef (hashRef hv) Just s | (pre, post) <- Str.splitAt 16 s -- 16 == length "tag:pugs:Mu:" , pre == packBuf "tag:pugs:Mu:" -> do
src/Pugs/Types.hs view
@@ -30,7 +30,7 @@ import Pugs.Internals import Data.Bits (shiftL) import qualified Data.Map as Map-import qualified Data.HashTable as H+import qualified Data.HashTable.IO as H import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet import qualified Data.ByteString.Char8 as Buf -- Intentionally not UTF8!@@ -440,7 +440,7 @@ cast x = unsafePerformIO (bufToVar x) {-# NOINLINE _BufToVar #-}-_BufToVar :: H.HashTable ByteString Var+_BufToVar :: H.BasicHashTable ByteString Var _BufToVar = unsafePerformIO hashNew bufToVar :: ByteString -> IO Var
src/Pugs/Types/Hash.hs view
@@ -101,14 +101,14 @@ encodeKey x = x decodeKey x = x -instance HashClass IHash where+instance x ~ IHash => HashClass x where hash_iType = const $ mkType "Hash" hash_clone hv = do ps <- unsafeIOToSTM $ H.toList hv ps' <- forM ps $ \(k, sv) -> do sv' <- cloneIVar sv return (k, sv')- unsafeIOToSTM $ H.fromList H.hashString ps'+ unsafeIOToSTM $ H.fromList ps' hash_fetch hv = do ps <- io $ H.toList hv ps' <- forM ps $ \(k, sv) -> do
src/Pugs/Version.hs view
@@ -17,7 +17,7 @@ #define PUGS_VERSION "6.2.13.dev" #endif #ifndef PUGS_DATE-#define PUGS_DATE "Today"+#define PUGS_DATE "20150815" #endif #ifndef PUGS_SVN_REVISION #define PUGS_SVN_REVISION 0@@ -33,7 +33,7 @@ versnum = PUGS_VERSION date = PUGS_DATE version = name ++ ", version " ++ versnum ++ ", " ++ date ++ revision-copyright = "Copyright 2005-2012, The Pugs Contributors"+copyright = "Copyright 2005-2015, The Pugs Contributors" revnum = show (PUGS_SVN_REVISION :: Integer) revision | rev <- revnum