Pugs 6.2.13.16 → 6.2.13.20110519
raw patch · 28 files changed
+109/−83 lines, 28 filesdep ~basedep ~haskelinedep ~mtl
Dependency ranges changed: base, haskeline, mtl, parsec, pugs-DrIFT
Files
- Pugs.cabal +5/−4
- src/Pugs.hs +5/−2
- src/Pugs/AST.hs +1/−0
- src/Pugs/AST/Eval.hs +3/−2
- src/Pugs/AST/Internals.hs +10/−11
- src/Pugs/AST/Internals/Instances.hs +4/−4
- src/Pugs/AST/Pad.hs +1/−0
- src/Pugs/AST/Types.hs +1/−1
- src/Pugs/CodeGen.hs +2/−1
- src/Pugs/Compile.hs +4/−0
- src/Pugs/Compile/Pugs.hs +1/−0
- src/Pugs/Eval.hs +3/−0
- src/Pugs/Eval/Var.hs +1/−0
- src/Pugs/Lexer.hs +1/−1
- src/Pugs/Monads.hs +3/−0
- src/Pugs/Parser.hs +28/−28
- src/Pugs/Parser/Literal.hs +2/−2
- src/Pugs/Parser/Operator.hs +1/−0
- src/Pugs/Parser/Program.hs +2/−2
- src/Pugs/Parser/Types.hs +11/−15
- src/Pugs/Parser/Unsafe.hs +2/−2
- src/Pugs/Parser/Util.hs +4/−4
- src/Pugs/Prim.hs +1/−0
- src/Pugs/Prim/Eval.hs +3/−2
- src/Pugs/Prim/Keyed.hs +1/−0
- src/Pugs/Prim/Match.hs +3/−1
- src/Pugs/Prim/Yaml.hs +1/−0
- src/Pugs/Run.hs +5/−1
Pugs.cabal view
@@ -1,5 +1,5 @@ Name : Pugs-Version : 6.2.13.16+Version : 6.2.13.20110519 license : BSD3 license-file : LICENSE cabal-version : >= 1.2.3@@ -158,17 +158,18 @@ executable pugs main-is: Main.hs hs-source-dirs: src+ extra-lib-dirs: /usr/lib /opt/local/lib build-depends:- base >= 3 && < 5, haskell98, filepath, mtl, parsec < 3.0.0, network,+ base >= 4 && < 5, haskell98, 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.2.1, FindBin,+ array, directory, utf8-string, binary, haskeline >= 0.6.4.0, FindBin, control-timeout >= 0.1.2, MetaObject >= 0.0.4, HsParrot >= 0.0.2, pugs-compat >= 0.0.5,- pugs-DrIFT >= 2.2.3.0,+ pugs-DrIFT >= 2.2.3.2, stringtable-atom >= 0.0.4, HsSyck >= 0.44, stm >= 2.1.2.1
src/Pugs.hs view
@@ -40,6 +40,7 @@ import qualified Data.Map as Map import qualified System.FilePath as FilePath (combine, splitFileName) import Control.Timeout+import Control.Exception (SomeException) {-| The entry point of Pugs. Uses 'Pugs.Run.runWithArgs' to normalise the command-line@@ -284,7 +285,7 @@ file = foldl1 FilePath.combine (x ++ [helper]) maybeFindFile :: FilePath -> MaybeT IO FilePath maybeFindFile pathname = do- dir <- liftIO $ getDirectoryContents path `catchIO` (const $ return [])+ dir <- liftIO $ getDirectoryContents path `catchIO` (\(_ :: SomeException) -> return []) guard (filename `elem` dir) return pathname where@@ -375,10 +376,12 @@ makeDumpEnv (Sym x y z w exp) = Sym x y z w $ makeDumpEnv exp makeDumpEnv exp = Stmts (Ann (Cxt cxtItemAny) exp) (Syn "continuation" []) +{- handler (IOException ioe) | isUserError ioe = do putStrLn "Internal error while running expression:" putStrLn $ ioeGetErrorString ioe- handler err = do+-}+ handler (err :: SomeException) = do putStrLn "Internal error while running expression:" putStrLn $ show err
src/Pugs/AST.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans -funbox-strict-fields -fallow-overlapping-instances -fparr #-}+{-# LANGUAGE GADTs #-} {-| Abstract syntax tree.
src/Pugs/AST/Eval.hs view
@@ -4,6 +4,7 @@ import Pugs.Internals import Pugs.Cont hiding (resetT) import System.IO.Error (try, IOError)+import Control.Exception (SomeException) import Pugs.AST.SIO import {-# SOURCE #-} Pugs.AST.Internals@@ -31,7 +32,7 @@ runEvalIO env = fmap liftResult . runIO . (`runReaderT` env) . (`runContT` return) . runEvalT tryIO :: a -> IO a -> Eval a-tryIO err = liftEval . io . (`catchIO` (const $ return err))+tryIO err = liftEval . io . (`catchIO` (\(e :: SomeException) -> return err)) {-| 'shiftT' is like @callCC@, except that when you activate the continuation@@ -178,7 +179,7 @@ guardSTM :: STM a -> Eval a guardSTM x = do- rv <- stm $ fmap Right x `catchSTM` (return . Left)+ rv <- stm $ fmap Right x `catchSTM` (\(e :: SomeException) -> return (Left e)) case rv of Left e -> fail (show e) Right v -> return v
src/Pugs/AST/Internals.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans -fallow-overlapping-instances -fallow-undecidable-instances -fparr #-}+{-# LANGUAGE GADTs #-} module Pugs.AST.Internals ( Eval(..), -- uses Val, Env, SIO@@ -1316,17 +1317,15 @@ instance Show VRef where show ref@(MkRef ivar) = case ivar of- IScalar x -> showAddr x- IArray x -> showAddr x- IHash x -> showAddr x- ICode x -> showAddr x- IHandle x -> showAddr x- IRule x -> showAddr x- IThunk x -> showAddr x- IPair x -> showAddr x- IVal x -> show x- where- showAddr x = showAddressOf (showType (refType ref)) x+ IScalar x -> showAddressOf (showType (refType ref)) x+ IArray x -> showAddressOf (showType (refType ref)) x+ IHash x -> showAddressOf (showType (refType ref)) x+ ICode x -> showAddressOf (showType (refType ref)) x+ IHandle x -> showAddressOf (showType (refType ref)) x+ IRule x -> showAddressOf (showType (refType ref)) x+ 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
src/Pugs/AST/Internals/Instances.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans -fallow-overlapping-instances -fallow-undecidable-instances -fparr #-}+{-# LANGUAGE GADTs #-} @@ -158,10 +159,9 @@ fmap (MkRef . IScalar) (fromYAML node :: IO VScalar) | s == packBuf "tag:hs:Pair" = fmap pairRef (fromYAML node :: IO VPair)- | s == packBuf "tag:hs:IScalar" = newV newScalar- | s == packBuf "tag:hs:Array" = newV newArray- | s == packBuf "tag:hs:Hash" = newV newHash- where newV f = fmap MkRef (f =<< fromYAML node)+ | s == packBuf "tag:hs:IScalar" = fmap MkRef (newScalar =<< fromYAML node)+ | 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 asYAML x = do
src/Pugs/AST/Pad.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fglasgow-exts -fparr #-}+{-# LANGUAGE GADTs #-} module Pugs.AST.Pad ( mkPad, unionPads, padKeys, filterPad, adjustPad, mergePadEntry, mergeLexPads, readMPad, writeMPad, appendMPad, modifyMPad, newMPad
src/Pugs/AST/Types.hs view
@@ -425,7 +425,7 @@ instance Ord VProcess where compare _ _ = EQ -instance Typeable Unique where typeOf _ = mkTyConApp (mkTyCon "Unique") []+-- instance Typeable Unique where typeOf _ = mkTyConApp (mkTyCon "Unique") [] instance Typeable ProcessHandle where typeOf _ = mkTyConApp (mkTyCon "ProcessHandle") [] instance Typeable Regex where typeOf _ = mkTyConApp (mkTyCon "Regex") []
src/Pugs/CodeGen.hs view
@@ -21,6 +21,7 @@ import Pugs.CodeGen.Binary (genParseBinary) import Pugs.CodeGen.JSON (genJSON) import Pugs.Compile.Pugs (genPugs)+import Control.Exception (SomeException) -- import Pugs.Compile.Haskell (genGHC) -- import Pugs.CodeGen.XML (genXML) import qualified Data.Map as Map@@ -94,7 +95,7 @@ codeGen :: String -> FilePath -> Env -> IO String codeGen s file env = do- gen <- catchIO (doLookup s) . const $ do+ gen <- catchIO (doLookup s) $ \(_ :: SomeException) -> do fail $ "Cannot generate code for " ++ s ++ ": " ++ file rv <- runEvalIO env (gen file) case rv of
src/Pugs/Compile.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances -fno-warn-orphans -funbox-strict-fields -cpp -fno-warn-deprecations -fallow-overlapping-instances #-}+{-# LANGUAGE GADTs #-} {-| Compiler interface.@@ -70,6 +71,8 @@ @\@*END@ are compiled. -} instance Compile Pad [PIL_Decl] where compile pad = do+ return [];+ {- XXX! entries' <- mapM canCompile entries return $ concat entries' where@@ -104,6 +107,7 @@ doCode name vsub = case subBody vsub of Prim _ -> return [] _ -> compile (name, vsub)+ -} eachM :: (Monad m) => [a] -> ((Int, a) -> m b) -> m [b] eachM = forM . ([0..] `zip`)
src/Pugs/Compile/Pugs.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fglasgow-exts -fallow-overlapping-instances -fparr #-}+{-# LANGUAGE GADTs #-} module Pugs.Compile.Pugs (genPugs) where import Pugs.AST
src/Pugs/Eval.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fglasgow-exts -cpp -fno-warn-deprecations -fallow-overlapping-instances -fparr #-}+{-# LANGUAGE GADTs #-} {-| Evaluation and reduction engine.@@ -838,6 +839,7 @@ where implies True = id implies False = const 0+ fromAdverb :: forall val. (Value val) => [(String, Val)] -> [String] -> Eval val fromAdverb _ [] = fromVal undef fromAdverb hv (k:ks) = case lookup k hv of Just v -> fromVal v@@ -1448,6 +1450,7 @@ applyMacroResult code@VCode{} = reduceApp (Val code) Nothing [] applyMacroResult VUndef = retEmpty applyMacroResult _ = fail "Macro did not return an AST, a Str or a Code!"+ localEnv :: Eval a -> Eval a localEnv = case appKind of AKDisplaced -> enterCaller _ -> id
src/Pugs/Eval/Var.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fglasgow-exts -fallow-overlapping-instances -funbox-strict-fields -fparr #-}+{-# LANGUAGE GADTs #-} module Pugs.Eval.Var ( findVar, findVarRef, findSub,
src/Pugs/Lexer.hs view
@@ -550,7 +550,7 @@ simpleSpace = do skipMany1 (satisfy isSpace) pos <- getPosition- modify (\s -> s{ s_wsLine = sourceLine pos, s_wsColumn = sourceColumn pos })+ updateState (\s -> s{ s_wsLine = sourceLine pos, s_wsColumn = sourceColumn pos }) multiLineComment :: RuleParser () multiLineComment = do
src/Pugs/Monads.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fglasgow-exts -fallow-overlapping-instances #-}+{-# LANGUAGE GADTs #-} {-| Common operations on Eval monad.@@ -353,10 +354,12 @@ assertBlocks f name = forM_ (f (subTraitBlocks sub)) $ \cv -> do rv <- fromVal =<< (evalExp . Syn "block" . (:[]) . Syn "sub" . (:[]) . Val . castV $ cv) if rv then return () else die (name ++ " assertion failed") (subName sub)+{- runBlocks' f = mapM_ (evalExp . Syn "block'" . (:[]) . Syn "sub" . (:[]) . Val . castV) (f (subTraitBlocks sub)) assertBlocks' f name = forM_ (f (subTraitBlocks sub)) $ \cv -> do rv <- fromVal =<< (evalExp . Syn "block'" . (:[]) . Syn "sub" . (:[]) . Val . castV $ cv) if rv then return () else die (name ++ " assertion failed") (subName sub)+-} typ = subType sub doCC :: (Val -> Eval b) -> [Val] -> Eval b doCC cc [] = cc undef
src/Pugs/Parser.hs view
@@ -50,7 +50,7 @@ ruleBlock :: RuleParser BlockInfo ruleBlock = do- lvl <- gets s_bracketLevel+ lvl <- s_bracketLevel `fmap` getState case lvl of StatementBracket -> ruleBlock' _ -> lexeme ruleVerbatimBlock@@ -253,7 +253,7 @@ case rv of Right (_, kind, pkgVal, env) -> do block <- verbatimBraces ruleBlockBody- env' <- ask+ env' <- getRuleEnv putRuleEnv env'{ envPackage = envPackage env } retInterpolatedBlock =<< retBlockWith (\body -> Syn "namespace" [kind, pkgVal, body]) block Left err -> fail err@@ -276,7 +276,7 @@ optional ruleVersionPart -- v optional ruleAuthorPart -- a whiteSpace- env <- ask+ env <- getRuleEnv newName <- case scope of Just SOur -> return $ cast (envPackage env) ++ "::" ++ name Nothing -> return name@@ -298,7 +298,7 @@ return (Left $ "Circular role composition detected for " ++ sym ++ " '" ++ name ++ "'") _ -> do unsafeEvalExp (newPackage pkgClass newName parentClasses mixinRoles)- modify $ \state -> state+ updateState $ \state -> state { s_env = (s_env state) { envPackage = cast newName }@@ -343,7 +343,7 @@ typ'' <- option typ' returnsOrOf traits <- ruleTraitsIsOnly - env <- ask+ env <- getRuleEnv let pkg = cast (envPackage env) nameQualified | ':' `elem` name = name | isGlobal = name@@ -390,7 +390,7 @@ -- Generate init pad for each of our params, as well as for ourselves... paramsPad <- genParamEntries styp signature- modify $ \s -> s{ s_protoPad = paramsPad }+ updateState $ \s -> s{ s_protoPad = paramsPad } block <- ruleBlock let (fun, names, _) = extractNamedPlaceholders styp formal (bi_body block)@@ -399,7 +399,7 @@ when (isJust formal && (not.null) names) $ fail "Cannot mix placeholder variables with formal parameters" - env <- ask+ env <- getRuleEnv let template' = template { subBody = case isMulti of@@ -517,7 +517,7 @@ _ -> Noop -- XXX - RIGHT HERE, add this one to CompPad?- modify $ \state -> state+ updateState $ \state -> state { s_knownVars = Map.insert (cast name) (fromJust . envCompPad $ s_env state) (s_knownVars state) } rv <- case opt of@@ -564,7 +564,7 @@ -- is eval(...), ... # sub call (aux, trait) <- ruleTrait ["is", "does"] lookAhead (eof <|> (oneOf ";}" >> return ()))- pkg <- asks envPackage+ pkg <- envPackage `fmap` getRuleEnv let meta = _Var (':':'*':cast pkg) expMeta = Syn "=" [ Syn "{}" [meta, Val (VStr aux)]@@ -587,7 +587,7 @@ lexeme $ choice [ ruleQualifiedIdentifier -- ::?CLASS, ::?ROLE, etc.- , char '?' >> ruleQualifiedIdentifier >> fmap cast (asks envPackage)+ , char '?' >> ruleQualifiedIdentifier >> fmap cast (envPackage `fmap` getRuleEnv) ] attr <- ruleVarName (sigil:twigil:key) <- case attr of@@ -600,7 +600,7 @@ traits <- ruleTraitsIsOnly optional $ do { symbol "handles"; ruleExpression } def <- ruleParamDefault- env <- ask+ env <- getRuleEnv let self = selfParam $ cast (envPackage env) paramsPad <- genParamEntries SubMethod [self] -- manufacture an accessor, and register this slot into metaobject@@ -745,11 +745,11 @@ ruleLoadPerlPackage :: String -> Bool -> String -> RuleParser Exp ruleLoadPerlPackage pkg use lang = do when use $ do -- for &no, don't load code- env <- ask+ env <- getRuleEnv env' <- unsafeEvalEnv $ if lang == "perl6" then (App (_Var "&use") Nothing [Val $ VStr pkg]) else (App (_Var $ "&require_" ++ lang) Nothing [Val $ VStr pkg])- modify $ \state -> state+ updateState $ \state -> state { s_env = env { envGlobal = envGlobal env' }@@ -936,7 +936,7 @@ -- Check for placeholder vs formal parameters unless (Set.null $ Set.delete varTopic params) $ fail "Closure traits take no formal parameters"- env <- ask+ env <- getRuleEnv let code = mkSub { subName = cast name , subType = SubBlock@@ -950,7 +950,7 @@ -- We unshift END blocks to @*END at compile-time. -- They're then run at the end of runtime or at the end of the -- whole program.- pkg <- asks envPackage+ pkg <- envPackage `fmap` getRuleEnv rv <- unsafeEvalExp $ App (_Var "&unshift") (Just (_Var (if pkg == mainPkg then "@Main::END" else "@*END")))@@ -960,7 +960,7 @@ -- We have to exit if the user has written code like BEGIN { exit }. val <- possiblyExit =<< unsafeEvalExp (checkForIOLeak code) -- And install any pragmas they've requested.- env <- ask+ env <- getRuleEnv let idat = unsafePerformSTM . readTVar $ envInitDat env install $ initPragmas idat clearDynParsers@@ -976,7 +976,7 @@ where install [] = return $ () install prag = do- env' <- ask+ env' <- getRuleEnv let env'' = envCaller env' -- not sure about this. case env'' of Just target -> do@@ -1272,7 +1272,7 @@ (styp, formal, lvalue) <- option (SubBlock, Nothing, False) $ choice variants paramsPad <- genParamEntries styp (maybe (defaultParamFor styp) id formal)- modify $ \s -> s{ s_protoPad = paramsPad }+ updateState $ \s -> s{ s_protoPad = paramsPad } block <- ruleBlock retBlock styp formal lvalue block@@ -1295,7 +1295,7 @@ -- Check for placeholder vs formal parameters when (isJust formal && (not.null) names) $ fail "Cannot mix placeholder variables with formal parameters"- env <- ask+ env <- getRuleEnv let sub = mkCode { isMulti = False , subName = __"<anon>"@@ -1418,7 +1418,7 @@ return (False, paramsToNameTypes params defType, accessors) makeAccessor prm = do -- Generate accessor for class attributes.- pkg <- asks envPackage+ pkg <- envPackage `fmap` getRuleEnv paramsPad <- genParamEntries SubPrim [selfParam $ cast pkg] let sub = mkPrim { isMulti = False@@ -1465,11 +1465,11 @@ , fmap (Ann Parens) (verbatimParens ruleBracketedExpression) ] pos <- getPosition- col <- gets s_wsColumn+ col <- s_wsColumn `fmap` getState -- If we terminated on whitespace, don't apply postterms. if (col == sourceColumn pos) then do- ln <- gets s_wsLine+ ln <- s_wsLine `fmap` getState if ln == sourceLine pos then return term else do@@ -1797,7 +1797,7 @@ char '.' option '.' (char '=') -- allow ".=foo" as a term to parse as "$_ .= $_.foo". insertIntoPosition "."- -- prevChar <- gets s_char+ -- prevChar <- s_char `fmap` getRuleEnv fs <- many s_postTerm -- when (prevChar == '}') $ do -- pos <- getPosition@@ -1951,7 +1951,7 @@ -} parseNoParenArgList :: RuleParser (Maybe Exp, [Exp]) parseNoParenArgList = do- lvl <- gets s_bracketLevel+ lvl <- s_bracketLevel `fmap` getState formal <- formalSegment lvl `sepEndBy1` (symbol ":") processFormals formal @@ -2067,7 +2067,7 @@ "INC" | "@" <- sigil -> return (makeVar name) _ -> do -- Plain and simple variable -- do a lexical check.- state <- get+ state <- getState let var = cast name env = s_env state@@ -2082,7 +2082,7 @@ let outerPads = takeWhile (/= mpad) [ pc | PCompiling pc <- lexPads ] markPad vars pad = Map.insertWith' Set.union pad (Set.singleton var) vars -- traceM $ "Adding: " ++ show (var, outerPads)- put state{ s_outerVars = foldl' markPad outerVars outerPads }+ setState state{ s_outerVars = foldl' markPad outerVars outerPads } return (makeVar name) _ -> do -- If the variable is already defined as global, resolve it as such here.@@ -2105,10 +2105,10 @@ postApp <- ruleInvocationArguments Nothing methName False return $ Syn (shows (v_sigil var) "{}") [postApp (_Var "$__SELF__")] TImplicit -> do- knowns <- gets s_knownVars+ knowns <- s_knownVars `fmap` getState case Map.lookup var knowns of Just pad -> do- cpad <- asks envCompPad+ cpad <- envCompPad `fmap` getRuleEnv when (Just pad /= cpad) $ addImplicitVarToPad var _ -> addImplicitVarToPad var return exp
src/Pugs/Parser/Literal.hs view
@@ -15,7 +15,7 @@ ruleLit :: RuleParser Exp ruleLit = do- lvl <- gets s_bracketLevel+ lvl <- s_bracketLevel `fmap` getState let blk | ConditionalBracket <- lvl = id | otherwise = (ruleBlockLiteral:) choice ( ruleDoBlock : blk@@ -101,7 +101,7 @@ regularAdverbPair :: RuleParser Exp regularAdverbPair = do key <- many1 wordAny- lvl <- gets s_bracketLevel+ lvl <- s_bracketLevel `fmap` getState val <- lexeme ((optional ruleDot >> valueExp lvl) <|> return (Val $ VBool True)) return $ if (all isDigit key) then App (_Var "&Pugs::Internals::base") Nothing [Val (VStr key), val]
src/Pugs/Parser/Operator.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -cpp -fglasgow-exts -funbox-strict-fields -fno-full-laziness -fno-cse -fallow-overlapping-instances -fno-warn-orphans #-}+{-# LANGUAGE GADTs #-} module Pugs.Parser.Operator where import Pugs.Internals
src/Pugs/Parser/Program.hs view
@@ -173,14 +173,14 @@ env <- getRuleEnv topPad <- genParamEntries SubRoutine [defaultArrayParam]- modify $ \s -> s{ s_protoPad = topPad }+ updateState $ \s -> s{ s_protoPad = topPad } block <- ruleBlockBody `finallyM` eof main <- retVerbatimBlock SubPrim Nothing False $ block{ bi_body = mergeStmts emptyExp $ bi_body block } -- We are still in the compile time.- modify $ \s -> s{ s_env = (s_env s){ envCompPad = Just (error "no comp pad") } }+ updateState $ \s -> s{ s_env = (s_env s){ envCompPad = Just (error "no comp pad") } } -- Force a reclose-pad evaluation here by way of unsafeEvalExp. main'@(Val (VCode vc)) <- unsafeEvalExp $ Syn "" [unwrap main]
src/Pugs/Parser/Types.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -fglasgow-exts -funbox-strict-fields #-}+{-# OPTIONS_GHC -fglasgow-exts -funbox-strict-fields -fallow-overlapping-instances #-} module Pugs.Parser.Types ( RuleParser, RuleState(..), CharClass(..),@@ -195,10 +195,6 @@ } return rv -instance MonadState RuleState RuleParser where- get = getState- put = setState- type RuleOperator a = Operator Char RuleState a type RuleOperatorTable a = OperatorTable Char RuleState a @@ -227,23 +223,23 @@ -} enterBracketLevel :: BracketLevel -> RuleParser a -> RuleParser a enterBracketLevel bracket rule = do- prev <- gets s_bracketLevel- modify $ \state -> state{ s_bracketLevel = bracket }+ prev <- s_bracketLevel `fmap` getState+ updateState $ \state -> state{ s_bracketLevel = bracket } rv <- rule- modify $ \state -> state{ s_bracketLevel = prev }+ updateState $ \state -> state{ s_bracketLevel = prev } return rv {-| Retrieve the 'Pugs.AST.Internals.Env' from the current state of the parser. -} getRuleEnv :: RuleParser Env-getRuleEnv = gets s_env+getRuleEnv = s_env `fmap` getState {-| Update the 'Pugs.AST.Internals.Env' in the parser's state by applying a transformation function. -} modifyRuleEnv :: (Env -> Env) -> RuleParser ()-modifyRuleEnv f = modify $ \state -> state{ s_env = f (s_env state) }+modifyRuleEnv f = updateState $ \state -> state{ s_env = f (s_env state) } {-| Update the 's_blockPads' in the parser's state by applying a transformation function.@@ -254,7 +250,7 @@ -- First, we check that our pad does not contain shadowed OUTER symbols. -- XXX TODO: it should be fine for two identical padEntry to shadow each other, -- as is the case with { our multi f () {}; { &f(); our multi f ($x) {} } }.- state <- get+ state <- getState let myVars = padKeys pad dupVars = case Map.lookup compPad (s_outerVars state) of Just vars -> myVars `Set.intersection` vars@@ -271,11 +267,11 @@ () <- stm $ appendMPad compPad pad let myKnownVars = Map.fromDistinctAscList [ (var, compPad) | var <- Set.toAscList myVars ]- put state{ s_knownVars = s_knownVars state `Map.union` myKnownVars }+ setState state{ s_knownVars = s_knownVars state `Map.union` myKnownVars } popClosureTrait :: RuleParser () popClosureTrait = do- modify $ \state -> state+ updateState $ \state -> state { s_closureTraits = case s_closureTraits state of [] -> [id] [_] -> [id]@@ -287,7 +283,7 @@ let names = words " ENTER LEAVE KEEP UNDO FIRST NEXT LAST PRE POST CATCH CONTROL " when (not $ name `elem` names) $ fail ("Invalid closure trait: " ++ name) - modify $ \state -> state+ updateState $ \state -> state { s_closureTraits = case s_closureTraits state of [] -> [addTrait] (f:fs) -> ((addTrait . f) : fs)@@ -327,7 +323,7 @@ These will be re-generated by 'Pugs.Parser.parseOpWith' when needed. -} clearDynParsers :: RuleParser ()-clearDynParsers = modify $ \state -> state{ s_dynParsers = MkDynParsersEmpty }+clearDynParsers = updateState $ \state -> state{ s_dynParsers = MkDynParsersEmpty } parserWarn :: (Typeable a, Show a) => String -> a -> RuleParser () parserWarn str val = do
src/Pugs/Parser/Unsafe.hs view
@@ -93,8 +93,8 @@ return $! fromObject o -- A Str should be (re)parsed. substMacroResult (Val (VStr code)) = fmap bi_body . localBlock $ do- parseProgram <- gets s_parseProgram- env <- ask+ parseProgram <- s_parseProgram `fmap` getState+ env <- getRuleEnv pos <- getPosition case envBody (parseProgram env ("MACRO { " ++ show pos ++" }") code) of Val (err@VError{}) -> fail $ pretty err
src/Pugs/Parser/Util.hs view
@@ -21,7 +21,7 @@ -- at the start, so that they can be restored after parsing the body localBlock :: RuleParser Exp -> RuleParser BlockInfo localBlock m = do- state <- get+ state <- getState -- XXX - Perhaps clone the protopad right here, for $_ etc? compPad <- newMPad (s_protoPad state)@@ -31,7 +31,7 @@ lexPads = (PCompiling compPad:envLexPads env) protoVars = Map.map (const compPad) (padEntries $ s_protoPad state) - put state+ setState state { s_closureTraits = (id : s_closureTraits state) , s_env = env { envLexPads = lexPads -- enter the scope@@ -42,7 +42,7 @@ } body <- m- state' <- get+ state' <- getState -- Remove from knownVars the bindings belonging to this scope. let outerKnownVars = Map.filter (/= compPad) (s_knownVars state')@@ -51,7 +51,7 @@ (t:ts) -> (t, ts) _ -> (id, []) - put state+ setState state { s_env = (s_env state') { envPackage = envPackage env , envLexical = envLexical env
src/Pugs/Prim.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fglasgow-exts -fno-warn-orphans -fno-full-laziness -fno-cse -fallow-overlapping-instances #-}+{-# LANGUAGE GADTs #-} {-| Primitive operators.
src/Pugs/Prim/Eval.hs view
@@ -21,6 +21,7 @@ import DrIFT.YAML import Data.Yaml.Syck import Data.Binary (decode)+import Control.Exception (SomeException) import qualified Data.ByteString.Char8 as Bytes type Bytes = Bytes.ByteString@@ -157,7 +158,7 @@ op1EvalP6Y' :: Bytes -> Eval Val op1EvalP6Y' bytecode = do- yml <- io $ (`catchIO` (return . Left . show)) $+ yml <- io $ (`catchIO` (return . Left . (show :: SomeException -> String))) $ fmap Right (parseYamlBytes bytecode) case yml of Right MkNode{ n_elem=ESeq (v:_) }@@ -183,7 +184,7 @@ opEval :: EvalStyle -> FilePath -> String -> Eval Val opEval style path str = enterCaller $ do env <- ask- let errHandler err = return env{ envBody = Val $ VError (VStr (show err)) [] }+ let errHandler (err :: SomeException) = return env{ envBody = Val $ VError (VStr (show err)) [] } env' <- io $ evaluateIO (parseProgram env path str) `catchIO` errHandler val <- tryT $ local (const env') $ do evl <- asks envEval
src/Pugs/Prim/Keyed.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fglasgow-exts -fno-warn-orphans #-}+{-# LANGUAGE GADTs #-} module Pugs.Prim.Keyed ( -- keyed values (Val)
src/Pugs/Prim/Match.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fglasgow-exts -fno-warn-orphans -fallow-overlapping-instances #-}+{-# LANGUAGE GADTs #-} module Pugs.Prim.Match ( op2Match, rxSplit, rxSplit_n, pkgParents, pkgParentClasses@@ -10,6 +11,7 @@ import Pugs.Config import Pugs.Prim.Code import Paths_Pugs+import Control.Exception (SomeException) import qualified Data.Map as Map import qualified Data.Array as Array import qualified Pugs.Prim.FileTest as FileTest@@ -49,7 +51,7 @@ let ruleEngine | Just "PGE" <- rv = evalPGE | otherwise = evalPCR pge <- io $ ruleEngine pwd cs text subrules- `catchIO` (\e -> return $ show e)+ `catchIO` (\(e :: SomeException) -> return $ show e) rv <- tryIO Nothing $ fmap Just (readIO $ decodeUTF8 pge) let matchToVal PGE_Fail = VMatch mkMatchFail matchToVal (PGE_String str) = VStr str
src/Pugs/Prim/Yaml.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fglasgow-exts -fno-warn-orphans #-}+{-# LANGUAGE GADTs #-} module Pugs.Prim.Yaml ( evalYaml, dumpYaml, stableAddressOf ) where import Pugs.Internals
src/Pugs/Run.hs view
@@ -28,6 +28,7 @@ import Pugs.Prim.Eval import Pugs.Embed import Pugs.Prelude +import Control.Exception (SomeException) import qualified Data.Map as Map import qualified Data.ByteString as Str import DrIFT.YAML@@ -238,12 +239,15 @@ if bypass then return env else do let dispProgress = (posName . envPos $ env) == (__"<interactive>") when dispProgress $ putStr "Loading Prelude... "- catchIO loadPreludePC $ \e -> do+ catchIO loadPreludePC $ \(e :: SomeException) -> do+ hPrint stderr e+ {- case e of IOException ioe | isUserError ioe, not . null $ ioeGetErrorString ioe -> hPrint stderr ioe _ -> hPrint stderr e+ -} when dispProgress $ do hPutStr stderr "Reloading Prelude from source..." evalPrelude