diff --git a/Pugs.cabal b/Pugs.cabal --- a/Pugs.cabal +++ b/Pugs.cabal @@ -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 diff --git a/src/Pugs/AST.hs b/src/Pugs/AST.hs --- a/src/Pugs/AST.hs +++ b/src/Pugs/AST.hs @@ -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) 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,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 diff --git a/src/Pugs/CodeGen.hs b/src/Pugs/CodeGen.hs --- a/src/Pugs/CodeGen.hs +++ b/src/Pugs/CodeGen.hs @@ -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 diff --git a/src/Pugs/Compile.hs b/src/Pugs/Compile.hs --- a/src/Pugs/Compile.hs +++ b/src/Pugs/Compile.hs @@ -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] diff --git a/src/Pugs/Embed/Haskell.hs b/src/Pugs/Embed/Haskell.hs --- a/src/Pugs/Embed/Haskell.hs +++ b/src/Pugs/Embed/Haskell.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -fglasgow-exts -cpp -package plugins #-} +{-# OPTIONS_GHC -fglasgow-exts -cpp #-} module Pugs.Embed.Haskell where diff --git a/src/Pugs/Eval.hs b/src/Pugs/Eval.hs --- a/src/Pugs/Eval.hs +++ b/src/Pugs/Eval.hs @@ -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 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 @@ -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 diff --git a/src/Pugs/Prim.hs b/src/Pugs/Prim.hs --- a/src/Pugs/Prim.hs +++ b/src/Pugs/Prim.hs @@ -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 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 @@ -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)