Changeset 14113

Timestamp:

10/09/06 17:26:24 (2 years ago)

Author:

audreyt

Message:

r14985@T: audreyt | 2006-10-09 16:45:12 +0800

• Use MonadError? instead of MonadCont? for error handling. This will help separate out continuations with exceptions.

Location:

src/Pugs

Files:

• AST/Eval.hs (modified) (6 diffs)
• AST/Internals.hs (modified) (8 diffs)
• AST/Internals.hs-boot (modified) (1 diff)
• Eval.hs (modified) (1 diff)
• Eval/Var.hs (modified) (1 diff)
• Internals.hs (modified) (2 diffs)
• Monads.hs (modified) (2 diffs)
• Parser.hs (modified) (3 diffs)
• Parser/Unsafe.hs (modified) (1 diff)
• Prim/List.hs (modified) (1 diff)
• Run.hs (modified) (1 diff)

src/Pugs/AST/Eval.hs

@@ -10 +10 @@
 
 {- Eval Monad -}
-type Eval = EvalT (ContT Val (ReaderT Env SIO))
+type Eval = EvalT (ErrorT Val (ReaderT Env SIO))
 newtype EvalT m a = EvalT { runEvalT :: m a }
 
 instance ((:>:) (Eval a)) (SIO a) where cast = liftSIO
 
+liftEither :: Either a a -> a
+liftEither (Left a) = a
+liftEither (Right a) = a
+
 runEvalSTM :: Env -> Eval Val -> STM Val
-runEvalSTM env = runSTM . (`runReaderT` enterAtomicEnv env) . (`runContT` return) . runEvalT
+runEvalSTM env = fmap liftEither . runSTM . (`runReaderT` enterAtomicEnv env) . runErrorT . runEvalT
 
 runEvalIO :: Env -> Eval Val -> IO Val
-runEvalIO env = runIO . (`runReaderT` env) . (`runContT` return) . runEvalT
+runEvalIO env = fmap liftEither . runIO . (`runReaderT` env) . runErrorT . runEvalT
 
 tryIO :: a -> IO a -> Eval a
@@ -41 +45 @@
        --     @esc@ is the current (sub)continuation
        -> Eval a
