diff --git a/Configure.PL b/Configure.PL --- a/Configure.PL +++ b/Configure.PL @@ -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; diff --git a/Pugs.cabal b/Pugs.cabal --- a/Pugs.cabal +++ b/Pugs.cabal @@ -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 category : Language, Pugs stability : experimental @@ -12,7 +12,7 @@ synopsis : A Perl 6 Implementation description : A Perl 6 Implementation author : Audrey Tang -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: diff --git a/src/Pugs/AST/Eval.hs b/src/Pugs/AST/Eval.hs --- a/src/Pugs/AST/Eval.hs +++ b/src/Pugs/AST/Eval.hs @@ -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 diff --git a/src/Pugs/AST/Internals.hs b/src/Pugs/AST/Internals.hs --- a/src/Pugs/AST/Internals.hs +++ b/src/Pugs/AST/Internals.hs @@ -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 diff --git a/src/Pugs/AST/Internals.hs-boot b/src/Pugs/AST/Internals.hs-boot --- a/src/Pugs/AST/Internals.hs-boot +++ b/src/Pugs/AST/Internals.hs-boot @@ -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 diff --git a/src/Pugs/AST/Internals/Instances.hs b/src/Pugs/AST/Internals/Instances.hs --- a/src/Pugs/AST/Internals/Instances.hs +++ b/src/Pugs/AST/Internals/Instances.hs @@ -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 diff --git a/src/Pugs/AST/Pad.hs b/src/Pugs/AST/Pad.hs --- a/src/Pugs/AST/Pad.hs +++ b/src/Pugs/AST/Pad.hs @@ -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 {- {-| diff --git a/src/Pugs/AST/SIO.hs b/src/Pugs/AST/SIO.hs --- a/src/Pugs/AST/SIO.hs +++ b/src/Pugs/AST/SIO.hs @@ -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 diff --git a/src/Pugs/AST/Types.hs b/src/Pugs/AST/Types.hs --- a/src/Pugs/AST/Types.hs +++ b/src/Pugs/AST/Types.hs @@ -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 diff --git a/src/Pugs/Class.hs b/src/Pugs/Class.hs --- a/src/Pugs/Class.hs +++ b/src/Pugs/Class.hs @@ -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 ] diff --git a/src/Pugs/CodeGen/PIR/Prelude.hs b/src/Pugs/CodeGen/PIR/Prelude.hs --- a/src/Pugs/CodeGen/PIR/Prelude.hs +++ b/src/Pugs/CodeGen/PIR/Prelude.hs @@ -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;" , "}" , "" diff --git a/src/Pugs/Compile/Pugs.hs b/src/Pugs/Compile/Pugs.hs --- a/src/Pugs/Compile/Pugs.hs +++ b/src/Pugs/Compile/Pugs.hs @@ -91,7 +91,7 @@ where syms = padToList pad -instance Compile IHash where +instance x ~ IHash => Compile x where compile map = error (show map) diff --git a/src/Pugs/Embed/Parrot.hs b/src/Pugs/Embed/Parrot.hs --- a/src/Pugs/Embed/Parrot.hs +++ b/src/Pugs/Embed/Parrot.hs @@ -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 diff --git a/src/Pugs/Eval.hs b/src/Pugs/Eval.hs --- a/src/Pugs/Eval.hs +++ b/src/Pugs/Eval.hs @@ -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 diff --git a/src/Pugs/Monads.hs b/src/Pugs/Monads.hs --- a/src/Pugs/Monads.hs +++ b/src/Pugs/Monads.hs @@ -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. diff --git a/src/Pugs/Parser/Charnames.hs b/src/Pugs/Parser/Charnames.hs --- a/src/Pugs/Parser/Charnames.hs +++ b/src/Pugs/Parser/Charnames.hs @@ -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 diff --git a/src/Pugs/Parser/Number.hs b/src/Pugs/Parser/Number.hs --- a/src/Pugs/Parser/Number.hs +++ b/src/Pugs/Parser/Number.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE UndecidableInstances,FlexibleContexts #-} module Pugs.Parser.Number ( parseNatOrRat, diff --git a/src/Pugs/Parser/Operator.hs b/src/Pugs/Parser/Operator.hs --- a/src/Pugs/Parser/Operator.hs +++ b/src/Pugs/Parser/Operator.hs @@ -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) diff --git a/src/Pugs/Parser/Types.hs b/src/Pugs/Parser/Types.hs --- a/src/Pugs/Parser/Types.hs +++ b/src/Pugs/Parser/Types.hs @@ -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 diff --git a/src/Pugs/Pretty.hs b/src/Pugs/Pretty.hs --- a/src/Pugs/Pretty.hs +++ b/src/Pugs/Pretty.hs @@ -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(" diff --git a/src/Pugs/Prim.hs b/src/Pugs/Prim.hs --- a/src/Pugs/Prim.hs +++ b/src/Pugs/Prim.hs @@ -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" diff --git a/src/Pugs/Prim/List.hs b/src/Pugs/Prim/List.hs --- a/src/Pugs/Prim/List.hs +++ b/src/Pugs/Prim/List.hs @@ -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 diff --git a/src/Pugs/Prim/Match.hs b/src/Pugs/Prim/Match.hs --- a/src/Pugs/Prim/Match.hs +++ b/src/Pugs/Prim/Match.hs @@ -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) diff --git a/src/Pugs/Prim/Yaml.hs b/src/Pugs/Prim/Yaml.hs --- a/src/Pugs/Prim/Yaml.hs +++ b/src/Pugs/Prim/Yaml.hs @@ -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 diff --git a/src/Pugs/Types.hs b/src/Pugs/Types.hs --- a/src/Pugs/Types.hs +++ b/src/Pugs/Types.hs @@ -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 diff --git a/src/Pugs/Types/Hash.hs b/src/Pugs/Types/Hash.hs --- a/src/Pugs/Types/Hash.hs +++ b/src/Pugs/Types/Hash.hs @@ -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 diff --git a/src/Pugs/Version.hs b/src/Pugs/Version.hs --- a/src/Pugs/Version.hs +++ b/src/Pugs/Version.hs @@ -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