Pugs 6.2.13.11 → 6.2.13.12
raw patch · 10 files changed
+78/−66 lines, 10 files
Files
- Pugs.cabal +1/−1
- src/Pugs/AST.hs +12/−11
- src/Pugs/AST/Eval.hs +2/−2
- src/Pugs/CodeGen.hs +7/−2
- src/Pugs/Compile.hs +2/−2
- src/Pugs/Embed/Haskell.hs +1/−1
- src/Pugs/Eval.hs +13/−12
- src/Pugs/Parser/Operator.hs +19/−17
- src/Pugs/Prim.hs +9/−14
- src/Pugs/Prim/Yaml.hs +12/−4
Pugs.cabal view
@@ -1,5 +1,5 @@ Name : Pugs-Version : 6.2.13.11+Version : 6.2.13.12 license : BSD3 license-file : LICENSE cabal-version : >= 1.2
src/Pugs/AST.hs view
@@ -193,18 +193,19 @@ , mc_signature = code_params c , mc_variants = Set.singleton var }- merge _ old = case old of- PEConstant{ pe_proto = MkRef (ICode oldCV) }- | Just (mc :: VMultiCode) <- fromTypeable oldCV -> protoEntry- { pe_proto = MkRef . ICode $ protoCode- { mc_assoc = code_assoc c `mappend` code_assoc mc- , mc_variants = Set.insert var (mc_variants mc)- , mc_signature = if length (mc_signature mc) == length (code_params c)- then code_params c- else [defaultArrayParam]- }+ merge :: PadEntry -> PadEntry -> PadEntry+ merge _ PEConstant{ pe_proto = MkRef (ICode oldCV) }+ | Just (mc :: VMultiCode) <- fromTypeable oldCV+ = protoEntry+ { pe_proto = MkRef . ICode $ protoCode+ { mc_assoc = code_assoc c `mappend` code_assoc mc+ , mc_variants = Set.insert var (mc_variants mc)+ , mc_signature = if length (mc_signature mc) == length (code_params c)+ then code_params c+ else [defaultArrayParam] }- _ -> old -- sub overrides multi -- XXX - error?+ }+ merge _ old = old -- sub overrides multi -- XXX - error? in MkPad (Map.insertWith' merge var' protoEntry (Map.insert var entry map)) | otherwise = MkPad (Map.insert var entry map)
src/Pugs/AST/Eval.hs view
@@ -3,7 +3,7 @@ module Pugs.AST.Eval where import Pugs.Internals import Pugs.Cont hiding (resetT)-import Control.Exception (try, Exception)+import System.IO.Error (try, IOError) import Pugs.AST.SIO import {-# SOURCE #-} Pugs.AST.Internals@@ -164,7 +164,7 @@ If t supress the exception and return an associated value instead. -}-guardIOexcept :: MonadIO m => [((Exception -> Bool), a)] -> IO a -> m a+guardIOexcept :: MonadIO m => [((IOError -> Bool), a)] -> IO a -> m a guardIOexcept safetyNet x = do rv <- io $ try x case rv of
src/Pugs/CodeGen.hs view
@@ -84,8 +84,13 @@ ('!':key) -> do hPutStrLn stderr $ "*** The backend '" ++ s ++ "' is deprecated." hPutStrLn stderr $ " Please use '" ++ key ++ "' instead."- Map.lookup key generators- key -> Map.lookup key generators+ lookupGenerator key+ key -> lookupGenerator key+ where+ lookupGenerator :: String -> IO Generator+ lookupGenerator k = case Map.lookup k generators of+ Just g -> return g+ _ -> fail $ "Cannot find generator: " ++ k codeGen :: String -> FilePath -> Env -> IO String codeGen s file env = do
src/Pugs/Compile.hs view
@@ -75,13 +75,13 @@ entries = sortBy padSort [ (cast var, readPadEntry ref) | (var, ref) <- padToList pad ] canCompile (name@('&':_) :: String, sym) = do (ref :: VRef) <- sym- case ref of+ (case ref of MkRef ICode{} -> do codes <- readCodesFromRef ref fmap concat $ forM codes (doCode name) MkRef (IScalar sv) | scalar_iType sv == mkType "Scalar::Const" -> doCode name =<< fromVal =<< scalar_fetch sv- _ -> return []+ _ -> return []) :: Comp [PIL_Decl] canCompile ("@*END", sym) = do ref <- sym cvList <- fromVals =<< readRef ref :: Comp [VCode]
src/Pugs/Embed/Haskell.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -fglasgow-exts -cpp -package plugins #-}+{-# OPTIONS_GHC -fglasgow-exts -cpp #-} module Pugs.Embed.Haskell where
src/Pugs/Eval.hs view
@@ -195,9 +195,9 @@ when (isCollectionRef && isItemCxt cxt) $ do -- auto-enreference esc $ VRef ref- case ref of+ (case ref of MkRef IPair{} -> esc (VRef ref)- _ -> esc =<< readRef ref+ _ -> esc =<< readRef ref) :: Eval () -- LValue here when isCollectionRef $ esc (castV ref) val <- readRef ref@@ -507,12 +507,12 @@ av <- enterLValue $ enterEvalContext cxtSlurpyAny list sub <- fromCodeExp body -- XXX this is wrong -- should use Array.next- elms <- case av of+ elms <- (case av of VRef (MkRef sv@IScalar{}) -> return [sv]- VList xs -> return . (`map` xs) $ \x -> case x of+ VList xs -> return . (`map` xs) $ \x -> ((case x of VRef (MkRef sv@IScalar{}) -> sv- _ -> (IScalar x)- _ -> join $ doArray av array_fetchElemAll+ _ -> (IScalar x)) :: IVar VScalar)+ _ -> join $ doArray av array_fetchElemAll) :: Eval [IVar VScalar] -- This makes "for @x { ... }" into "for @x -> $_ is rw {...}" let arity = length (subParams sub) runBody [] _ _ = return undef@@ -1150,6 +1150,7 @@ | name <- map paramName (prms ++ repeat (last prms)) | v <- vals ]+ forceThunk :: Val -> Eval Val forceThunk (VRef (MkRef (IThunk tv))) = thunk_force tv forceThunk x = return x chainFun _ _ _ _ _ = fail "Impossible: Chained function with less than 2 arguments?"@@ -1490,18 +1491,18 @@ (True, False) -> do --- not scalarRef! -- use the new "transparent IType" thing! case showType (typeOfSigilVar var) of- "Hash" -> ($ v) . fix $ \(redo :: Val -> Eval Val) x -> case x of+ "Hash" -> ($ v) . fix $ \(redo :: Val -> Eval Val) x -> (case x of VRef (MkRef (IHash h)) -> return (VRef $ hashRef h) VRef ref@(MkRef IScalar{}) -> redo =<< readRef ref- _ -> fmap (VRef . hashRef) (fromVal v :: Eval VHash)- "Array" -> ($ v) . fix $ \(redo :: Val -> Eval Val) x -> case x of+ _ -> fmap (VRef . hashRef) (fromVal v :: Eval VHash)) :: Eval Val+ "Array" -> ($ v) . fix $ \(redo :: Val -> Eval Val) x -> (case x of VRef (MkRef (IArray a)) -> return (VRef $ arrayRef a) VRef ref@(MkRef IScalar{}) -> redo =<< readRef ref- _ -> fmap (VRef . arrayRef) (fromVal v :: Eval VArray)- _ -> case v of+ _ -> fmap (VRef . arrayRef) (fromVal v :: Eval VArray)) :: Eval Val+ _ -> (case v of VRef (MkRef IScalar{}) -> return (VRef $ scalarRef v) VRef _ -> return v -- XXX - preserving ref- _ -> return (VRef $ scalarRef v) + _ -> return (VRef $ scalarRef v)) :: Eval Val (False, False) -> return v -- XXX reduce to val? (False, True) -> do -- make a copy
src/Pugs/Parser/Operator.hs view
@@ -203,23 +203,25 @@ Just rv -> return rv Nothing -> do ref <- readPadEntry entry- case ref of- MkRef (ICode cv)- | relevantToParsing (code_type cv) (code_assoc cv) -> do- let rv = MkCurrentFunction var (code_assoc cv) (code_params cv)- res = seq rv (Just rv)- unsafeIOToSTM (H.insert _RefToFunction entry res)- return res- MkRef (IScalar sv)- | Just (VCode cv) <- scalar_const sv- , relevantToParsing (code_type cv) (code_assoc cv) -> do- let rv = MkCurrentFunction var (code_assoc cv) (code_params cv)- res = seq rv (Just rv)- unsafeIOToSTM (H.insert _RefToFunction entry res)- return res- _ -> do- unsafeIOToSTM (H.insert _RefToFunction entry Nothing)- return Nothing+ filterRef ref+ where+ filterRef :: VRef -> STM (Maybe CurrentFunction)+ filterRef (MkRef (ICode cv))+ | relevantToParsing (code_type cv) (code_assoc cv) = do+ let rv = MkCurrentFunction var (code_assoc cv) (code_params cv)+ res = seq rv (Just rv)+ unsafeIOToSTM (H.insert _RefToFunction entry res)+ return res+ filterRef (MkRef (IScalar sv))+ | Just (VCode cv) <- scalar_const sv+ , relevantToParsing (code_type cv) (code_assoc cv) = do+ let rv = MkCurrentFunction var (code_assoc cv) (code_params cv)+ res = seq rv (Just rv)+ unsafeIOToSTM (H.insert _RefToFunction entry res)+ return res+ filterRef _ = do+ unsafeIOToSTM (H.insert _RefToFunction entry Nothing)+ return Nothing inScope :: Pkg -> Var -> Bool inScope pkg var
src/Pugs/Prim.hs view
@@ -38,7 +38,6 @@ import qualified Data.Set as Set import Data.IORef import System.IO.Error (isEOFError)-import Control.Exception (ioErrors) import Pugs.Prim.Keyed import Pugs.Prim.Yaml@@ -216,12 +215,13 @@ op1 "+^" = op1Cast (VInt . pred . negate) -- Arbitrary precision complement- 0 ==> -1 / 1 ==> -2 op1 "~^" = op1Cast (VStr . mapStr complement) op1 "?^" = op1 "!"-op1 "\\" = \v -> do- return $ case v of- (VRef (MkRef (IScalar _))) -> VRef . scalarRef $ v- (VRef _) -> v- (VList vs) -> VRef . arrayRef $ vs- _ -> VRef . scalarRef $ v+op1 "\\" = return . doCapture+ where+ doCapture :: Val -> Val+ doCapture v@(VRef (MkRef IScalar{})) = VRef . scalarRef $ v+ doCapture v@VRef{} = v+ doCapture (VList vs) = VRef . arrayRef $ vs+ doCapture v = VRef . scalarRef $ v op1 "^" = op2RangeExclRight (VNum 0) op1 "post:..." = op1Range op1 "not" = op1 "!"@@ -839,20 +839,15 @@ Just str -> return $! VStr $! (length str `seq` str) _ -> return undef doGetLine :: VHandle -> IO (Maybe VStr)- doGetLine fh = guardIOexcept [(isIOError isEOFError, Nothing)] $ do+ doGetLine fh = guardIOexcept [(isEOFError, Nothing)] $ do line <- hGetLine fh return . Just . decodeUTF8 $ line -isIOError :: (IOError -> Bool) -> Exception -> Bool-isIOError f err = case ioErrors err of- Just ioe -> f ioe- Nothing -> False- op1Getc :: Val -> Eval Val op1Getc = \v -> op1Read v (getChar) (getChar) where getChar :: VHandle -> Eval Val- getChar fh = guardIOexcept [(isIOError isEOFError, undef)] $ do+ getChar fh = guardIOexcept [(isEOFError, undef)] $ do char <- hGetChar fh str <- getChar' fh char return $ VStr $ decodeUTF8 str
src/Pugs/Prim/Yaml.hs view
@@ -53,10 +53,18 @@ --spec <- io . newTVarIO . Map.map lazyScalar $ Map.fromList (vals :: [(String, Val)]) spec' <- io . newTVarIO $ Map.fromList (vals :: [(String, Val)]) spec <- stm . readTVar $ spec'- rule <- fromVal =<< Map.lookup "rule" spec- global <- fromVal =<< Map.lookup "global" spec- stringify <- fromVal =<< Map.lookup "stringify" spec- adverbs <- Map.lookup "adverbs" spec+ rule <- case Map.lookup "rule" spec of+ Just v -> fromVal v + _ -> fail "Cannot find the 'rule' spec"+ global <- case Map.lookup "global" spec of+ Just v -> fromVal v + _ -> fail "Cannot find the 'global' spec"+ stringify <- case Map.lookup "stringify" spec of+ Just v -> fromVal v + _ -> fail "Cannot find the 'stringify' spec"+ adverbs <- case Map.lookup "adverbs" spec of+ Just v -> fromVal v + _ -> fail "Cannot find the 'adverbs' spec" return $ VRule MkRulePGE{rxRule=rule, rxGlobal=global, rxStringify=stringify, rxAdverbs=adverbs} Just x -> error ("can't deserialize: " ++ unpackBuf x)