-shiftT e = EvalT . ContT $ \k ->
-    runContT (runEvalT . e $ lift . lift . k) return
+shiftT f = do
+    rv <- f (error "invalid use of shiftT under ErrorT")
+    EvalT (throwError rv)
 
 {-|
@@ -87 +92 @@
 resetT :: Eval Val -- ^ An evaluation, possibly containing a 'shiftT'
        -> Eval Val
-resetT e = lift . lift $
-    runContT (runEvalT e) return
+resetT e = catchError e return
 
 instance Monad Eval where
@@ -97 +101 @@
     fail str = do
         pos <- asks envPos'
-        shiftT . const . return $ errStrPos (cast str) pos
+        EvalT (throwError $ errStrPos (cast str) pos)
+
+instance Error Val where
+    noMsg = errStr ""
+    strMsg = errStr
 
 instance MonadTrans EvalT where
@@ -111 +119 @@
     throwError err = do
         pos <- asks envPos'
-        shiftT . const . return $ errValPos err pos
-    catchError _ _ = fail "catchError unimplemented"
+        EvalT (throwError $ errValPos err pos)
+    catchError (EvalT action) handler = EvalT (catchError action (runEvalT . handler))
 
 {-|
@@ -161 +169 @@
     local f m = EvalT $ local f (runEvalT m)
 
+{-
 instance MonadCont Eval where
     -- callCC :: ((a -> Eval b) -> Eval a) -> Eval a
     callCC f = EvalT . callCCT $ \c -> runEvalT . f $ \a -> EvalT $ c a
+-}
 
 {-

src/Pugs/AST/Internals.hs

@@ -10 +10 @@
     InitDat(..),
 
-    EvalT(..), ContT(..), SubAssoc(..),
+    EvalT(..), SubAssoc(..),
 
     Pad(..), PadEntry(..), PadMutator, -- uses Var, TVar, VRef
@@ -53 +53 @@
     transformExp,
 
-    runEvalSTM, runEvalIO, shiftT, resetT, callCC,
+    runEvalSTM, runEvalIO, shiftT, resetT, catchT,
     undef, defined, tryIO, guardSTM, guardIO, guardIOexcept,
     readRef, writeRef, clearRef, dumpRef, forceRef,
@@ -76 +76 @@
     newObjectId, runInvokePerl5,
     
-    errStrPos, errValPos, enterAtomicEnv, valToBool, envPos', -- for circularity
+    errStr, errStrPos, errValPos, enterAtomicEnv, valToBool, envPos', -- for circularity
     expToEvalVal, -- Hack, should be removed once it's figured out how
 
@@ -85 +85 @@
 import Pugs.Internals
 import Pugs.Types
-import Pugs.Cont hiding (shiftT, resetT)
 import qualified Data.Set       as Set
 import qualified Data.Map       as Map
@@ -131 +130 @@
 #include "../Types/Pair.hs"
 #include "../Types/Object.hs"
+
+catchT :: ((Val -> Eval b) -> Eval Val) -> Eval Val
+catchT action = resetT (action retShift)
 
 {-|
@@ -712 +714 @@
     deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}
 
+errStr :: VStr -> Val
+errStr str = VError (VStr str) []
+
 errStrPos :: VStr -> Pos -> Val
 errStrPos str pos = VError (VStr str) [pos]
@@ -1486 +1491 @@
 
 retShift :: Val -> Eval a
-retShift = shiftT . const . return
+-- retShift = shiftT . const . return
+retShift = EvalT . throwError
 
 retShiftEmpty :: Eval a
-retShiftEmpty = shiftT (const retEmpty)
+-- retShiftEmpty = shiftT (const retEmpty)
+retShiftEmpty = retShift =<< retEmpty
 
 defined :: VScalar -> Bool
@@ -1847 +1854 @@
     typeOf (MkRef x) = typeOf x
 
-instance Typeable1 (EvalT (ContT Val (ReaderT Env SIO))) where
+instance Typeable1 (EvalT (ErrorT Val (ReaderT Env SIO))) where
     typeOf1 _ = typeOf ()
 

src/Pugs/AST/Internals.hs-boot

@@ -24 +24 @@
 
 envPos' :: Env -> Pos
+errStr :: VStr -> Val
 errStrPos :: VStr -> Pos -> Val
 errValPos :: Val -> Pos -> Val

src/Pugs/Eval.hs

@@ -187 +187 @@
 evalRef ref = do
     if refType ref == (mkType "Thunk") then forceRef ref else do
-    val <- callCC $ \esc -> do
+    val <- catchT $ \esc -> do
         MkEnv{ envContext = cxt, envLValue = lv, envClasses = cls } <- ask
         let typ = typeOfCxt cxt

src/Pugs/Eval/Var.hs

@@ -103 +103 @@
 doFindVarRef :: Var -> Eval (Maybe (TVar VRef))
 doFindVarRef var = do
-    callCC $ \foundIt -> do
-        lexSym  <- fmap (findSym var . envLexical) ask
-        when (isJust lexSym) $ foundIt lexSym
-        -- XXX - this is bogus; we should not fallback if it's not in lex csope.
-        glob    <- liftSTM . readTVar . envGlobal =<< ask
-        var'    <- toQualified var
-        let globSym = findSym var' glob
-        when (isJust globSym) $ foundIt globSym
-        -- XXX - ditto for globals
-        let globSym = findSym (toGlobalVar var) glob
-        when (isJust globSym) $ foundIt globSym
-        return Nothing
+    lexSym  <- fmap (findSym var . envLexical) ask
+    if isJust lexSym then return lexSym else do
+    -- XXX - this is bogus; we should not fallback if it's not in lex csope.
+    glob    <- liftSTM . readTVar . envGlobal =<< ask
+    var'    <- toQualified var
+    let globSym = findSym var' glob
+    if isJust globSym then return globSym else do
+    -- XXX - ditto for globals
+    let globSym = findSym (toGlobalVar var) glob
+    if isJust globSym then return globSym else do
+    return Nothing
 
 

src/Pugs/Internals.hs

@@ -122 +122 @@
 import Control.Monad.RWS (MonadIO(..), MonadReader(..), MonadState(..), MonadWriter(..), MonadTrans(..), asks, ReaderT(..), WriterT(..), when, join, liftM, filterM, modify, unless, gets, foldM, guard, liftM2, liftM3, fix, mplus, mappend, mzero, mconcat, msum, censor)
 import Control.Monad.Identity (Identity(..))
-import Control.Monad.Error (MonadError(..))
+import Control.Monad.Error (MonadError(..), ErrorT(..), Error(..))
 import Control.Concurrent
 import Control.Concurrent.STM
@@ -153 +153 @@
 
 import qualified UTF8
-import qualified Judy.CollectionsM as C
+import qualified Judy.CollectionsM as C ()
 import qualified Data.HashTable as H
 import qualified Foreign as Foreign

src/Pugs/Monads.hs

@@ -186 +186 @@
          -> Eval Val -- ^ Result of passing the pad-transformer to the 
                      --     \'action\'
-genSymCC symName action = callCC $ \esc -> do
+genSymCC symName action = catchT $ \esc -> do
     genSymPrim symName (const $ esc undef) action
 
@@ -205 +205 @@
                 doFix <- fixEnv return env
                 local doFix runAction
-            else resetT . callCC $ \cc -> do
+            else resetT . catchT $ \cc -> do
                 doFix <- fixEnv cc env
                 local doFix runAction

src/Pugs/Parser.hs

@@ -783 +783 @@
         imp <- option emptyExp ruleExpression
         let sub = _Var $ ('&':pkg) ++ if use then "::import" else "::unimport"
-        unsafeEvalExp $ Syn "if"
+
+        Val res <- unsafeEvalExp $ Syn "if"
             [ sub
             , App sub (Just $ Val $ VStr $ pkg) [imp]
@@ -789 +790 @@
             ]
 
-        Val (VList exportList) <- unsafeEvalExp $ case lang of
+        Val (VList exportList) <- res `seq` unsafeEvalExp $ case lang of
             -- map { ~$_, [::Pkg.can($_)] }, @importlist
             "perl5" -> App (_Var "&map") Nothing [Syn "sub"
@@ -1057 +1058 @@
 vcode2initBlock :: Val -> RuleParser Exp
 vcode2initBlock code = do
-    body <- vcode2startBlock code
+    body    <- vcode2startBlock code
     fstcode <- unsafeEvalExp $ Syn "sub" [ Val $ VCode mkSub { subBody = body } ]
-    unsafeEvalExp $
+    Val res <- unsafeEvalExp $
         App (_Var "&push") (Just $ _Var "@*INIT") [ fstcode ]
-    return $ App fstcode Nothing []
+    return (res `seq` App fstcode Nothing [])
 
 vcode2checkBlock :: Val -> RuleParser Exp
 vcode2checkBlock code = do
-    body <- vcode2startBlock code
+    body    <- vcode2startBlock code
     fstcode <- unsafeEvalExp $ 
         Syn "sub" [ Val $ VCode mkSub { subBody = checkForIOLeak body } ]
-    unsafeEvalExp $
+    Val res <- unsafeEvalExp $
         App (_Var "&unshift") (Just $ _Var "@*CHECK") [ fstcode ]
-    return $ App fstcode Nothing []
+    return (res `seq` App fstcode Nothing [])
 
 -- Constructs ------------------------------------------------

src/Pugs/Parser/Unsafe.hs

@@ -47 +47 @@
             evl exp
     case val of
-        VError _ _  -> error $ pretty (val :: Val)
-        _           -> return $ Val val
+        VError{} -> error $ pretty (val :: Val)
+        _        -> return $ Val val
 
 {-# NOINLINE possiblyApplyMacro #-}

src/Pugs/Prim/List.hs

@@ -200 +200 @@
                     then fail
                         "When reducing using a chain-associative sub,\nthe sub must take exactly two arguments."
-                    else callCC $ \esc -> do
+                    else catchT $ \esc -> do
                         let doFold' x y = do
                             val <- doFold [x, y]

src/Pugs/Run.hs

@@ -273 +273 @@
         runEnv env{ envBody = ast, envDebug = Nothing }
         --     Right Nothing -> fail ""
+{-# OPTIONS_GHC -fglasgow-exts #-}
+
+{-
+
+  This needs to be redone as a proper Haskell parser,
+  which will be one of my next projects. But so far,
+  this works.
+
+  The operators are simple prefix operators
+  with zero or one argument, except for everything
+  that ultimatively goes into @ARGS for the Pugs
+  script.
+
+  If you change anything here, make sure all tests under
+  t/pugsrun/ still pass. Otherwise you might break building
+  for everybody, once you commit.
+
+-}
+
+-- | Command line argument parser for pugs.
+module Pugs.Run.Args (
+    canonicalArgs,
+    gatherArgs,
+    unpackOptions,
+) where
+import Pugs.Internals
+
+{- | 
+  Convert command line arguments into canonical form for 
+  'Pugs.Run.runWithArgs'.  The switch ordering is defined
+  by compareArgs and is currently:
+
+  > (-h -v -V) (-I) (-d) (-w) (-c) (-C) (--external) (-M) (-n -p) (-0 -e other)
+
+  Args -M, -n and -p are converted to -e scripts by desugarDashE.
+-}
+canonicalArgs :: [String] -> [String]
+canonicalArgs x = concatMap procArg
+                . concatDashE
+                . desugarDashE
+                . sortBy compareArgs
+                . gatherArgs
+                . unpackOptions
+                $ x
+
+concatDashE :: [Arg] -> [Arg]
+concatDashE (Opt "-e" e:xs) = (Opt "-e" $ concat (intersperse "\n" (e:map optArg es))) : rest
+    where
+    (es, rest)          = partition isOptE xs
+    isOptE (Opt "-e" _) = True
+    isOptE _            = False
+concatDashE (x:xs) = (x:concatDashE xs)
+concatDashE xs = xs
+
+data Arg
+    = File !String
+    | Switch !Char
+    | Opt { _optFlag :: !String, optArg :: !String }
+    deriving Show
+
+procArg :: Arg -> [String]
+procArg (Opt name arg)  = [name, arg]
+procArg (File name)     = [name]
+procArg (Switch name)   = ['-':name:[]]
+
+unpackOptions :: [String] -> [String]
+unpackOptions []                = []
+unpackOptions (("-"):rest)      = ("-":unpackOptions rest)
+unpackOptions opts@("--":_)     = opts
+unpackOptions (('-':opt):arg:rest)
+    | takesArg opt              = unpackOption opt ++ (arg:unpackOptions rest)
+unpackOptions (('-':opt):rest)  = unpackOption opt ++ unpackOptions rest
+unpackOptions opts@[_]          = opts
+unpackOptions (filename:rest)   = filename : "--" : rest
+
+takesArg :: String -> Bool
+takesArg xs     | xs `elem` withParam   = True
+takesArg (x:xs) | x `elem` composable   = takesArg xs
+takesArg _                              = False
+
+unpackOption :: String -> [String]
+unpackOption "" = [] -- base case for composing
+unpackOption opt
+    | Just short <- lookup ('-':opt) longOptions = [short]
+    | head opt `elem` composable = ['-', head opt] : unpackOption (tail opt)
+    | Just (prefix, param) <- prefixOpt opt = ['-':prefix, param]
+    | otherwise = ['-':opt]
+
+-- | List of options with long and sort variants, as tupples of long, short (with the dashes).
+longOptions :: [(String, String)]
+longOptions = [("--help", "-h"), ("--version", "-v")]
+
+-- | List of options that can have their argument just after, with no space.
+composable :: [Char]
+composable = "cdlnpw"
+
+-- | List of options that can take arguments
+withParam :: [String]
+withParam = words "e C B I M V:"
+
+prefixOpt :: [Char] -> Maybe (String, String)
+prefixOpt opt = msum $ map (findArg opt) withParam
+
+findArg :: Eq a => [a] -> [a] -> Maybe ([a], [a])
+findArg arg prefix = do
+    param <- afterPrefix prefix arg
+    guard (not (null param))
+    return (prefix, param)
+
+{-
+  Enforce a canonical order of command line switches.  Currently this is:
+
+  > (-h -v -V) (-I) (-d) (-w) (-c) (-C) (--external) (-M) (-n -p) (-0 -e other)
+
+  This makes pattern matching more convenient
+
+  Backwards incompatible changes:
+
+   *  -p and -n autochomp.
+
+   *  -p uses say() instead of print()
+-}
+
+compareArgs :: Arg -> Arg -> Ordering
+compareArgs a b = compare (argRank a) (argRank b)
+
+argRank :: Arg -> Int
+argRank (Switch 'h')         = -1
+argRank (Switch 'v')         = -1
+argRank (Opt "-V:" _)        = -1
+argRank (Switch 'V')         = -1
+argRank (Opt "-I" _)         = 0
+argRank (Switch 'd')         = 1
+argRank (Switch 'w')         = 2
+argRank (Switch 'c')         = 3
+argRank (Opt "-C" _)         = 4
+argRank (Opt "-B" _)         = 4
+argRank (Opt "--external" _) = 5
+argRank (Opt "-M" _)         = 98
+argRank (Switch 'n')         = 99   -- translated into Perl code (later)
+argRank (Switch 'p')         = 99   -- translated into Perl code (later)
+argRank (Switch 'l')         = 100  -- translated into Perl code (later)
+argRank (Switch '0')         = 100  -- translated into Perl code (later)
+argRank (Opt "-e" _)         = 100  -- translated into Perl code
+argRank _                    = 100  -- filename or @ARGS or whatever
+
+gatherArgs :: [String] -> [Arg]
+gatherArgs [] = []
+gatherArgs ("-e":frag:rest)        = [Opt "-e" frag] ++ gatherArgs(rest)
+gatherArgs ("--external":mod:rest) = [Opt "--external" mod] ++ gatherArgs(rest)
+gatherArgs ("-I":dir:rest)         = [Opt "-I" dir] ++ gatherArgs(rest)
+gatherArgs ("-M":mod:rest)         = [Opt "-M" mod] ++ gatherArgs(rest)
+gatherArgs ("-C":backend:rest)     = [Opt "-C" backend] ++ gatherArgs(rest)
+gatherArgs ("-B":backend:rest)     = [Opt "-B" backend] ++ gatherArgs(rest)
+gatherArgs ("-V:":item:rest)       = [Opt "-V:" item] ++ gatherArgs(rest)
+gatherArgs (('-':[]):xs)           = [File "-"] ++ gatherArgs(xs)
+gatherArgs (("--"):rest)           = [File x | x <- rest]
+gatherArgs (('-':x:[]):xs)         = [Switch x] ++ gatherArgs(xs)
+gatherArgs (x:xs)                  = [File x] ++ gatherArgs(xs)
+
+{- collect "-e" switches together,
+   handle transformation of "-M", "-n"
+   and "-p" into "-e" fragments
+-}
+desugarDashE :: [Arg] -> [Arg]
+desugarDashE [] = []
+desugarDashE ((Switch 'p'):args) = desugarDashE $
+    (Opt "-e" "env $_; while (defined($_ = =<>)) { " : args) ++ [Opt "-e" "; say $_; }"]
+desugarDashE ((Switch 'n'):args) = desugarDashE $
+    (Opt "-e" "env $_; while (defined($_ = =<>)) { " : args) ++ [Opt "-e" "}"]
+
+-- -E is like -e, but not accessible as a normal parameter and used only
+-- internally:
+--   "-e foo bar.pl" executes "foo" with @*ARGS[0] eq "bar.pl",
+--   "-E foo bar.pl" executes "foo" and then bar.pl.
+desugarDashE ((Opt "-M" mod):args)
+    | (mod', (_:args)) <- break (== '=') mod
+    = useWith $ mod' ++ " '" ++ escape args ++ "'.split(',')"
+    | otherwise
+    = useWith mod
+    where
+    useWith mod = desugarDashE ((Opt "-E" (";use " ++ mod ++ ";\n")):args)
+    escape [] = []
+    escape ('\'':xs) = '\\':'\'':escape xs
+    escape ('\\':xs) = '\\':'\\':escape xs
+    escape (x:xs) = x:escape xs
+
+
+-- Preserve the curious Perl5 behaviour:
+--   perl -e 'print CGI->VERSION' -MCGI     # works
+--   perl print_cgi.pl -MCGI                # fails
+desugarDashE (x@(Opt "-e" _):y@(Opt "-E" _):args) = desugarDashE (y:x:args)
+desugarDashE ((Opt "-E" a):y@(Opt "-e" _):args) = desugarDashE ((Opt "-e" a):y:args)
+desugarDashE (x:xs) = (x:desugarDashE xs)
         --     x  -> fail $ "Error loading precompiled Prelude: " ++ show x