packages feed

Pugs (empty) → 6.2.13.1

raw patch · 97 files changed

+25702/−0 lines, 97 filesdep +HsParrotdep +HsSyckdep +MetaObjectsetup-changed

Dependencies added: HsParrot, HsSyck, MetaObject, array, base, bytestring, containers, directory, filepath, haskell98, mtl, network, parsec, pretty, process, pugs-DrIFT, pugs-compat, random, readline, stm, stringtable-atom, time, utf8-string

Files

+ LICENSE view
@@ -0,0 +1,20 @@+The "MIT" License++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Pugs.cabal view
@@ -0,0 +1,128 @@+Name            : Pugs+Version         : 6.2.13.1+license         : BSD3+license-file    : LICENSE+copyright       : 2005-2008, The Pugs Contributors+maintainer      : Audrey Tang <audreyt@audreyt.org>+category        : Language, Pugs+build-depends   : base, haskell98, filepath, mtl, stm, parsec, network,+                  pretty, time, random, process, containers, bytestring,+                  array, directory, readline, utf8-string,++                  MetaObject       >= 0.0.3,+                  HsParrot         >= 0.0.2,+                  pugs-compat      >= 0.0.2,+                  pugs-DrIFT       >= 2.2.3.0,+                  stringtable-atom >= 0.0.3,+                  HsSyck           >= 0.44++                  -- HsPerl5+stability       : experimental+build-type      : Simple+homepage        : http://pugscode.org/+synopsis        : A Perl 6 Implementation+description     : A Perl 6 Implementation+author          : Audrey Tang <audreyt@audreyt.org>+tested-with     : GHC+-- c-sources       : src/perl5/p5embed.c+-- hs-source-dirs  : src+-- extensions      : ForeignFunctionInterface+-- include-dirs    : /usr/local/include /opt/local/include /usr/local/lib/perl5/5.9.5/darwin-2level/CORE+extra-source-files:+    src/Pugs.hs+    src/Pugs/AST.hs+    src/Pugs/AST.hs-boot+    src/Pugs/AST/Eval.hs+    src/Pugs/AST/Internals.hs+    src/Pugs/AST/Internals.hs-boot+    src/Pugs/AST/Internals/Instances.hs+    src/Pugs/AST/Pad.hs+    src/Pugs/AST/Pos.hs+    src/Pugs/AST/Prag.hs+    src/Pugs/AST/SIO.hs+    src/Pugs/AST/Scope.hs+    src/Pugs/AST/Utils.hs+    src/Pugs/Bind.hs+    src/Pugs/Class.hs+    src/Pugs/CodeGen.hs+    src/Pugs/CodeGen/JSON.hs+    src/Pugs/CodeGen/PIL1.hs+    src/Pugs/CodeGen/PIR.hs+    src/Pugs/CodeGen/PIR/Prelude.hs+    src/Pugs/CodeGen/Perl5.hs+    src/Pugs/CodeGen/YAML.hs+    src/Pugs/Compile.hs+    src/Pugs/Compile/Pugs.hs+    src/Pugs/Config.hs+    src/Pugs/Cont.hs+    src/Pugs/Embed.hs+    src/Pugs/Embed/Haskell.hs+    src/Pugs/Embed/Parrot.hs+    src/Pugs/Embed/Perl5.hs+    src/Pugs/Embed/Pugs.hs+    src/Pugs/Eval.hs+    src/Pugs/Eval/Var.hs+    src/Pugs/Exp.hs+    src/Pugs/Exp.hs-boot+    src/Pugs/External.hs+    src/Pugs/External/Haskell.hs+    src/Pugs/Help.hs+    src/Pugs/Internals.hs+    src/Pugs/Junc.hs+    src/Pugs/Lexer.hs+    src/Pugs/Meta.hs+    src/Pugs/Meta/Class.hs+    src/Pugs/Meta/Perl5.hs+    src/Pugs/Meta/Str.hs+    src/Pugs/Monads.hs+    src/Pugs/PIL1.hs+    src/Pugs/PIL1/Instances.hs+    src/Pugs/Parser.hs+    src/Pugs/Parser.hs-boot+    src/Pugs/Parser/Charnames.hs+    src/Pugs/Parser/Doc.hs+    src/Pugs/Parser/Export.hs+    src/Pugs/Parser/Literal.hs+    src/Pugs/Parser/Number.hs+    src/Pugs/Parser/Operator.hs+    src/Pugs/Parser/Program.hs+    src/Pugs/Parser/Types.hs+    src/Pugs/Parser/Unsafe.hs+    src/Pugs/Parser/Util.hs+    src/Pugs/Prelude.hs+    src/Pugs/Pretty.hs+    src/Pugs/Prim.hs+    src/Pugs/Prim/Code.hs+    src/Pugs/Prim/Eval.hs+    src/Pugs/Prim/FileTest.hs+    src/Pugs/Prim/Keyed.hs+    src/Pugs/Prim/Lifts.hs+    src/Pugs/Prim/List.hs+    src/Pugs/Prim/Match.hs+    src/Pugs/Prim/Numeric.hs+    src/Pugs/Prim/Param.hs+    src/Pugs/Prim/Yaml.hs+    src/Pugs/Rule.hs+    src/Pugs/Run.hs+    src/Pugs/Run/Args.hs+    src/Pugs/Run/Perl5.hs+    src/Pugs/Shell.hs+    src/Pugs/Types.hs+    src/Pugs/Types/Array.hs+    src/Pugs/Types/Code.hs+    src/Pugs/Types/Handle.hs+    src/Pugs/Types/Hash.hs+    src/Pugs/Types/Object.hs+    src/Pugs/Types/Pair.hs+    src/Pugs/Types/Rule.hs+    src/Pugs/Types/Scalar.hs+    src/Pugs/Types/Thunk.hs+    src/Pugs/Val.hs+    src/Pugs/Val/Base.hs+    src/Pugs/Val/Capture.hs+    src/Pugs/Val/Code.hs+    src/Pugs/Version.hs++executable:         pugs+main-is:            Main.hs+hs-source-dirs:     src
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ src/Main.hs view
@@ -0,0 +1,20 @@+{-# OPTIONS_GHC -fglasgow-exts #-}++{-|+    The Main REPL loop.++>   Но сpок настал, и новый челн+>   В даp получил Эаpендил:+>   Избpали Эльфы для него+>   Хpусталь эльфийский и мифpил;+>   Его венчал живой огонь,+>   Огонь бессмеpтный - Сильмаpилл,+>   Подаpок светлой Элбеpет++-}++module Main where+import Pugs++main :: IO ()+main = pugsMain
+ src/Pugs.hs view
@@ -0,0 +1,465 @@+{-# OPTIONS_GHC -fglasgow-exts -fallow-overlapping-instances #-}++{-|+    Public API for the Pugs system.++>   Dance all ye joyful, now dance all together!+>   Soft is the grass, and let foot be like feather!+>   The river is silver, the shadows are fleeting;+>   Merry is May-time, and merry our meeting.++-}++module Pugs (+    module Pugs,+    Command(..),+    banner,+    liftSTM,+    printCommandLineHelp,+    intro,+    initializeShell,+    getCommand,+    pretty,+    printInteractiveHelp,+) where+import Pugs.AST+import Pugs.CodeGen+import Pugs.Config+import Pugs.Embed+import Pugs.Eval+import Pugs.External+import Pugs.Help+import Pugs.Internals+import Pugs.Monads+import Pugs.Parser.Program+import Pugs.Pretty+import Pugs.Run+import Pugs.Shell+import Pugs.Types+import Data.IORef+import qualified Data.Map as Map+import qualified System.FilePath as FilePath (combine, splitFileName)++{-|+The entry point of Pugs. Uses 'Pugs.Run.runWithArgs' to normalise the command-line+arguments and pass them to 'run'.+-}+pugsMain :: IO ()+pugsMain = do+    let ?debugInfo = Nothing+    mainWith run++defaultProgramName :: String+defaultProgramName = "<interactive>"++runFile :: String -> IO ()+runFile file = do+    withArgs [file] pugsMain++run :: [String] -> IO ()+run xs = let ?debugInfo = Nothing in run' xs++-- see also Run/Args.hs+run' :: (?debugInfo :: DebugInfo) => [String] -> IO ()+run' ("-d":rest)                 = do+    info <- newDebugInfo+    let ?debugInfo = info+    run' rest+run' ("-l":rest)                 = run' rest+run' ("-w":rest)                 = run' rest+run' ("-I":_:rest)               = run' rest++-- XXX should raise an error here:+-- run ("-I":[])                     = do+--                                    print "Empty -I"++run' ("-h":_)                  = printCommandLineHelp+run' ("-V":_)                  = printConfigInfo []+run' ("-V:":item:_)            = printConfigInfo [item]+run' ("-v":_)                  = banner++-- turn :file: and "-e":frag into a common subroutine/token+run' ("-c":"-e":prog:_)          = doCheck "-e" prog+run' ("-c":file:_)               = readFile file >>= doCheck file++-- -CPIL1.Perl5 outputs PIL formatted as Perl 5.+run' ("-C":backend:args) | (== map toLower backend) `any` ["js","perl5","js-perl5"] = do+    exec <- getArg0+    doHelperRun backend ("--compile-only":("--pugs="++exec):args)+run' ("-C":backend:"-e":prog:_)           = doCompileDump backend "-e" prog+run' ("-C":backend:file:_)                = readFile file >>= doCompileDump backend file++run' ("-B":backend:_) | (== map toLower backend) `any` ["js","perl5","js-perl5","redsix"] = do+    exec <- getArg0+    args <- getArgs+    doHelperRun backend (("--pugs="++exec):args)+run' ("-B":backend:"-e":prog:_)           = doCompileRun backend "-e" prog+run' ("-B":backend:file:_)                = readFile file >>= doCompileRun backend file++run' ("--external":mod:"-e":prog:_)       = doExternal mod "-e" prog+run' ("--external":mod:file:_)            = readFile file >>= doExternal mod file++run' ("-e":prog:args)                     = do doRun "-e" args prog+-- -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.+-- XXX - Wrong -- Need to preserve environment across -E runs+run' ("-E":prog:rest)            = run' ("-e":prog:[]) >> run' rest+run' ("-":args)                  = do doRun "-" args =<< readStdin+run' (file:args)                 = readFile file >>= doRun file args+run' []                          = do+    isTTY <- hIsTerminalDevice stdin+    if isTTY+        then do banner >> intro >> repLoop+        else run' ["-"]++readStdin :: IO String+readStdin = do+    eof     <- isEOF+    if eof then return [] else do+    ch      <- getChar+    rest    <- readStdin+    return (ch:rest)++repLoop :: IO ()+repLoop = do+    initializeShell+    tvEnv <- io . newTVarIO . noEnvDebug =<< tabulaRasa defaultProgramName+    fix $ \loop -> do+        command <- getCommand+        let parseEnv f prog = do+                env <- stm (readTVar tvEnv)+                doParse env f defaultProgramName prog+            resetEnv = do+                env <- fmap noEnvDebug (tabulaRasa defaultProgramName)+                stm (writeTVar tvEnv env)+        case command of+            CmdQuit           -> putStrLn "Leaving pugs."+            CmdLoad fn        -> doLoad tvEnv fn >> loop+            CmdRun opts prog  -> doRunSingle tvEnv opts prog >> loop+            CmdParse prog     -> parseEnv pretty prog >> loop+            CmdParseRaw prog  -> parseEnv show prog >> loop+            CmdHelp           -> printInteractiveHelp >> loop+            CmdReset          -> resetEnv >> loop++mainWith :: ([String] -> IO a) -> IO ()+mainWith run = do+    hSetBuffering stdout NoBuffering+    when (isJust _DoCompile) $ do+        writeIORef (fromJust _DoCompile) doCompile+    runWithArgs run+    globalFinalize++-- convenience functions for GHCi+eval :: String -> IO ()+eval prog = do+    args <- getArgs+    runProgramWith id (putStrLn . encodeUTF8 . pretty) defaultProgramName args (encodeUTF8 prog)++parse :: String -> IO ()+parse prog = do+    env <- tabulaRasa defaultProgramName+    doParse env (encodeUTF8 . pretty) "-" (encodeUTF8 prog)++dump :: String -> IO ()+dump = (doParseWith $ \env _ -> print $ envBody env) "-"++globalFinalize :: IO ()+globalFinalize = join $ readIORef _GlobalFinalizer++dumpGlob :: String -> IO ()+dumpGlob = (doParseWith $ \env _ -> do+    glob <- stm . readMPad $ envGlobal env+    print $ filterUserDefinedPad glob) "-"++{-|+Create a \'blank\' 'Env' for our program to execute in. Of course,+'prepareEnv' actually declares quite a few symbols in the environment,+e.g. \'\@\*ARGS\', \'\$\*PID\', \'\$\*ERR\' etc.++('Tabula rasa' is Latin for 'a blank slate'.)+-}+tabulaRasa :: String -> IO Env+tabulaRasa name = prepareEnv name []++doCheck :: FilePath -> String -> IO ()+doCheck = doParseWith $ \_ name -> do+    putStrLn $ name ++ " syntax OK"++doExternal :: String -> FilePath -> String -> IO ()+doExternal mod = doParseWith $ \env _ -> do+    str <- externalize mod $ envBody env+    putStrLn str++doCompile :: String -> FilePath -> String -> IO String+doCompile backend = doParseWith $ \env file -> do+    globRef <- stm $ do+        glob <- readMPad $ envGlobal env+        newMPad $ filterUserDefinedPad glob+    codeGen backend file env{ envGlobal = globRef }++initCompile :: IO ()+initCompile = do+    compPrelude <- getEnv "PUGS_COMPILE_PRELUDE"+    let bypass = case compPrelude of+            Nothing     -> True+            Just ""     -> True+            Just "0"    -> True+            _           -> False+    setEnv "PUGS_COMPILE_PRELUDE" (if bypass then "0" else "") True++doCompileDump :: String -> FilePath -> String -> IO ()+doCompileDump backend file prog = do+    initCompile+    str <- doCompile backend' file prog+    putStr str+    where+    backend' = capitalizeWord backend+    capitalizeWord []     = []+    capitalizeWord (c:cs) = toUpper c:(map toLower cs)++doCompileRun :: String -> FilePath -> String -> IO ()+doCompileRun backend file prog = do+    initCompile+    str <- doCompile backend' file prog+    evalEmbedded backend' str+    where+    backend' = capitalizeWord backend+    capitalizeWord []     = []+    capitalizeWord (c:cs) = toUpper c:(map toLower cs)++doHelperRun :: String -> [String] -> IO ()+doHelperRun backend args =+    case map toLower backend of+        "js"    -> if (args' == [])+                   then (doExecuteHelper "jspugs.pl"  args)+                   else (doExecuteHelper "runjs.pl"   args)+        "perl5" ->       doExecuteHelper "v6.pm" args+        "js-perl5" -> doExecuteHelper "runjs.pl" (jsPerl5Args ++ args)+        "redsix" -> doExecuteHelper "redsix" args+        _       ->       fail ("unknown backend: " ++ backend)+    where+    args' = f args+    jsPerl5Args = words "--run=jspm --perl5"+    f [] = []+    f (bjs:rest)      | "-BJS" `isPrefixOf` map toUpper bjs = f rest+    f ("-B":js:rest)  | "JS" `isPrefixOf` map toUpper  js = f rest+    f (pugspath:rest) | "--pugs=" `isPrefixOf` pugspath = f rest+    f (x:xs) = x:f xs++doExecuteHelper :: FilePath -> [String] -> IO ()+doExecuteHelper helper args = do+    let searchPaths = concatMap (\x -> map (x++) suffixes) [["."], ["..", ".."], [getConfig "sourcedir"], [getConfig "sourcedir", "blib6", "pugs"], [getConfig "privlib", "auto", "pugs"], [getConfig "sitelib", "auto", "pugs"]]+    mbin <- runMaybeT (findHelper searchPaths)+    case mbin of+        Just binary -> do+            let (p, _) = FilePath.splitFileName binary+            exitWith =<< executeFile' perl5 True (("-I" ++ p):binary:args) Nothing+        _ -> fail ("Couldn't find helper program " ++ helper ++ " (searched in " ++ show (map (foldl1 FilePath.combine) searchPaths) ++ ")")+    where+    suffixes =+        [ []+        , ["perl5", "PIL2JS"]                -- sourcedir/perl5/PIL2JS/jspugs.pl+        , ["perl5", "lib"]                   -- pugslibdir/perl5/lib/jspugs.pl+        , ["misc", "pX", "Common", "redsix"] -- sourcedir/misc/pX/Common/redsix/redsix+        ]+    perl5 = getConfig "perl5_path"+    findHelper :: [[FilePath]] -> MaybeT IO FilePath+    findHelper []     = fail "Can't find anything"+    findHelper (x:xs) = maybeFindFile file+                `mplus` maybeFindFile (file ++ getConfig "exe_ext")+                `mplus` findHelper xs+        where +        file = foldl1 FilePath.combine (x ++ [helper])+    maybeFindFile :: FilePath -> MaybeT IO FilePath+    maybeFindFile pathname = do+        dir <- liftIO $ getDirectoryContents path `catchIO` (const $ return [])+        guard (filename `elem` dir)+        return pathname+        where+        (path, filename) = FilePath.splitFileName pathname++doParseWith :: (Env -> FilePath -> IO a) -> FilePath -> String -> IO a+doParseWith f name prog = do+    env <- tabulaRasa name+    f' $ parseProgram env{ envDebug = Nothing } name prog+    where+    f' env | Val err@(VError _ _) <- envBody env = do+        hPutStrLn stderr $ pretty err+        globalFinalize+        exitFailure+    f' env = f env name++doParse :: Env -> (Exp -> String) -> FilePath -> String -> IO ()+doParse env prettyFunc name prog = do+    case envBody $ parseProgram env name prog of+        (Val err@(VError _ _)) -> putStrLn $ pretty err+        exp -> putStrLn $ prettyFunc exp++doLoad :: TVar Env -> String -> IO ()+doLoad env fn = do+    runImperatively env (evaluate exp)+    return ()+    where+    exp = App (_Var "&require") Nothing [Val $ VStr fn]++doRunSingle :: TVar Env -> RunOptions -> String -> IO ()+doRunSingle menv opts prog = (`catchIO` handler) $ do+    exp     <- makeProper =<< parse+    if exp == Noop then return () else do+    env     <- theEnv+    rv      <- runImperatively env (evaluate exp)+    result  <- case rv of+        VControl (ControlContinuation env' val _) -> do+            stm $ writeTVar menv env'+            return val+        _ -> return rv+    printer env result+    where+    parse = do+        env <- stm $ readTVar menv+        return $ envBody $ parseProgram env defaultProgramName $+          (dropTrailingSemi prog)+    dropTrailingSemi = reverse .+                       (\x -> ';' : (dropWhile (`elem` " \t\r\n;") x)) .+                       reverse+    hasTrailingSemi = case f prog of ';':_ -> True; _ -> False+        where f = dropWhile (`elem` " \t\r\n\f") . reverse+    theEnv = do+        ref <- if runOptSeparately opts+                then (io . newTVarIO) =<< tabulaRasa defaultProgramName+                else return menv+        debug <- if runOptDebug opts+                then newDebugInfo+                else return Nothing+        stm $ modifyTVar ref $ \e -> e{ envDebug = debug }+        return ref+    printer' = if runOptShowPretty opts then putStrLn . pretty else print+    printer env = \val -> do+      final <- runImperatively env (fromVal' val)+      if hasTrailingSemi+         then case final of (VError _ _) -> printer' final ; _ -> return ()+         else printer' final+    makeProper exp = case exp of+        Val err@(VError (VStr msg) _)+            | runOptShowPretty opts+            , any (== "Unexpected end of input") (lines msg) -> do+            cont <- readline "....> "+            case cont of+                Just line   -> do+                    doRunSingle menv opts (prog ++ ('\n':line))+                    return Noop+                _           -> fail $ pretty err+        Val err@VError{} -> fail $ pretty err+        _ | runOptSeparately opts -> return exp+        App (Syn "block" [Val (VCode cv)]) invs args -> return $+            App (Syn "block" [Val (VCode cv{ subBody = makeDumpEnv (subBody cv) })]) invs args+        _ -> return $ makeDumpEnv exp++    -- XXX Generalize this into structural folding+    makeDumpEnv Noop              = Syn "continuation" []+    makeDumpEnv (Stmts x Noop)    = Stmts (Ann (Cxt cxtItemAny) x) (Syn "continuation" [])+    makeDumpEnv (Stmts x exp)     = Stmts x   $ makeDumpEnv exp+    makeDumpEnv (Ann ann exp)     = Ann ann   $ makeDumpEnv exp+    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+        putStrLn "Internal error while running expression:"+        putStrLn $ show err++runImperatively :: TVar Env -> Eval Val -> IO Val+runImperatively menv eval = do+    env <- stm $ readTVar menv+    runEvalIO env $ do+        val <- eval+        newEnv <- ask+        stm $ writeTVar menv newEnv+        return val++doRun :: (?debugInfo :: DebugInfo) => String -> [String] -> String -> IO ()+doRun = do+    runProgramWith (\e -> e{ envDebug = ?debugInfo }) end+    where+    end err@(VError _ _)  = do+        hPutStrLn stderr $ encodeUTF8 $ pretty err+        globalFinalize+        exitFailure+    end (VControl (ControlExit exit)) = do+        globalFinalize+        exitWith exit+    end _ = return ()++noEnvDebug :: Env -> Env+noEnvDebug e = e{ envDebug = Nothing }++runProgramWith ::+    (Env -> Env) -> (Val -> IO a) -> VStr -> [VStr] -> String -> IO a+runProgramWith fenv f name args prog = do+    env <- prepareEnv name args+    val <- runEnv $ parseProgram (fenv env) name prog+    f val++createConfigLine :: String -> String+createConfigLine item = "\t" ++ item ++ ": " ++ (Map.findWithDefault "UNKNOWN" item config)++printConfigInfo :: [String] -> IO ()+printConfigInfo [] = do+    libs <- getLibs+    putStrLn $ unlines $+        ["This is " ++ version ++ " built for " ++ getConfig "archname"+        ,""+        ,"Summary of pugs configuration:" ]+        ++ map (\x -> createConfigLine x) (map (fst) (Map.toList config))+        ++ [ "" ]+        ++ [ "@*INC:" ] ++ libs++printConfigInfo (item:_) = do+        putStrLn $ createConfigLine item++compPIR :: String -> IO ()+compPIR prog = do+    pir <- doCompile "PIR" "-" prog+    putStr $ (subMain ++ (last $ split subMain pir))+    where+    subMain = ".sub main"++runPIR :: String -> IO ()+runPIR prog = do+    pir <- doCompile "PIR" "-" prog+    writeFile "a.pir" pir+    evalParrotFile "a.pir"++{-+withInlinedIncludes :: String -> IO String+withInlinedIncludes prog = do+    libs <- getLibs+    expandInc libs prog+    where+    expandInc :: [FilePath] -> String -> IO String+    expandInc incs str = case breakOnGlue "\nuse " ('\n':str) of+        Nothing -> case breakOnGlue "\nrequire " ('\n':str) of+            Nothing -> return str+            Just (pre, post) -> do+                let (mod, (_:rest)) = span (/= ';') (dropWhile isSpace post)+                mod'    <- includeInc incs mod+                rest'   <- expandInc incs rest+                return $ pre ++ mod' ++ rest'+        Just (pre, post) -> do+            let (mod, (_:rest)) = span isAlphaNum (dropWhile isSpace post)+            mod'    <- includeInc incs mod+            rest'   <- expandInc incs rest+            return $ pre ++ "\n{" ++ mod' ++ "\n}\n" ++ rest'+    includeInc :: [FilePath] -> String -> IO String+    includeInc _ ('v':_) = return []+    includeInc incs name = do+        let name' = concat (intersperse "/" names) ++ ".pm"+            names = split "::" name+        pathName    <- requireInc incs name' (errMsg name incs)+        readFile pathName+    errMsg fn incs = "Can't locate " ++ fn ++ " in @*INC (@*INC contains: " ++ unwords incs ++ ")."+-}
+ src/Pugs/AST.hs view
@@ -0,0 +1,483 @@+{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans -funbox-strict-fields -fallow-overlapping-instances -fparr #-}++{-|+    Abstract syntax tree.++>   Tall ships and tall kings+>   Three times three.+>   What brought they from the foundered land+>   Over the flowing sea?+>   Seven stars and seven stones+>   And one white tree.+-}++module Pugs.AST (+    evalExp, evalExp_, readCodesFromRef,+    genSym, genMultiSym, genSymScoped, genPadEntryScoped, mkPadMutator,+    strRangeInf, strRange, strInc,+    mergeStmts, isEmptyParams, isCompileTime,+    newPackage, newType, newMetaType, typeMacro, isScalarLValue,+    filterPrim, filterUserDefinedPad, typeOfParam, listVal, isImmediateMatchContext,+    (./), defaultScalarPad, envPosStack,++    module Pugs.AST.Internals,+    module Pugs.AST.Prag,+    module Pugs.AST.Pos,+    module Pugs.AST.Scope,+    module Pugs.AST.SIO,+    module Pugs.AST.Pad,+    module Pugs.Val,+    module Pugs.Class+) where+import Pugs.Internals+import Pugs.Types+import qualified Data.Map as Map+import qualified Data.Set as Set+import Pugs.AST.Internals.Instances ()+import Pugs.AST.Internals+import Pugs.AST.Prag+import Pugs.AST.Pos+import Pugs.AST.Scope+import Pugs.AST.SIO+import Pugs.AST.Pad+import Pugs.Val hiding (Val, Param, listVal) -- (val, castVal, formatVal, PureBit, PureBool, PureStr, PureInt, PureNum, Capt(..), ValCapt, Feed(..), ValFeed, emptyFeed, Sig(..), SigParam(..), ParamAccess(..), ParamDefault(..))+import qualified Pugs.Val as Val+import Pugs.Meta ()+import Pugs.Class (Boxable(..), ResponderInterface(..), Invocant(..), AnyResponder(..), MethodInvocation(..), ivDispatch)++instance Value (Val.Val) where+    fromVV = return+    fromSV = return . mkVal+    fromVal v = case v of+        VV x@(MkInvocant x' _) -> case fromTypeable x' of+            Just v  -> fromVal v+            _       -> return x+        VUndef      -> return . mkVal $ UUndef+        VBool x     -> return . mkVal $ ((cast x) :: Val.PureBit)+        VInt x      -> return . mkVal $ ((cast x) :: Val.PureInt)+        VNum x      -> return . mkVal $ ((cast x) :: Val.PureNum)+        VRat x      -> return . mkVal $ ((cast x) :: Val.PureNum)+        VStr x      -> return . mkVal $ ((cast x) :: Val.PureStr)+        PerlSV x    -> return . mkVal $ x+        _           -> return . mkVal $ v+    doCast = fromVal+    castV  = VV++data OldValResponder = OldValResponder deriving Typeable+instance ResponderInterface Eval OldValResponder where+    dispatch _          = dispatchOldVal+    fromMethodList _    = return OldValResponder++instance Boxable Val where+    mkVal sv = MkInvocant sv (MkResponder (return OldValResponder))++dispatchOldVal :: Val.Val -> Call -> Eval Val.Val+dispatchOldVal inv call+    | meth == nullID = do+        typ <- evalValType =<< castVal inv+        (fromVal =<<) . evalExp $ _Var (':':'*':showType typ)+    | otherwise      = do +        inv' <- castVal inv+        (fromVal =<<) . evalExp $ App+            (_Var ('&':cast meth))+            (Just $ Val inv')+            [Syn "|" [Val . VV . mkVal $ mi_arguments call]]+    where+    meth = mi_name call++{-|+Return an infinite (lazy) Haskell list of the given string and its+successors. 'strInc' is used to determine what the \'next\' string is.++Used to implement the @...@ infinite-range operator on strings.+-}+strRangeInf :: String -> [String]+strRangeInf s = (s:strRangeInf (strInc s))++{-|+Return a range of strings from the first argument to the second, inclusive+(as a Haskell list). 'strInc' is used to determine what the \'next\' string +is.++Used to implement the @..@ range operator on strings.+-}+strRange :: String -> String -> [String]+strRange s1 s2+    | s1 == s2              = [s2]+    | length s1 > length s2 = []+    | length s1 < length s2 = (s1:strRange (strInc s1) s2)+    | s1 >  s2              = []+    | otherwise             = (s1:strRange (strInc s1) s2)++{-|+Find the successor of a string (i.e. the next string \'after\' it).+Special rules are used to handle wraparound for strings ending in an+alphanumeric character; otherwise the last character is simply incremented +using 'succ'.+-}+strInc :: String -> String+strInc []       = "1"+strInc "z"      = "aa"+strInc "Z"      = "AA"+strInc "9"      = "10"+strInc str+    | x == 'z'  = strInc xs ++ "a"+    | x == 'Z'  = strInc xs ++ "A"+    | x == '9'  = strInc xs ++ "0"+    | otherwise = xs ++ [succ x]+    where+    x   = last str+    xs  = init str++{-|+Evaluate the given expression, using the currently active evaluator+(as given by the 'envEval' slot of the current 'Env').+-}+evalExp :: Exp -> Eval Val+evalExp exp = do+    evl <- asks envEval+    evl exp++evalExp_ :: Exp -> Eval ()+evalExp_ exp = do+    evalExp exp+    return ()++genMultiSym :: MonadSTM m => Var -> VRef -> EntryFlags -> m PadMutator+genMultiSym var = case v_sigil var of+    SCode -> \ref flags -> do+        case ref of+            MkRef (ICode c) -> do+                let var' = var{ v_longname = _cast (cast (code_params c)) }+                genSymScoped SMy var' ref flags+            _               -> die "Cannot generate multi variants of non-code object" ref+    _           -> const $ die "Cannot generate multi variants of variable" var++isStaticScope :: Scope -> Bool+isStaticScope SOur    = True+isStaticScope SState  = True+isStaticScope _       = False++genPadEntryScoped :: MonadSTM m => Scope -> VRef -> EntryFlags -> m PadEntry+genPadEntryScoped scope ref flags+    | SConstant <- scope = do+        return (PEConstant typ ref flags)+    | isStaticScope scope = stm $ do+        tvar    <- newTVar ref+        return (PEStatic typ ref flags tvar)+    | otherwise = stm $ do+        tvar    <- newTVar ref+        return (PELexical typ ref flags tvar)+    where+    typ = refType ref++{-# NOINLINE genSymScoped #-}+genSymScoped :: MonadSTM m => Scope -> Var -> VRef -> EntryFlags -> m PadMutator+genSymScoped scope var ref flags = do+    entry <- genPadEntryScoped scope ref flags+    return (mkPadMutator var entry ref)++mkPadMutator :: Var -> PadEntry -> VRef -> PadMutator+mkPadMutator var entry ref (MkPad map)+    | v_longname var /= nullID, MkRef (ICode c) <- ref+    = let   var'        = var{ v_longname = nullID }+            protoEntry  = PEConstant+                { pe_type  = pe_type entry+                , pe_proto = MkRef (ICode protoCode)+                , pe_flags = pe_flags entry+                }+            protoCode = MkMultiCode+                { mc_type       = pe_type entry+                , mc_subtype    = code_type c+                , mc_assoc      = code_assoc c+                , 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]+                            }+                        }+                _ -> 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)++{-|+Create a lexical 'Pad'-transforming transaction that will install a symbol+mapping from a name to a thing, in the 'Pad' it is applied to.+-}+genSym :: MonadSTM m => Var -> VRef -> m PadMutator+genSym var ref = genSymScoped scope var ref $! case v_twigil var of+    TMagical    -> mempty{ ef_isContext = True }+    _           -> mempty+    where+    scope = case v_twigil var of+        TMagical -> SConstant+        _        -> SMy++{-|+Tests whether an expression is /simple/, per the definition of S03.+On the LHS of assignment, those expressions incurs a scalar context.+-}+isScalarLValue :: Exp -> Bool+isScalarLValue x = case x of+    Ann Parens _    -> False+    Var var | SScalar <- v_sigil var -> True+    Syn "${}" _     -> True -- XXX - Change tp App("&prefix:<$>") later+    Syn "$::()" _   -> True+    _               -> False++opSet :: VarCateg -> [String] -> Set Var+opSet cat posts = Set.fromList $ map doMakeVar posts+    where+    doMakeVar name = MkVar+        { v_sigil   = SCode+        , v_twigil  = TNil+        , v_package = emptyPkg+        , v_categ   = cat+        , v_name    = cast name+        , v_meta    = MNil+        , v_longname= nullID+        }++coercePrefixOps, simplePrefixOps, simplePostfixOps, simpleInfixOps :: Set Var+coercePrefixOps = opSet C_prefix [ "!","+","-","~","?","$" ]+simplePrefixOps = opSet C_prefix+    [ "++","--"+    , "$","&","+^","~^","?^","\\","^","="+    ]+simplePostfixOps = opSet C_postfix ["++", "--"]+simpleInfixOps = opSet C_infix+    [ "**"+    , "**="+    , "*","/","%","x","+&","+<","+>","~&","~<","~>"+    , "*=","/=","%=","x=","+&=","+<=","+>=","~&=","~<=","~>="+    , "+","-","~","+|","+^","~|","~^"+    , "+=","-=","~=","+|=","+^=","~|=","~^="+    ]+++++-- Stmt is essentially a cons cell+-- Stmt (Stmt ...) is illegal+mergeStmts :: Exp -> Exp -> Exp+mergeStmts (Stmts x1 x2) y = mergeStmts x1 (mergeStmts x2 y)+mergeStmts Noop y@(Stmts _ _) = y+mergeStmts (Sym scope name flag init x) y = Sym scope name flag init (mergeStmts x y)+mergeStmts (Syn "package" [kind, pkg@(Val (VStr _))]) y =+    Syn "namespace" [kind, pkg, y]+mergeStmts x@(Ann ann (Syn syn _)) y | isImplicitTopic syn =+    mergeStmts (Ann ann (App (_Var "&infix:~~") Nothing [_Var "$_", x])) y+mergeStmts x y@(Ann ann (Syn syn _)) | isImplicitTopic syn =+    mergeStmts x (Ann ann (App (_Var "&infix:~~") Nothing [_Var "$_", y]))+mergeStmts x@(Ann _ (Syn "sub" [Val (VCode sub)])) y | subType sub == SubBlock =+    -- bare Block in statement level; annul all its parameters and run it!+    mergeStmts (Syn "block" [x]) y+mergeStmts x y@(Ann _ (Syn "sub" [Val (VCode sub)])) | subType sub == SubBlock =+    -- bare Block in statement level; annul all its parameters and run it!+    mergeStmts x (Syn "block" [y])+mergeStmts x (Stmts y Noop) = mergeStmts x y+mergeStmts x (Stmts Noop y) = mergeStmts x y+mergeStmts x y = Stmts x y++isImplicitTopic :: String -> Bool+isImplicitTopic "subst" = True+isImplicitTopic "match" = True+isImplicitTopic "trans" = True+isImplicitTopic "//"    = True+isImplicitTopic _       = False++isEmptyParams :: [Param] -> Bool+isEmptyParams [] = True+isEmptyParams [x]+    | var <- paramName x+    , _underscore == v_name var+    , emptyPkg    == v_package var+    , TNil        == v_twigil var+    = True+isEmptyParams _ = False++_underscore :: ID+_underscore = cast "_" ++newPackage :: String -> String -> [String] -> [String] -> Exp+newPackage cls name classes roles = Stmts metaObj (newType name)+    where+    metaObj = _Sym SOur (':':'*':name) mempty (+        App (_Var "&HOW::new")+            (Just $ Val (VType $ mkType cls))+            [ Syn "named"+                [ Val (VStr "is")+                , Val (VList $ map VStr classes)+                ]+            , Syn "named"+                [ Val (VStr "does")+                , Val (VList $ map VStr roles)+                ]+            , Syn "named"+                [ Val (VStr "name")+                , Val (VStr name)+                ]+            , Syn "named"+                [ Val (VStr "attrs")+                , Syn "\\{}" [Noop]+                ]+            ]+            ) Noop++newType :: String -> Exp+newType name = _Sym SOur ('&':'*':termName) mempty (typeMacro name (Val . VType . mkType $ name)) Noop+    where+    termName = "term:" ++ name+++newMetaType :: String -> Exp+newMetaType name = _Sym SOur ('&':'*':termName) mempty (typeMacro name (_Var (':':'*':name))) Noop+    where+    termName = "term:" ++ name++typeMacro :: String -> Exp -> Exp+typeMacro name exp = Syn "sub" . (:[]) . Val . VCode $ MkCode+    { isMulti       = True+    , subName       = cast name+    , subOuterPads  = []+    , subInnerPad   = emptyPad+--  , subLexical    = emptyPad+    , subStarted    = Nothing+    , subPackage    = emptyPkg+    , subType       = SubMacro+    , subAssoc      = ANil+    , subReturns    = typ+    , subLValue     = False+    , subParams     = [ defaultArrayParam, defaultHashParam ]+    , subBindings   = []+    , subSlurpLimit = []+    , subBody       = Prim $ \v -> do+        list <- mapM fromVals v :: Eval [VList]+        case concat list of+            []  -> expToEvalVal $ exp+            xs  -> die ("Cannot coerce to " ++ name) xs+    , subCont          = Nothing+    , subTraitBlocks   = emptyTraitBlocks+    }+    where+    typ = mkType name++{- utilities for filtering out primitives from an environmet, useful for+ - CodeGen and Pugs::Internals::emit_yaml -}++filterPrim :: MPad -> Eval Pad+filterPrim glob = do+    MkPad pad   <- readMPad glob+    fmap (MkPad . Map.fromAscList . catMaybes) . mapM checkPrim $ Map.toAscList pad++checkPrim :: (Var, PadEntry) -> Eval (Maybe (Var, PadEntry))+checkPrim e@(var, entry)+    | SType <- v_sigil var, isGlobalVar var = return Nothing+    | otherwise = do+        rv <- isPrim =<< readPadEntry entry+        return (if rv then Nothing else Just e)++isPrim :: VRef -> Eval Bool+isPrim vref = do+    case vref of+        MkRef (ICode cv)    -> fmap (isPrimVal . VCode) (code_fetch cv)+        MkRef (IScalar sv)  -> fmap isPrimVal (scalar_fetch sv)+        _                   -> return False+    where+    isPrimVal (VCode MkCode{ subBody = Prim _ }) = True+    isPrimVal _ = False++{-|+Filter out reserved symbols from the specified Pad.+-}+filterUserDefinedPad :: Pad -> Pad+filterUserDefinedPad (MkPad pad) = MkPad $ Map.filterWithKey doFilter pad+    where+    doFilter key _ = (not . Set.member key) _reserved++{-|+Symbols which are reserved for the current interpreter or compiler instance and+should not be set from the preamble or other sources. See @filterUserDefinedPad@.+-}+_reserved :: Set Var+_reserved = Set.fromList . cast . words $+    "@*ARGS @*INC %*INC $*PUGS_HAS_HSPLUGINS $*EXECUTABLE_NAME " +++    "$*PROGRAM_NAME $*PID $*UID $*EUID $*GID $*EGID @*CHECK @*INIT $*IN " +++    "$*OUT $*ERR $*ARGS $/ %*ENV $*CWD @=POD $=POD $?PUGS_VERSION " +++    "$*OS %?CONFIG $*_ $*AUTOLOAD $*PUGS_VERSION $*BASETIME"++typeOfParam :: Param -> Type+typeOfParam p = case v_sigil (paramName p) of+    SScalar -> typeOfCxt (paramContext p)+    s       -> typeOfSigil s++listVal :: Val -> [Val]+listVal (VList xs)  = xs+listVal x           = [x]++isImmediateMatchContext :: Eval Bool+isImmediateMatchContext = do+    env <- ask+    let cxt = envContext env+        typ = typeOfCxt cxt+    return (cxt == CxtVoid || (any (\x -> isaType x typ) ["Bool", "Num", "Str"]))++(./) :: ((:>:) Call a) => Val -> a -> Eval Val+(VV vv) ./ y = vvToVal =<< ivDispatch vv (cast y)+x ./ y       = do+    vv <- fromVal x+    vvToVal =<< ivDispatch vv (cast y)++instance ((:>:) Call) Cxt where+    cast CxtSlurpy{} = __LIST__+    cast _           = __ITEM__++__LIST__ :: Call+__LIST__ = cast "LIST"++__ITEM__ :: Call+__ITEM__ = cast "ITEM"++readCodesFromRef :: VRef -> Eval [VCode]+readCodesFromRef (MkRef (ICode c))+    | Just (mc :: VMultiCode) <- fromTypeable c = do+        let names@(pivot:_) = Set.elems (mc_variants mc)+        rvs <- fmap concat . forM names $ \var -> do+            ref  <- fromVal =<< readVar var+            readCodesFromRef ref+        if not (isLexicalVar pivot) then return rvs else do+            -- Lexical multis must also include global variants.+            cvGlobal <- readVar (toGlobalVar pivot{ v_longname = nullID })+            if not (defined cvGlobal) then return rvs else do+                rvsGlobal <- readCodesFromRef =<< fromVal cvGlobal+                return (rvsGlobal ++ rvs)+    | Just (cv :: VCode) <- fromTypeable c = return [cv]+readCodesFromRef ref = do+    code <- fromVal =<< readRef ref+    readCodesFromRef (MkRef (ICode (code :: VCode)))++isCompileTime :: Env -> Bool+isCompileTime = isJust . envCompPad+++{-# NOINLINE defaultScalarPadStore #-}+defaultScalarPadStore :: TVar VRef+defaultScalarPadStore = unsafePerformIO (newTVarIO defaultScalarRef)++defaultScalarRef :: VRef+defaultScalarRef = scalarRef undef++defaultScalarPad :: Pad+defaultScalarPad = mkPad [(varTopic, PELexical anyType defaultScalarRef mempty defaultScalarPadStore)]++envPosStack :: Env -> [Pos]+envPosStack env = envPos env : maybe [] envPosStack (envCaller env)+
+ src/Pugs/AST.hs-boot view
@@ -0,0 +1,9 @@+{-# OPTIONS_GHC -fglasgow-exts -fno-warn-orphans -funbox-strict-fields -fallow-overlapping-instances #-}+module Pugs.AST where+import Pugs.Internals+import Pugs.Types+import Pugs.Class hiding (Val)+import {-# SOURCE #-} Pugs.AST.Internals++(./) :: ((:>:) Call a) => Val -> a -> Eval Val+instance ((:>:) Call) Cxt
+ src/Pugs/AST/Eval.hs view
@@ -0,0 +1,210 @@+{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans -fallow-overlapping-instances -funbox-strict-fields -fallow-undecidable-instances #-}++module Pugs.AST.Eval where+import Pugs.Internals+import Pugs.Cont hiding (resetT)+import Control.Exception (try, Exception)++import Pugs.AST.SIO+import {-# SOURCE #-} Pugs.AST.Internals++{- Eval Monad -}++newtype Eval a = EvalT { runEvalT :: ContT (EvalResult Val) (ReaderT Env SIO) (EvalResult a) }+    deriving (Typeable)++data EvalResult a+    = RNormal    !a+    | RException !Val+    deriving (Typeable)++instance ((:>:) (Eval a)) (SIO a) where cast = liftSIO++liftResult :: EvalResult Val -> Val+liftResult (RNormal x) = x+liftResult (RException x) = x++runEvalSTM :: Env -> Eval Val -> STM Val+runEvalSTM env = fmap liftResult . runSTM . (`runReaderT` enterAtomicEnv env) . (`runContT` return) . runEvalT++runEvalIO :: Env -> Eval Val -> IO Val+runEvalIO env = fmap liftResult . runIO . (`runReaderT` env) . (`runContT` return) . runEvalT++tryIO :: a -> IO a -> Eval a+tryIO err = liftEval . io . (`catchIO` (const $ return err))++{-|+'shiftT' is like @callCC@, except that when you activate the continuation+provided by 'shiftT', it will run to the end of the nearest enclosing 'resetT',+then jump back to just after the point at which you activated the continuation.++Note that because control eventually returns to the point after the +subcontinuation is activated, you can activate it multiple times in the +same block. This is unlike @callCC@'s continuations, which discard the current+execution path when activated.++See 'resetT' for an example of how these delimited subcontinuations actually+work.+-}+shiftT :: ((a -> Eval Val) -> Eval Val)+       -- ^ Typically a lambda function of the form @\\esc -> do ...@, where+       --     @esc@ is the current (sub)continuation+       -> Eval a+shiftT _ = fail "shiftT not yet implemented in Eval"++{-|+Create an scope that 'shiftT'\'s subcontinuations are guaranteed to eventually+exit out the end of.++Consider this example:++> resetT $ do+>     alfa+>     bravo+>     x <- shiftT $ \esc -> do+>        charlie+>        esc 1+>        delta+>        esc 2+>        return 0+>     zulu x++This will:++  1) Perform @alfa@+  +  2) Perform @bravo@+  +  3) Perform @charlie@+  +  4) Bind @x@ to 1, and thus perform @zulu 1@+  +  5) Fall off the end of 'resetT', and jump back to just after @esc 1@+  +  6) Perform @delta@+  +  7) Bind @x@ to 2, and thus perform @zulu 2@+  +  8) Fall off the end of 'resetT', and jump back to just after @esc 2@+  +  6) Escape from the 'resetT', causing it to yield 0++Thus, unlike @callCC@'s continuations, these subcontinuations will eventually+return to the point after they are activated, after falling off the end of the+nearest 'resetT'.+-}+resetT :: Eval Val -- ^ An evaluation, possibly containing a 'shiftT'+       -> Eval Val+resetT (EvalT e) = EvalT (lift (e `runContT` return))++tryT :: Eval Val -- ^ An evaluation, possibly containing an exception+     -> Eval Val+tryT e = catchError e return++instance Monad Eval where+    return a = EvalT $ return (RNormal a)+    m >>= k = EvalT $ do+        a <- runEvalT m+        case a of+            RNormal x   -> runEvalT (k x)+            RException x-> return (RException x)+    fail str = do+        pos <- asks envPos'+        EvalT $ return (RException (errStrPos (cast str) pos))++instance Error Val where+    noMsg = errStr ""+    strMsg = errStr++liftEval :: ReaderT Env SIO a -> Eval a+liftEval m = EvalT $ do+    a <- ContT (m >>=)+    return (RNormal a)++{-+instance MonadTrans EvalT where+    lift m = EvalT $ do+        a <- ContT (m >>=)+        return (RNormal a)+-}++instance Functor Eval where+    fmap f m = EvalT $ do+        a <- runEvalT m+        return $ case a of+            RNormal x   -> RNormal (f x)+            RException x-> RException x++instance MonadIO Eval where+    liftIO = liftEval . io++instance MonadError Val Eval where+    throwError err = do+        pos <- asks envPos'+        EvalT $ return (RException (errValPos err pos))+    m `catchError` h = EvalT $ do+        a <- runEvalT m+        case a of+            RException l    -> runEvalT (h l)+            _               -> return a++{-|+Perform an IO action and raise an exception if it fails.+-}+guardIO :: IO a -> Eval a+guardIO x = do+    rv <- io $ try x+    case rv of+        Left e -> fail (show e)+        Right v -> return v++{-|+Like @guardIO@, perform an IO action and raise an exception if it fails.++If t+supress the exception and return an associated value instead.+-}+guardIOexcept :: MonadIO m => [((Exception -> Bool), a)] -> IO a -> m a+guardIOexcept safetyNet x = do+    rv <- io $ try x+    case rv of+        Right v -> return v+        Left  e -> catcher e safetyNet+    where+    catcher e [] = fail (show e)+    catcher e ((f, res):safetyNets)+        | f e       = return res+        | otherwise = catcher e safetyNets++guardSTM :: STM a -> Eval a+guardSTM x = do+    rv <- stm $ fmap Right x `catchSTM` (return . Left)+    case rv of+        Left e -> fail (show e)+        Right v -> return v+    +instance MonadSTM Eval where+    liftSIO = EvalT . fmap RNormal . lift . lift+    liftSTM x = do+        atom <- asks envAtomic+        if atom+            then EvalT (fmap RNormal . lift . lift . stm $ x)+            else EvalT (fmap RNormal . lift . lift . io . stm $ x)++instance MonadReader Env Eval where+    ask       = liftEval ask+    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 (RNormal a)))++{-+instance MonadEval Eval++class (MonadReader Env m, MonadCont m, MonadIO m, MonadSTM m) => MonadEval m+--     askGlobal :: m Pad+-}+
+ src/Pugs/AST/Internals.hs view
@@ -0,0 +1,2289 @@+{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans -fallow-overlapping-instances -fallow-undecidable-instances -fparr #-}++module Pugs.AST.Internals (+    Eval(..),      -- uses Val, Env, SIO+    Ann(..),   -- Cxt, Pos, Prag+    Exp(..),   -- uses Pad, Eval, Val+    Env(..),   -- uses Pad, TVar, Exp, Eval, Val+    Val(..),   -- uses V.* (which ones?)+    Value(..), -- uses Val, Eval+    InitDat(..),+    SubAssoc(..), TraitBlocks(..), emptyTraitBlocks,++    MPad(..), LexPad(..), LexPads, Pad(..), PadEntry(..), EntryFlags(..), PadMutator, -- uses Var, TVar, VRef+    Param(..), -- uses Cxt, Exp+    Params, -- uses Param+    Bindings, -- uses Param, Exp+    SlurpLimit, -- VInt, Exp+    +    emptyPad,++    VRef(..), -- uses IVar+    VOpaque(..), -- uses Value+    VControl(..), -- uses Env, Eval, Val+    ControlLoop(..), ControlWhen(..), Frame(..),+    VScalar, -- uses Val+    VPair, -- uses Val+    VList, -- uses Val+    VThread(..), -- uses Val+    VSubst(..),  -- uses VRule, VStr, Exp+    VArray, -- uses Val+    VHash, -- uses VStr, Val+    VThunk(..), -- uses Eval, Val+    VProcess(..),+    VMatch(..), mkMatchFail, mkMatchOk, -- uses VList, VHash+    VCode(..), SubType(..), -- uses Pad, Exp, Type+    VJunc(..), JuncType(..), -- uss Val+    VObject(..), -- uses VType, IHash, Unique+    ObjectId(..),+    VType, -- uses Type+    VRule(..), -- uses Val+    VMultiCode(..),++    IVar(..), -- uses *Class and V*+    IArray(..), IArraySlice, IHash, IScalar, IScalarProxy,+    IScalarLazy, IPairHashSlice, IRule, IHandle, IHashEnv(..),+    IScalarCwd(..),++    ArrayClass(..), CodeClass(..), HandleClass(..), HashClass(..),+    ObjectClass(..), PairClass(..), RuleClass(..), ScalarClass(..),+    ThunkClass(..),++    CompUnit(..), mkCompUnit, compUnitVersion,++    -- MonadEval(..),++    transformExp,++    runEvalSTM, runEvalIO, callCC, tryT, resetT, shiftT, catchT,+    undef, defined, tryIO, guardSTM, guardIO, guardIOexcept,+    readRef, writeRef, clearRef, dumpRef, forceRef,+    askGlobal, writeVar, readVar,+    findSymRef, findSym, valType,+    ifListContext, ifValTypeIsa, evalValType, fromVal',+    scalarRef, codeRef, arrayRef, hashRef, thunkRef, pairRef,+    newScalar, newArray, newHash, newHandle, newObject,++    cloneRef, cloneIVar,++    proxyScalar, constScalar, lazyScalar, lazyUndef, constArray,+    retControl, retShift, retShiftEmpty, retEmpty, retIVar, readIVar, writeIVar,+    fromVals, refType,+    readPadEntry, writePadEntry, refreshPad, lookupPad, padToList, listToPad,+    mkPrim, mkSub, mkCode, showRat, showTrueRat,+    cxtOfSigil, cxtOfSigilVar, typeOfSigil, typeOfSigilVar,+    buildParam, defaultArrayParam, defaultHashParam, defaultScalarParam,+    paramsToSig,+    emptyExp,+    isSlurpy, envWant,+    extractPlaceholderVars, fromObject, createObject, createObjectRaw,+    doPair, doHash, doArray,+    unwrap, -- Unwrap(..) -- not used in this file, suitable for factoring out+    newObjectId, runInvokePerl5,+    +    showVal, errStr, errStrPos, errValPos, enterAtomicEnv, valToBool, envPos', -- for circularity+    expToEvalVal, -- Hack, should be removed once it's figured out how++    newSVval, -- used in Run.Perl5++    anyToVal, vvToVal, anyFromVal, -- for circularity++    DebugInfo, newDebugInfo, _Sym, _Var -- String -> ByteString constructors+) 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 GHC.Conc (unsafeIOToSTM)++import Pugs.Cont (callCC)+import Pugs.Parser.Number+import Pugs.AST.Eval+import Pugs.AST.Utils+import Pugs.AST.Prag+import Pugs.AST.Pos+import Pugs.AST.Scope+import Pugs.AST.SIO+import Pugs.Embed.Perl5+import qualified Pugs.Val as Val+import GHC.PArr+import {-# SOURCE #-} Pugs.AST++{- <DrIFT> Imports for the DrIFT+import Pugs.AST.Scope+import Pugs.AST.Pos+import Pugs.AST.Prag+import Pugs.AST.SIO+import Pugs.Types+import Pugs.Internals+import Pugs.Embed.Perl5+import qualified Data.Set       as Set+import qualified Data.Map       as Map+import qualified Pugs.Val       as Val++import qualified Data.HashTable    as H+ </DrIFT> -}+ +#include "../Types/Array.hs"+#include "../Types/Handle.hs"+#include "../Types/Hash.hs"+#include "../Types/Scalar.hs"+#include "../Types/Code.hs"+#include "../Types/Thunk.hs"+#include "../Types/Rule.hs"+#include "../Types/Pair.hs"+#include "../Types/Object.hs"+++catchT :: ((Val -> Eval b) -> Eval Val) -> Eval Val+catchT action = tryT (action retShift)++{-|+Return the appropriate 'empty' value for the current context -- either+an empty list ('VList' []), or undef ('VUndef').+-}+retEmpty :: Eval Val+retEmpty = do+    ifListContext+        (return $ VList [])+        (return VUndef)++evalValType :: Val -> Eval Type+evalValType (VRef (MkRef (IScalar sv))) = scalar_type sv+evalValType (VRef r) = return $ refType r+evalValType (VType t) = return t+evalValType val = return $ valType val++{-|+Check whether a 'Val' is of the specified type. Based on the result,+either the first or the second evaluation should be performed.+-}+ifValTypeIsa :: Val      -- ^ Value to check the type of+             -> String   -- ^ Name of the type to check against+             -> (Eval a) -- ^ The @then@ case+             -> (Eval a) -- ^ The @else@ case+             -> Eval a+ifValTypeIsa v (':':typ) trueM falseM = ifValTypeIsa v typ trueM falseM+ifValTypeIsa v typ trueM falseM = do+    vt  <- evalValType v+    if isaType typ vt+        then trueM+        else falseM++{-|+Collapse a junction value into a single boolean value.++Works by recursively casting the junction members to booleans, then performing+the actual junction test.+-}+juncToBool :: VJunc -> Eval Bool+juncToBool (MkJunc JAny  _  vs) = do+    bools <- mapM valToBool (Set.elems vs)+    return . isJust $ find id bools+juncToBool (MkJunc JAll  _  vs) = do+    bools <- mapM valToBool (Set.elems vs)+    return . isNothing $ find not bools+juncToBool (MkJunc JNone _  vs) = do+    bools <- mapM valToBool (Set.elems vs)+    return . isNothing $ find id bools+juncToBool (MkJunc JOne ds vs) = do+    bools <- mapM valToBool (Set.elems ds)+    if isJust (find id bools) then return False else do+    bools <- mapM valToBool (Set.elems vs)+    return $ 1 == (length $ filter id bools)++instance Show JuncType where+    show JAny  = "any"+    show JAll  = "all"+    show JNone = "none"+    show JOne  = "one"++instance Show VJunc where+    show (MkJunc jtype _ set) =+        (show jtype) ++ "(" +++            (foldl (\x y ->+                if x == "" then show y+                else x ++ "," ++ show y)+            "" $ Set.elems set) ++ ")"++{-|+Typeclass indicating types that can be converted to\/from 'Val's.++Not to be confused with 'Val' itself, or the 'Exp' constructor @Val@.+-}+class (Typeable n, Show n, Ord n) => Value n where+    fromVal :: Val -> Eval n+    fromVal = fromVal'+    doCast :: Val -> Eval n+{-    doCast v = castFailM v "default implementation of doCast" -}+    fromVV :: Val.Val -> Eval n+    fromVV v = do+        str <- Val.asStr v+        fail $ "Cannot cast from VV (" ++ cast str ++ ") to " ++ errType (undefined :: n)+    fromSV :: PerlSV -> Eval n+    fromSV sv = do+        str <- io $ svToVStr sv+        fail $ "Cannot cast from SV (" ++ str ++ ") to " ++ errType (undefined :: n)+    castV :: n -> Val+    castV x = VOpaque (MkOpaque x) -- error $ "Cannot cast into Val"++#ifndef HADDOCK+data VOpaque where+    MkOpaque :: Value a => !a -> VOpaque+#endif++fromVal' :: (Value a) => Val -> Eval a+fromVal' (VRef r) = do+    v <- readRef r+    fromVal v+fromVal' (VList vs) | any isRef vs = do+    vs <- forM vs $ \v -> case v of { VRef r -> readRef r; _ -> return v }+    fromVal $ VList vs+    where+    isRef VRef{}    = True+    isRef _         = False+fromVal' (PerlSV sv) = do+    v <- io $ svToVal sv+    case v of+        PerlSV sv'  -> fromSV sv'   -- it was a SV+        VV vv+            | Just sv  <- Val.castVal vv -> fromSV sv+            | Just v   <- Val.castVal vv -> fromVal v+        val         -> fromVal val  -- it was a Val+fromVal' (VV vv) = do+    v' <- vvToVal vv+    case v' of+        VV vv''     -> fromVV vv''+        PerlSV sv   -> fromSV sv+        _           -> fromVal v'+fromVal' v = doCast v++-- XXX - This is makeshift until all our native types are in VV.+vvToVal :: Val.Val -> Eval Val+vvToVal x+    | Just sv <- Val.castVal x  = do+        rv <- io (svToVal sv)+        case rv of+            VV vv+                | Just sv  <- Val.castVal vv -> return (PerlSV sv)+                | Just v   <- Val.castVal vv -> return v+            _ -> return rv+    | Just v  <- Val.castVal x  = return v+    | Just x' <- Val.castVal x  = return . VStr $ (cast :: Val.PureStr -> String)  x'+    | Just x' <- Val.castVal x  = return . VInt $ (cast :: Val.PureInt -> Integer) x'+    | Just x' <- Val.castVal x  = return . VNum $ (cast :: Val.PureNum -> Double)  x'+    | Just x' <- Val.castVal x  = return (VStr x')+    | Just x' <- Val.castVal x  = return (VInt x')+    | Just x' <- Val.castVal x  = return (VNum x')+    | Just x' <- Val.castVal x  = return (VBool x')+    | Just () <- Val.castVal x  = return VUndef+    | otherwise                 = return (VV x)++getArrayIndex :: Int -> Maybe (IVar VScalar) -> Eval IArray -> Maybe (Eval b) -> Eval (IVar VScalar)+getArrayIndex idx def getArr _ | idx < 0 = do+    -- first, check if the list is at least abs(idx) long+    MkIArray iv <- getArr+    a   <- stm $ readTVar iv+    let size = a_size a+    if size > abs (idx+1)+        then return (a !: (idx `mod` size))+        else errIndex def idx+-- now we are all positive; either extend or return+getArrayIndex idx def getArr ext = do+    MkIArray iv <- getArr+    a   <- stm $ readTVar iv+    let size = a_size a+    if size > idx+        then return (a !: idx)+        else case ext of+            Just doExt -> do { doExt; getArrayIndex idx def getArr Nothing }+            Nothing    -> errIndex def idx++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+    return $ MkObject+        { objType   = typ+        , objId     = uniq+        , objAttrs  = attrs+        , objOpaque = opaq+        }++instance Value (IVar VScalar) where+    fromVal (VRef (MkRef v@(IScalar _))) = return v+    fromVal (VRef r) = fromVal =<< readRef r+    fromVal v = return $ constScalar v+    doCast v = castFailM v "IVar VScalar"++instance Value VType where+    fromVal (VType t)   = return t+    fromVal v@(VObject obj) | objType obj == (mkType "Class") = do+        meta    <- readRef =<< fromVal v+        fetch   <- doHash meta hash_fetchVal+        str     <- fromVal =<< fetch "name"+        return $ mkType str+    fromVal v           = evalValType v+    doCast v = castFailM v "VType"++instance Value VMatch where+    fromVal (VRef r) = fromVal =<< readRef r+    fromVal (VMatch m) = return m+    fromVal (VList (x:_)) = fromVal x+    fromVal _ = return $ mkMatchFail+    doCast v = castFailM v "VMatch"++instance Value VRef where+    fromVal (VRef r)   = return $ r+    fromVal (VList vs) = return $ arrayRef vs+    fromVal (VCode c)  = return $ codeRef c+    fromVal v          = return $ scalarRef v+    castV = VRef+    doCast v = castFailM v "VRef"++instance Value [Int] where+    fromVal v = do+        vlist <- fromVal v+        mapM fromVal vlist+    doCast v = castFailM v "[Int]"++instance Value [VStr] where+    castV = VList . map VStr+    fromVal v = do+        vlist <- fromVal v+        mapM fromVal vlist+    doCast v = castFailM v "[VStr]"++instance Value VPair where+    castV pv = VRef $ pairRef pv+    fromVal VUndef  = return (VUndef, VUndef)+    fromVal v       = join $ doPair v pair_fetch+    doCast v = castFailM v "VPair"++instance Value [(VStr, Val)] where+    fromVal v = do+        list <- fromVal v+        forM list $ \(k, v) -> do+            str <- fromVal k+            return (str, v)+    doCast v = castFailM v "[(VStr, Val)]"++instance Value VObject where+    fromVal (VObject o) = return o+    fromVal v@(VRef _) = fromVal' v+    fromVal v = do+        fail $ "Cannot cast from " ++ show v ++ " to Object"+    doCast v = castFailM v "VObject"++instance Value VHash where+    fromVal (VObject o) = do+        l <- io $ H.toList (objAttrs o)+        fmap Map.fromList . forM l $ \(k, ivar) -> do+            v <- readIVar ivar+            return (k, v)+    fromVal VType{} = return Map.empty -- ::Hash<foo>+    fromVal (VRef r) = fromVal =<< readRef r+    fromVal v = do+        list <- fromVal v+        fmap Map.fromList $ forM list $ \(k, v) -> do+            str <- fromVal k+            return (str, v)+    doCast v = castFailM v "VHash"++instance Value [VPair] where+    fromVal VUndef = return []+    fromVal v = do+        list <- fromVals v+        doFrom $ concat list+        where+        doFrom :: [Val] -> Eval [VPair]+        doFrom [] = return []+        doFrom [_] = fail $ "Odd number of elements found where hash expected: " ++ show v+        doFrom (k:v:list) = do+            rest <- doFrom list+            return ((k, v):rest)+    doCast v = castFailM v "Hash"++instance Value VCode where+    castV = VCode+    fromSV sv = return $ mkPrim+        { subName     = cast "<anon>"+        , subParams   = [defaultArrayParam]+        , subReturns  = mkType "Scalar::Perl5"+        , subBody     = Prim $ \(args:_) -> do+            svs     <- fromVals args+            runInvokePerl5 sv nullSV svs+        }+    doCast (VCode b) = return b+    doCast (VType t) = return $ mkPrim+        { subName     = cast t+        , subParams   = [buildParam "Any" "*" "@?0" (Val VUndef), buildParam "Any" "*" "%?0" (Val VUndef)]+        , subReturns  = mkType "Scalar::Perl5"+        , subBody     = Prim $ \(p:n:_) -> do+            evl <- asks envEval+            evl (App (_Var "&new") (Just $ Val (VType t)) [Syn "|" [Val p], Syn "|" [Val n]])+        }+    doCast (VList [VCode b]) = return b -- XXX Wrong+    doCast v = castFailM v "VCode"++runInvokePerl5 :: PerlSV -> PerlSV -> [PerlSV] -> Eval Val+runInvokePerl5 sub inv args = do +    env     <- ask+    rv      <- io $ do+        envSV   <- mkEnv env+        invokePerl5 sub inv args envSV (enumCxt $ envContext env)+    case rv of+        Perl5ReturnValues [x]   -> io $ svToVal x+        Perl5ReturnValues xs    -> io $ fmap VList (mapM svToVal xs)+        Perl5ErrorString str    -> fail str+        Perl5ErrorObject err    -> throwError (PerlSV err)++anyFromVal :: forall a. Typeable a => Val -> a+anyFromVal v = case fromTypeable (fromVal v :: Eval PerlSV) of+    Just f  -> f :: a+    _       -> error "anyFromVal failed!"++anyToVal :: (Show a, Typeable a) => a -> Val+anyToVal x+    | Just v <- fromTypeable x      = v+    | Just v <- fromTypeable x      = PerlSV v+    | Just v <- fromTypeable x      = VStr v+    | Just v <- fromTypeable x      = VInt v+    | Just v <- fromTypeable x      = VNum v+    | Just () <- fromTypeable x     = VUndef+    | otherwise                     = error (show x)++instance Value VBool where+    castV = VBool+    fromSV sv = io $ svToVBool sv+    fromVV vv = fmap cast (Val.asBit vv)+    doCast (VJunc j)   = juncToBool j+    doCast (VMatch m)  = return $ matchOk m+    doCast (VBool b)   = return $ b+    doCast VUndef      = return $ False+    doCast VType{}     = return $ False+    doCast (VStr "")   = return $ False+    doCast (VStr "0")  = return $ False+    doCast (VInt 0)    = return $ False+    doCast (VRat 0)    = return $ False+    doCast (VNum 0)    = return $ False+    doCast (VList [])  = return $ False+    doCast _           = return $ True+++instance Value VInt where+    castV = VInt+    fromVV vv = fmap cast (Val.asInt vv)+    fromSV sv = io $ svToVInt sv+    doCast (VInt i)     = return $ i+    doCast x            = fmap truncate (fromVal x :: Eval VRat)++instance Value VRat where+    castV = VRat+    fromSV sv = io $ svToVNum sv+    doCast (VInt i)     = return $ i % 1+    doCast (VRat r)     = return $ r+    doCast (VBool b)    = return $ if b then 1 % 1 else 0 % 1+    doCast (VList l)    = return $ genericLength l+    doCast (VStr s) | not (null s) , isSpace $ last s = do+        str <- fromVal (VStr $ init s)+        return str+    doCast (VStr s) | not (null s) , isSpace $ head s = do +        str <- fromVal (VStr $ tail s)+        return str+    doCast (VStr s)     = return $+        case ( parseNatOrRat s ) of+            Left _   -> 0 % 1+            Right rv -> case rv of+                Left  i -> i % 1+                Right d -> d+    doCast x            = fmap toRational (fromVal x :: Eval VNum)++instance Value VNum where+    castV = VNum+    fromVV vv = fmap cast (Val.asNum vv)+    fromSV sv = io $ svToVNum sv+    doCast VUndef       = return $ 0+    doCast VType{}      = return $ 0+    doCast (VBool b)    = return $ if b then 1 else 0+    doCast (VInt i)     = return $ fromIntegral i+    doCast (VRat r)     = return $ realToFrac r+    doCast (VNum n)     = return $ n+    doCast (VComplex (r :+ _)) = return $ r+    doCast (VStr s) | not (null s) , isSpace $ last s = do+        str <- fromVal (VStr $ init s)+        return str+    doCast (VStr s) | not (null s) , isSpace $ head s = do+        str <- fromVal (VStr $ tail s)+        return str+    doCast (VStr "Inf") = return $ 1/0+    doCast (VStr "-Inf") = return $ -1/0+    doCast (VStr "NaN") = return $ 0/0+    doCast (VStr s)     = return $+        case ( parseNatOrRat s ) of+            Left _   -> 0+            Right rv -> case rv of+                Left  i -> fromIntegral i+                Right d -> realToFrac d+    doCast (VList l)     = return $ genericLength l+    doCast t@VThread{}   = fmap read (fromVal t)+    doCast (VMatch m)    = fromVal (VStr $ matchStr m)+    doCast v = castFailM v "VNum"++instance Value Ordering where+    castV x = VInt $ case x of+        LT -> -1+        EQ -> 0+        GT -> 1+    doCast x = do+        n <- fromVal x :: Eval VInt+        return $ case signum n of+            -1  -> LT+            0   -> EQ+            1   -> GT+            _   -> error "signum: impossible"++instance Value VComplex where+    castV = VComplex+    doCast (VComplex x) = return x+    doCast x            = fmap (:+ 0) (fromVal x :: Eval VNum)++instance Value ID where+    castV = VStr . cast+    fromSV sv = fmap cast (io $ svToVStr sv)+    fromVV vv = fmap cast (Val.asStr vv)+    fromVal = fmap (cast :: VStr -> ID) . fromVal+    doCast = fmap (cast :: VStr -> ID) . doCast++instance Value VStr where+    castV = VStr+    fromSV sv = io $ svToVStr sv+    fromVV vv = fmap cast (Val.asStr vv)+    fromVal (VList l)    = return . unwords =<< mapM fromVal l+    fromVal v@(PerlSV _) = fromVal' v+    fromVal VUndef       = return ""+    fromVal (VType t)    = return (showType t)+    fromVal v = do+        vt  <- evalValType v+        case showType vt of+            "Pair" -> do+                -- Special case for pairs: "$pair" eq+                -- "$pair.key()\t$pair.value()"+                (k, v)  <- join $ doPair v pair_fetch+                k'      <- fromVal k+                v'      <- fromVal v+                return $ k' ++ "\t" ++ v'+            "Hash" -> do+                --- XXX special case for Hash -- need to Objectify+                hv      <- join $ doHash v hash_fetch+                lns     <- forM (Map.assocs hv) $ \(k, v) -> do+                    str <- fromVal v+                    return $ k ++ "\t" ++ str+                return $ unlines lns+            _ -> fromVal' v+    doCast VUndef        = return ""+    doCast VType{}       = return ""+    doCast (VStr s)      = return s+    doCast (VBool b)     = return $ if b then "1" else ""+    doCast (VInt i)      = return $ show i+    doCast (VRat r)      = return $ showRat r+    doCast (VNum n)      = return $ showNum n+    doCast (VComplex (r :+ i)) = return $ showNum r ++ " + " ++ showNum i ++ "i"+    doCast (VList l)     = fmap unwords (mapM fromVal l)+    doCast (VCode s)     = return $ "<" ++ show (subType s) ++ "(" ++ cast (subName s) ++ ")>"+    doCast (VJunc j)     = return $ show j+    doCast (VThread t)   = return $ takeWhile isDigit $ dropWhile (not . isDigit) $ show t+    doCast (VHandle h)   = return $ "<" ++ "VHandle (" ++ (show h) ++ ">"+    doCast (VMatch m)    = return $ matchStr m+ -- doCast (VType typ)   = return $ showType typ -- "::" ++ showType typ+    doCast (VObject o)   = return $ "<obj:" ++ showType (objType o) ++ ">"+    doCast x             = return $ "<" ++ showType (valType x) ++ ">"+++instance Value [PerlSV] where+    fromVal = fromVals+    doCast v = castFailM v "[PerlSV]"++instance Value PerlSV where+    fromVal val = io $ newSVval val+    doCast v = castFailM v "PerlSV"++newSVval :: Val -> IO PerlSV+newSVval val = case val of+    PerlSV sv   -> return sv+    VStr str    -> vstrToSV str+    VType typ   -> vstrToSV (showType typ)+    VBool bool  -> vintToSV (fromEnum bool)+    VInt int    -> vintToSV int+    VRat rat    -> vnumToSV rat+    VNum num    -> vnumToSV num+{-+    VRef ref@(MkRef (IArray a)) -> case fromTypeable a of+        Just (MkIArray iv@(I.IntMap fp) _) -> do+            sv      <- vrefToSV ref+            sptr    <- newStablePtr fp+            warn "Fin: SPTR" fp+            let fin = do+                    warn "Fin: FPTR" (sptr == sptr)+                    touchForeignPtr fp+            modifyIORef _GlobalFinalizer (>> fin)+            addFinalizer sv fin+            return sv+        _ -> vrefToSV ref+-}+    VRef ref    -> vrefToSV ref+    VCode{}     -> mkValRef val "Code"+    VBlock{}    -> mkValRef val "Code"+    VHandle{}   -> mkValRef val "Handle"+    VSocket{}   -> mkValRef val "Socket"+    VList{}     -> mkValRef val "Array"+    VUndef      -> svUndef+    VError{}    -> svUndef+    _           -> mkValRef val ""++vrefToSV :: VRef -> IO PerlSV+vrefToSV ref = mkValRef (VRef ref) $ case ref of+    MkRef IScalar{}   -> "Scalar"+    MkRef IArray{}    -> "Array"+    MkRef IHash{}     -> "Hash"+    MkRef ICode{}     -> "Code"+    MkRef IHandle{}   -> "Handle"+    MkRef IRule{}     -> "Rule"+    MkRef IThunk{}    -> "Thunk"+    MkRef IPair{}     -> "Pair"+    MkRef (IVal v)    -> show (valType v)++valToStr :: Val -> Eval VStr+valToStr = fromVal++instance Value VList where+    castV = VList+    fromSV sv = return [PerlSV sv]+    fromVV = cast . fmap (map VV . cast) . Val.listVal+    fromVal (VRef r) = do+        v <- readRef r+        case v of+            (VList vs) -> return vs+            _          -> return [v]+    fromVal (VList vs) = return vs+    fromVal v = fromVal' v+    doCast (VList l)     = return $ l+    doCast (VUndef)      = return $ [VUndef]+    doCast v             = return $ [v]++instance Value VHandle where+    castV = VHandle+    doCast (VHandle x)  = return $ x+    doCast v = castFailM v "VHandle"++instance Value VSocket where+    castV = VSocket+    doCast (VSocket x)  = return $ x+    doCast v = castFailM v "VSocket"++instance Value VThread where+    castV = VThread+    doCast (VThread x)  = return $ x+    doCast v = castFailM v "VThread"++instance Value VProcess where+    castV = VProcess+    doCast (VProcess x)  = return $ x+    doCast v = castFailM v "VProcess"++instance Value Int where+    fromSV sv = io $ svToVInt sv+    doCast x = intCast x+    castV = VInt . fromIntegral+instance Value Word  where +    fromVal x = intCast x+    doCast v = castFailM v "Word"+instance Value Word8 where +    fromVal x = intCast x+    doCast v = castFailM v "Word8"+instance Value [Word8] where+    fromVal val = fmap (map (toEnum . ord)) (fromVal val)+    doCast v = castFailM v "[Word8]"++type VScalar = Val++instance Value VScalar where+    fromSV = return . PerlSV+    fromVV = cast . fmap VV . Val.itemVal+    fromVal (VRef r) = fromVal =<< readRef r+    fromVal v = return v+    doCast v = return v+    castV = id -- XXX not really correct; need to referencify things++intCast :: Num b => Val -> Eval b+intCast x = fmap fromIntegral (fromVal x :: Eval VInt)++-- | Uses Haskell's underlying representation for threads.+data VThread = MkThread+    { threadId      :: ThreadId+    , threadLock    :: TMVar Val+    }+    deriving (Show, Eq, Ord, Typeable)++type VList = [Val]+data VSubst+    = MkSubst+        { substRegex    :: !VRule+        , substExp      :: !Exp+        }+    | MkTrans+        { transFrom     :: !VStr+        , transTo       :: !VStr+        }+    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}+type VArray = [Val]+type VHash = Map VStr Val++data VThunk = MkThunk+    { thunkExp  :: Eval Val+    , thunkType :: VType+    }+    deriving (Typeable) {-!derive: YAML_Pos!-}++newtype VProcess = MkProcess (ProcessHandle)+    deriving (Typeable) {-!derive: YAML_Pos!-}++type VPair = (Val, Val)+type VType = Type++{-|+Representation for rules (i.e. regexes).++Currently there are two types of rules: Perl 5 rules, implemented with PCRE,+and Perl 6 rules, implemented with PGE.+-}+data VRule+    -- | Perl5-compatible regular expression+    = MkRulePCRE+        { rxRegex     :: !Regex -- ^ The \'regular\' expression (as a PCRE+                                --     'Regex' object)+        , rxGlobal    :: !Bool  -- ^ Flag indicating \'global\' (match-all)+        , rxNumSubs   :: !Int   -- ^ The number of subpatterns present.+        , rxStringify :: !Bool+        , rxRuleStr   :: !String -- ^ The rule string, for user reference.+        , rxAdverbs   :: !Val+        }+    -- | Parrot Grammar Engine rule+    | MkRulePGE+        { rxRule      :: !String -- ^ The rule string+        , rxGlobal    :: !Bool   -- ^ Flag indicating \'global\' (match-all)+        , rxStringify :: !Bool+        , rxAdverbs   :: !Val+        }+    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}++instance Show Regex where+    show _ = "<regex>"++instance Ord Regex where+    compare x y = compare (addressOf x) (addressOf y)++instance Eq Regex where+    x == y = addressOf x == addressOf y++showVal :: Val -> String+showVal = show++errStr :: VStr -> Val+errStr str = VError (VStr str) []++errStrPos :: VStr -> Pos -> Val+errStrPos str pos = VError (VStr str) [pos]++errValPos :: Val -> Pos -> Val+errValPos val pos = VError val [pos]++enterAtomicEnv :: Env -> Env+enterAtomicEnv env = env{ envAtomic = True }++{-|+Represents a value.++Note that 'Val' is also a constructor for 'Exp' (i.e. an expression containing +a value), so don't confuse the two. Similarly, all the constructors for +@data 'Val'@ are themselves puns on the types of values they contain.+-}+data Val+    = VUndef                 -- ^ Undefined value+    | VBool     !VBool       -- ^ Boolean value+    | VInt      !VInt        -- ^ Integer value+    | VRat      !VRat        -- ^ Rational number value+    | VNum      !VNum        -- ^ Number (i.e. a double)+    | VComplex  !VComplex    -- ^ Complex number value+    | VStr      !VStr        -- ^ String value+    | VList     !VList       -- ^ List value+    | VType     !VType       -- ^ Type value (e.g. @Int@ or @Type@)+    | VJunc     !VJunc       -- ^ Junction value+    | VError    !Val ![Pos]  -- ^ Error+    | VControl  !VControl+-------------------------------------------------------------------+-- The following are runtime-only values (VRef is negotiable)+    | VRef      !VRef        -- ^ Reference value+    | VCode     !VCode       -- ^ A code object+    | VBlock    !VBlock+    | VHandle   !VHandle     -- ^ File handle+    | VSocket   !VSocket     -- ^ Socket handle+    | VThread   !VThread+    | VProcess  !VProcess    -- ^ PID value+    | VRule     !VRule       -- ^ Rule\/regex value+    | VSubst    !VSubst      -- ^ Substitution value (correct?)+    | VMatch    !VMatch      -- ^ Match value+    | VObject   !VObject     -- ^ Object+    | VOpaque   !VOpaque+    | PerlSV    !PerlSV+    | VV        !Val.Val+    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}++{-|+Find the 'Type' of the value contained by a 'Val'.++See "Pugs.Types" for info on types.+-}+valType :: Val -> Type+valType VUndef          = mkType "Scalar"+valType (VRef v)        = refType v+valType (VBool    _)    = mkType "Bool"+valType (VInt     _)    = mkType "Int"+valType (VRat     _)    = mkType "Rat"+valType (VNum     _)    = mkType "Num"+valType (VComplex _)    = mkType "Complex"+valType (VStr     _)    = mkType "Str"+-- valType (VList    _)    = mkType "List"+valType (VList    _)    = mkType "Array"+valType (VCode    c)    = code_iType c+valType (VBlock   _)    = mkType "Block"+valType (VJunc    _)    = mkType "Junction"+valType (VError _ _)    = mkType "Error"+valType (VHandle  _)    = mkType "IO"+valType (VSocket  _)    = mkType "Socket"+valType (VThread  _)    = mkType "Thread"+valType (VProcess _)    = mkType "Process"+valType (VControl _)    = mkType "Control"+valType (VRule    _)    = mkType "Regex"+valType (VSubst   _)    = mkType "Subst"+valType (VMatch   _)    = mkType "Match"+valType (VType    t)    = t+valType (VObject  o)    = objType o+valType (VOpaque  _)    = mkType "Object"+valType (PerlSV   _)    = mkType "Scalar::Perl5"+valType (VV       _)    = mkType "Scalar::Perl5" -- (cast $ Val.valMeta v)++valToBool :: Val -> Eval VBool+valToBool = fromVal++type VBlock = Exp+data VControl+    = ControlExit  !ExitCode+    | ControlContinuation+        { ccEnv     :: !Env+        , ccVal     :: !Val+        , ccCont    :: !(Val -> Eval Val)+        }+    | ControlLoop  !ControlLoop+    | ControlWhen  !ControlWhen+    | ControlLeave+        { leaveType     :: !(SubType -> Bool)+        , leaveDepth    :: !Int+        , leaveValue    :: !Val+        }+-- \| ControlLeave !(Env -> Eval Bool) !Val+    deriving (Show, Eq, Ord, Typeable) -- don't derive YAML for now++data ControlLoop+    = LoopNext+    | LoopRedo+    | LoopLast+    deriving (Show, Eq, Ord, Typeable) -- don't derive YAML for now++data ControlWhen+    = WhenContinue+    | WhenBreak+    deriving (Show, Eq, Ord, Typeable) -- don't derive YAML for now++{-|+Each 'VCode' structure has a 'SubType' indicating what \'level\' of+callable item it is. 'doApply' uses this to figure out how to enter+the proper scope and 'Env' when the sub is called.++Note that this is the \'type\' of a \'sub\', and has nothing to do with+subtyping.+-}+data SubType = SubMethod    -- ^ Method+             | SubCoroutine -- ^ Coroutine+             | SubMacro     -- ^ Macro+             | SubRoutine   -- ^ Regular subroutine+             | SubBlock     -- ^ Bare block+             | SubPointy    -- ^ Pointy block+             | SubPrim      -- ^ Built-in primitive operator (see "Pugs.Prim")+    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos, JSON, Perl5!-}++isSlurpy :: Param -> Bool+isSlurpy param = isSlurpyCxt $ paramContext param++{-|+A formal parameter of a sub (or other callable).++These represent declared parameters; don't confuse them with actual parameter +values, which are henceforth termed "arguments".+-}+data Param = MkOldParam -- "Old" because Pugs.Val.Code defined a new one+    { isInvocant    :: !Bool        -- ^ Is it in invocant slot?+    , isOptional    :: !Bool        -- ^ Is it optional?+    , isNamed       :: !Bool        -- ^ Is it named-only?+    , isLValue      :: !Bool        -- ^ Is it lvalue (i.e. not `is copy`)?+    , isWritable    :: !Bool        -- ^ Is it writable (i.e. `is rw`)?+    , isLazy        :: !Bool        -- ^ Is it call-by-name (short-circuit)?+    , paramName     :: !Var         -- ^ Parameter name+    , paramContext  :: !Cxt         -- ^ Parameter context: slurpiness and type+    , paramDefault  :: !Exp         -- ^ Default expression (to evaluate to)+                                    --     when omitted+    }+    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos, Perl5, JSON!-}++-- | A list of formal parameters.+type Params     = [Param]++instance ((:>:) String) Params where+    cast = show . paramsToSig++paramToValParam :: Param -> Val.SigParam+paramToValParam param = ret+    where +    ret = Val.MkParam +        { Val.p_variable    = paramName param+        , Val.p_types       = []+        , Val.p_constraints = []+        , Val.p_unpacking   = Nothing+        , Val.p_default     = Val.MkParamDefault Nothing -- XXX Exp incompatibility+        , Val.p_label       = v_name $ paramName param  -- XXX sigility+        , Val.p_slots       = Map.empty+        , Val.p_hasAccess   = case param of+                                  MkOldParam { isLValue = True, isWritable = False } -> Val.AccessRO+                                  MkOldParam { isLValue = True, isWritable = True }  -> Val.AccessRW+                                  MkOldParam { isLValue = False }                    -> Val.AccessCopy+        , Val.p_isRef       = Val.p_hasAccess ret == Val.AccessRW+        , Val.p_isLazy      = isLazy param+        , Val.p_isContext   = False -- XXX - not yet handled+        }++paramsToSig :: Params -> Val.Sig+paramsToSig params = +    Val.MkSig+        { Val.s_invocant = Nothing+        , Val.s_requiredPositionalCount =+            length $ filter (\x -> not (isNamed x) && not (isOptional x)) params+        , Val.s_requiredNames =+            Set.fromList $ map (v_name . paramName) $ filter (not . isOptional) params+        , Val.s_positionalList = map paramToValParam $ filter (not . isNamed) params+        , Val.s_namedSet = Map.fromList $ +            map (\p -> (v_name (paramName p), paramToValParam p)) $ +                filter isNamed params+        , Val.s_slurpyScalarList = []  -- XXX unimplemented+        , Val.s_slurpyArray   = Nothing  -- XXX ditto+        , Val.s_slurpyHash    = Nothing  -- XXX yep+        , Val.s_slurpyCode    = Nothing  -- XXX all right+        , Val.s_slurpyCapture = Nothing -- this one is okay as it is ;-)+        }   ++{-|+A list of bindings from formal parameters ('Param') to actual parameter+expressions ('Exp').+-}+type Bindings   = [(Param, Exp)]+{-|+A sub that has a non-empty 'SlurpLimit' is a bound (or partially bound) sub+that has a finite number of slurpy scalar params bound, and no slurpy array+param bound (see 'VCode' and "Pugs.Bind").++Each list entry consists of the number of slurpable args expected, and an+expression that will evaluate to the actual list of slurpable args.+When the sub is called (see 'Pugs.Eval.apply'), the expression is evaluated.+If it evaluates to /too many/ args, the call will fail.++This needs to be a list (rather than a @Maybe@) because Perl 6's @.assuming@+(i.e. explicit currying) means that a sub can have its arguments bound in+separate stages, and each of the bindings needs to be checked.++>[12:02] <autrijus> scook0: .assuming will impose multiple limits+>[12:02] <autrijus> because you can assume (curry) multiple times+>[12:02] <scook0> ah+>[12:02] <scook0> I'll have to write that in the docs then+>[12:03] <scook0> Am I correct in that they only apply to subs that take a finite number of slurpy scalars?+>[12:04] <scook0> Slurpy array params seem to nuke the SlurpLimit+>[12:04] <scook0> because slurpy arrays can take any number of args+>[12:07] <autrijus> scook0: yes, and yes.+-}+type SlurpLimit = [(VInt, Exp)]++data SubAssoc+    = ANil | AIrrelevantToParsing | A_left | A_right | A_non | A_chain | A_list +    deriving (Show, Eq, Ord, Typeable, Data) {-!derive: YAML_Pos, JSON, Perl5 !-}++instance Monoid SubAssoc where+    mempty = ANil+    mappend ANil y = y+    mappend x    _ = x++data MPad = MkMPad { mp_id :: !Word, mp_pad :: !(TVar Pad) }+    deriving (Show, Typeable, Data) {-!derive: YAML_Pos, JSON, Perl5 !-}++instance Eq MPad where+    x == y = mp_id x == mp_id y++instance Ord MPad where+    x `compare` y = mp_id x `compare` mp_id y++-- | Represents a sub, method, closure etc. -- basically anything callable.+data VCode = MkCode+    { isMulti           :: !Bool                  -- ^ Is this a multi sub\/method?+    , subName           :: !ByteString            -- ^ Name of the closure+    , subType           :: !SubType               -- ^ Type of the closure+    , subOuterPads      :: !LexPads               -- ^ Lexical pads for this scope+    , subInnerPad       :: !Pad                   -- ^ Inner lexical pad (immutable)+--  , subLexical        :: !Pad                   -- ^ Cached merged pads+    , subPackage        :: !Pkg                   -- ^ Package of the subroutine+    , subAssoc          :: !SubAssoc              -- ^ Associativity+    , subParams         :: !Params                -- ^ Parameters list+    , subBindings       :: !Bindings              -- ^ Currently assumed bindings+    , subSlurpLimit     :: !SlurpLimit            -- ^ Max. number of slurpy arguments+    , subReturns        :: !Type                  -- ^ Return type+    , subLValue         :: !Bool                  -- ^ Is this a lvalue sub?+    , subBody           :: !Exp                   -- ^ Body of the closure+    , subCont           :: !(Maybe (TVar VThunk)) -- ^ Coroutine re-entry point+    , subStarted        :: !(Maybe (TVar Bool))   -- ^ Whether START was run+    , subTraitBlocks    :: !TraitBlocks+    }+    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}++data TraitBlocks = MkTraitBlocks+    { subPreBlocks      :: ![VCode]+    , subPostBlocks     :: ![VCode]+    , subFirstBlocks    :: ![VCode]+    , subLastBlocks     :: ![VCode]+    , subNextBlocks     :: ![VCode]+    , subKeepBlocks     :: ![VCode]+    , subUndoBlocks     :: ![VCode]+    , subEnterBlocks    :: ![VCode]+    , subLeaveBlocks    :: ![VCode]+    , subControlBlocks  :: ![VCode]+    , subCatchBlocks    :: ![VCode]+    }+    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}++emptyTraitBlocks :: TraitBlocks+emptyTraitBlocks = MkTraitBlocks [] [] [] [] [] [] [] [] [] [] []++{-|+Construct a 'VCode' representing a built-in primitive operator.++See "Pugs.Prim" for more info.+-}+mkPrim :: VCode+mkPrim = MkCode+    { isMulti        = True+    , subName        = cast "&"+    , subType        = SubPrim+    , subOuterPads   = []+    , subInnerPad    = emptyPad+--  , subLexical     = emptyPad+    , subPackage     = emptyPkg+    , subAssoc       = ANil+    , subParams      = []+    , subBindings    = []+    , subSlurpLimit  = []+    , subReturns     = anyType+    , subBody        = emptyExp+    , subLValue      = False+    , subCont        = Nothing+    , subStarted     = Nothing+    , subTraitBlocks = emptyTraitBlocks+    }++mkSub :: VCode+mkSub = MkCode+    { isMulti        = False+    , subName        = cast "&"+    , subType        = SubBlock+    , subOuterPads   = []+    , subInnerPad    = emptyPad+--  , subLexical     = emptyPad+    , subPackage     = emptyPkg+    , subAssoc       = ANil+    , subParams      = []+    , subBindings    = []+    , subSlurpLimit  = []+    , subReturns     = anyType+    , subBody        = emptyExp+    , subLValue      = False+    , subCont        = Nothing+    , subStarted     = Nothing+    , subTraitBlocks = emptyTraitBlocks+    }++mkCode :: VCode+mkCode = MkCode+    { isMulti        = False+    , subName        = cast "&"+    , subType        = SubBlock+    , subOuterPads   = []+    , subInnerPad    = emptyPad+--  , subLexical     = emptyPad+    , subPackage     = emptyPkg+    , subAssoc       = ANil+    , subParams      = []+    , subBindings    = []+    , subSlurpLimit  = []+    , subReturns     = anyType+    , subBody        = emptyExp+    , subLValue      = False+    , subCont        = Nothing+    , subStarted     = Nothing+    , subTraitBlocks = emptyTraitBlocks+    } ++instance Ord VComplex where+    compare (a :+ ai) (b :+ bi) = compare (a, ai) (b, bi)++instance Show (TVar a) where+    show = showAddressOf "ref"++instance Show (IORef a) where+    show = showAddressOf "ref"++{- Expression annotation+-}+data Ann+    = Cxt !Cxt                -- ^ Context+    | Pos !Pos                -- ^ Position+    | Prag ![Pragma]          -- ^ Lexical pragmas+    | Decl !Scope             -- ^ Within an declarator+    | Parens                  -- ^ Parenthesized+    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}++{- Expressions+   "App" represents function application, e.g. myfun($invocant: $arg)++   "Syn" represents a structure that cannot be represented by an App.+   For example, Syn "block" [...block body...]+                Syn "="     [lhs, rhs]+   ... or class definitions, where traits may be assigned either in+   the signature or inside the body.++   There is no top-level marker, like unix filesystems don't have+   volume letters.+-}++-- | Represents an expression tree.+data Exp+    = Noop                              -- ^ No-op+    | App !Exp !(Maybe Exp) ![Exp]      -- ^ Function application+                                        --     e.g. myfun($invocant: $arg)+    | Syn !String ![Exp]                -- ^ Syntactic construct that cannot+                                        --     be represented by 'App'.+    | Ann !Ann !Exp                     -- ^ Annotation (see @Ann@)+--  | Pad !Scope !Pad !Exp              -- ^ Lexical pad+    | Sym !Scope !Var !EntryFlags !Exp !Exp -- ^ Symbol declaration+    | Stmts !Exp !Exp                   -- ^ Multiple statements+    | Prim !([Val] -> Eval Val)         -- ^ Primitive+    | Val !Val                          -- ^ Value+    | Var !Var                          -- ^ Variable+    | NonTerm !Pos                      -- ^ Parse error+    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}++_Sym :: Scope -> String -> EntryFlags -> Exp -> Exp -> Exp+_Sym scope str flags init rest = Sym scope (cast str) flags init rest++_Var :: String -> Exp+_Var str = Var (possiblyFixOperatorName (cast str))++instance Value Exp where+    {- Val -> Eval Exp -}+    fromVal val = do+        obj <- fromVal val+        return $ fromObject obj+    {- Exp -> Val -}+    {- castV exp = VObject (createObject (mkType "Code::Exp") [("theexp", exp)]) -}+    doCast v = castFailM v "Exp"++-- Recursively apply a transformation to an Exp structure+transformExp :: (Monad m) => (Exp -> m Exp) -> Exp -> m Exp+transformExp f (App a b cs) = do+    a' <- transformExp f a+    b' <- case b of+        Just e -> liftM Just $ transformExp f e+        Nothing -> return Nothing+    cs' <- mapM (transformExp f) cs+    f $ App a' b' cs'+transformExp f (Syn t es) = f =<< liftM (Syn t) (mapM (transformExp f) es)+transformExp f (Ann a e) = f =<< liftM (Ann a) (transformExp f e)+-- transformExp f (Pad s p e) = f =<< liftM (Pad s p) (transformExp f e)+transformExp f (Sym s v c i e) = f =<< liftM (Sym s v c i) (transformExp f e)+transformExp f (Stmts e1 e2) = do +    e1' <- transformExp f e1+    e2' <- transformExp f e2+    f $ Stmts e1' e2'+transformExp f e = f e++fromObject :: (Typeable a) => VObject -> a+fromObject obj = case objOpaque obj of+    Nothing     -> castFail obj "VObject without opaque"+    Just dyn    -> case fromDynamic dyn of+        Nothing -> castFail obj "VObject's opaque not valueable"+        Just x  -> x++{- FIXME: Figure out how to get this working without a monad, and make it castV -}+expToEvalVal :: Exp -> Eval Val+expToEvalVal exp = do+    obj <- createObject (mkType "Code::Exp") []+    return $ VObject obj{ objOpaque = Just $ toDyn exp }++instance Unwrap [Exp] where+    unwrap = map unwrap++instance Unwrap Exp where+    unwrap (Ann _ exp)      = unwrap exp+    -- unwrap (Pad _ _ exp)    = unwrap exp+    unwrap (Sym _ _ _ _ exp)= unwrap exp+    unwrap x                = x++fromVals :: (Value n) => Val -> Eval [n]+fromVals v = mapM fromVal =<< fromVal v++instance Show VThunk where+    show _ = "<thunk>"+instance Eq VThunk+instance Ord VThunk where+    compare _ _ = EQ++instance Show VProcess where+    show _ = "<process>"+instance Eq VProcess+instance Ord VProcess where+    compare _ _ = EQ++extractPlaceholderVarsExp :: Exp -> ([Exp], Set Var) -> ([Exp], Set Var)+extractPlaceholderVarsExp ex (exps, vs) = (ex':exps, vs')+    where+    (ex', vs') = extractPlaceholderVars ex vs++{-| Deduce the placeholder vars ($^a, $^x etc.) used by a block). -}+extractPlaceholderVars :: Exp -> Set Var -> (Exp, Set Var)+extractPlaceholderVars (App n invs args) vs = (App n' invs' args', vs''')+    where+    (n', vs')      = extractPlaceholderVars n vs+    (invs', vs'')  = maybe (invs, vs') (\inv -> let (x, y) = extractPlaceholderVars inv vs' in (Just x, y)) invs+    (args', vs''') = foldr extractPlaceholderVarsExp ([], vs'') args+extractPlaceholderVars (Stmts exp1 exp2) vs = (Stmts exp1' exp2', vs'')+    where+    (exp1', vs')  = extractPlaceholderVars exp1 vs+    (exp2', vs'') = extractPlaceholderVars exp2 vs'+extractPlaceholderVars (Syn n exps) vs = (Syn n exps', vs'')+    where+    (exps', vs') = foldr extractPlaceholderVarsExp ([], vs) exps+    vs'' = case n of+        "when"  -> Set.insert (cast "$_") vs'+        "given" -> Set.delete (cast "$_") vs'+        _       -> vs'+extractPlaceholderVars (Var var) vs+    | TImplicit <- v_twigil var+    , var' <- var{ v_twigil = TNil }+    = (Var var', Set.insert var' vs)+    | var == cast "$_"+    = (Var var, Set.insert var vs)+    | otherwise+    = (Var var, vs)+extractPlaceholderVars (Ann ann ex) vs = ((Ann ann ex'), vs')+    where+    (ex', vs') = extractPlaceholderVars ex vs+-- extractPlaceholderVars (Pad scope pad ex) vs = ((Pad scope pad ex'), vs')+--     where+--     (ex', vs') = extractPlaceholderVars ex vs+extractPlaceholderVars (Sym scope var flags ini ex) vs = ((Sym scope var flags ini ex'), vs')+    where+    (ex', vs') = extractPlaceholderVars ex vs+extractPlaceholderVars exp vs = (exp, vs)++buildParam :: String -- ^ Type of the parameter+           -> String -- ^ Parameter-sigil (@:@, @!:@, @?@, @!@, etc.)+           -> String -- ^ Name of the parameter (including primary sigil)+           -> Exp    -- ^ Expression for the param's default value+           -> Param+buildParam typ sigil name e = MkOldParam+    { isInvocant    = False+    , isOptional    = '?' `elem` sigil+    , isNamed       = ':' `elem` sigil+    , isLValue      = True+    , isWritable    = (name == "$_")+    , isLazy        = False+    , paramName     = cast name+    , paramContext  = if '*' `elem` sigil+        then CxtSlurpy typ'+        else CxtItem typ'+    , paramDefault  = e+    }+    where+    typ' = if null typ then anyType else mkType typ++defaultArrayParam :: Param+defaultHashParam :: Param+defaultScalarParam :: Param++defaultArrayParam   = buildParam "" "*" "@_" (Val VUndef)+defaultHashParam    = buildParam "" "*" "%_" (Val VUndef)+defaultScalarParam  = buildParam "" "?" "$_" (Var $ cast "$OUTER::_")++type DebugInfo = Maybe (TVar (Map ID String))++newDebugInfo :: IO DebugInfo+newDebugInfo = fmap Just (io $ newTVarIO Map.empty)++type LexPads = [LexPad]+data LexPad+    = PRuntime      { pr_pad :: !Pad }+    | PCompiling    { pc_pad :: !MPad }+    deriving (Show, Eq, Ord, Typeable)++{-|+Evaluation environment.++The current environment is stored in the @Reader@ monad inside the current +'Eval' monad, and can be retrieved using @ask@ for the whole 'Env', or @asks@ +if you just want a single field.+-}+data Env = MkEnv+    { envContext :: !Cxt                -- ^ Current context+                                        -- ('CxtVoid', 'CxtItem' or 'CxtSlurpy')+    , envLValue  :: !Bool               -- ^ Are we in an LValue context?+    , envLexical :: !Pad                -- ^ Cached lexical pad for variable lookup+    , envLexPads :: !LexPads            -- ^ Current lexical pads; MY is leftmost, OUTER is next, etc+    , envCaller  :: !(Maybe Env)        -- ^ CALLER pads+    , envCompPad :: !(Maybe MPad)       -- ^ Current COMPILING pad+    , envGlobal  :: !MPad               -- ^ Global pad for variable lookup+    , envPackage :: !Pkg                -- ^ Current package+    , envEval    :: !(Exp -> Eval Val)  -- ^ Active evaluator+    , envBody    :: !Exp                -- ^ Current AST expression+    , envFrames  :: !(Set Frame)        -- ^ Special-markers in the dynamic path+    , envDebug   :: !DebugInfo          -- ^ Debug info map+    , envPos     :: !Pos                -- ^ Source position range+    , envPragmas :: ![Pragma]           -- ^ List of pragmas in effect+    , envInitDat :: !(TVar InitDat)     -- ^ BEGIN result information+    , envMaxId   :: !(TVar ObjectId)    -- ^ Current max object id+    , envAtomic  :: !Bool               -- ^ Are we in an atomic transaction?+    } +    deriving (Show, Eq, Ord, Typeable) -- don't derive YAML for now++data Frame+    = FrameLoop+    | FrameWhen+    | FrameGather+    | FrameRoutine+    deriving (Show, Eq, Ord, Typeable) -- don't derive YAML for now++envPos' :: Env -> Pos+envPos' = envPos++{-|+Module initialization information.++When a module is loaded and initialized (i.e., its &import routine is+called), it may need to communicate information back to the parser. +This information is held in a TVar to which the parser has access.+Currently we use this for keeping track of lexical pragma change+requests, but the possiblyExit mechanism may be refactored to use+this as well.+-}+newtype InitDat = MkInitDat+    { initPragmas :: [Pragma]            -- ^ Pragma values being installed+    } deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}++envWant :: Env -> String+envWant env =+    showCxt (envContext env) ++ (if envLValue env then ", LValue" else "")+    where+    showCxt CxtVoid         = "Void"+    showCxt (CxtItem typ)   = "Scalar (" ++ showType typ ++ ")"+    showCxt (CxtSlurpy typ) = "List (" ++ showType typ ++ ")"++{- Pad -}+{-|+A 'Pad' keeps track of the names of all currently-bound symbols, and+associates them with the things they actually represent.++It is represented as a mapping from names to /lists/ of bound items.+This is to allow for multi subs, because we will need to keep+/multiple/ subs associated with one symbol. In other cases, the list+should just contain a single value. See 'Pugs.AST.genSym' and 'Pugs.AST.genMultiSym' for+more details.++@TVar@ indicates that the mapped-to items are STM transactional variables.++The @Bool@ is a \'freshness\' flag used to ensure that @my@ variable slots+are re-generated each time we enter their scope; see the+'Pugs.Eval.reduce' entry for ('Pad' 'SMy' ...).++The current global and lexical pads are stored in the current 'Env', which+is stored in the @Reader@-monad component of the current 'Eval' monad.+-}++newtype Pad = MkPad { padEntries :: Map Var PadEntry }+    deriving (Eq, Ord, Typeable)++{-|+An empty Pad with no symbols.+-}++emptyPad :: Pad+emptyPad = MkPad Map.empty++newtype EntryFlags = MkEntryFlags { ef_isContext :: Bool }+    deriving (Show, Eq, Ord, Typeable)++instance Monoid EntryFlags where+    mempty = MkEntryFlags False+    mappend (MkEntryFlags x) (MkEntryFlags y) = MkEntryFlags (x || y)++data PadEntry+    = PELexical  { pe_type :: !Type, pe_proto :: !VRef, pe_flags :: !EntryFlags, pe_store :: !(TVar VRef) } -- pe_fresh :: !(TVar Bool) }+    | PEStatic   { pe_type :: !Type, pe_proto :: !VRef, pe_flags :: !EntryFlags, pe_store :: !(TVar VRef) }+    | PEConstant { pe_type :: !Type, pe_proto :: !VRef, pe_flags :: !EntryFlags }+    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}++data IHashEnv = MkHashEnv deriving (Show, Typeable) {-!derive: YAML_Pos!-}+data IScalarCwd = MkScalarCwd deriving (Show, Typeable) {-!derive: YAML_Pos!-}++{-# SPECIALISE readPadEntry :: PadEntry -> Eval VRef #-}+{-# SPECIALISE readPadEntry :: PadEntry -> STM VRef #-}+readPadEntry :: MonadSTM m => PadEntry -> m VRef+readPadEntry PEConstant{ pe_proto = v } = return v+readPadEntry x                             = stm (readTVar (pe_store x))++{-# SPECIALISE writePadEntry :: PadEntry -> VRef -> Eval () #-}+{-# SPECIALISE writePadEntry :: PadEntry -> VRef -> STM () #-}+writePadEntry :: MonadSTM m => PadEntry -> VRef -> m ()+writePadEntry x@PEConstant{} _ = die "Cannot rebind constant" x+writePadEntry x                 v = stm (writeTVar (pe_store x) v)++refreshPad :: Pad -> Eval Pad+refreshPad pad = do+    fmap listToPad $ forM (padToList pad) $ \(name, entry) -> do+        -- warn "Refreshing pad entry" (name, entry)+        entry' <- case entry of+            PELexical{ pe_proto = proto } -> stm $ do+                ref     <- cloneRef proto+                tvar'   <- newTVar ref+                return entry{ pe_store = tvar' }+            _ -> return entry+        return (name, entry')++newtype ObjectId = MkObjectId { unObjectId :: Int }+    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}++data VObject = MkObject+    { objType   :: !VType+    , objAttrs  :: !IHash+    , objOpaque :: !(Maybe Dynamic)+    , objId     :: !ObjectId+    }+    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}++-- | A '$/' object, the return of a rx match operation.+data VMatch = MkMatch+    { matchOk           :: !VBool   -- success?+    , matchFrom         :: !Int     -- .from+    , matchTo           :: !Int     -- .to+    , matchStr          :: !VStr    -- captured str+    , matchSubPos       :: !VList   -- positional submatches+    , matchSubNamed     :: !VHash   -- named submatches+    }+    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}+++instance Show Pad where+    show pad = "MkPad (padToList " ++ show (padToList pad) ++ ")"++findSymRef :: Var -> Pad -> Eval VRef+findSymRef name pad = stm $ join (findSym name pad)++{-# SPECIALISE findSym :: Var -> Pad -> Eval (STM VRef) #-}+{-# SPECIALISE findSym :: Var -> Pad -> Maybe (STM VRef) #-}+findSym :: Monad m => Var -> Pad -> m (STM VRef)+findSym name pad = case lookupPad name pad of+    Just PEConstant{ pe_proto = v }  -> return (return v)+    Just x                              -> return (readTVar (pe_store x))+    _      -> fail $ "Cannot find variable: " ++ show name++-- | Look up a symbol in a 'Pad', returning the ref it is bound to.+lookupPad :: Var -- ^ Symbol to look for+          -> Pad -- ^ Pad to look in+          -> Maybe PadEntry -- ^ Might return 'Nothing' if var is not found++{-+    We (may) have to fix the name, as the user can write things like+        &::("infix:<+>")(2, 3)+    which, without fixName, wouldn't work, as all operators are currently+    stored as &infix:+, i.e. without the brackets.+-}++lookupPad key (MkPad pad) = Map.lookup key pad++{-|+Transform a pad into a flat list of bindings. The inverse of 'mkPad'.++Note that @Data.Map.assocs@ returns a list of mappings in ascending key order.+-}+padToList :: Pad -> [(Var, PadEntry)]+padToList (MkPad pad) = Map.assocs pad++listToPad :: [(Var, PadEntry)] -> Pad+listToPad entries = MkPad (Map.fromList entries)++-- | type for a function introducing a change to a Pad+type PadMutator = (Pad -> Pad)++{-|+Serializable compilation unit++See: docs/notes/precompilation_cache.pod+-}+data CompUnit = MkCompUnit+    { ver  :: Int        -- a version number, see compUnitVersion+    , desc :: String     -- e.g., the name of the contained module+    , pad  :: Pad        -- pad for unit Env+    , ast  :: Exp        -- AST of unit+    } deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos !-}++mkCompUnit :: String -> Pad -> Exp -> CompUnit+mkCompUnit = MkCompUnit compUnitVersion++{-# NOINLINE compUnitVersion #-}+compUnitVersion :: Int+compUnitVersion = 18++{-|+Retrieve the global 'Pad' from the current evaluation environment.++'Env' stores the global 'Pad' in an STM variable, so we have to @asks@+'Eval'\'s @ReaderT@ for the variable, then extract the pad itself from the+STM var.+-}+askGlobal :: Eval Pad+askGlobal = do+    glob <- asks (mp_pad . envGlobal)+    stm $ readTVar glob++writeVar :: Var -> Val -> Eval ()+writeVar var val+    | isLexicalVar var  = doWriteVar (asks envLexical)+    | otherwise         = doWriteVar askGlobal+    where+    doWriteVar askPad = do+        pad <- askPad+        case lookupPad var pad of+            Just PEConstant{} -> fail $ "Cannot rebind constant: " ++ show var+            Just c -> do+                ref <- stm $ readTVar (pe_store c)+                writeRef ref val+            _  -> fail $ "Cannot bind to non-existing variable: " ++ show var++readVar :: Var -> Eval Val+readVar var+    | isLexicalVar var = do+        lex <- asks envLexical+        case findSym var lex of+            Just action -> stm action >>= readRef+            _           -> return undef+    | otherwise = do+        glob <- askGlobal+        case findSym var glob of+            Just action -> stm action >>= readRef+            _           -> return undef++{-|+The \'empty expression\' is just a no-op ('Noop').+-}+emptyExp :: Exp+emptyExp = Noop++retControl :: VControl -> Eval a+retControl = retShift . VControl++retShift :: Val -> Eval a+-- retShift = shiftT . const . return+retShift = EvalT . return . RException++retShiftEmpty :: Eval a+-- retShiftEmpty = shiftT (const retEmpty)+retShiftEmpty = retShift =<< retEmpty++defined :: VScalar -> Bool+defined VUndef  = False+defined VType{} = False+defined _       = True+-- | Produce an undefined Perl 6 value (i.e. 'VUndef').+undef :: VScalar+undef = VUndef++forceRef :: VRef -> Eval Val+forceRef (MkRef (IScalar sv)) = forceRef =<< fromVal =<< scalar_fetch sv+forceRef (MkRef (IThunk tv)) = thunk_force tv+forceRef r = die "Cannot forceRef" r++dumpRef :: VRef -> Eval Val+dumpRef (MkRef (ICode cv)) = do+    vsub <- code_fetch cv+    return (VStr $ "(MkRef (ICode $ " ++ show vsub ++ "))")+dumpRef (MkRef (IScalar sv)) | scalar_iType sv == mkType "Scalar::Const" = do+    sv <- scalar_fetch sv+    return (VStr $ "(MkRef (IScalar $ " ++ show sv ++ "))")+dumpRef ref = return (VStr $ "(unsafePerformIO . newObject $ mkType \"" ++ showType (refType ref) ++ "\")")++-- Reduce a VRef in rvalue context. +readRef :: VRef -> Eval Val+readRef (MkRef (IScalar sv)) = scalar_fetch sv+readRef (MkRef (ICode cv)) = do+    vsub <- code_fetch cv+    return $ VCode vsub+readRef (MkRef (IHash hv)) = do+    pairs <- hash_fetch hv+    return $ VList $ map (\(k, v) -> castV (castV k, v)) (Map.assocs pairs)+readRef (MkRef (IArray av)) = do+    vals <- array_fetch av+    return $ VList vals++-- XXX - This case is entirely bogus; but no time to fix it now.+readRef (MkRef (IPair pv)) = do+    (k, v) <- pair_fetch pv+    return $ VList [k, v]++readRef (MkRef (IHandle io)) = return . VHandle =<< handle_fetch io+readRef (MkRef (IRule rx)) = return . VRule =<< rule_fetch rx+readRef (MkRef (IThunk tv)) = readRef =<< fromVal =<< thunk_force tv+readRef (MkRef (IVal v)) = do+    cxt <- asks envContext+    v ./ cxt++retIVar :: (Typeable a) => IVar a -> Eval Val+retIVar = return . VRef . MkRef++fromVList :: Val -> Eval VArray+fromVList (VList v) = return v+fromVList x = return [x]++fromVHash :: Val -> Eval VHash+fromVHash = fromVal++writeRef :: VRef -> Val -> Eval ()+writeRef (MkRef (IScalar s)) (VList vals) = do+    av <- newArray vals+    scalar_store s (VRef $ MkRef av)+writeRef (MkRef (IScalar s)) val = scalar_store s val+writeRef (MkRef (IArray s)) val  = array_store s =<< fromVList val+writeRef (MkRef (IHash s)) val   = hash_store s =<< fromVHash val+writeRef (MkRef (ICode s)) val   = code_store s =<< fromVal val+writeRef (MkRef (IPair s)) val   = pair_storeVal s val+writeRef (MkRef (IThunk tv)) val = (`writeRef` val) =<< fromVal =<< thunk_force tv+writeRef r _ = die "Cannot writeRef" r++cloneRef :: VRef -> STM VRef+cloneRef (MkRef x) = fmap MkRef (cloneIVar x)++clearRef :: VRef -> Eval ()+clearRef (MkRef (IScalar s)) = scalar_store s undef+clearRef (MkRef (IArray s))  = array_clear s+clearRef (MkRef (IHash s))   = hash_clear s+clearRef (MkRef (IPair s))   = pair_storeVal s undef+clearRef (MkRef (IThunk tv)) = clearRef =<< fromVal =<< thunk_force tv+clearRef r = die "Cannot clearRef" r++{-# SPECIALISE newObject :: Type -> Eval VRef #-}+{-# SPECIALISE newObject :: Type -> IO VRef #-}+newObject :: (MonadSTM m, MonadIO m) => Type -> m VRef+newObject typ = case showType typ of+    "Any"       -> io $ fmap scalarRef $ newTVarIO undef+    "Item"      -> io $ fmap scalarRef $ newTVarIO undef+    "Scalar"    -> io $ fmap scalarRef $ newTVarIO undef+    "Array"     -> io $ do+        iv  <- newTVarIO [::]+        return $ arrayRef (MkIArray iv)+    "Hash"      -> do+        h   <- io (H.new (==) H.hashString)+        return $ hashRef (h :: IHash)+    "Sub"       -> newObject $ mkType "Code"+    "Routine"   -> newObject $ mkType "Code"+    "Method"    -> newObject $ mkType "Code"+    "Submethod" -> newObject $ mkType "Code"+    "Code"      -> return $! codeRef $ mkPrim+        { subAssoc = AIrrelevantToParsing+        , subBody  = Prim . const $ fail "Cannot use Undef as a Code object"+        }+    "Type"      -> io $ fmap scalarRef $ newTVarIO undef+    "Pair"      -> do+        key <- newObject (mkType "Scalar")+        val <- newObject (mkType "Scalar")+        return $ MkRef (IPair (VRef key, VRef val))+    "Regex"     -> io $ fmap scalarRef $ newTVarIO undef -- XXX Wrong+    "Capture"   -> io $ fmap scalarRef $ newTVarIO undef -- XXX Wrong+    _           -> fail ("Class prototype occured where its instance object expected: " ++ showType typ)++doPair :: Val -> (forall a. PairClass a => a -> b) -> Eval b+doPair (VRef (MkRef (IPair pv))) f = return $ f pv+doPair (VRef (MkRef (IHash hv))) f = do+    vals <- hash_fetch hv+    let [(k, v)] = Map.toList vals+    return $ f (VStr k, v)+doPair (VRef (MkRef (IArray av))) f = do+    vals <- array_fetch av+    let [k, v] = take 2 (vals ++ repeat undef)+    return $ f (k, v)+doPair (VRef (MkRef (IScalar sv))) f = do+    val <- scalar_fetch sv+    case val of+        VUndef  -> do+            ref@(MkRef (IPair pv)) <- newObject (mkType "Pair")+            scalar_store sv (VRef ref)+            return $ f pv+        _  -> doPair val f+doPair (VRef x) _ = die "Cannot cast into Pair" x+doPair val f = do+    vs <- fromVal val+    case (vs :: VList) of+        [x, y]  -> return $ f (x, y)+        _       -> do+            pv <- castFailM val "Confusing pair?"+            return $ f (pv :: VPair)++-- XXX: Refactor doHash and doArray into one -- also see Eval's [] and {}+doHash :: Val -> (forall a. HashClass a => a -> b) -> Eval b+doHash (PerlSV sv) f = return $ f sv+doHash (VRef (MkRef (IHash hv))) f = return $ f hv+doHash (VRef (MkRef (IScalar sv))) f = do+    val <- scalar_fetch sv+    case val of+        VUndef  -> do+            ref@(MkRef (IHash hv)) <- newObject (mkType "Hash")+            scalar_store sv (VRef ref)+            return $ f hv+        _  -> doHash val f+doHash (VRef (MkRef p@(IPair _))) f = return $ f p+doHash (VObject o) f = return $ f (objAttrs o)+doHash (VMatch m) f = do+    return $ f (matchSubNamed m)+doHash val@(VRef _) _ = die "Cannot cast into Hash" val+doHash val f = do+    hv  <- fromVal val+    return $ f (hv :: VHash)++-- can be factored out+doArray :: Val -> (forall a. ArrayClass a => a -> b) -> Eval b+doArray (PerlSV sv) f = return $ f sv+doArray (VRef (MkRef (IArray av))) f = return $ f av+doArray (VRef (MkRef (IScalar sv))) f = do+    val <- scalar_fetch sv+    if defined val+        then doArray val f+        else do+            ref@(MkRef (IArray hv)) <- newObject (mkType "Array")+            scalar_store sv (VRef ref)+            return $ f hv+doArray (VRef (MkRef p@(IPair _))) f = return $ f p+doArray val@(VRef (MkRef IHash{})) f = do+    av  <- fromVal val+    return $ f (av :: VArray)+doArray val@(VRef _) _ = die "Cannot cast into Array" val+doArray (VMatch m) f = do+    return $ f (matchSubPos m)+doArray val f = do+    av  <- fromVal val+    return $ f (av :: VArray)++-- Haddock doesn't seem to like data/instance declarations with a where clause.+#ifndef HADDOCK++data IVar v where+    IScalar :: ScalarClass a => !a -> IVar VScalar+    IArray  :: ArrayClass  a => !a -> IVar VArray+    IHash   :: HashClass   a => !a -> IVar VHash+    ICode   :: CodeClass   a => !a -> IVar VCode+    IHandle :: HandleClass a => !a -> IVar VHandle+    IRule   :: RuleClass   a => !a -> IVar VRule+    IThunk  :: ThunkClass  a => !a -> IVar VThunk+    IPair   :: PairClass   a => !a -> IVar VPair+    IVal    ::                !Val -> IVar Val++-- | An empty failed match+mkMatchFail :: VMatch+mkMatchFail = MkMatch False 0 0 "" [] Map.empty++-- | Makes a successful match+mkMatchOk :: Int -> Int -> VStr -> VList -> VHash -> VMatch+mkMatchOk   = MkMatch True++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 Value VOpaque where+    fromVal (VOpaque o) = return o+    fromVal v = return $ MkOpaque v+    castV (MkOpaque x) = castV x+    doCast v = castFailM v "VOpaque"+#endif++readIVar :: IVar v -> Eval v+readIVar (IScalar x) = scalar_fetch x+readIVar (IPair x)   = pair_fetch x+readIVar (IArray x)  = array_fetch x+readIVar (IHash x)   = hash_fetch x+readIVar _ = fail "readIVar"++cloneIVar :: IVar v -> STM (IVar v)+cloneIVar (IScalar x) = fmap IScalar $ scalar_clone x+cloneIVar (IArray x)  = fmap IArray  $ array_clone x+cloneIVar (IHash x)   = fmap IHash   $ hash_clone x+cloneIVar (ICode x)   = fmap ICode   $ code_clone x+cloneIVar x = return x++writeIVar :: IVar v -> v -> Eval ()+writeIVar (IScalar x) = scalar_store x+writeIVar (IArray x) = array_store x+writeIVar (IHash x) = hash_store x+writeIVar _ = fail "writeIVar"++refType :: VRef -> Type+refType (MkRef x) = object_iType x++-- Haddock doesn't seem to like data/instance declarations with a where clause.+#ifndef HADDOCK+instance Eq IHash where+    x == y = addressOf x == addressOf y+instance Ord IHash where+    compare x y = compare (addressOf x) (addressOf y)+instance Show IHash where+    show = showAddressOf "Hash"+instance Typeable2 H.HashTable where+    typeOf2 _ = mkTyConApp (mkTyCon "HashTable") []++instance Eq VRef where+    x == y = addressOf x == addressOf y+instance Ord VRef where+    compare x y = compare (addressOf x) (addressOf y)+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++instance Typeable a => Show (IVar a) where+    show ivar = show (MkRef ivar)++instance Eq (IVar a) where+    x == y = addressOf x == addressOf y+instance Ord (IVar a) where+    compare x y = compare (addressOf x) (addressOf y)+instance Ord (TVar a) where+    compare x y = compare (addressOf x) (addressOf y)+instance Ord (IORef a) where+    compare x y = compare (addressOf x) (addressOf y)+#endif++scalarRef   :: ScalarClass a=> a -> VRef+scalarRef x = MkRef (IScalar x)+codeRef     :: CodeClass a  => a -> VRef+codeRef x   = MkRef (ICode x)+arrayRef    :: ArrayClass a => a -> VRef+arrayRef x  = MkRef (IArray x)+hashRef     :: HashClass a  => a -> VRef+hashRef x   = MkRef (IHash x)+thunkRef    :: ThunkClass a => a -> VRef+thunkRef x  = MkRef (IThunk x)+pairRef     :: PairClass a  => a -> VRef+pairRef x   = MkRef (IPair x)++newScalar :: (MonadSTM m) => VScalar -> m (IVar VScalar)+newScalar = stm . (fmap IScalar) . newTVar++newArray :: (MonadSTM m) => VArray -> m (IVar VArray)+newArray vals = stm $ do+    tvs <- mapM newScalar vals+    iv  <- newTVar (toP tvs)+    return $ IArray (MkIArray iv)++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))+    return $ IHash ihash++newHandle :: (MonadSTM m) => VHandle -> m (IVar VHandle)+newHandle = return . IHandle++proxyScalar :: Eval VScalar -> (VScalar -> Eval ()) -> IVar VScalar+proxyScalar fetch store = IScalar (fetch, store)++constScalar :: VScalar -> IVar VScalar+constScalar = IScalar++lazyScalar :: VScalar -> IVar VScalar+lazyScalar = IScalar . Just++lazyUndef :: IVar VScalar+lazyUndef = IScalar (Nothing :: IScalarLazy)++constArray :: VArray -> IVar VArray+constArray = IArray++retConstError :: VScalar -> Eval b+retConstError val = die "Can't modify constant item" val+++-- Haddock doesn't like these; not sure why ...+#ifndef HADDOCK++{-+instance A.MArray IArray ArrayIndex STM where+    getBounds (MkIArray iv) = do+        a   <- readTVar iv+        return (bounds a)+    newArray b e = do+        a   <- replicateM (rangeSize b) (newTVar e)+        iv  <- newTVar (A.listArray b a)+        return $ MkIArray iv+    newArray_ b = do+        a   <- replicateM (rangeSize b) (newTVar A.arrEleBottom)+        iv  <- newTVar (A.listArray b a)+        return $ MkIArray iv+    unsafeRead (MkIArray iv) i = do+        a   <- readTVar iv+        readTVar $ A.unsafeAt a i+    unsafeWrite (MkIArray iv) i e = do+        a   <- readTVar iv+        writeTVar (A.unsafeAt a i) e+-}++newtype IArray = MkIArray (TVar [:IVar VScalar:])+    deriving (Typeable)++type IArraySlice        = [IVar VScalar]+type IHash              = H.HashTable VStr (IVar VScalar) -- XXX UTF8 handled at Types/Hash.hs+type IScalar            = TVar Val+type IScalarProxy       = (Eval VScalar, (VScalar -> Eval ()))+type IScalarLazy        = Maybe VScalar+type IPairHashSlice     = (VStr, IVar VScalar)++data VMultiCode = MkMultiCode+    { mc_type       :: !Type+    , mc_subtype    :: !SubType+    , mc_assoc      :: !SubAssoc+    , mc_signature  :: !Params+    , mc_variants   :: !(Set Var)+    }+    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}++-- these implementation allows no destructions+type IRule   = VRule+type IHandle = VHandle -- XXX maybe TVar?++-- GADTs, here we come!+data VRef where+    MkRef   :: (Typeable a) => !(IVar a) -> VRef++instance Typeable VRef where+    typeOf (MkRef x) = typeOf 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+#endif++{- <DrIFT> -- Do NOT delete! These are valuable instances!++{-# NOINLINE _FakeEnv #-}+_FakeEnv :: Env+_FakeEnv = unsafePerformIO $ stm $ do+    glob <- newTVar $ MkPad Map.empty+    ref  <- newTVar Map.empty+    init <- newTVar $ MkInitDat { initPragmas=[] }+    maxi <- newTVar $ MkObjectId 1+    return $ MkEnv+        { envContext = CxtVoid+        , envLexical = emptyPad+        , envLexPads = []+        , envCaller  = Nothing+        , envCompPad = Nothing+        , envLValue  = False+        , envGlobal  = MkMPad (addressOf glob) glob+        , envPackage = cast "Main"+        , envEval    = const (return VUndef)+        , envFrames  = Set.empty+        , envBody    = Val undef+        , envDebug   = Just ref -- Set to "Nothing" to disable debugging+        , envPos     = MkPos (__"<null>") 1 1 1 1+        , envPragmas = []+        , envInitDat = init+        , envMaxId   = maxi+        , envAtomic  = False+        }++fakeEval :: MonadIO m => Eval Val -> m Val+fakeEval = io . runEvalIO _FakeEnv++instance YAML Val.Val++instance YAML LexPads where+    asYAML _ = return nilNode+    fromYAML _ = return []++instance YAML ([Val] -> Eval Val) where+    asYAML _ = return nilNode+    fromYAML _ = return (const $ return VUndef)+instance YAML (Maybe Env) where+    asYAML _ = return nilNode+    fromYAML _ = return Nothing+instance YAML (Eval Val) where+    asYAML x = asYAML =<< fakeEval x+    fromYAML x = return =<< fromYAML x+instance (Ord a, YAML a) => YAML (Set a) where+    asYAML x = do+        x' <- mapM asYAML (Set.toAscList x)+        (return . mkTagNode "Set" . ESeq) x'+    fromYAML node = do+        fmap Set.fromDistinctAscList (fromYAMLseq node)++instance YAML a => YAML (Map String a) where+    asYAML x = asYAMLmap "Map" $ Map.toAscList (Map.map asYAML x)+    fromYAML node = fmap Map.fromList (fromYAMLmap node)+instance YAML a => YAML (Map Var a) where+    asYAML x = asYAMLmap "Map" . sortBy (\x y -> fst x `compare` fst y) $+        [ (cast k, asYAML v) | (k, v) <- Map.toList x ]+    fromYAML node = do+        list <- fromYAMLmapBuf node+        return (Map.fromList [ (cast k, v) | (k, v) <- list ])+instance Typeable a => YAML (IVar a) where+    asYAML x = asYAML (MkRef x)+instance YAML VRef where+    asYAML (MkRef (ICode cv))+        | Just (mc :: VMultiCode) <- fromTypeable cv = do+            mcC <- asYAML (mc :: VMultiCode)+            return $ mkTagNode (tagHs "VMultiCode") $ ESeq [mcC]+        | otherwise = do+            VCode vsub  <- fakeEval $ fmap VCode (code_fetch cv)+            vsubC       <- asYAML vsub+            return $ mkTagNode (tagHs "VCode") $ ESeq [vsubC]+    asYAML (MkRef (IScalar sv)) = do+        val <- fakeEval $ scalar_fetch sv+        svC <- asYAML val+        let tag = if scalar_iType sv == mkType "Scalar::Const"+                    then "VScalar" else "IScalar"+        return $ mkTagNode (tagHs tag) $ ESeq [svC]+    asYAML (MkRef (IArray av)) = do+        VList vals <- fakeEval $ fmap VList (array_fetch av)+        avC <- asYAML vals+        return $ mkTagNode (tagHs "Array") $ ESeq [avC]+    asYAML (MkRef (IHash hv)) = do+        VMatch MkMatch{ matchSubNamed = hv } <- fakeEval $ fmap (VMatch . MkMatch False 0 0 "" []) (hash_fetch hv)+        hvC <- asYAML hv+        return $ mkTagNode (tagHs "Hash") $ ESeq [hvC]+    asYAML (MkRef (IPair pv)) = do+        VList [k, v] <- fakeEval $ fmap (\(k, v) -> VList [k, v]) (pair_fetch pv)+        avC <- asYAML (k, v)+        return $ mkTagNode (tagHs "Pair") $ ESeq [avC]+    asYAML ref = do+        val <- fakeEval $ readRef ref+        svC <- asYAML val+        io $ print "====>"+        io $ print svC+        fail ("Not implemented: asYAML \"" ++ showType (refType ref) ++ "\"")+    fromYAML MkNode{n_tag=Just s, n_elem=ESeq [node]}+        | s == packBuf "tag:hs:VMultiCode"   =+            fmap (MkRef . ICode) (fromYAML node :: IO VMultiCode)+        | s == packBuf "tag:hs:VCode"   =+            fmap (MkRef . ICode) (fromYAML node :: IO VCode)+        | s == packBuf "tag:hs:VScalar" =+            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)+    fromYAML node = fail $ "Unhandled YAML node: " ++ show node+instance YAML IHash 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+         return l'++instance YAML ID where+    asYAML x = asYAML (idBuf x)+    fromYAML x = do+        buf <- fromYAML x+        return $ bufToID buf+ +instance Perl5 ID where+    showPerl5 x = showPerl5 (cast x :: ByteString)+instance JSON ID where+    showJSON x = showJSON (cast x :: ByteString)++instance YAML Pkg where+    asYAML x = asYAML (cast x :: ByteString)+    fromYAML = fmap (cast :: ByteString -> Pkg) . fromYAML++instance YAML Var where+    asYAML x = asYAML (cast x :: ByteString)+    fromYAML = fmap (cast :: ByteString -> Var) . fromYAML++instance YAML EntryFlags where+    asYAML (MkEntryFlags x) = asYAML x+    fromYAML = fmap MkEntryFlags . fromYAML+ +instance Perl5 Var where+    showPerl5 x = showPerl5 (cast x :: String)+instance JSON Var where+    showJSON x = showJSON (cast x :: String)++instance YAML (Set Val) where+    asYAML = asYAML . Set.toAscList+    fromYAML = fmap Set.fromAscList . fromYAML ++instance YAML VControl+instance YAML VThread+instance YAML ClassTree+instance YAML Dynamic+instance YAML ProcessHandle+instance YAML Regex+instance YAML Unique+instance YAML VComplex+instance YAML VHandle+instance YAML VOpaque+instance YAML VSocket+instance YAML PerlSV++instance Perl5 Exp where+    showPerl5 _ = "(undef)"+instance JSON Exp where+    showJSON _ = "null"++-- Non-canonical serialization... needs work+instance (Show (TVar a)) => Perl5 (TVar a) where+    showPerl5 _ = "(warn '<ref>')"+instance (Show (TVar a)) => JSON (TVar a) where+    showJSON _ = "null"++instance Perl5 Val where+    showPerl5 (VUndef) = showP5Class "VUndef"+    showPerl5 (VBool aa) = showP5ArrayObj "VBool" [showPerl5 aa]+    showPerl5 (VInt aa) = showP5ArrayObj "VInt" [showPerl5 aa]+    showPerl5 (VRat aa) = showP5ArrayObj "VRat" [showPerl5 aa]+    showPerl5 (VNum aa) = showP5ArrayObj "VNum" [showPerl5 aa]+    showPerl5 (VStr aa) = showP5ArrayObj "VStr" [showPerl5 aa]+    showPerl5 (VList aa) = showP5ArrayObj "VList" [showPerl5 aa]+    showPerl5 (VType aa) = showP5ArrayObj "VType" [showPerl5 aa]+    showPerl5 (VCode{}) = showP5Class "VUndef"++</DrIFT> Do NOT delete! These instances are your friends! -}++instance Typeable Unique where typeOf _ = mkTyConApp (mkTyCon "Unique") []+instance Typeable ProcessHandle where typeOf _ = mkTyConApp (mkTyCon "ProcessHandle") []+instance Typeable Regex where typeOf _ = mkTyConApp (mkTyCon "Regex") []+++instance Eq VJunc where+    (MkJunc aa ab ac) == (MkJunc aa' ab' ac') = aa == aa' && ab == ab'+                      && ac == ac'++instance Ord VJunc where+    compare (MkJunc aa ab ac) (MkJunc aa' ab' ac') =+            foldl (\x y -> if x == EQ then compare y EQ else x) EQ+            [compare aa aa',compare ab ab',compare ac ac']++{- !!! For DrIFT -- Don't delete !!!++data VJunc = MkJunc+    { juncType :: !JuncType+    , juncDup  :: !(Set Val)+    , juncSet  :: !(Set Val)+    } deriving (Typeable) {-!derive: YAML_Pos!-}++data JuncType = JAny | JAll | JNone | JOne+    deriving (Eq, Ord, Typeable) {-!derive: YAML_Pos!-}++data Scope = SState | SConstant | SHas | SMy | SOur+    {-!derive: YAML_Pos, JSON, Perl5!-}++data Pad = MkPad { padEntries :: Map Var PadEntry }+    {-!derive: YAML_Pos!-}++data Pos = MkPos+    { posName           :: !String, posBeginLine      :: !Int+    , posBeginColumn    :: !Int+    , posEndLine        :: !Int+    , posEndColumn      :: !Int+    }+    {-!derive: YAML_Pos, JSON, Perl5!-}++data Type+    = MkType !String      -- ^ A regular type+    | TypeOr  !Type !Type -- ^ The disjunction (|) of two types+    | TypeAnd !Type !Type -- ^ The conjunction (&) of two types+    {-!derive: YAML_Pos, JSON, Perl5!-}++data Cxt = CxtVoid | CxtItem !Type | CxtSlurpy !Type+    {-!derive: YAML_Pos, JSON, Perl5!-}++data Val+    = VUndef                 -- ^ Undefined value+    | VBool     !VBool       -- ^ Boolean value+    | VInt      !VInt        -- ^ Integer value+    | VRat      !VRat        -- ^ Rational number value+    | VNum      !VNum        -- ^ Number (i.e. a double)+    | VStr      !VStr        -- ^ String value+    | VList     !VList       -- ^ List value+    | VType     !VType       -- ^ Type value (e.g. @Int@ or @Type@)+    {-!derive: JSON!-}++data Pragma = MkPrag+    { pragName           :: !String -- ^ Name of pragma+    , pragDat            :: !Int    -- ^ (lexically scoped) pragmatic data+                                    --     This element is subject to change;+                                    --     we don't necessarily want to limit+                                    --     ourselves to 32 bit ints.+    }+    {-!derive: YAML_Pos, JSON, Perl5!-}++-}++------------------------------------------------------------------------
+ src/Pugs/AST/Internals.hs-boot view
@@ -0,0 +1,42 @@+{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans -fallow-overlapping-instances -fallow-undecidable-instances #-}++module Pugs.AST.Internals where+import Pugs.Types+import Pugs.Internals+import Pugs.AST.Pos+import Pugs.AST.SIO+import Control.Concurrent.STM+import Data.Dynamic++instance Typeable Val++data Env+data Val+data VRef+data VObject+data PadEntry+data Exp+-- newtype Pad = MkPad { padEntries :: Map Var PadEntry }+newtype ObjectId = MkObjectId { unObjectId :: Int }++type VType = Type+type VArray = [Val]+type VList = [Val]+type VHash = Map VStr Val++showVal :: Val -> String+envPos' :: Env -> Pos+errStr :: VStr -> Val+errStrPos :: VStr -> Pos -> Val+errValPos :: Val -> Pos -> Val+envAtomic :: Env -> Bool+envContext :: Env -> Cxt+envMaxId :: Env -> TVar ObjectId+enterAtomicEnv :: Env -> Env+objOpaque :: VObject -> Maybe Dynamic++anyToVal :: (Show a, Typeable a) => a -> Val+anyFromVal :: Typeable a => Val -> a++createObjectRaw :: (MonadSTM m)+    => ObjectId -> Maybe Dynamic -> VType -> [(VStr, Val)] -> m VObject
+ src/Pugs/AST/Internals/Instances.hs view
@@ -0,0 +1,909 @@+{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans -fallow-overlapping-instances -fallow-undecidable-instances -fparr #-}+++++{- +-- WARNING WARNING WARNING --++This is an autogenerated file from src/Pugs/AST/Internals.hs.++Do not edit this file.++All changes made here will be lost!++-- WARNING WARNING WARNING --+-}++#ifndef HADDOCK++++++++++module Pugs.AST.Internals.Instances ()+where+import Pugs.AST.Internals+import Data.Yaml.Syck+import DrIFT.YAML+import DrIFT.JSON+import DrIFT.Perl5+import DrIFT.Perl6Class+import Control.Monad+import qualified Data.ByteString as Buf++import Pugs.AST.Scope+import Pugs.AST.Pos+import Pugs.AST.Prag+import Pugs.AST.SIO+import Pugs.Types+import Pugs.Internals+import Pugs.Embed.Perl5+import qualified Data.Set       as Set+import qualified Data.Map       as Map+import qualified Pugs.Val       as Val++import qualified Data.HashTable    as H++{-# NOINLINE _FakeEnv #-}+_FakeEnv :: Env+_FakeEnv = unsafePerformIO $ stm $ do+    glob <- newTVar $ MkPad Map.empty+    ref  <- newTVar Map.empty+    init <- newTVar $ MkInitDat { initPragmas=[] }+    maxi <- newTVar $ MkObjectId 1+    return $ MkEnv+        { envContext = CxtVoid+        , envLexical = emptyPad+        , envLexPads = []+        , envCaller  = Nothing+        , envCompPad = Nothing+        , envLValue  = False+        , envGlobal  = MkMPad (addressOf glob) glob+        , envPackage = cast "Main"+        , envEval    = const (return VUndef)+        , envFrames  = Set.empty+        , envBody    = Val undef+        , envDebug   = Just ref -- Set to "Nothing" to disable debugging+        , envPos     = MkPos (__"<null>") 1 1 1 1+        , envPragmas = []+        , envInitDat = init+        , envMaxId   = maxi+        , envAtomic  = False+        }++fakeEval :: MonadIO m => Eval Val -> m Val+fakeEval = io . runEvalIO _FakeEnv++instance YAML Val.Val++instance YAML LexPads where+    asYAML _ = return nilNode+    fromYAML _ = return []++instance YAML ([Val] -> Eval Val) where+    asYAML _ = return nilNode+    fromYAML _ = return (const $ return VUndef)+instance YAML (Maybe Env) where+    asYAML _ = return nilNode+    fromYAML _ = return Nothing+instance YAML (Eval Val) where+    asYAML x = asYAML =<< fakeEval x+    fromYAML x = return =<< fromYAML x+instance (Ord a, YAML a) => YAML (Set a) where+    asYAML x = do+        x' <- mapM asYAML (Set.toAscList x)+        (return . mkTagNode "Set" . ESeq) x'+    fromYAML node = do+        fmap Set.fromDistinctAscList (fromYAMLseq node)++instance YAML a => YAML (Map String a) where+    asYAML x = asYAMLmap "Map" $ Map.toAscList (Map.map asYAML x)+    fromYAML node = fmap Map.fromList (fromYAMLmap node)+instance YAML a => YAML (Map Var a) where+    asYAML x = asYAMLmap "Map" . sortBy (\x y -> fst x `compare` fst y) $+        [ (cast k, asYAML v) | (k, v) <- Map.toList x ]+    fromYAML node = do+        list <- fromYAMLmapBuf node+        return (Map.fromList [ (cast k, v) | (k, v) <- list ])+instance Typeable a => YAML (IVar a) where+    asYAML x = asYAML (MkRef x)+instance YAML VRef where+    asYAML (MkRef (ICode cv))+        | Just (mc :: VMultiCode) <- fromTypeable cv = do+            mcC <- asYAML (mc :: VMultiCode)+            return $ mkTagNode (tagHs "VMultiCode") $ ESeq [mcC]+        | otherwise = do+            VCode vsub  <- fakeEval $ fmap VCode (code_fetch cv)+            vsubC       <- asYAML vsub+            return $ mkTagNode (tagHs "VCode") $ ESeq [vsubC]+    asYAML (MkRef (IScalar sv)) = do+        val <- fakeEval $ scalar_fetch sv+        svC <- asYAML val+        let tag = if scalar_iType sv == mkType "Scalar::Const"+                    then "VScalar" else "IScalar"+        return $ mkTagNode (tagHs tag) $ ESeq [svC]+    asYAML (MkRef (IArray av)) = do+        VList vals <- fakeEval $ fmap VList (array_fetch av)+        avC <- asYAML vals+        return $ mkTagNode (tagHs "Array") $ ESeq [avC]+    asYAML (MkRef (IHash hv)) = do+        VMatch MkMatch{ matchSubNamed = hv } <- fakeEval $ fmap (VMatch . MkMatch False 0 0 "" []) (hash_fetch hv)+        hvC <- asYAML hv+        return $ mkTagNode (tagHs "Hash") $ ESeq [hvC]+    asYAML (MkRef (IPair pv)) = do+        VList [k, v] <- fakeEval $ fmap (\(k, v) -> VList [k, v]) (pair_fetch pv)+        avC <- asYAML (k, v)+        return $ mkTagNode (tagHs "Pair") $ ESeq [avC]+    asYAML ref = do+        val <- fakeEval $ readRef ref+        svC <- asYAML val+        io $ print "====>"+        io $ print svC+        fail ("Not implemented: asYAML \"" ++ showType (refType ref) ++ "\"")+    fromYAML MkNode{n_tag=Just s, n_elem=ESeq [node]}+        | s == packBuf "tag:hs:VMultiCode"   =+            fmap (MkRef . ICode) (fromYAML node :: IO VMultiCode)+        | s == packBuf "tag:hs:VCode"   =+            fmap (MkRef . ICode) (fromYAML node :: IO VCode)+        | s == packBuf "tag:hs:VScalar" =+            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)+    fromYAML node = fail $ "Unhandled YAML node: " ++ show node+instance YAML IHash 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+         return l'++instance YAML ID where+    asYAML x = asYAML (idBuf x)+    fromYAML x = do+        buf <- fromYAML x+        return $ bufToID buf+ +instance Perl5 ID where+    showPerl5 x = showPerl5 (cast x :: ByteString)+instance JSON ID where+    showJSON x = showJSON (cast x :: ByteString)++instance YAML Pkg where+    asYAML x = asYAML (cast x :: ByteString)+    fromYAML = fmap (cast :: ByteString -> Pkg) . fromYAML++instance YAML Var where+    asYAML x = asYAML (cast x :: ByteString)+    fromYAML = fmap (cast :: ByteString -> Var) . fromYAML++instance YAML EntryFlags where+    asYAML (MkEntryFlags x) = asYAML x+    fromYAML = fmap MkEntryFlags . fromYAML+ +instance Perl5 Var where+    showPerl5 x = showPerl5 (cast x :: String)+instance JSON Var where+    showJSON x = showJSON (cast x :: String)++instance YAML (Set Val) where+    asYAML = asYAML . Set.toAscList+    fromYAML = fmap Set.fromAscList . fromYAML ++instance YAML VControl+instance YAML VThread+instance YAML ClassTree+instance YAML Dynamic+instance YAML ProcessHandle+instance YAML Regex+instance YAML Unique+instance YAML VComplex+instance YAML VHandle+instance YAML VOpaque+instance YAML VSocket+instance YAML PerlSV++instance Perl5 Exp where+    showPerl5 _ = "(undef)"+instance JSON Exp where+    showJSON _ = "null"++-- Non-canonical serialization... needs work+instance (Show (TVar a)) => Perl5 (TVar a) where+    showPerl5 _ = "(warn '<ref>')"+instance (Show (TVar a)) => JSON (TVar a) where+    showJSON _ = "null"++instance Perl5 Val where+    showPerl5 (VUndef) = showP5Class "VUndef"+    showPerl5 (VBool aa) = showP5ArrayObj "VBool" [showPerl5 aa]+    showPerl5 (VInt aa) = showP5ArrayObj "VInt" [showPerl5 aa]+    showPerl5 (VRat aa) = showP5ArrayObj "VRat" [showPerl5 aa]+    showPerl5 (VNum aa) = showP5ArrayObj "VNum" [showPerl5 aa]+    showPerl5 (VStr aa) = showP5ArrayObj "VStr" [showPerl5 aa]+    showPerl5 (VList aa) = showP5ArrayObj "VList" [showPerl5 aa]+    showPerl5 (VType aa) = showP5ArrayObj "VType" [showPerl5 aa]+    showPerl5 (VCode{}) = showP5Class "VUndef"++{-* Generated by DrIFT : Look, but Don't Touch. *-}+instance YAML VSubst where+    fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of+	"MkSubst" -> do+	    let ESeq [aa, ab] = e+	    liftM2 MkSubst (fromYAML aa) (fromYAML ab)+	"MkTrans" -> do+	    let ESeq [aa, ab] = e+	    liftM2 MkTrans (fromYAML aa) (fromYAML ab)+	_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["MkSubst","MkTrans"] ++ " in node " ++ show e+    fromYAML e = fail $ "no tag found: expecting " ++ show ["MkSubst","MkTrans"] ++ " in node " ++ show e+    asYAML (MkSubst aa ab) = asYAMLseq "MkSubst" [asYAML aa, asYAML ab]+    asYAML (MkTrans aa ab) = asYAMLseq "MkTrans" [asYAML aa, asYAML ab]++instance YAML VThunk where+    fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of+	"MkThunk" -> do+	    let ESeq [aa, ab] = e+	    liftM2 MkThunk (fromYAML aa) (fromYAML ab)+	_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["MkThunk"] ++ " in node " ++ show e+    fromYAML e = fail $ "no tag found: expecting " ++ show ["MkThunk"] ++ " in node " ++ show e+    asYAML (MkThunk aa ab) = asYAMLseq "MkThunk" [asYAML aa, asYAML ab]++instance YAML VProcess where+    fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of+	"MkProcess" -> do+	    let ESeq [aa] = e+	    liftM MkProcess (fromYAML aa)+	_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["MkProcess"] ++ " in node " ++ show e+    fromYAML e = fail $ "no tag found: expecting " ++ show ["MkProcess"] ++ " in node " ++ show e+    asYAML (MkProcess aa) = asYAMLseq "MkProcess" [asYAML aa]++instance YAML VRule where+    fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of+	"MkRulePCRE" -> do+	    let liftM6 f m1 m2 m3 m4 m5 m6 = do+		{x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; x6 <- m6; return (f x1 x2 x3 x4 x5 x6)}+	    let ESeq [aa, ab, ac, ad, ae, af] = e+	    liftM6 MkRulePCRE (fromYAML aa) (fromYAML ab) (fromYAML ac) (fromYAML ad) (fromYAML ae) (fromYAML af)+	"MkRulePGE" -> do+	    let ESeq [aa, ab, ac, ad] = e+	    liftM4 MkRulePGE (fromYAML aa) (fromYAML ab) (fromYAML ac) (fromYAML ad)+	_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["MkRulePCRE","MkRulePGE"] ++ " in node " ++ show e+    fromYAML e = fail $ "no tag found: expecting " ++ show ["MkRulePCRE","MkRulePGE"] ++ " in node " ++ show e+    asYAML (MkRulePCRE aa ab ac ad ae af) = asYAMLseq "MkRulePCRE"+	   [asYAML aa, asYAML ab, asYAML ac, asYAML ad, asYAML ae, asYAML af]+    asYAML (MkRulePGE aa ab ac ad) = asYAMLseq "MkRulePGE"+	   [asYAML aa, asYAML ab, asYAML ac, asYAML ad]++instance YAML Val where+    fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of+	"VUndef" -> do+	    return VUndef+	"VBool" -> do+	    let ESeq [aa] = e+	    liftM VBool (fromYAML aa)+	"VInt" -> do+	    let ESeq [aa] = e+	    liftM VInt (fromYAML aa)+	"VRat" -> do+	    let ESeq [aa] = e+	    liftM VRat (fromYAML aa)+	"VNum" -> do+	    let ESeq [aa] = e+	    liftM VNum (fromYAML aa)+	"VComplex" -> do+	    let ESeq [aa] = e+	    liftM VComplex (fromYAML aa)+	"VStr" -> do+	    let ESeq [aa] = e+	    liftM VStr (fromYAML aa)+	"VList" -> do+	    let ESeq [aa] = e+	    liftM VList (fromYAML aa)+	"VType" -> do+	    let ESeq [aa] = e+	    liftM VType (fromYAML aa)+	"VJunc" -> do+	    let ESeq [aa] = e+	    liftM VJunc (fromYAML aa)+	"VError" -> do+	    let ESeq [aa, ab] = e+	    liftM2 VError (fromYAML aa) (fromYAML ab)+	"VControl" -> do+	    let ESeq [aa] = e+	    liftM VControl (fromYAML aa)+	"VRef" -> do+	    let ESeq [aa] = e+	    liftM VRef (fromYAML aa)+	"VCode" -> do+	    let ESeq [aa] = e+	    liftM VCode (fromYAML aa)+	"VBlock" -> do+	    let ESeq [aa] = e+	    liftM VBlock (fromYAML aa)+	"VHandle" -> do+	    let ESeq [aa] = e+	    liftM VHandle (fromYAML aa)+	"VSocket" -> do+	    let ESeq [aa] = e+	    liftM VSocket (fromYAML aa)+	"VThread" -> do+	    let ESeq [aa] = e+	    liftM VThread (fromYAML aa)+	"VProcess" -> do+	    let ESeq [aa] = e+	    liftM VProcess (fromYAML aa)+	"VRule" -> do+	    let ESeq [aa] = e+	    liftM VRule (fromYAML aa)+	"VSubst" -> do+	    let ESeq [aa] = e+	    liftM VSubst (fromYAML aa)+	"VMatch" -> do+	    let ESeq [aa] = e+	    liftM VMatch (fromYAML aa)+	"VObject" -> do+	    let ESeq [aa] = e+	    liftM VObject (fromYAML aa)+	"VOpaque" -> do+	    let ESeq [aa] = e+	    liftM VOpaque (fromYAML aa)+	"PerlSV" -> do+	    let ESeq [aa] = e+	    liftM PerlSV (fromYAML aa)+	"VV" -> do+	    let ESeq [aa] = e+	    liftM VV (fromYAML aa)+	_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["VUndef","VBool","VInt","VRat","VNum","VComplex","VStr","VList","VType","VJunc","VError","VControl","VRef","VCode","VBlock","VHandle","VSocket","VThread","VProcess","VRule","VSubst","VMatch","VObject","VOpaque","PerlSV","VV"] ++ " in node " ++ show e+    fromYAML e = fail $ "no tag found: expecting " ++ show ["VUndef","VBool","VInt","VRat","VNum","VComplex","VStr","VList","VType","VJunc","VError","VControl","VRef","VCode","VBlock","VHandle","VSocket","VThread","VProcess","VRule","VSubst","VMatch","VObject","VOpaque","PerlSV","VV"] ++ " in node " ++ show e+    asYAML (VUndef) = asYAMLcls "VUndef"+    asYAML (VBool aa) = asYAMLseq "VBool" [asYAML aa]+    asYAML (VInt aa) = asYAMLseq "VInt" [asYAML aa]+    asYAML (VRat aa) = asYAMLseq "VRat" [asYAML aa]+    asYAML (VNum aa) = asYAMLseq "VNum" [asYAML aa]+    asYAML (VComplex aa) = asYAMLseq "VComplex" [asYAML aa]+    asYAML (VStr aa) = asYAMLseq "VStr" [asYAML aa]+    asYAML (VList aa) = asYAMLseq "VList" [asYAML aa]+    asYAML (VType aa) = asYAMLseq "VType" [asYAML aa]+    asYAML (VJunc aa) = asYAMLseq "VJunc" [asYAML aa]+    asYAML (VError aa ab) = asYAMLseq "VError" [asYAML aa, asYAML ab]+    asYAML (VControl aa) = asYAMLseq "VControl" [asYAML aa]+    asYAML (VRef aa) = asYAMLseq "VRef" [asYAML aa]+    asYAML (VCode aa) = asYAMLseq "VCode" [asYAML aa]+    asYAML (VBlock aa) = asYAMLseq "VBlock" [asYAML aa]+    asYAML (VHandle aa) = asYAMLseq "VHandle" [asYAML aa]+    asYAML (VSocket aa) = asYAMLseq "VSocket" [asYAML aa]+    asYAML (VThread aa) = asYAMLseq "VThread" [asYAML aa]+    asYAML (VProcess aa) = asYAMLseq "VProcess" [asYAML aa]+    asYAML (VRule aa) = asYAMLseq "VRule" [asYAML aa]+    asYAML (VSubst aa) = asYAMLseq "VSubst" [asYAML aa]+    asYAML (VMatch aa) = asYAMLseq "VMatch" [asYAML aa]+    asYAML (VObject aa) = asYAMLseq "VObject" [asYAML aa]+    asYAML (VOpaque aa) = asYAMLseq "VOpaque" [asYAML aa]+    asYAML (PerlSV aa) = asYAMLseq "PerlSV" [asYAML aa]+    asYAML (VV aa) = asYAMLseq "VV" [asYAML aa]++instance YAML SubType where+    fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of+	"SubMethod" -> do+	    return SubMethod+	"SubCoroutine" -> do+	    return SubCoroutine+	"SubMacro" -> do+	    return SubMacro+	"SubRoutine" -> do+	    return SubRoutine+	"SubBlock" -> do+	    return SubBlock+	"SubPointy" -> do+	    return SubPointy+	"SubPrim" -> do+	    return SubPrim+	_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["SubMethod","SubCoroutine","SubMacro","SubRoutine","SubBlock","SubPointy","SubPrim"] ++ " in node " ++ show e+    fromYAML e = fail $ "no tag found: expecting " ++ show ["SubMethod","SubCoroutine","SubMacro","SubRoutine","SubBlock","SubPointy","SubPrim"] ++ " in node " ++ show e+    asYAML (SubMethod) = asYAMLcls "SubMethod"+    asYAML (SubCoroutine) = asYAMLcls "SubCoroutine"+    asYAML (SubMacro) = asYAMLcls "SubMacro"+    asYAML (SubRoutine) = asYAMLcls "SubRoutine"+    asYAML (SubBlock) = asYAMLcls "SubBlock"+    asYAML (SubPointy) = asYAMLcls "SubPointy"+    asYAML (SubPrim) = asYAMLcls "SubPrim"++instance JSON SubType where+    showJSON (SubMethod) = showJSScalar "SubMethod"+    showJSON (SubCoroutine) = showJSScalar "SubCoroutine"+    showJSON (SubMacro) = showJSScalar "SubMacro"+    showJSON (SubRoutine) = showJSScalar "SubRoutine"+    showJSON (SubBlock) = showJSScalar "SubBlock"+    showJSON (SubPointy) = showJSScalar "SubPointy"+    showJSON (SubPrim) = showJSScalar "SubPrim"++instance Perl5 SubType where+    showPerl5 (SubMethod) = showP5Class "SubMethod"+    showPerl5 (SubCoroutine) = showP5Class "SubCoroutine"+    showPerl5 (SubMacro) = showP5Class "SubMacro"+    showPerl5 (SubRoutine) = showP5Class "SubRoutine"+    showPerl5 (SubBlock) = showP5Class "SubBlock"+    showPerl5 (SubPointy) = showP5Class "SubPointy"+    showPerl5 (SubPrim) = showP5Class "SubPrim"++instance YAML Param where+    fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of+	"MkOldParam" -> do+	    let liftM9 f m1 m2 m3 m4 m5 m6 m7 m8 m9 = do+		{x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; x6 <- m6; x7 <- m7; x8 <- m8; x9 <- m9; return (f x1 x2 x3 x4 x5 x6 x7 x8 x9)}+	    let ESeq [aa, ab, ac, ad, ae, af, ag, ah, ai] = e+	    liftM9 MkOldParam (fromYAML aa) (fromYAML ab) (fromYAML ac) (fromYAML ad) (fromYAML ae) (fromYAML af) (fromYAML ag) (fromYAML ah) (fromYAML ai)+	_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["MkOldParam"] ++ " in node " ++ show e+    fromYAML e = fail $ "no tag found: expecting " ++ show ["MkOldParam"] ++ " in node " ++ show e+    asYAML (MkOldParam aa ab ac ad ae af ag ah ai) =+	   asYAMLseq "MkOldParam"+	   [asYAML aa, asYAML ab, asYAML ac, asYAML ad, asYAML ae, asYAML af,+	    asYAML ag, asYAML ah, asYAML ai]++instance Perl5 Param where+    showPerl5 (MkOldParam aa ab ac ad ae af ag ah ai) =+	      showP5HashObj "MkOldParam"+	      [("isInvocant", showPerl5 aa) , ("isOptional", showPerl5 ab) ,+	       ("isNamed", showPerl5 ac) , ("isLValue", showPerl5 ad) ,+	       ("isWritable", showPerl5 ae) , ("isLazy", showPerl5 af) ,+	       ("paramName", showPerl5 ag) , ("paramContext", showPerl5 ah) ,+	       ("paramDefault", showPerl5 ai)]++instance JSON Param where+    showJSON (MkOldParam aa ab ac ad ae af ag ah ai) =+	     showJSHashObj "MkOldParam"+	     [("isInvocant", showJSON aa), ("isOptional", showJSON ab),+	      ("isNamed", showJSON ac), ("isLValue", showJSON ad),+	      ("isWritable", showJSON ae), ("isLazy", showJSON af),+	      ("paramName", showJSON ag), ("paramContext", showJSON ah),+	      ("paramDefault", showJSON ai)]++instance YAML SubAssoc where+    fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of+	"ANil" -> do+	    return ANil+	"AIrrelevantToParsing" -> do+	    return AIrrelevantToParsing+	"A_left" -> do+	    return A_left+	"A_right" -> do+	    return A_right+	"A_non" -> do+	    return A_non+	"A_chain" -> do+	    return A_chain+	"A_list" -> do+	    return A_list+	_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["ANil","AIrrelevantToParsing","A_left","A_right","A_non","A_chain","A_list"] ++ " in node " ++ show e+    fromYAML e = fail $ "no tag found: expecting " ++ show ["ANil","AIrrelevantToParsing","A_left","A_right","A_non","A_chain","A_list"] ++ " in node " ++ show e+    asYAML (ANil) = asYAMLcls "ANil"+    asYAML (AIrrelevantToParsing) = asYAMLcls "AIrrelevantToParsing"+    asYAML (A_left) = asYAMLcls "A_left"+    asYAML (A_right) = asYAMLcls "A_right"+    asYAML (A_non) = asYAMLcls "A_non"+    asYAML (A_chain) = asYAMLcls "A_chain"+    asYAML (A_list) = asYAMLcls "A_list"++instance JSON SubAssoc where+    showJSON (ANil) = showJSScalar "ANil"+    showJSON (AIrrelevantToParsing) =+	     showJSScalar "AIrrelevantToParsing"+    showJSON (A_left) = showJSScalar "A_left"+    showJSON (A_right) = showJSScalar "A_right"+    showJSON (A_non) = showJSScalar "A_non"+    showJSON (A_chain) = showJSScalar "A_chain"+    showJSON (A_list) = showJSScalar "A_list"++instance Perl5 SubAssoc where+    showPerl5 (ANil) = showP5Class "ANil"+    showPerl5 (AIrrelevantToParsing) =+	      showP5Class "AIrrelevantToParsing"+    showPerl5 (A_left) = showP5Class "A::left"+    showPerl5 (A_right) = showP5Class "A::right"+    showPerl5 (A_non) = showP5Class "A::non"+    showPerl5 (A_chain) = showP5Class "A::chain"+    showPerl5 (A_list) = showP5Class "A::list"++instance YAML MPad where+    fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of+	"MkMPad" -> do+	    let ESeq [aa, ab] = e+	    liftM2 MkMPad (fromYAML aa) (fromYAML ab)+	_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["MkMPad"] ++ " in node " ++ show e+    fromYAML e = fail $ "no tag found: expecting " ++ show ["MkMPad"] ++ " in node " ++ show e+    asYAML (MkMPad aa ab) = asYAMLseq "MkMPad" [asYAML aa, asYAML ab]++instance JSON MPad where+    showJSON (MkMPad aa ab) = showJSHashObj "MkMPad"+	     [("mp_id", showJSON aa), ("mp_pad", showJSON ab)]++instance Perl5 MPad where+    showPerl5 (MkMPad aa ab) = showP5HashObj "MkMPad"+	      [("mp_id", showPerl5 aa) , ("mp_pad", showPerl5 ab)]++instance YAML VCode where+    fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of+	"MkCode" -> do+	    let liftM16 f m1 m2 m3 m4 m5 m6 m7 m8 m9 m10 m11 m12 m13 m14 m15 m16 = do+		{x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; x6 <- m6; x7 <- m7; x8 <- m8; x9 <- m9; x10 <- m10; x11 <- m11; x12 <- m12; x13 <- m13; x14 <- m14; x15 <- m15; x16 <- m16; return (f x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16)}+	    let ESeq [aa, ab, ac, ad, ae, af, ag, ah, ai, aj, ak, al, am, an, ao, ap] = e+	    liftM16 MkCode (fromYAML aa) (fromYAML ab) (fromYAML ac) (fromYAML ad) (fromYAML ae) (fromYAML af) (fromYAML ag) (fromYAML ah) (fromYAML ai) (fromYAML aj) (fromYAML ak) (fromYAML al) (fromYAML am) (fromYAML an) (fromYAML ao) (fromYAML ap)+	_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["MkCode"] ++ " in node " ++ show e+    fromYAML e = fail $ "no tag found: expecting " ++ show ["MkCode"] ++ " in node " ++ show e+    asYAML (MkCode aa ab ac ad ae af ag ah ai aj ak al am an ao ap) =+	   asYAMLseq "MkCode"+	   [asYAML aa, asYAML ab, asYAML ac, asYAML ad, asYAML ae, asYAML af,+	    asYAML ag, asYAML ah, asYAML ai, asYAML aj, asYAML ak, asYAML al,+	    asYAML am, asYAML an, asYAML ao, asYAML ap]++instance YAML TraitBlocks where+    fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of+	"MkTraitBlocks" -> do+	    let liftM11 f m1 m2 m3 m4 m5 m6 m7 m8 m9 m10 m11 = do+		{x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; x6 <- m6; x7 <- m7; x8 <- m8; x9 <- m9; x10 <- m10; x11 <- m11; return (f x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11)}+	    let ESeq [aa, ab, ac, ad, ae, af, ag, ah, ai, aj, ak] = e+	    liftM11 MkTraitBlocks (fromYAML aa) (fromYAML ab) (fromYAML ac) (fromYAML ad) (fromYAML ae) (fromYAML af) (fromYAML ag) (fromYAML ah) (fromYAML ai) (fromYAML aj) (fromYAML ak)+	_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["MkTraitBlocks"] ++ " in node " ++ show e+    fromYAML e = fail $ "no tag found: expecting " ++ show ["MkTraitBlocks"] ++ " in node " ++ show e+    asYAML (MkTraitBlocks aa ab ac ad ae af ag ah ai aj ak) =+	   asYAMLseq "MkTraitBlocks"+	   [asYAML aa, asYAML ab, asYAML ac, asYAML ad, asYAML ae, asYAML af,+	    asYAML ag, asYAML ah, asYAML ai, asYAML aj, asYAML ak]++instance YAML Ann where+    fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of+	"Cxt" -> do+	    let ESeq [aa] = e+	    liftM Cxt (fromYAML aa)+	"Pos" -> do+	    let ESeq [aa] = e+	    liftM Pos (fromYAML aa)+	"Prag" -> do+	    let ESeq [aa] = e+	    liftM Prag (fromYAML aa)+	"Decl" -> do+	    let ESeq [aa] = e+	    liftM Decl (fromYAML aa)+	"Parens" -> do+	    return Parens+	_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["Cxt","Pos","Prag","Decl","Parens"] ++ " in node " ++ show e+    fromYAML e = fail $ "no tag found: expecting " ++ show ["Cxt","Pos","Prag","Decl","Parens"] ++ " in node " ++ show e+    asYAML (Cxt aa) = asYAMLseq "Cxt" [asYAML aa]+    asYAML (Pos aa) = asYAMLseq "Pos" [asYAML aa]+    asYAML (Prag aa) = asYAMLseq "Prag" [asYAML aa]+    asYAML (Decl aa) = asYAMLseq "Decl" [asYAML aa]+    asYAML (Parens) = asYAMLcls "Parens"++instance YAML Exp where+    fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of+	"Noop" -> do+	    return Noop+	"App" -> do+	    let ESeq [aa, ab, ac] = e+	    liftM3 App (fromYAML aa) (fromYAML ab) (fromYAML ac)+	"Syn" -> do+	    let ESeq [aa, ab] = e+	    liftM2 Syn (fromYAML aa) (fromYAML ab)+	"Ann" -> do+	    let ESeq [aa, ab] = e+	    liftM2 Ann (fromYAML aa) (fromYAML ab)+	"Sym" -> do+	    let ESeq [aa, ab, ac, ad, ae] = e+	    liftM5 Sym (fromYAML aa) (fromYAML ab) (fromYAML ac) (fromYAML ad) (fromYAML ae)+	"Stmts" -> do+	    let ESeq [aa, ab] = e+	    liftM2 Stmts (fromYAML aa) (fromYAML ab)+	"Prim" -> do+	    let ESeq [aa] = e+	    liftM Prim (fromYAML aa)+	"Val" -> do+	    let ESeq [aa] = e+	    liftM Val (fromYAML aa)+	"Var" -> do+	    let ESeq [aa] = e+	    liftM Var (fromYAML aa)+	"NonTerm" -> do+	    let ESeq [aa] = e+	    liftM NonTerm (fromYAML aa)+	_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["Noop","App","Syn","Ann","Sym","Stmts","Prim","Val","Var","NonTerm"] ++ " in node " ++ show e+    fromYAML e = fail $ "no tag found: expecting " ++ show ["Noop","App","Syn","Ann","Sym","Stmts","Prim","Val","Var","NonTerm"] ++ " in node " ++ show e+    asYAML (Noop) = asYAMLcls "Noop"+    asYAML (App aa ab ac) = asYAMLseq "App"+	   [asYAML aa, asYAML ab, asYAML ac]+    asYAML (Syn aa ab) = asYAMLseq "Syn" [asYAML aa, asYAML ab]+    asYAML (Ann aa ab) = asYAMLseq "Ann" [asYAML aa, asYAML ab]+    asYAML (Sym aa ab ac ad ae) = asYAMLseq "Sym"+	   [asYAML aa, asYAML ab, asYAML ac, asYAML ad, asYAML ae]+    asYAML (Stmts aa ab) = asYAMLseq "Stmts" [asYAML aa, asYAML ab]+    asYAML (Prim aa) = asYAMLseq "Prim" [asYAML aa]+    asYAML (Val aa) = asYAMLseq "Val" [asYAML aa]+    asYAML (Var aa) = asYAMLseq "Var" [asYAML aa]+    asYAML (NonTerm aa) = asYAMLseq "NonTerm" [asYAML aa]++instance YAML InitDat where+    fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of+	"MkInitDat" -> do+	    let ESeq [aa] = e+	    liftM MkInitDat (fromYAML aa)+	_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["MkInitDat"] ++ " in node " ++ show e+    fromYAML e = fail $ "no tag found: expecting " ++ show ["MkInitDat"] ++ " in node " ++ show e+    asYAML (MkInitDat aa) = asYAMLseq "MkInitDat" [asYAML aa]++instance YAML PadEntry where+    fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of+	"PELexical" -> do+	    let ESeq [aa, ab, ac, ad] = e+	    liftM4 PELexical (fromYAML aa) (fromYAML ab) (fromYAML ac) (fromYAML ad)+	"PEStatic" -> do+	    let ESeq [aa, ab, ac, ad] = e+	    liftM4 PEStatic (fromYAML aa) (fromYAML ab) (fromYAML ac) (fromYAML ad)+	"PEConstant" -> do+	    let ESeq [aa, ab, ac] = e+	    liftM3 PEConstant (fromYAML aa) (fromYAML ab) (fromYAML ac)+	_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["PELexical","PEStatic","PEConstant"] ++ " in node " ++ show e+    fromYAML e = fail $ "no tag found: expecting " ++ show ["PELexical","PEStatic","PEConstant"] ++ " in node " ++ show e+    asYAML (PELexical aa ab ac ad) = asYAMLseq "PELexical"+	   [asYAML aa, asYAML ab, asYAML ac, asYAML ad]+    asYAML (PEStatic aa ab ac ad) = asYAMLseq "PEStatic"+	   [asYAML aa, asYAML ab, asYAML ac, asYAML ad]+    asYAML (PEConstant aa ab ac) = asYAMLseq "PEConstant"+	   [asYAML aa, asYAML ab, asYAML ac]++instance YAML IHashEnv where+    fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of+	"MkHashEnv" -> do+	    return MkHashEnv+	_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["MkHashEnv"] ++ " in node " ++ show e+    fromYAML e = fail $ "no tag found: expecting " ++ show ["MkHashEnv"] ++ " in node " ++ show e+    asYAML (MkHashEnv) = asYAMLcls "MkHashEnv"++instance YAML IScalarCwd where+    fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of+	"MkScalarCwd" -> do+	    return MkScalarCwd+	_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["MkScalarCwd"] ++ " in node " ++ show e+    fromYAML e = fail $ "no tag found: expecting " ++ show ["MkScalarCwd"] ++ " in node " ++ show e+    asYAML (MkScalarCwd) = asYAMLcls "MkScalarCwd"++instance YAML ObjectId where+    fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of+	"MkObjectId" -> do+	    let ESeq [aa] = e+	    liftM MkObjectId (fromYAML aa)+	_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["MkObjectId"] ++ " in node " ++ show e+    fromYAML e = fail $ "no tag found: expecting " ++ show ["MkObjectId"] ++ " in node " ++ show e+    asYAML (MkObjectId aa) = asYAMLseq "MkObjectId" [asYAML aa]++instance YAML VObject where+    fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of+	"MkObject" -> do+	    let ESeq [aa, ab, ac, ad] = e+	    liftM4 MkObject (fromYAML aa) (fromYAML ab) (fromYAML ac) (fromYAML ad)+	_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["MkObject"] ++ " in node " ++ show e+    fromYAML e = fail $ "no tag found: expecting " ++ show ["MkObject"] ++ " in node " ++ show e+    asYAML (MkObject aa ab ac ad) = asYAMLseq "MkObject"+	   [asYAML aa, asYAML ab, asYAML ac, asYAML ad]++instance YAML VMatch where+    fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of+	"MkMatch" -> do+	    let liftM6 f m1 m2 m3 m4 m5 m6 = do+		{x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; x6 <- m6; return (f x1 x2 x3 x4 x5 x6)}+	    let ESeq [aa, ab, ac, ad, ae, af] = e+	    liftM6 MkMatch (fromYAML aa) (fromYAML ab) (fromYAML ac) (fromYAML ad) (fromYAML ae) (fromYAML af)+	_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["MkMatch"] ++ " in node " ++ show e+    fromYAML e = fail $ "no tag found: expecting " ++ show ["MkMatch"] ++ " in node " ++ show e+    asYAML (MkMatch aa ab ac ad ae af) = asYAMLseq "MkMatch"+	   [asYAML aa, asYAML ab, asYAML ac, asYAML ad, asYAML ae, asYAML af]++instance YAML CompUnit where+    fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of+	"MkCompUnit" -> do+	    let ESeq [aa, ab, ac, ad] = e+	    liftM4 MkCompUnit (fromYAML aa) (fromYAML ab) (fromYAML ac) (fromYAML ad)+	_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["MkCompUnit"] ++ " in node " ++ show e+    fromYAML e = fail $ "no tag found: expecting " ++ show ["MkCompUnit"] ++ " in node " ++ show e+    asYAML (MkCompUnit aa ab ac ad) = asYAMLseq "MkCompUnit"+	   [asYAML aa, asYAML ab, asYAML ac, asYAML ad]++instance YAML VMultiCode where+    fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of+	"MkMultiCode" -> do+	    let ESeq [aa, ab, ac, ad, ae] = e+	    liftM5 MkMultiCode (fromYAML aa) (fromYAML ab) (fromYAML ac) (fromYAML ad) (fromYAML ae)+	_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["MkMultiCode"] ++ " in node " ++ show e+    fromYAML e = fail $ "no tag found: expecting " ++ show ["MkMultiCode"] ++ " in node " ++ show e+    asYAML (MkMultiCode aa ab ac ad ae) = asYAMLseq "MkMultiCode"+	   [asYAML aa, asYAML ab, asYAML ac, asYAML ad, asYAML ae]++instance YAML VJunc where+    fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of+	"MkJunc" -> do+	    let ESeq [aa, ab, ac] = e+	    liftM3 MkJunc (fromYAML aa) (fromYAML ab) (fromYAML ac)+	_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["MkJunc"] ++ " in node " ++ show e+    fromYAML e = fail $ "no tag found: expecting " ++ show ["MkJunc"] ++ " in node " ++ show e+    asYAML (MkJunc aa ab ac) = asYAMLseq "MkJunc"+	   [asYAML aa, asYAML ab, asYAML ac]++instance YAML JuncType where+    fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of+	"JAny" -> do+	    return JAny+	"JAll" -> do+	    return JAll+	"JNone" -> do+	    return JNone+	"JOne" -> do+	    return JOne+	_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["JAny","JAll","JNone","JOne"] ++ " in node " ++ show e+    fromYAML e = fail $ "no tag found: expecting " ++ show ["JAny","JAll","JNone","JOne"] ++ " in node " ++ show e+    asYAML (JAny) = asYAMLcls "JAny"+    asYAML (JAll) = asYAMLcls "JAll"+    asYAML (JNone) = asYAMLcls "JNone"+    asYAML (JOne) = asYAMLcls "JOne"++instance YAML Scope where+    fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of+	"SState" -> do+	    return SState+	"SConstant" -> do+	    return SConstant+	"SHas" -> do+	    return SHas+	"SMy" -> do+	    return SMy+	"SOur" -> do+	    return SOur+	_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["SState","SConstant","SHas","SMy","SOur"] ++ " in node " ++ show e+    fromYAML e = fail $ "no tag found: expecting " ++ show ["SState","SConstant","SHas","SMy","SOur"] ++ " in node " ++ show e+    asYAML (SState) = asYAMLcls "SState"+    asYAML (SConstant) = asYAMLcls "SConstant"+    asYAML (SHas) = asYAMLcls "SHas"+    asYAML (SMy) = asYAMLcls "SMy"+    asYAML (SOur) = asYAMLcls "SOur"++instance JSON Scope where+    showJSON (SState) = showJSScalar "SState"+    showJSON (SConstant) = showJSScalar "SConstant"+    showJSON (SHas) = showJSScalar "SHas"+    showJSON (SMy) = showJSScalar "SMy"+    showJSON (SOur) = showJSScalar "SOur"++instance Perl5 Scope where+    showPerl5 (SState) = showP5Class "SState"+    showPerl5 (SConstant) = showP5Class "SConstant"+    showPerl5 (SHas) = showP5Class "SHas"+    showPerl5 (SMy) = showP5Class "SMy"+    showPerl5 (SOur) = showP5Class "SOur"++instance YAML Pad where+    fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of+	"MkPad" -> do+	    let ESeq [aa] = e+	    liftM MkPad (fromYAML aa)+	_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["MkPad"] ++ " in node " ++ show e+    fromYAML e = fail $ "no tag found: expecting " ++ show ["MkPad"] ++ " in node " ++ show e+    asYAML (MkPad aa) = asYAMLseq "MkPad" [asYAML aa]++instance YAML Pos where+    fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of+	"MkPos" -> do+	    let ESeq [aa, ab, ac, ad, ae] = e+	    liftM5 MkPos (fromYAML aa) (fromYAML ab) (fromYAML ac) (fromYAML ad) (fromYAML ae)+	_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["MkPos"] ++ " in node " ++ show e+    fromYAML e = fail $ "no tag found: expecting " ++ show ["MkPos"] ++ " in node " ++ show e+    asYAML (MkPos aa ab ac ad ae) = asYAMLseq "MkPos"+	   [asYAML aa, asYAML ab, asYAML ac, asYAML ad, asYAML ae]++instance JSON Pos where+    showJSON (MkPos aa ab ac ad ae) = showJSHashObj "MkPos"+	     [("posName", showJSON aa), ("posBeginLine", showJSON ab),+	      ("posBeginColumn", showJSON ac), ("posEndLine", showJSON ad),+	      ("posEndColumn", showJSON ae)]++instance Perl5 Pos where+    showPerl5 (MkPos aa ab ac ad ae) = showP5HashObj "MkPos"+	      [("posName", showPerl5 aa) , ("posBeginLine", showPerl5 ab) ,+	       ("posBeginColumn", showPerl5 ac) , ("posEndLine", showPerl5 ad) ,+	       ("posEndColumn", showPerl5 ae)]++instance YAML Type where+    fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of+	"MkType" -> do+	    let ESeq [aa] = e+	    liftM MkType (fromYAML aa)+	"TypeOr" -> do+	    let ESeq [aa, ab] = e+	    liftM2 TypeOr (fromYAML aa) (fromYAML ab)+	"TypeAnd" -> do+	    let ESeq [aa, ab] = e+	    liftM2 TypeAnd (fromYAML aa) (fromYAML ab)+	_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["MkType","TypeOr","TypeAnd"] ++ " in node " ++ show e+    fromYAML e = fail $ "no tag found: expecting " ++ show ["MkType","TypeOr","TypeAnd"] ++ " in node " ++ show e+    asYAML (MkType aa) = asYAMLseq "MkType" [asYAML aa]+    asYAML (TypeOr aa ab) = asYAMLseq "TypeOr" [asYAML aa, asYAML ab]+    asYAML (TypeAnd aa ab) = asYAMLseq "TypeAnd" [asYAML aa, asYAML ab]++instance JSON Type where+    showJSON (MkType aa) = showJSArrayObj "MkType" [showJSON aa]+    showJSON (TypeOr aa ab) = showJSArrayObj "TypeOr"+	     [showJSON aa, showJSON ab]+    showJSON (TypeAnd aa ab) = showJSArrayObj "TypeAnd"+	     [showJSON aa, showJSON ab]++instance Perl5 Type where+    showPerl5 (MkType aa) = showP5ArrayObj "MkType" [showPerl5 aa]+    showPerl5 (TypeOr aa ab) = showP5ArrayObj "TypeOr"+	      [showPerl5 aa , showPerl5 ab]+    showPerl5 (TypeAnd aa ab) = showP5ArrayObj "TypeAnd"+	      [showPerl5 aa , showPerl5 ab]++instance YAML Cxt where+    fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of+	"CxtVoid" -> do+	    return CxtVoid+	"CxtItem" -> do+	    let ESeq [aa] = e+	    liftM CxtItem (fromYAML aa)+	"CxtSlurpy" -> do+	    let ESeq [aa] = e+	    liftM CxtSlurpy (fromYAML aa)+	_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["CxtVoid","CxtItem","CxtSlurpy"] ++ " in node " ++ show e+    fromYAML e = fail $ "no tag found: expecting " ++ show ["CxtVoid","CxtItem","CxtSlurpy"] ++ " in node " ++ show e+    asYAML (CxtVoid) = asYAMLcls "CxtVoid"+    asYAML (CxtItem aa) = asYAMLseq "CxtItem" [asYAML aa]+    asYAML (CxtSlurpy aa) = asYAMLseq "CxtSlurpy" [asYAML aa]++instance JSON Cxt where+    showJSON (CxtVoid) = showJSScalar "CxtVoid"+    showJSON (CxtItem aa) = showJSArrayObj "CxtItem" [showJSON aa]+    showJSON (CxtSlurpy aa) = showJSArrayObj "CxtSlurpy" [showJSON aa]++instance Perl5 Cxt where+    showPerl5 (CxtVoid) = showP5Class "CxtVoid"+    showPerl5 (CxtItem aa) = showP5ArrayObj "CxtItem" [showPerl5 aa]+    showPerl5 (CxtSlurpy aa) = showP5ArrayObj "CxtSlurpy"+	      [showPerl5 aa]++instance JSON Val where+    showJSON (VUndef) = showJSScalar "VUndef"+    showJSON (VBool aa) = showJSArrayObj "VBool" [showJSON aa]+    showJSON (VInt aa) = showJSArrayObj "VInt" [showJSON aa]+    showJSON (VRat aa) = showJSArrayObj "VRat" [showJSON aa]+    showJSON (VNum aa) = showJSArrayObj "VNum" [showJSON aa]+    showJSON (VStr aa) = showJSArrayObj "VStr" [showJSON aa]+    showJSON (VList aa) = showJSArrayObj "VList" [showJSON aa]+    showJSON (VType aa) = showJSArrayObj "VType" [showJSON aa]++instance YAML Pragma where+    fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of+	"MkPrag" -> do+	    let ESeq [aa, ab] = e+	    liftM2 MkPrag (fromYAML aa) (fromYAML ab)+	_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["MkPrag"] ++ " in node " ++ show e+    fromYAML e = fail $ "no tag found: expecting " ++ show ["MkPrag"] ++ " in node " ++ show e+    asYAML (MkPrag aa ab) = asYAMLseq "MkPrag" [asYAML aa, asYAML ab]++instance JSON Pragma where+    showJSON (MkPrag aa ab) = showJSHashObj "MkPrag"+	     [("pragName", showJSON aa), ("pragDat", showJSON ab)]++instance Perl5 Pragma where+    showPerl5 (MkPrag aa ab) = showP5HashObj "MkPrag"+	      [("pragName", showPerl5 aa) , ("pragDat", showPerl5 ab)]++--  Imported from other files :-+++#endif
+ src/Pugs/AST/Pad.hs view
@@ -0,0 +1,103 @@+{-# OPTIONS_GHC -fglasgow-exts -fparr #-}+module Pugs.AST.Pad (+  mkPad, unionPads, padKeys, filterPad, adjustPad, mergePadEntry,+  mergeLexPads, readMPad, writeMPad, appendMPad, modifyMPad, newMPad+) where+import Pugs.Internals+import Pugs.AST.SIO+import Pugs.AST.Internals+import Pugs.Types+import qualified Data.Map as Map+import qualified Data.Set as Set++instance Monoid Pad where+    mempty  = emptyPad+    mappend = unionPads+    mconcat = MkPad . Map.unionsWith mergePadEntry . map padEntries++{-|+Produce a 'Pad' from a list of bindings. The inverse of 'padToList'.++Not to be confused with the actual 'Pad' constructor @MkPad@.+-}+mkPad :: [(Var, PadEntry)] -> Pad+mkPad = listToPad++{-|+Merge multiple (possibly mutable) pads into one.+-}+mergeLexPads :: MonadSTM m => LexPads -> m Pad+mergeLexPads chain = stm $ do+    pads <- forM chain $ \lpad -> case lpad of+        PRuntime p      -> return p+        PCompiling p    -> readMPad p+    return . MkPad $ Map.unionsWith mergePadEntry (map padEntries pads)++readMPad :: MonadSTM m => MPad -> m Pad+readMPad = stm . readTVar . mp_pad++writeMPad :: MonadSTM m => MPad -> Pad -> m ()+writeMPad mp p = stm $ writeTVar (mp_pad mp) p++appendMPad :: MonadSTM m => MPad -> Pad -> m ()+appendMPad mp p = stm $ modifyTVar (mp_pad mp) (`unionPads` p)++modifyMPad :: MonadSTM m => MPad -> (Pad -> Pad) -> m ()+modifyMPad mp f = stm $ modifyTVar (mp_pad mp) f++newMPad :: MonadSTM m => Pad -> m MPad+newMPad p = do+    tvar <- stm $ newTVar p+    return $ MkMPad (addressOf tvar) tvar++{-+{-|+Return the difference between two 'Pad's.++Any keys found in both pads that has identical values are removed from the+resulting pad.  Keys found only in the second pad are ignored.+-}+diffPads :: Pad -> Pad -> Pad+diffPads (MkPad map1) (MkPad map2) = MkPad $ Map.differenceWith diffPadEntry map1 map2+    where+    diffPadEntry x y | x == y    = Nothing+                     | otherwise = Just x+-}++{-|+Return the key-wise union of two 'Pad's.++If the same key is found in both pads, merging multi subs into one.+-}+unionPads :: Pad -> Pad -> Pad+unionPads (MkPad map1) (MkPad map2) = MkPad $ Map.unionWith mergePadEntry map1 map2++adjustPad :: (PadEntry -> PadEntry) -> Var -> Pad -> Pad+adjustPad f v (MkPad p) = MkPad (Map.adjust f v p)++mergePadEntry :: PadEntry -> PadEntry -> PadEntry+mergePadEntry+    PEConstant{ pe_proto = MkRef (ICode newCV), pe_flags = flags }+    PEConstant{ pe_proto = MkRef (ICode oldCV) }+    | Just (newMC :: VMultiCode) <- fromTypeable newCV+    , Just (oldMC :: VMultiCode) <- fromTypeable oldCV+    = PEConstant+        { pe_type  = mc_type newMC -- XXX - Select a narrower type?+        , pe_proto = MkRef . ICode $! MkMultiCode+            { mc_type       = mc_type newMC+            , mc_subtype    = mc_subtype newMC+            , mc_assoc      = code_assoc newMC `mappend` code_assoc oldMC+            , mc_signature  = if length (mc_signature newMC) == length (code_params oldMC)+                then code_params newMC+                else [defaultArrayParam]+            , mc_variants   = mc_variants newMC `Set.union` mc_variants oldMC+            }+        , pe_flags          = flags+        }+mergePadEntry x _ = x++padKeys :: Pad -> Set Var+padKeys (MkPad pad) = Map.keysSet pad++filterPad :: (Var -> Bool) -> Pad -> Pad+filterPad f (MkPad pad) = MkPad (Map.filterWithKey (\k _ -> f k) pad)
+ src/Pugs/AST/Pos.hs view
@@ -0,0 +1,27 @@+{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans -funbox-strict-fields #-}++module Pugs.AST.Pos (+    Pos(..),+) where+import Data.Typeable+import Data.ByteString (ByteString)++{-|+Represents the position of a chunk of source code: filename; start+line & column; end line & column.++Not to be confused with the 'Exp' constructor of the same name, which stores+a sub-tree and its associated 'Pos'.+-}+data Pos = MkPos+    { posName           :: !ByteString -- ^ Source file name+    , posBeginLine      :: !Int+    , posBeginColumn    :: !Int+    , posEndLine        :: !Int+    , posEndColumn      :: !Int+    }+    deriving (Eq, Ord, Typeable)++instance Show Pos where+    show (MkPos name bln bcl eln ecl) = "(MkPos " ++ show name ++ " " +++        (unwords . map show $ [bln, bcl, eln, ecl]) ++ ")"
+ src/Pugs/AST/Prag.hs view
@@ -0,0 +1,26 @@+{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans -funbox-strict-fields #-}++module Pugs.AST.Prag (+    Pragma(..),+) where+import Data.Typeable++{-|+Represents lexical pragmas associated with a statement: each of these+is node in a linked list, containing the name of the pragma and some+data associated with this node. For now the data is limited to a native+Int, but we'll figure out how to extend this sometime.++Not to be confused with the 'Exp' constructor of the same name, which stores+a sub-tree and its associated 'Prag'.+-}++data Pragma = MkPrag+    { pragName           :: !String -- ^ Name of pragma+    , pragDat            :: !Int    -- ^ (lexically scoped) pragmatic data+                                    --     This element is subject to change;+                                    --     we don't necessarily want to limit+                                    --     ourselves to 32 bit ints.+    }+    deriving (Show, Eq, Ord, Typeable)+
+ src/Pugs/AST/SIO.hs view
@@ -0,0 +1,81 @@+{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans -funbox-strict-fields #-}++module Pugs.AST.SIO (+    MonadSTM(..),++    SIO,++    runSTM, runIO, liftIO, runSIO, stm, io,++    module Control.Concurrent.STM+) where+import Pugs.Internals+import Control.Concurrent.STM++instance Monad m => ((:>:) (m a)) (Identity a) where cast = return . runIdentity+instance ((:>:) (SIO a)) (STM a) where cast = liftSTM++data SIO a = MkSTM !(STM a) | MkIO !(IO a) | MkSIO !a+    deriving (Typeable)++{-# INLINE runSIO #-}+{-# SPECIALISE runSIO :: SIO () -> Maybe () #-}+{-# SPECIALISE runSIO :: SIO () -> Either String () #-}+runSIO :: Monad m => SIO a -> m a+runSIO MkSTM{}      = fail "Unsafe STM caught in pure computation"+runSIO MkIO{}       = fail "Unsafe IO caught in pure computation"+runSIO (MkSIO x)    = return x++{-# INLINE runSTM #-}+{-# SPECIALISE runSTM :: SIO () -> STM () #-}+runSTM :: SIO a -> STM a+runSTM (MkSTM stm)  = stm+runSTM MkIO{}       = fail "Unsafe IO caught in STM"+runSTM (MkSIO x)    = return x++{-# INLINE runIO #-}+{-# SPECIALISE runIO :: SIO () -> IO () #-}+runIO :: SIO a -> IO a+runIO (MkIO io)     = io+runIO (MkSTM stm)   = atomically stm+runIO (MkSIO x)     = return x++instance Monad SIO where+    return a = MkSIO a+    (MkIO io)   >>= k = MkIO $ do { a <- io; runIO (k a) }+    (MkSTM stm) >>= k = MkSTM $ do { a <- stm; runSTM (k a) }+    (MkSIO x)   >>= k = k x++instance Functor SIO where+    fmap = liftM++-- | Typeclass of monadic types that an @STM@ monad can be lifted to.+class (Monad m, Functor m) => MonadSTM m where+    liftSIO :: SIO a -> m a+    liftSIO = fail "liftSIO not detailed for this monad"+    {-# SPECIALISE liftSTM :: STM a -> STM a #-}+    {-# SPECIALISE liftSTM :: STM a -> IO a #-}+    {-# SPECIALISE liftSTM :: STM a -> SIO a #-}+    liftSTM :: STM a -> m a++instance MonadSTM STM where+    liftSTM = id+    liftSIO = runSTM++instance MonadSTM IO where+    liftSTM = atomically+    liftSIO = runIO++instance MonadSTM SIO where+    liftSTM stm = MkSTM stm+    liftSIO = id++instance MonadIO SIO where+    liftIO io = MkIO io++{-# INLINE stm #-}+stm :: (MonadSTM m) => STM a -> m a+stm = liftSTM++io :: (MonadIO m) => IO a -> m a+io = liftIO
+ src/Pugs/AST/Scope.hs view
@@ -0,0 +1,14 @@+{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans -funbox-strict-fields #-}++module Pugs.AST.Scope (+    Scope(..),+) where+import Data.Typeable++-- | The scope of a variable declaration.+data Scope = SMy        -- ^ Ordinary lexically scoped variable+           | SConstant  -- ^ Lexically scoped alias to package variable+           | SHas       -- ^ Object attribute+           | SState     -- ^ Persistent lexical (cloned with closures)+           | SOur       -- ^ Lexically scoped compile-time constant+    deriving (Show, Eq, Ord, Enum, Typeable, Bounded)
+ src/Pugs/AST/Utils.hs view
@@ -0,0 +1,174 @@+{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans -fallow-overlapping-instances -funbox-strict-fields -fallow-undecidable-instances #-}++module Pugs.AST.Utils where+import Pugs.Internals+import Pugs.Types+import qualified Data.Set       as Set+import qualified Data.IntMap    as IntMap++import Pugs.AST.SIO+import Pugs.AST.Eval+import {-# SOURCE #-} Pugs.AST.Internals++errIndex :: Show a => Maybe b -> a -> Eval b+errIndex (Just v) _ = return v+errIndex _ idx      = die "Modification of non-creatable array value attempted" idx++-- Three outcomes: Has value; can extend; cannot extend+getIndex :: Int -> Maybe a -> Eval [a] -> Maybe (Eval b) -> Eval a++getIndex idx def doList _ | idx < 0 = do+    -- first, check if the list is at least abs(idx) long.+    list <- doList+    if null (drop (abs (idx+1)) list)+        then errIndex def idx+        else return (list !! (idx `mod` (length list)))++-- now we are all positive; either extend or return+getIndex idx def doList ext = do+    list <- doList+    case drop idx list of+        [] -> case ext of+            Just doExt -> do { doExt ; getIndex idx def doList Nothing }+            Nothing    -> errIndex def idx+        (a:_) -> return a++{-|+If we are in list context (i.e. 'CxtSlurpy'), then perform the first+evaluation; otherwise perform the second.+-}+ifListContext :: (MonadReader Env m)+              => m t -- ^ The @then@ case+              -> m t -- ^ The @else@ case+              -> m t+ifListContext trueM falseM = do+    cxt <- asks envContext+    case cxt of+        CxtSlurpy _ -> trueM+        _           -> falseM++errType :: (Typeable a) => a -> String+errType x = show (typeOf x)++createObject :: VType -> [(VStr, Val)] -> Eval VObject+createObject typ attrList = do+    uniq    <- newObjectId+    createObjectRaw uniq Nothing typ attrList++newObjectId :: Eval ObjectId+newObjectId = do+    tv <- asks envMaxId+    stm $ do+        rv <- readTVar tv+        writeTVar tv (MkObjectId (succ (unObjectId rv)))+        return rv+        +castFailM :: forall a b. (Show a, Typeable b) => a -> String -> Eval b+castFailM v str = fail $ "Cannot cast from " ++ show v ++ " to " ++ errType (undefined :: b) ++ " (" ++ str ++ ")"++castFail :: forall a b. (Show a, Typeable b) => a -> String -> b+castFail v str = error $ "Cannot cast from " ++ show v ++ " to " ++ errType (undefined :: b) ++ " (" ++ str ++ ")"++class Unwrap a where+    {-|+    Unwrap a nested expression, throwing away wrappers (such as 'Cxt' or+    'Pos' to get at the more interesting expression underneath. Works both+    on individual 'Exp's, and elementwise on ['Exp']s.+    -}+    unwrap :: a -> a+    unwrap = id++{-|+Represents a junction value.++Note that @VJunc@ is also a pun for a 'Val' constructor /containing/ a 'VJunc'.+-}+data VJunc = MkJunc+    { juncType :: !JuncType -- ^ 'JAny', 'JAll', 'JNone' or 'JOne'+    , juncDup  :: !(Set Val)+    -- ^ Only used for @one()@ junctions. Contains those values+    --     that appear more than once (the actual count is+    --     irrelevant), since matching any of these would+    --     automatically violate the 'match /only/ one value'+    --     junctive semantics.+    , juncSet  :: !(Set Val)+    -- ^ Set of values that make up the junction. In @one()@+    --     junctions, contains the set of values that appear exactly+    --     /once/.+    } deriving (Typeable) {-!derive: YAML_Pos!-}++-- | The combining semantics of a junction. See 'VJunc' for more info.+data JuncType = JAny  -- ^ Matches if /at least one/ member matches+              | JAll  -- ^ Matches only if /all/ members match+              | JNone -- ^ Matches only if /no/ members match+              | JOne  -- ^ Matches if /exactly one/ member matches+    deriving (Eq, Ord, Typeable) {-!derive: YAML_Pos!-}+++showRat :: VRat -> String+showRat r+    | frac == 0 = s ++ show quot+    | otherwise = s ++ show quot ++ "." ++ showFrac frac+    where+    n = numerator r+    d = denominator r+    s = if signum n < 0 then "-" else ""+    (quot, rem) = quotRem (abs n) d+    frac :: VInt+    frac = round ((rem * (10 ^ (40 :: VInt))) % d)+    showFrac = reverse . dropWhile (== '0') . reverse . pad . show+    pad x = (replicate (40 - length x) '0') ++ x++showTrueRat :: VRat -> String+showTrueRat r =+    (show n) ++ "/" ++ (show d)+    where+    n = numerator r+    d = denominator r++showNum :: Show a => a -> String+showNum x+    | str == "Infinity"+    = "Inf"+    | str == "-Infinity"+    = "-Inf"+    | (i, ".0") <- break (== '.') str+    = i -- strip the trailing ".0"+    | otherwise = str+    where+    str = show x++-- can be factored+{-|+Return the context implied by a particular primary sigil+(\$, \@, \% or \&). E.g. used to find what context to impose on+the RHS of a binding (based on the sigil of the LHS).+-}+cxtOfSigil :: VarSigil -> Cxt+cxtOfSigil SScalar      = cxtItemAny+cxtOfSigil SArray       = cxtSlurpyAny+cxtOfSigil SArrayMulti  = cxtSlurpyAny+cxtOfSigil SHash        = cxtSlurpyAny+cxtOfSigil SCode        = CxtItem $ mkType "Code"+cxtOfSigil SRegex       = CxtItem $ mkType "Regex"+cxtOfSigil SType        = CxtItem $ mkType "Type"++cxtOfSigilVar :: Var -> Cxt+cxtOfSigilVar = cxtOfSigil . v_sigil++{-|+Return the type of variable implied by a name beginning with the specified+sigil.+-}+typeOfSigil :: VarSigil -> Type+typeOfSigil SScalar     = mkType "Item"+typeOfSigil SArray      = mkType "Array"+typeOfSigil SArrayMulti = mkType "Array"+typeOfSigil SHash       = mkType "Hash"+typeOfSigil SCode       = mkType "Code"+typeOfSigil SRegex      = mkType "Regex"+typeOfSigil SType       = mkType "Type"++typeOfSigilVar :: Var -> Type+typeOfSigilVar = typeOfSigil . v_sigil+
+ src/Pugs/Bind.hs view
@@ -0,0 +1,270 @@+{-# OPTIONS_GHC -fglasgow-exts -fallow-overlapping-instances #-}++{-|+    Parameter binding.++>   A star was bound upon her brows,+>   A light was on her hair+>   As sun upon the golden boughs+>   In Lorien the fair...+-}++module Pugs.Bind (+    bindParams, bindSomeParams,+) where+import Pugs.Internals+import Pugs.AST+import Pugs.Types++{-|+Contains either a valid value of @a@ (@Right@), or a @String@ error+message (@Left@).+-}+type MaybeError a = Either String a++{-|+Match up named arguments with named parameters, producing a list of new+bindings, and lists of remaining unbound args and params.+-}+bindNames :: [Exp] -- ^ List of argument expressions to be bound+          -> [Param] -- ^ List of parameters to try binding; includes both+                     --     named params and positional params+          -> (Bindings, [Exp], [Param]) -- ^ Bindings made;+                                        --   remaining (unbound) named args;+                                        --   remaining (positional) params+bindNames exps prms = (bound, exps', prms')+    where+    prms' = prms \\ (map fst bound)+    (bound, exps') = foldr doBindNamed ([], []) (map unwrapNamedArg exps)+    doBindNamed (name, exp) (bound, exps) = case foundParam of+        Just prm -> ( ((prm, exp) : bound), exps )+        _        -> ( bound, (Syn "named" [Val (VStr $ cast name), exp]:exps) )+        where+        foundParam = find ((== name) . v_name . paramName) prms++emptyHashExp :: Exp+emptyHashExp  = Val $ VList [] -- VHash $ vCast $ VList []++emptyArrayExp :: Exp+emptyArrayExp = Val $ VList [] -- VArray $ vCast $ VList []++{-|+Create a binding from the slurpy hash parameter (e.g. @\*%_@) to a hash+containing all the remaining named arguments. If multiple slurpy hashes+are given, only the first gets the arguments--the rest get an empty hash.+Used by 'bindSomeParams'.+-}+bindHash :: [Exp]   -- ^ Named arguments (pair expressions) that were not+                    --     consumed by explicit named parameters+         -> [Param] -- ^ List of slurpy hash parameters+         -> MaybeError Bindings+bindHash [] []          = return []+bindHash [] [p]         = return [ (p, emptyHashExp) ]+bindHash (v:_) []       = fail $ "Named argument found where no matched parameter expected: " ++ show (unwrapNamedArg v)+bindHash vs (p:ps@(_:_))= do+    first <- (bindHash vs [p])+    return $ first ++ (ps `zip` repeat emptyHashExp)+bindHash vs [p]         = return [ (p, Syn "\\{}" [Syn "," vs]) ] -- XXX cast to Hash++{-|+Create bindings from the slurpy scalar and array parameters to the remaining+positional arguments. The first slurpy array param gets all of the remaining+args; subsequent slurpy array params get an empty array. Slurpy scalars may+not appear after slurpy array params.++Returns the bindings performed, and the sub's new 'SlurpLimit'.++Mostly uses 'doBindArray' to do its dirty work. Used by 'bindSomeParams'.++>[12:16] <scook0> autrijus: At the moment, if you call a sub that has multiple slurpy arrays, +>                   Pugs deliberately binds the first one normally, and makes all the rest empty+>[12:17] <scook0> Is this proper behaviour, or is it just a quirk of the current implementation?+>[12:17] <autrijus> no, that's specced.+>[12:17] <autrijus> i.e. correct+-}+bindArray :: [Exp]      -- ^ List of slurpable argument expressions+          -> [Param]    -- ^ List of all slurpy positional params (scalar and array)+          -> SlurpLimit -- ^ The sub's current 'SlurpLimit'+          -> MaybeError (Bindings, SlurpLimit)+bindArray vs ps oldLimit = do+    let exp = Ann (Cxt cxtSlurpyAny) (Syn "," vs)+    case foldM (doBindArray exp) ([], 0) prms of+        Left errMsg      -> fail errMsg+        Right (bound, n) -> do+            let newLimit = case prms of+                    ((_, SArray):_) -> oldLimit+                    ((_, SArrayMulti):_) -> oldLimit+                    _    | n > 0 -> (n, exp) : oldLimit+                    _            -> oldLimit+            return (reverse bound, newLimit)+    where+    prms = map (\p -> (p, v_sigil $ paramName p)) ps ++{-|+Construct an expression representing an infinite slice of the given+array expression, beginning at element /n/ (i.e. @\@array\[\$n...\]@).++Used by 'doBindArray' to bind a slurpy array parameter to the rest of+the slurpable arguments.+-}+doSlice :: Exp -- ^ The array expression to slice+        -> VInt -- ^ Index of the first element in the resulting slice (/n/)+        -> Exp +doSlice v n = Syn "[...]" [v, Val $ VInt n]++-- XXX - somehow force failure+{-|+Construct an expression representing element /n/ in the given array+expression (i.e. @\@array\[\$n\]@).++Used by 'doBindArray' to bind a particular slurpy scalar parameter to one of +the slurpable arguments.+-}+doIndex :: Exp -> VInt -> Exp+doIndex v n = Syn "[]" [Syn "val" [v], Val $ VInt n]++doBindArray :: Exp -> (Bindings, VInt) -> (Param, VarSigil) -> MaybeError (Bindings, VInt)+doBindArray _ (xs, -1) (p, SArray) = return (((p, emptyArrayExp):xs), -1)+doBindArray _ (_, -1)  (p, _) = fail $ "Slurpy array followed by slurpy scalar: " ++ show p+doBindArray v (xs, n)  (p, SArray) = return (((p, doSlice v n):xs), -1)+doBindArray v (xs, n)  (p, _) = case v of+    (Syn "," [])    -> fail $ "Insufficient arguments for slurpy scalar"+    _               -> return (((p, doIndex v n):xs), n+1)+-- doBindArray _ (_, _)  (_, x) = internalError $ "doBindArray: unexpected char: " ++ (show x)+++isNamedArg :: Exp -> Bool+isNamedArg (Syn "named" [(Val (VStr _)), _]) = True+isNamedArg (Syn "named" [Ann _ (Val (VStr _)), _]) = True -- should the Ann reach here?+isNamedArg arg@(Syn "named" _)               = error $ "malformed named arg: " ++ show arg+isNamedArg _                                 = False++unwrapNamedArg :: Exp -> (ID, Exp)+unwrapNamedArg (Syn "named" [(Val (VStr key)), val]) = (cast key, val)+unwrapNamedArg (Syn "named" [Ann _ (Val (VStr key)), val]) = (cast key, val) -- (see comment in isNamedArg)+unwrapNamedArg x = error $ "not a well-formed named arg: " ++ show x++{-|+Bind parameters to a callable, then verify that the binding is complete+(i.e. all mandatory params are bound; all unspecified params have default+bindings).++Uses 'bindSomeParams' to perform the initial binding, then uses+'finalizeBindings' to check all required params and give default values to+any unbound optional ones. Once this is complete, /everything/ should be+bound.++Note that while 'bindParams' produces values /representing/ the bindings from+params to args, it does not actually introduce any symbols--that occurs later+on in the call process.+-}+bindParams :: VCode       -- ^ A code object to perform bindings on+           -> (Maybe Exp) -- ^ (Optional) explicit invocant+           -> [Exp]       -- ^ List of arguments (actual params) to bind+           -> MaybeError VCode -- ^ Returns either a new 'VCode' with all the+                               --     bindings in place, or an error message+-- Special case: 'close $fh' should be bound as '$fh.close'+bindParams sub Nothing [inv]+    | (p:_) <- subParams sub, isInvocant p+    = bindParams sub (Just inv) []+bindParams sub invExp argsExp = do+    case bindSomeParams sub invExp argsExp of+        Left errMsg -> Left errMsg+        Right boundSub -> finalizeBindings boundSub++{-|+Verify that all invocants and required parameters are bound, and give default+values to any unbound optional parameters.+-}+finalizeBindings :: VCode -> MaybeError VCode+finalizeBindings sub = do+    let params    = subParams sub+        bindings  = subBindings sub+        boundInvs = filter (isInvocant . fst) bindings    -- bound invocants+        invocants = takeWhile isInvocant params           -- expected invocants++    -- Check that we have enough invocants bound+    when (not . null $ invocants) $ do+        let missing  = show (length invocants)+            supplied = show (length boundInvs)+        fail $ concat+            [ "Missing invocant parameters in '"+            , cast (subName sub)+            , "': "+            , supplied, " received, "+            , missing,  " missing"+            ]+            +    let (boundOpt, boundReq) = partition (isOptional . fst) bindings -- bound params which are required+        (optPrms, reqPrms)   = partition isOptional params -- all params which are required, and all params which are opt++    -- Check length of required parameters+    when (length boundReq < length reqPrms) $ do+        fail $ "Missing required parameters: "+            ++ unwords (map (cast . paramName) $ reqPrms \\ map fst boundReq)++    let unboundOptPrms = optPrms \\ (map fst boundOpt) -- unbound optParams are allPrms - boundPrms+        optPrmsDefaults = [+            Syn "param-default" [paramDefault prm, Val (VCode sub)]+            | prm <- unboundOptPrms+            ] -- get a list of default values+        boundDefOpts = unboundOptPrms `zip` optPrmsDefaults -- turn into exprs, so that +$y = $x will work+        +    return sub {+        subBindings = ((subBindings sub) ++ boundDefOpts)+    }++{-|+Take a code object and lists of invocants and arguments, and produce (if+possible) a new 'VCode' value representing the same code object, with as many+parameters bound as possible (using the given invocants and args).+-}+bindSomeParams :: VCode       -- ^ Code object to perform bindings on+               -> (Maybe Exp) -- ^ Explicit invocant expression+               -> [Exp]       -- ^ List of argument expressions+               -> MaybeError VCode -- ^ A new 'VCode' structure, augmented+                                   --     with the new bindings+bindSomeParams sub invExp argsExp = do+    let params     = subParams sub+        bindings   = subBindings sub+        slurpLimit = subSlurpLimit sub+        (invPrms, argPrms) = span isInvocant params+        (givenInvs, givenArgs) = if null invPrms+            then ([], (maybeToList invExp++argsExp))+            else (maybeToList invExp, argsExp)++    let boundInv                = invPrms `zip` givenInvs -- invocants are just bound, params to given+        (namedArgs, posArgs)    = partition isNamedArg givenArgs+        (boundNamed, namedForSlurp, allPosPrms) = bindNames namedArgs argPrms -- bind pair args to params. namedForSlup = leftover pair args+        (itemPrms, slurpyPrms)  = break isSlurpy allPosPrms -- split any prms not yet bound, into regular and slurpy. allPosPrms = not bound by named+        posPrms                 = filter (not . isNamed) itemPrms+        boundPos                = posPrms `zip` posArgs -- bind all the unbound params in positional order+        posForSlurp             = drop (length posPrms) posArgs -- and whatever's left will be slurped++    -- Bind slurpy arrays and hashes+    let (slurpNamed, slurpPos) = partition ((SHash ==) . v_sigil . paramName) slurpyPrms+        -- defaultPos      = if hasDefaultArray  then [] else [defaultArrayParam]+        defaultScalar   = if hasDefaultScalar then [] else [] -- XXX - fetch from *@_+        hasDefaultScalar= isJust (find ((varTopic ==) . paramName) params)+        +    boundHash   <- bindHash namedForSlurp slurpNamed -- put leftover named args in %_+    (boundArray, newSlurpLimit) <- bindArray posForSlurp slurpPos slurpLimit+    boundScalar <- return $ defaultScalar `zip` (givenInvs ++ givenArgs) -- put, uh, something in $_++    let newParams = params \\ (map fst newBindings);+        newBindings = concat+            [ bindings      -- Existing bindings+            , boundInv      -- Newly bound invocants+            , boundNamed    -- ...nameds+            , boundPos      -- ...positional+            , boundHash     -- ...*%hash+            , boundArray    -- ...*@array+            , boundScalar   -- ...*$scalar+            ]+    +    return sub+        { subBindings   = newBindings+        , subParams     = newParams+        , subSlurpLimit = newSlurpLimit+        }+
+ src/Pugs/Class.hs view
@@ -0,0 +1,178 @@+{-# OPTIONS_GHC -fglasgow-exts -fparr -fallow-undecidable-instances -fallow-incoherent-instances #-}++{-|+    Class meta-model.  (object meta-meta-model)++>   Learn now the lore of Living Creatures!+>   First name the four, the free peoples:+>   Eldest of all, the elf-children;+>   Dwarf the delver, dark are his houses;+>   Ent the earthborn, old as mountains;+>   Man the mortal, master of horses...+-}++module Pugs.Class+    ( module Pugs.Class+    , module Pugs.AST.Eval+    , module MO.Run+    , module MO.Compile+    , module MO.Compile.Class+    , module MO.Util+    , module Control.Monad.Fix+    ) where+import MO.Run hiding (__)+import MO.Compile+import MO.Compile.Class+import MO.Util hiding (traceM, traceShow)+import Pugs.Internals+import Pugs.AST.Eval+import Control.Monad.Fix+import qualified StringTable.AtomMap as AtomMap+import qualified Data.Typeable as Typeable++type Val = Invocant Eval+type Call = MethodInvocation Eval++class (Show a, Typeable a, Ord a) => Boxable a where+    mkVal :: a -> Val+    mkVal x = MkInvocant x (class_interface (classOf x))++    coerceVal :: Val -> Eval a+    coerceVal (MkInvocant x _) = case Typeable.cast x of+        Just y -> return y+        _      -> fail $ "Cannot coerce from " ++ (show $ typeOf x) ++ " to " ++ (show $ typeOf (undefined :: a))++    instanceMethods :: [(ID, MethodPrim a)]+    instanceMethods = []++    classOf :: a -> PureClass+    classOf _ = mkPureClass (classNameOf (undefined :: a)) (instanceMethods :: [(ID, MethodPrim a)])++    classNameOf :: a -> String+    classNameOf _ = takeTypeName "" . reverse . show . typeOf $ (undefined :: a)+        -- Here we intuit "Str" from "Pugs.Val.Str.PureStr".+        where+        takeTypeName acc [] = acc+        takeTypeName acc (x:xs)+            | isLower x = takeTypeName (x:acc) xs+            | otherwise = x:acc++type MethodPrim a = (a -> [:Val:] -> Eval Val)++class Boxable b => MethodPrimable a b | a -> b where +    asPrim :: a -> MethodPrim b++instance Boxable a => MethodPrimable Val a where+    asPrim v _ _ = return v++instance Boxable a => MethodPrimable Call a where+    asPrim 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))++instance MethodPrimable (a -> b -> c -> Eval z) a => MethodPrimable (a -> b -> c -> z) a where+    asPrim f = asPrim ((\x y args -> return (f x y args)) :: (a -> b -> c -> Eval z))++instance (Boxable a, Boxable z) => MethodPrimable (a -> z) a where+    asPrim f x _ = return (mkVal (f x))++instance (Boxable a, Boxable z) => MethodPrimable (a -> Eval z) a where+    asPrim f x _ = fmap mkVal (f x)++instance (Boxable a, Boxable z) => MethodPrimable (a -> Val -> Eval z) a where+    asPrim f x args = fmap mkVal (f x (args !: 0))++instance (Boxable a, Boxable z) => MethodPrimable (a -> [:Val:] -> Eval z) a where+    asPrim f x args = fmap mkVal (f x args)++instance (Boxable a, Boxable z) => MethodPrimable (a -> [Val] -> Eval z) a where+    asPrim f x args = fmap mkVal (f x (cast args))++instance (Boxable a, Boxable b, Boxable z) => MethodPrimable (a -> [b] -> Eval z) a where+    asPrim f x args = do+        args' <- mapM coerceVal (cast args)+        fmap mkVal (f x args')++instance (Boxable a, Boxable b, Boxable z) => MethodPrimable (a -> b -> Eval z) a where+    asPrim f x args = do+        y <- coerceVal (args !: 0)+        fmap mkVal (f x y)++instance (Boxable a, Boxable b, Boxable c, Boxable z) => MethodPrimable (a -> b -> c -> Eval z) a where+    asPrim f x args = do+        y <- coerceVal (args !: 0)+        z <- coerceVal (args !: 1)+        fmap mkVal (f x y z)++(...) :: MethodPrimable a b => String -> a -> (ID, MethodPrim b)+(...) x y = (_cast x, asPrim y)++(!!!) :: Boxable b => String -> (a -> Eval b) -> (ID, a -> Eval Val)+(!!!) x y = (_cast x, mkValM . y)++mkValM :: Boxable a => Eval a -> Eval Val+mkValM x = do+    x' <- x+    return $ MkInvocant x' (class_interface (classOf x'))++mkBoxClass :: Boxable a => String -> [(ID, MethodPrim a)] -> PureClass+mkBoxClass cls methods = newMOClass MkMOClass+    { moc_parents         = []+    , moc_roles           = []+    , moc_attributes      = []+    , moc_public_methods  = newCollection' methodName $ map mkBoxMethod methods+    , moc_private_methods = newCollection []+    , moc_name            = _cast cls+    }++++-- | Variant of @mkBoxClass@ making use of the fixed-point combinator+-- to tye in its "self", and, that adds the standard HOW and WHICH methods.+-- 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+    , "ITEM"    ... id+    , "LIST"    ... id+    ]++raiseWhatError :: String -> a+raiseWhatError = error++mkBoxMethod :: forall a. Boxable a => (ID, MethodPrim a) -> AnyMethod Eval+mkBoxMethod (meth, fun) = MkMethod $ MkSimpleMethod+    { sm_name       = meth+    , sm_definition = MkMethodCompiled $ \args -> do+        inv  <- fromInvocant args :: Eval a+        fun inv $ concatMapP f_positionals (c_feeds args)+    }++type PureClass = MOClass Eval++instance (Show a, Typeable a, Ord a) => Boxable (Maybe a)++instance Boxable a => Boxable [a]+instance Boxable a => Boxable [:a:]++instance Boxable ID+instance Boxable PureClass where+    classOf _ = _PureClass++_PureClass :: PureClass+_PureClass = mkPureClass "Class"+    [ "methods"     ... ((filter (/= nullID) . map methodName . all_methods) :: PureClass -> [ID])+    ]++instance ((:>:) Call) String where+    cast = (`MkMethodInvocation` CaptSub{ c_feeds = [::] }) . _cast++instance ((:>:) Call) ByteString where+    cast = (`MkMethodInvocation` CaptSub{ c_feeds = [::] }) . cast++instance ((:>:) Call (ByteString, [Val], AtomMap Val)) where+    cast (meth, pos, named) = MkMethodInvocation (cast meth) CaptSub+        { c_feeds = [: MkFeed (toP pos) (AtomMap.map (\x -> [:x:]) named) :]}+
+ src/Pugs/CodeGen.hs view
@@ -0,0 +1,94 @@+{-# OPTIONS_GHC -fglasgow-exts #-}++{-|+    Code generation interface.++>   I sit beside the fire and think+>   of all that I have seen,+>   of meadow-flowers and butterflies+>   in summers that have been...+-}++module Pugs.CodeGen (codeGen, backends) where+import Pugs.AST+import Pugs.Pretty+import Pugs.Internals+import Pugs.CodeGen.PIL1 (genPIL1)+-- import Pugs.CodeGen.PIL2 (genPIL2, genPIL2Perl5, genPIL2JSON, genPIL2YAML)+import Pugs.CodeGen.PIR (genPIR, genPIR_YAML)+import Pugs.CodeGen.Perl5 (genPerl5)+import Pugs.CodeGen.YAML (genParseYAML, genParseHsYAML, genYAML)+import Pugs.CodeGen.JSON (genJSON)+import Pugs.Compile.Pugs (genPugs)+-- import Pugs.Compile.Haskell (genGHC)+-- import Pugs.CodeGen.XML (genXML)+import qualified Data.Map as Map++type Generator = FilePath -> Eval Val++generators :: Map String Generator+generators = Map.fromList $+    [ ("PIR",         genPIR)+    , ("PIR-YAML",    genPIR_YAML)+    , ("PIL1",        genPIL1)+    , ("PIL1-Perl5",  genPerl5)+    , ("PIL1-JSON",   genJSON)+    , ("PIL1-YAML",   genYAML)+--  , ("PIL2",        genPIL2)+--  , ("PIL2-Perl5",  genPIL2Perl5)+--  , ("PIL2-JSON",   genPIL2JSON)+--  , ("PIL2-YAML",   genPIL2YAML)+ -- , ("GHC",         genGHC)+    , ("Pugs",        genPugs)+    , ("Parse-YAML",  genParseYAML)+    , ("Parse-HsYAML",genParseHsYAML)+    , ("Parse-Pretty",const $ fmap (VStr . (++"\n") . pretty) (asks envBody))+--  , ("XML",         genXML)+    ]++backends :: [String]+backends = Map.keys generators++norm :: String -> String+norm = norm' . map toLower . filter isAlphaNum+    where+    norm' "ghc"    = "GHC"+    norm' "parrot" = "!PIR"+    norm' "pir"    = "PIR"+    norm' "piryaml"= "PIR-YAML"+    norm' "pil"    = "!PIL1"+    norm' "pil1"   = "PIL1"+--  norm' "pil2"   = "PIL2"+    norm' "perl5"  = "!PIL1-Perl5"+    norm' "json"   = "!PIL1-JSON"+    norm' "yaml"   = "!PIL1-YAML"+    norm' "pil1perl5"  = "PIL1-Perl5"+    norm' "pil1json"   = "PIL1-JSON"+    norm' "pil1yaml"   = "PIL1-YAML"+--  norm' "pil2perl5"  = "PIL2-Perl5"+--  norm' "pil2json"   = "PIL2-JSON"+--  norm' "pil2yaml"   = "PIL2-YAML"+    norm' "parseyaml"  = "Parse-YAML"+    norm' "parsehsyaml"= "Parse-HsYAML"+    norm' "parsepretty"= "Parse-Pretty"+    norm' "pugs"   = "Pugs"+    -- norm' "xml"    = "XML"+    norm' x        = x++doLookup :: String -> IO Generator+doLookup s = do+    case norm s of+        ('!':key) -> do+            hPutStrLn stderr $ "*** The backend '" ++ s ++ "' is deprecated."+            hPutStrLn stderr $ "    Please use '" ++ key ++ "' instead."+            Map.lookup key generators+        key -> Map.lookup key generators++codeGen :: String -> FilePath -> Env -> IO String+codeGen s file env = do+    gen <- catchIO (doLookup s) . const $ do+        fail $ "Cannot generate code for " ++ s ++ ": " ++ file+    rv <- runEvalIO env (gen file)+    case rv of+        VStr str    -> return str+        _           -> fail (show rv)
+ src/Pugs/CodeGen/JSON.hs view
@@ -0,0 +1,14 @@+{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances -fno-warn-orphans -funbox-strict-fields -cpp #-}++module Pugs.CodeGen.JSON (genJSON) where+import Pugs.AST+import Pugs.Compile+import Pugs.PIL1.Instances ()+import Pugs.PIL1+import DrIFT.JSON++-- XXX: do something useful with the filename arg+genJSON :: FilePath -> Eval Val+genJSON _ = do+    penv <- compile () :: Eval PIL_Environment+    return . VStr . unlines $ [showJSON penv]
+ src/Pugs/CodeGen/PIL1.hs view
@@ -0,0 +1,17 @@+{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances -fno-warn-orphans -funbox-strict-fields -cpp #-}++module Pugs.CodeGen.PIL1 (genPIL1) where+import Pugs.AST+import Pugs.PIL1.Instances ()+import Pugs.PIL1+import Pugs.Compile++genPIL1 :: FilePath -> Eval Val+genPIL1 _ = do+    penv <- compile ()+    return . VStr . unlines $+        [ "PIL_Environment"+        , "    { pilMain = (" ++ show (pilMain penv) ++ ")"+        , "    , pilGlob = (" ++ show (pilGlob penv) ++ ")"+        , "    }"+        ]
+ src/Pugs/CodeGen/PIR.hs view
@@ -0,0 +1,455 @@+{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances -fno-warn-orphans -funbox-strict-fields -cpp -fallow-overlapping-instances #-}++{-|+    This module provides 'genPIR', a function which compiles the current+    environment to PIR code.++    The general plan is to first compile the environment (subroutines,+    statements, etc.) to an abstract syntax tree ('PIL' -- Pugs Intermediate+    Language) using the 'compile' function and 'Compile' class, and then+    translate the PIL_to a data structure of type 'PIR' using the 'trans'+    function and 'Translate' class. This data structure is then reduced to+    final PIR code by "Emit.PIR".+-}++module Pugs.CodeGen.PIR (genPIR, genPIR_YAML) where+import Pugs.Internals+import Pugs.AST hiding (Sig(..), PureSig)+import Pugs.Types+import Pugs.PIL1+import Language.PIR+import Pugs.Pretty+import Text.PrettyPrint+import Pugs.CodeGen.PIR.Prelude (preludeStr)+import Pugs.Prim.Eval+import Pugs.Compile+import Pugs.Run (getLibs)+import DrIFT.YAML+import qualified Data.ByteString.UTF8 as Str++type CodeGen a = WriterT [Stmt] (ReaderT TEnv IO) a+type CodeGenMonad = WriterT [Stmt] (ReaderT TEnv IO)++ratToNum :: VRat -> VNum+ratToNum x = (fromIntegral $ numerator x) / (fromIntegral $ denominator x)++{-| Currently only 'PIL' → 'PIR' -}+class (Show a, Typeable b) => Translate a b | a -> b where+    trans :: a -> CodeGen b+    trans _ = fail "Untranslatable construct!"++instance EnterClass CodeGenMonad TCxt where+    enter cxt = local (\e -> e{ tCxt = cxt })++transError :: forall a b. Translate a b => a -> CodeGen b+transError = die $ "Translate error -- invalid "+    ++ (show $ typeOf (undefined :: b))++instance Translate PIL_Stmts [Stmt] where+    trans PNil = return []+    trans (PStmts this rest) = do+        thisC   <- trans this+        tell [thisC]+        trans rest+    trans (PPad SMy pad exps) = do+        valsC   <- mapM trans (map snd pad)+        pass $ do+            expsC   <- trans exps+            return ([], (StmtPad (map fst pad `zip` valsC) expsC:))+    trans (PPad _ pad exps) = do+        -- XXX - maybe warn about bad pads?+        trans (PPad SMy pad exps)++instance Translate PIL_Stmt Stmt where+    trans PNoop = return (StmtComment "")+    trans (PStmt (PLit (PVal VUndef))) = return $ StmtComment ""+    trans (PStmt (PLit (PVal VType{}))) = return $ StmtComment ""+    trans (PStmt exp) = do+        expC    <- trans exp+        return $ StmtIns $ InsExp expC+    trans (PPos pos exp rest) = do+        dep     <- asks tTokDepth+        tell [StmtComment $ (replicate dep ' ') ++ "{{{ " ++ pretty exp]+        expC    <- local (\e -> e{ tTokDepth = dep + 1 }) $ trans rest+        tell [StmtComment $ (replicate dep ' ') ++ "}}} " ++ pretty pos]+        return expC++instance Translate PIL_Expr Expression where+    trans (PRawName name) = fmap ExpLV $ genName name+    trans (PExp exp) = fmap ExpLV $ trans exp+    trans (PLit (PVal VUndef)) = do+        pmc     <- genScalar "undef"+        return $ ExpLV pmc+    trans (PLit (PVal VType{})) = do+        pmc     <- genScalar "undef"+        return $ ExpLV pmc+    trans (PLit lit) = do+        -- generate fresh supply and things...+        litC    <- trans lit+        pmc     <- genScalar "lit"+        tellIns $ pmc <== litC+        return $ ExpLV pmc+    trans (PThunk exp) = do+        [begL, _]  <- genLabel ["thunk", "thunkInit"]+        this    <- genPMC "thunk"+        let begP = begL ++ "_C"+        tellIns $ InsConst (VAR begP) Sub (lit begL)+        tellIns $ reg this <-- "newclosure" $ [bare begP]+        -- inner subroutine begins+        censor ((:[]) . StmtSub begL) $ do+            -- tellIns $ "push_eh" .- [bare initL]+            expC <- trans exp+            tellIns $ "set_returns" .- retSigList [expC]+            tellIns $ "returncc" .- []+        return (ExpLV this)+    trans (PCode styp params _ _ body) = do+        [begL]  <- genLabel ["block"]+        this    <- genPMC "block"+        let begP = begL ++ "_C"+        tellIns $ InsConst (VAR begP) Sub (lit begL)+        tellIns $ reg this <-- "newclosure" $ [bare begP]+        -- inner subroutine begins+        censor ((:[]) . StmtSub begL) $ do+            let prms = map tpParam params+            tell [StmtPad (map prmToPad prms) []]+            tellIns $ "get_params" .- sigList (map prmToSig prms)+            wrapSub styp $ do+                mapM storeLex params+                bodyC   <- case body of+                    PNil -> return nullPMC+                    _    -> trans body >> lastPMC+                tellIns $ "set_returns" .- retSigList [bodyC]+                tellIns $ "returncc" .- []+        return (ExpLV this)++prmToPad :: Param -> (VarName, Expression)+prmToPad prm = (cast (paramName prm), ExpLV (VAR $ prmToIdent prm))++isQualified :: String -> Maybe (String, String)+isQualified name+    | Just (post, pre) <- breakOnGlue "::" (reverse name) =+    let (sigil, pkg) = span (not . isAlphaNum) preName+        name'       = possiblyFixOperatorName (cast $ sigil ++ postName)+        preName     = reverse pre+        postName    = reverse post+    in case takeWhile isAlphaNum pkg of+        "OUTER"     -> Nothing+        "CALLER"    -> Nothing+        _           -> Just (pkg, cast name')+isQualified _ = Nothing++instance Translate PIL_Decl Decl where+    trans (PSub name styp params lvalue ismulti body) +        | Just (pkg, name') <- isQualified name = do+            declC <- trans $ PSub (cast name') styp params lvalue ismulti body+            return $ DeclNS (cast pkg) [declC]+    trans (PSub name styp params _ _ body) = do+        (_, stmts)  <- listen $ do+            let prms = map tpParam params+            tell [StmtPad (map prmToPad prms) []]+            tellIns $ "get_params" .- sigList (map prmToSig prms)+            -- tellIns $ "new_pad" .- [lit curPad]+            wrapSub styp $ do+                mapM storeLex params+                bodyC   <- case body of+                    PNil -> return nullPMC+                    _    -> trans body >> lastPMC+                tellIns $ "set_returns" .- retSigList [bodyC]+                tellIns $ "returncc" .- []+        return (DeclSub name [SubOUTER "MAIN"] stmts)++instance Translate PIL_Literal Expression where+    trans (PVal (VBool bool)) = return $ ExpLit (LitInt (toInteger $ fromEnum bool))+    trans (PVal (VStr str)) = return $ ExpLit (LitStr str)+    trans (PVal (VInt int)) = return $ ExpLit (LitInt int)+    trans (PVal (VNum num)) = return $ ExpLit (LitNum num)+    trans (PVal (VRat rat)) = return $ ExpLit (LitNum (ratToNum rat))+    -- trans (PVal (VList [])) = return $ LitInt 0 -- XXX Wrong+    trans (PVal (VCode code))+        | MkCode{ subBody = Syn "block" [ Ann _ exp ] } <- code+        , App (Var var) Nothing [] <- exp+        = fmap ExpLV (trans (PVar $ cast var))+    trans (PVal (VList vs)) = do+        pmc <- genArray "vlist"+        forM vs $ \val -> do+            valC <- trans (PVal val)+            tellIns $ "push" .- [pmc, valC]+        return pmc+    trans val@(PVal _) = transError val++instance Translate PIL_LValue LValue where+    trans (PVar name) | Just (pkg, name') <- isQualified (cast name) = do+        [globL] <- genLabel ["glob"]+        pmc     <- genScalar "glob"+        tell [StmtRaw (text "errorsoff .PARROT_ERRORS_GLOBALS_FLAG")]+        tellIns $ pmc       <-- "find_global" $ [lit pkg, lit name']+        -- XXX - change this to an unless_null call on parrot 0.4.2!+        tellIns $ tempINT   <-- "defined" $ [reg pmc]+        tellIns $ "if" .- [tempINT, bare globL]+        tellIns $ InsNew pmc PerlScalar+        tellIns $ "store_global" .- [lit pkg, lit name', reg pmc]+        tellLabel globL+        tell [StmtRaw (text "errorson .PARROT_ERRORS_GLOBALS_FLAG")]+        return pmc+    -- XXX - hack to erase OUTER before we have proper pad uplevel support+    trans (PVar name)+        | Just (package, name') <- breakOnGlue "::" name+        , Just (sig, "") <- breakOnGlue "OUTER" package+        = trans $ PVar (sig ++ name')+    trans (PVar name) = do+        pmc     <- genScalar "lex"+        tellIns $ pmc <-- "find_name" $ [lit $ possiblyFixOperatorName $ cast name]+        return pmc+    trans (PAssign [lhs] rhs) = do+        lhsC    <- enter tcLValue $ trans lhs+        rhsC    <- trans rhs+        tellIns $ lhsC <== rhsC+        return lhsC+    trans (PBind [PVar name] rhs) = do+        rhsC    <- trans rhs+        tellIns $ "store_lex" .- [lit name, rhsC]+        trans (PVar name)+    trans (PBind [lhs] rhs) = do+        lhsC    <- enter tcLValue $ trans lhs+        rhsC    <- trans rhs+        tellIns $ lhsC <:= rhsC+        return lhsC+    trans (PApp _ exp@PCode{} Nothing []) = do+        blockC  <- trans exp+        tellIns $ [reg tempPMC] <-& blockC $ []+        return tempPMC+    trans (PApp (TCxtLValue _) (PExp (PVar "&postcircumfix:[]")) Nothing [PExp lhs, rhs]) = do+        lhsC    <- trans lhs+        rhsC    <- trans rhs+        return $ lhsC `KEYED` rhsC+    trans (PApp ctx fun (Just inv) args) =+        trans (PApp ctx fun Nothing (inv:args))  -- XXX wrong+    trans (PApp _ fun Nothing args) = do+        funC <- trans fun {- case fun of+            PExp (PVar name) -> return $ lit name+            _           -> trans fun+        -}+        argsC   <- mapM trans args+        -- XXX WORKAROUND PARROT BUG (see below)+        pmc     <- genScalar "app"+        -- XXX - probe if funC is slurpy, then modify ExpLV pmc accordingly+        tellIns $ [reg pmc] <-& funC $ argsC+        return pmc+        {- XXX PARROT BUG -- tailcall broken+        case cxt of+            TTailCall _ -> do+                tellIns $ InsTailFun funC argsC+                return nullPMC+            _ -> do+                pmc     <- genScalar "app"+                -- XXX - probe if funC is slurpy, then modify ExpLV pmc accordingly+                tellIns $ [reg pmc] <-& funC $ argsC+                return pmc+        -}+    trans x = transError x++instance LiteralClass Var where+    lit = ExpLit . LitStr . cast++instance LiteralClass ByteString where+    lit = ExpLit . LitStr . cast++-- XXX - slow way of implementing "return"+wrapSub :: SubType -> CodeGen () -> CodeGen ()+wrapSub SubPrim = id+wrapSub SubBlock = id -- XXX not really+wrapSub _ = \body -> do+    [retL, errL] <- genLabel ["returnHandler", "errHandler"]+    tellIns $ "push_eh" .- [bare retL]+    body+    tellLabel retL+    tellIns $ ("get_results" .- sigList [tempPMC, tempSTR])+    tellIns $ "clear_eh" .- []+    tellIns $ tempSTR <-- "typeof" $ [tempPMC]+    tellIns $ "eq" .- [tempSTR, lit "Exception", bare errL]+    tellIns $ "set_returns" .- sigList [tempPMC]+    tellIns $ "returncc" .- []+    tellLabel errL+    tellIns $ "throw" .- [tempPMC]++prmToSig :: Param -> Sig+prmToSig prm = MkSig (prmToArgs prm) . bare $ prmToIdent prm++prmToArgs :: Param -> [ArgFlag]+prmToArgs prm = combine +    [ isSlurpy   ==> MkArgSlurpyArray+    , isOptional ==> MkArgOptional+    ] []+    where+    f ==> arg = if f prm then (arg:) else id++prmToIdent :: Param -> String+prmToIdent = render . varText . cast. paramName++storeLex :: TParam -> CodeGen ()+storeLex param = do+    when (isOptional prm) $ do+        [defC] <- genLabel ["defaultDone"]+        tellIns $ "unless_null" .- [bare name, bare defC]+        case tpDefault param of+            Nothing     -> tellIns $ InsNew (VAR name) PerlScalar+            (Just exp)  -> do+                expC <- trans exp+                -- compile it away+                tellIns $ VAR name <:= expC+        tellLabel defC+    tellIns $ "store_lex" .- [lit (cast var :: VarName), bare name]+    where+    var     = paramName prm+    name    = prmToIdent prm+    prm     = tpParam param++tellIns :: Ins -> CodeGen ()+tellIns = tell . (:[]) . StmtIns++{-| Inserts a label. -}+tellLabel :: String -> CodeGen ()+tellLabel name = tellIns $ InsLabel name++lastPMC :: (RegClass a) => CodeGen a+lastPMC = do+    tvar    <- asks tReg+    io $ stm $ do+        (cur, name) <- readTVar tvar+        return $ case cur of+            0 -> nullPMC+            _ -> reg (VAR (('p':show cur) ++ (if null name then name else ('_':name))))++genPMC :: (RegClass a) => String -> CodeGen a+genPMC name = do+    tvar    <- asks tReg+    name'   <- io $ stm $ do+        (cur, _) <- readTVar tvar+        writeTVar tvar (cur + 1, name)+        return $ ('p':show (cur + 1)) ++ ('_':name)+    tellIns $ InsLocal RegPMC name'+    return $ reg (VAR name')++genWith :: (RegClass a) => (LValue -> Ins) -> String -> CodeGen a+genWith f name = do+    pmc <- genPMC name+    tellIns $ f pmc+    return $ reg pmc++genScalar :: (RegClass a) => String -> CodeGen a+genScalar = genWith (`InsNew` PerlScalar)++genArray :: (RegClass a) => String -> CodeGen a+genArray = genWith (`InsNew` PerlArray)++-- genHash :: (RegClass a) => String -> CodeGen a+-- genHash = genWith (`InsNew` PerlHash)++genLabel :: [String] -> CodeGen [LabelName]+genLabel names = do+    tvar    <- asks tLabel+    cnt     <- io $ stm $ do+        cur <- readTVar tvar+        writeTVar tvar (cur + 1)+        return cur+    return $ map (\name -> "LABEL_" ++ show cnt ++ ('_':name)) names++genName :: (RegClass a) => String -> CodeGen a+genName name = do+    let var = render $ varText name+    tellIns $ InsLocal RegPMC var+    tellIns $ InsNew (VAR var) (varInit name)+    return $ reg (VAR var)++varInit :: String -> ObjType+varInit ('$':_) = PerlScalar+varInit ('@':_) = PerlArray+varInit ('%':_) = PerlHash+varInit ('&':_) = PerlScalar+varInit x       = internalError $ "Invalid name: " ++ x++-- XXX: do something useful with the filename arg+genPIR_YAML :: FilePath -> Eval Val+genPIR_YAML _ = genPIRWith $ \globPIR mainPIR _ -> do+    yaml <- io (showYaml (mainPIR, globPIR))+    return (VStr yaml)++{-| Compiles the current environment to PIR code. -}+genPIR :: FilePath -> Eval Val+genPIR file = genPIRWith $ \globPIR mainPIR penv -> do+    libs        <- io $ getLibs+    return . VStr . unlines $+        [ "#!/usr/bin/env parrot"+        , "# " ++ file+        , renderStyle (Style PageMode 0 0) $ preludePIR $+$ vcat+        -- Namespaces have bugs in both pugs and parrot.+        [ emit $ DeclNS "Main"+        [ DeclSub "init" [SubMAIN, SubANON] $ map StmtIns (+            -- Eventually, we'll have to write our own find_name wrapper (or+            -- fix Parrot's find_name appropriately). See Pugs.Eval.Var.+            -- For now, we simply store $P0 twice.+            [ InsNew tempPMC PerlEnv+            , "store_global"    .- [lit "%*ENV", tempPMC]+            , "store_global"    .- [lit "%ENV", tempPMC]+            , InsNew tempPMC PerlArray+            ] ++ [ "push" .- [tempPMC, lit path] | path <- libs ] +++            [ "store_global"    .- [lit "@*INC", tempPMC]+            , "store_global"    .- [lit "@INC", tempPMC]+            , InsNew tempPMC PerlArray+            , "store_global"    .- [lit "@*END", tempPMC]+            , "store_global"    .- [lit "@END", tempPMC]+            , InsNew tempPMC PerlArray+            , "store_global"    .- [lit "@*CHECK", tempPMC]+            , "store_global"    .- [lit "@CHECK", tempPMC]+            , "getstdin"        .- [tempPMC]+            , "store_global"    .- [lit "$*IN", tempPMC]+            , "store_global"    .- [lit "$IN", tempPMC]+            , "getstdout"       .- [tempPMC]+            , "store_global"    .- [lit "$*OUT", tempPMC]+            , "store_global"    .- [lit "$OUT", tempPMC]+            , "getstderr"       .- [tempPMC]+            , "store_global"    .- [lit "$*ERR", tempPMC]+            , "store_global"    .- [lit "$ERR", tempPMC]+            , "getinterp"       .- [tempPMC]+            , tempPMC   <:= ExpLV (tempPMC `KEYED` bare ".IGLOBALS_ARGV_LIST")+            , tempPMC2  <-- "shift" $ [tempPMC]+            , "store_global"    .- [lit "@*ARGS", tempPMC]+            , "store_global"    .- [lit "@ARGS", tempPMC]+            , "store_global"    .- [lit "$*PROGRAM_NAME", tempPMC2]+            , "store_global"    .- [lit "$PROGRAM_NAME", tempPMC2]+            -- XXX wrong, should be lexical+            , InsNew tempPMC PerlScalar+            , "store_global"    .- [lit "$_", tempPMC]+            ]) ++ [ StmtRaw (text (name ++ "()")) | PSub name@('_':'_':_) _ _ _ _ _ <- pilGlob penv ] +++            [ StmtRaw (text "MAIN()")+            , StmtIns $ tempPMC  <-- "find_global" $ [lit "Perl6::Internals", lit "&exit"]+            , StmtIns $ "set_args" .- sigList [MkSig [] lit0]+            , StmtIns $ "invokecc" .- [tempPMC]+            ]+        , DeclSub "MAIN" [SubANON] mainPIR ]+        , emit globPIR ] ]++genPIRWith :: ([Decl] -> [Stmt] -> PIL_Environment -> Eval a) -> Eval a+genPIRWith f = do+    tenv        <- initTEnv+    -- Load the PIR Prelude.+    local (\env -> env{ envDebug = Nothing }) $ do+        opEval style "<prelude-pir>" preludeStr+    penv        <- compile ()+    globPIR     <- runCodeGenGlob tenv (pilGlob penv)+    mainPIR     <- runCodeGenMain tenv (pilMain penv)+    f globPIR mainPIR penv+    where+    style = MkEvalStyle+        { evalResult = EvalResultModule+        , evalError  = EvalErrorFatal+        }++runCodeGenGlob :: TEnv -> [PIL_Decl] -> Eval [Decl]+runCodeGenGlob tenv = mapM $ fmap fst . runCodeGen tenv++runCodeGenMain :: TEnv -> PIL_Stmts -> Eval [Stmt]+runCodeGenMain tenv = fmap snd . runCodeGen tenv++runCodeGen :: (Translate a b) => TEnv -> a -> Eval (b, [Stmt])+runCodeGen tenv = io . (`runReaderT` tenv) . runWriterT . trans
+ src/Pugs/CodeGen/PIR/Prelude.hs view
@@ -0,0 +1,153 @@+{-# OPTIONS -fglasgow-exts #-}+ +{-+    *** NOTE ***+    DO NOT EDIT THIS FILE.+    This module is automatically generated by src/gen_prelude.hs.+-}+ +{-|+    Perl 6 Prelude.+ +>   The world was fair, the mountains tall,+>   In Eldar Days before the fall+>   Of mighty kings in Nargothrond+>   And Gondolin, who now beyond+>   The Western Seas have passed away:+>   The world was fair in Durin's day.+ +-}+ + +module Pugs.CodeGen.PIR.Prelude (+    preludeStr+) where+ +preludeStr :: String+preludeStr = unlines+    [ ""+    , ""+    , "sub prefix:<?> ($var) returns Bool is builtin is primitive { true $var }"+    , ""+    , "sub chomp (Str $str) returns Str is builtin is primitive {"+    , "    if substr($str, -1, 1) eq \"\\n\" {"+    , "        substr $str, 0, chars($str) - 1;"+    , "    } else {"+    , "        $str;"+    , "    }"+    , "}"+    , ""+    , "sub chop (Str $str is rw) returns Str is builtin is primitive {"+    , "    if chars($str) == 0 {"+    , "        undef;"+    , "    } else {"+    , "        my $removed = substr $str, -1, 1;"+    , "        $str = substr $str, 0, chars($str) - 1;"+    , "        $removed;"+    , "    }"+    , "}"+    , ""+    , "sub sleep (Num $seconds) returns Num is builtin is primitive {"+    , "    my $time = time;"+    , "    Perl6::Internals::sleep $seconds;"+    , "    my $seconds_slept = time() - $time;"+    , "    $seconds_slept;"+    , "}"+    , ""+    , "sub exit (Int $status = 0) is builtin is primitive {"+    , "    Perl6::Internals::exit $status;"+    , "}"+    , ""+    , "sub Perl6::Internals::eval_parrot (Str $code) is builtin is primitive {"+    , "    my $sub = substr($code, 0, 1) eq \".\""+    , "        ?? Perl6::Internals::compile_pir($code)"+    , "        !! Perl6::Internals::compile_pir(\".sub pugs_eval_parrot\\n$code\\n.end\\n\");"+    , "    $sub();"+    , "}"+    , ""+    , "sub pi () returns Num is builtin is primitive {"+    , "    3.14159265358979323846264338327950288419716939937510;"+    , "}"+    , ""+    , "sub lcfirst (Str $str) returns Str is builtin is primitive {"+    , "    lc(substr $str, 0, 1) ~ substr $str, 1, chars($str) - 1;"+    , "}"+    , ""+    , "sub ucfirst (Str $str) returns Str is builtin is primitive {"+    , "    uc(substr $str, 0, 1) ~ substr $str, 1, chars($str) - 1;"+    , "}"+    , ""+    , "sub shift (@a) is builtin is primitive {"+    , "    my $top = +@a -1;"+    , "    return undef if $top < 0;"+    , "    my $e = @a[0];"+    , "    my $i = 0;"+    , "    while $i < $top {"+    , "        @a[$i++] = @a[$i];"+    , "    }"+    , "    pop(@a);"+    , "    return $e;"+    , "}"+    , ""+    , "sub splice (@a is rw, $offset=0, $length?, *@list) is builtin is primitive {"+    , "    my $off = +$offset;"+    , "    my $len = $length;"+    , "    my $size = +@a;"+    , ""+    , "    $off += $size if $off < 0;"+    , "    if $off > $size {"+    , "        warn \"splice() offset past end of array\\n\";"+    , "        $off = $size;"+    , "    }"+    , ""+    , "    $len = +$len if defined($len);"+    , "    $len = $size - $off if !defined($len);"+    , "    $len = $size + $len - $off if $len < 0;"+    , "    $len = 0 if $len < 0;"+    , ""+    , "    my $listlen = +@list;"+    , "    my $size_change = $listlen - $len;"+    , "    my @result;"+    , ""+    , "    if 1 {"+    , "        my $i = $off;"+    , "        my $stop = $off + $len;"+    , "        while $i < $stop {"+    , "            push(@result,@a[$i]);"+    , "            $i++;"+    , "        }"+    , "    }"+    , ""+    , "    if $size_change > 0 {"+    , "        my $i = $size + $size_change -1;"+    , "        my $final = $off + $size_change;"+    , "        while $i >= $final {"+    , "            @a[$i] = @a[$i-$size_change];"+    , "            $i--;"+    , "        }"+    , "    } elsif $size_change < 0 {"+    , "        my $i = $off;"+    , "        my $final = $size + $size_change -1;"+    , "        while $i <= $final {"+    , "            @a[$i] = @a[$i-$size_change];"+    , "            $i++;"+    , "        }"+    , "        my $n = 0;"+    , "        while $n-- > $size_change {"+    , "            pop(@a);"+    , "        }"+    , "    }"+    , ""+    , "    if $listlen > 0 {"+    , "        my $i = 0;"+    , "        while $i < $listlen {"+    , "            @a[$off+$i] = @list[$i];"+    , "            $i++;"+    , "        }"+    , "    }"+    , ""+    , "    @result;"+    , "}"++    ]+
+ src/Pugs/CodeGen/Perl5.hs view
@@ -0,0 +1,14 @@+{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances -fno-warn-orphans -funbox-strict-fields -cpp #-}++module Pugs.CodeGen.Perl5 (genPerl5) where+import Pugs.AST+import Pugs.Compile+import Pugs.PIL1.Instances ()+import Pugs.PIL1+import DrIFT.Perl5++-- XXX: do something useful with the filename arg+genPerl5 :: FilePath -> Eval Val+genPerl5 _ = do+    penv <- compile () :: Eval PIL_Environment+    return . VStr . unlines $ [showPerl5 penv]
+ src/Pugs/CodeGen/YAML.hs view
@@ -0,0 +1,28 @@+{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances -fno-warn-orphans -funbox-strict-fields -cpp #-}++module Pugs.CodeGen.YAML (genYAML, genParseYAML, genParseHsYAML) where+import Pugs.Internals+import Pugs.AST+import Pugs.Compile+import Pugs.PIL1.Instances ()+import Pugs.PIL1+import DrIFT.YAML++genParseHsYAML, genParseYAML :: FilePath -> Eval Val+genParseHsYAML file = doGenParseYAML file (fmap show . toYamlNode)+genParseYAML   file = doGenParseYAML file showYamlCompressed++doGenParseYAML :: FilePath -> (CompUnit -> IO String) -> Eval Val+doGenParseYAML file f = do+    pad  <- filterPrim =<< asks envGlobal+    main <- asks envBody+    yaml <- io $ f $ mkCompUnit file pad main+    return $ VStr yaml++-- XXX: do something useful with the filename arg+genYAML :: FilePath -> Eval Val+genYAML _ = do+    penv <- compile () :: Eval PIL_Environment+    yaml <- io (showYamlCompressed penv)+    return $ VStr yaml+
+ src/Pugs/Compile.hs view
@@ -0,0 +1,454 @@+{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances -fno-warn-orphans -funbox-strict-fields -cpp -fno-warn-deprecations -fallow-overlapping-instances #-}++{-|+    Compiler interface.++>   And words unheard were spoken then+>   Of folk and Men and Elven-kin,+>   Beyond the world were visions showed+>   Forbid to those that dwell therein...+-}++module Pugs.Compile (+    PIL_Stmts(..), PIL_Stmt(..), PIL_Expr(..), PIL_Decl(..), PIL_Literal(..), PIL_LValue(..),+    Compile(..),+    TEnv(..), initTEnv,+    TCxt(..), tcVoid, tcLValue,+    TParam(..),+    EnterClass(..),+    die, varText+) where+import Pugs.AST+import Pugs.Internals+import Pugs.Types+import Pugs.Monads+import Pugs.PIL1+import Language.PIR+import Text.PrettyPrint++tcVoid, tcLValue :: TCxt+tcVoid      = TCxtVoid+tcLValue    = TCxtLValue anyType++{-+tcItem, tcSlurpy :: TCxt+tcItem      = TCxtItem anyType+tcSlurpy    = TCxtSlurpy anyType+-}++type Comp = Eval++{-| Currently only 'Exp' → 'PIL' -}+class (Show a, Typeable b) => Compile a b where+    compile :: a -> Comp b+    compile x = fail ("Unrecognized construct: " ++ show x)++-- Compile instances+instance Compile () PIL_Environment where+    compile _ = do+        glob    <- askGlobal+        main    <- asks envBody+        globPIL <- compile glob+        mainPIL <- compile main+        return $ PIL_Environment globPIL mainPIL++instance Compile (Var, [(TVar Bool, TVar VRef)]) PIL_Decl where+    compile = compError++instance Compile Param TParam where+    compile prm = do+        defC <- if isOptional prm+            then fmap Just $ compile (paramDefault prm)+            else return Nothing+        return $ MkTParam+            { tpParam = prm+            , tpDefault = defC+            }++{-| Compiles a 'Pad' to a list of 'PIL_Decl's. Currently, only subroutines and+    @\@*END@ are compiled. -}+instance Compile Pad [PIL_Decl] where+    compile pad = do+        entries' <- mapM canCompile entries+        return $ concat entries'+        where+        entries = sortBy padSort [ (cast var, readPadEntry ref) | (var, ref) <- padToList pad ]+        canCompile (name@('&':_) :: String, sym) = do+            (ref :: VRef) <- sym+            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 []+        canCompile ("@*END", sym) = do+            ref     <- sym+            cvList  <- fromVals =<< readRef ref :: Comp [VCode]+            decls   <- eachM cvList $ \(i, cv) -> do+                compile (("&*END_" ++ show i), cv) :: Comp [PIL_Decl]+            compile ("&*END", concat decls)+        canCompile ((_:twigil:_), _) | not (isAlphaNum twigil) = return []+        canCompile (name, sym) = do+            -- translate them into store_global calls?+            -- placing them each into one separate init function?+            val     <- readRef =<< sym+            valC    <- compile val+            let assignC = PAssign [PVar name'] valC+                bodyC   = PStmts (PStmt . PExp $ assignC) PNil+                initL   = "__init_" ++ (render $ varText name)+                name' | ':' `elem` name = name+                      | otherwise = "Main::" ++ name -- XXX wrong+            return [PSub initL SubPrim [] False False bodyC]+        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`)++instance Compile (SubName, [PIL_Decl]) [PIL_Decl] where+    compile (name, decls) = do+        let bodyC = [ PStmts . PStmt . PExp $ PApp tcVoid (PExp (PVar sub)) Nothing []+                    | PSub sub _ _ _ _ _ <- decls+                    ]+        return (PSub name SubPrim [] False False (combine bodyC PNil):decls)++instance Compile (SubName, VCode) [PIL_Decl] where+{-+    compile (name, vsub) | packageOf name /= packageOf (subName vsub) = do+        let storeC  = PBind [PVar $ qualify name] (PExp . PVar . qualify $ subName vsub)+            bodyC   = PStmts (PStmt . PExp $ storeC) PNil+            exportL = "__export_" ++ (render $ varText name)+        return [PSub exportL SubPrim [] False False bodyC]+-}+    compile (name, vsub) = do+        bodyC   <- enter cxtItemAny . compile $ case subBody vsub of+            Syn "block" [body]  -> body+            body                -> body+        paramsC <- compile $ subParams vsub+        return [PSub name (subType vsub) paramsC (subLValue vsub) (isMulti vsub) bodyC]++instance Compile (String, PadEntry) PIL_Expr where+    compile (name, entry) = do+        rv <- readRef =<< readPadEntry entry+        case rv of+            VCode sub   -> return $ PRawName (cast $ subName sub)+            _           -> return $ PRawName name++instance Compile Exp PIL_Stmts where+    -- XXX: pragmas?+    compile (Ann Pos{} rest) = compile rest -- fmap (PPos pos rest) $ compile rest+    compile (Ann Prag{} rest) = compile rest -- fmap (PPos pos rest) $ compile rest+    compile (Ann (Cxt cxt) rest) = enter cxt $ compile rest+    compile (Ann _ rest) = compile rest+{-+    compile (Stmts (Pad SOur _ exp) rest) = do+        compile $ mergeStmts exp rest+    compile (Stmts (Pad scope pad exp) rest) = do+        padC    <- compile [ (cast var :: String, ref) | (var, ref) <- padToList pad ]+        let symC = (map (cast . fst) $ padToList pad) `zip` padC+            exps = [ Syn ":=" [_Var name, _Var from]+                   | (name, PRawName from) <- symC+                   , name /= from+                   ]+        expC    <- compile $ mergeStmts (foldl1 mergeStmts (exps ++ [exp])) rest+        return $ PPad scope symC expC+-}+    compile exp = compileStmts exp++class EnterClass m a where+    enter :: a -> m b -> m b++instance EnterClass Comp VCode where+    enter sub = local (\e -> e{ envLValue = subLValue sub, envContext = CxtItem (subReturns sub) })++instance EnterClass Comp Cxt where+    enter cxt = local (\e -> e{ envContext = cxt })++compileStmts :: Exp -> Comp PIL_Stmts+compileStmts exp = case exp of+    Stmts this Noop -> do+        thisC   <- compile this+        return $ PStmts (tailCall thisC) PNil+        where+        tailCall (PStmt (PExp (PApp cxt fun inv args)))+            = PStmt $ PExp $ PApp (TTailCall cxt) fun inv args+        tailCall (PPos pos exp x) = PPos pos exp (tailCall x)+        tailCall x = x+    Stmts this (Syn "namespace" [Val (VStr sym), Val (VStr pkg), rest]) -> do+        thisC   <- enter cxtVoid $ compile this+        declC   <- enter cxtVoid $ compile decl+        restC   <- enterPackage (cast pkg) $ compileStmts rest+        return $ PStmts thisC $ PStmts declC restC+        where+          -- XXX - kludge.+          decl = App (_Var func) Nothing [(Val (VStr pkg))]+          func = "&" ++ (capitalize sym) ++ "::_create"+          capitalize []     = []+          capitalize (c:cs) = toUpper c:cs++    Stmts this rest -> do+        thisC   <- enter cxtVoid $ compile this+        restC   <- compileStmts rest+        return $ PStmts thisC restC+    Noop        -> return PNil+    _           -> compile (Stmts exp Noop)++instance Compile Val PIL_Stmt where+    compile = fmap PStmt . compile . Val++instance Compile Val PIL_Expr where+    compile = compile . Val++instance Compile Exp PIL_Stmt where+    compile (Ann (Pos pos) rest) = fmap (PPos pos rest) $ compile rest+    compile (Ann (Cxt cxt) rest) = enter cxt $ compile rest+    -- XXX: pragmas?+    compile (Ann Prag{} rest) = compile rest -- fmap (PPos pos rest) $ compile rest+    compile (Ann _ rest) = compile rest+    compile Noop = return PNoop+    compile (Val val) = do+        cxt     <- asks envContext+        if isVoidCxt cxt+            then case val of+                VBool True      -> compile Noop+                _               -> do+                    warn "Useless use of a constant in void context" val+                    compile Noop+            else compile val+    compile (Syn "loop" [exp]) =+        compile (Syn "loop" $ [emptyExp, Val (VBool True), emptyExp, exp])+    compile (Syn "loop" [pre, cond, post, body]) = do+        preC    <- compile pre+        -- loop (...; ; ...) {...} ->+        -- loop (...; True; ...) {...}+        let cond' | unwrap cond == Noop+                  = return $ PStmts (PStmt . PLit . PVal $ VBool True) PNil+                  | otherwise+                  = compile cond+        condC   <- cond'+        bodyC   <- compile body+        postC   <- compile post+        funC    <- compile (_Var "&statement_control:loop")+        return . PStmt . PExp $ PApp TCxtVoid funC Nothing+            [preC, pBlock condC, bodyC, pBlock postC]+    compile exp@(Syn "unless" _) = fmap (PStmt . PExp) $ compConditional exp+    compile exp@(Syn "while" _) = compLoop exp+    compile exp@(Syn "until" _) = compLoop exp+    compile exp@(Syn "postwhile" _) = compLoop exp+    compile exp@(Syn "postuntil" _) = compLoop exp+    compile (Syn "for" [exp, body]) = do+        expC    <- compile exp+        bodyC   <- compile body+        funC    <- compile (_Var "&statement_control:for")+        return . PStmt . PExp $ PApp TCxtVoid funC Nothing [expC, bodyC]+    compile (Syn "given" _) = compile (_Var "$_") -- XXX+    compile (Syn "when" _) = compile (_Var "$_") -- XXX+    compile exp = fmap PStmt $ compile exp++pBlock :: PIL_Stmts -> PIL_Expr+pBlock = PCode SubBlock [] False False++{-+subTCxt :: VCode -> Eval TCxt+subTCxt sub = return $ if subLValue sub+    then TCxtLValue (subReturns sub)+    else TCxtItem (subReturns sub)+-}++askTCxt :: Eval TCxt+askTCxt = do+    env <- ask+    return $ if envLValue env+        then TCxtLValue (typeOfCxt $ envContext env)+        else case envContext env of+            CxtVoid         -> TCxtVoid+            CxtItem typ     -> TCxtItem typ+            CxtSlurpy typ   -> TCxtSlurpy typ++instance (Compile a b) => Compile [a] [b] where+    compile = fmapM compile++instance (Compile a b, Compile a c) => Compile [a] (b, c) where+    compile [x, y] = do { x' <- compile x ; y' <- compile y; return (x', y') }+    compile x = compError x++instance (Compile a b, Compile a c, Compile a d) => Compile [a] (b, c, d) where+    compile [x, y, z] = do { x' <- compile x ; y' <- compile y; z' <- compile z; return (x', y', z') }+    compile x = compError x++instance Compile Exp PIL_LValue where+    compile (Ann Pos{} rest) = compile rest -- fmap (PPos pos rest) $ compile rest+    compile (Ann Prag{} rest) = compile rest+    compile (Ann (Cxt cxt) rest) = enter cxt $ compile rest+    compile (Ann _ rest) = compile rest+    -- XXX: pragmas?+    compile (Var name) = return $ _PVar name+    compile (Syn (sigil:"::()") exps) = do+        compile $ App (_Var "&Pugs::Internals::symbolic_deref") Nothing $+            (Val . VStr $ sigil:""):exps+    compile (App (Var var) (Just inv) args) | var == cast "&goto" = do+        cxt     <- askTCxt+        funC    <- compile inv+        argsC   <- enter cxtItemAny $ compile args+        return $ PApp (TTailCall cxt) funC Nothing argsC+    compile (App fun inv args) = do+        cxt     <- askTCxt+        funC    <- compile fun+        invC    <- maybeM (return inv) compile+        argsC   <- enter cxtItemAny $ compile args+        if isLogicalLazy funC+            then return $ PApp cxt funC invC (head argsC:map PThunk (tail argsC))+            else return $ PApp cxt funC invC argsC+        where+        -- XXX HACK+        isLogicalLazy (PExp (PVar "&infix:or"))  = True+        isLogicalLazy (PExp (PVar "&infix:and")) = True+        isLogicalLazy (PExp (PVar "&infix:andthen")) = True+        isLogicalLazy (PExp (PVar "&infix:orelse")) = True+        isLogicalLazy (PExp (PVar "&infix:||"))  = True+        isLogicalLazy (PExp (PVar "&infix:&&"))  = True+        isLogicalLazy (PExp (PVar "&infix://"))  = True+        isLogicalLazy _ = False+    compile exp@(Syn "if" _) = compConditional exp+    compile exp@(Syn "cond" _) = compConditional exp+    compile (Syn "{}" (x:xs)) = compile $ App (_Var "&postcircumfix:{}") (Just x) xs+    compile (Syn "[]" (x:xs)) = do+        compile (App (_Var "&postcircumfix:[]") (Just x) xs)+    compile (Syn "," exps) = do+        compile (App (_Var "&infix:,") Nothing exps)+    -- Minor hack, my $a = [] is parsed as my $a = [Noop], resulting in my $a =+    -- [undef], which is wrong.+    compile (Syn "\\[]" [Noop]) = do+        compile (App (_Var "&circumfix:[]") Nothing [])+    compile (Syn "\\[]" exps) = do+        compile (App (_Var "&circumfix:[]") Nothing exps)+    compile (Syn name@(sigil:"{}") exps) | (sigil ==) `any` "$@%&" = do+        compile (App (_Var $ "&circumfix:" ++ name) Nothing exps)+    compile (Syn "\\{}" exps) = do+        compile (App (_Var "&circumfix:{}") Nothing exps)+    compile (Syn "*" exps) = do+        compile (App (_Var "&prefix:*") Nothing exps)+    compile (Syn "=" [lhs, rhs]) = do+        lhsC <- enterLValue $ compile lhs+        rhsC <- enterRValue $ compile rhs+        return $ PAssign [lhsC] rhsC+    compile (Syn ":=" exps) = do+        (lhsC, rhsC) <- enterLValue $ compile exps+        return $ PBind [lhsC] rhsC+    compile (Syn syn [lhs, exp]) | last syn == '=' = do+        let op = "&infix:" ++ init syn+        compile $ Syn "=" [lhs, App (_Var op) Nothing [lhs, exp]]+    compile (Syn "but" [obj, block]) =+        compile $ App (_Var "&Pugs::Internals::but_block") Nothing [obj, block]+    compile exp@(Syn "namespace" _) = do+        -- XXX - Is there a better way to wrap Stmts as LValue?+        compile $ App (Syn "sub"+            [ Val . VCode $ mkSub+                { subBody   = Stmts Noop exp+                , subParams = []+                }+            ]) Nothing []+    -- For PIL2 we want real zone separation, e.g.+    --   PApp { pNamedArgs = [...], pPositionalArgs = [...], ... }+    -- For now, using &Pugs::Internals::named_pair is probably ok.+    compile (Syn "named" kv@[_, _]) = do+        compile $ App (_Var "&Pugs::Internals::named_pair") Nothing kv+    compile exp = compError exp++compLoop :: Exp -> Comp PIL_Stmt+compLoop (Syn name [cond, body]) = do+    cxt     <- askTCxt+    condC   <- enter (CxtItem $ mkType "Bool") $ compile cond+    bodyC   <- enter CxtVoid $ compile body+    funC    <- compile (_Var $ "&statement_control:" ++ name)+    return . PStmt . PExp $ PApp cxt funC Nothing [pBlock condC, bodyC]+compLoop exp = compError exp++{-| Compiles a conditional 'Syn' (@if@ and @unless@) to a call to an+    appropriate function call (@&statement_control:if@ or+    @&statement_control:unless@). -}+compConditional :: Exp -> Comp PIL_LValue+compConditional (Syn name exps) = do+    [condC, trueC, falseC] <- compile exps+    funC    <- compile $ _Var ("&statement_control:" ++ name)+    cxt     <- askTCxt+    return $ PApp cxt funC Nothing [condC, PThunk trueC, PThunk falseC]+compConditional exp = compError exp++_PVar :: Var -> PIL_LValue+_PVar = PVar . cast++{-| Compiles various 'Exp's to 'PIL_Expr's. -}+instance Compile Exp PIL_Expr where+    compile (Ann Pos{} rest) = compile rest -- fmap (PPos pos rest) $ compile rest+    compile (Ann Prag{} rest) = compile rest+    compile (Ann (Cxt cxt) rest) = enter cxt $ compile rest+    compile (Ann _ rest) = compile rest+    -- XXX: pragmas?+    compile (Var name) = return . PExp $ _PVar name+    compile exp@(Val (VCode _)) = compile $ Syn "sub" [exp]+    compile (Val val) = fmap PLit $ compile val+    compile Noop = compile (Val undef)+    compile (Syn "block" [body]) = do+        cxt     <- askTCxt+        bodyC   <- compile body+        return $ PExp $ PApp cxt (pBlock bodyC) Nothing []+    compile (Syn "sub" [Val (VCode sub)]) = do+        bodyC   <- enter sub $ compile $ case subBody sub of+            Syn "block" [exp]   -> exp+            exp                 -> exp+        paramsC <- compile $ subParams sub+        return $ PCode (subType sub) paramsC (subLValue sub) (isMulti sub) bodyC+    compile (Syn "module" _) = compile Noop+    compile (Syn "match" exp) = compile $ Syn "rx" exp -- wrong+    compile (Syn "//" exp) = compile $ Syn "rx" exp+    compile (Syn "rx" (exp:_)) = compile exp -- XXX WRONG - use PCRE+    compile (Syn "subst" (exp:_)) = compile exp -- XXX WRONG - use PCRE+    compile (Syn "trans" (exp:_)) = compile exp -- XXX WRONG+    compile (Syn "|" [exp]) = compile exp -- XXX WRONG+    compile (Syn "|<<" [exp]) = compile exp -- XXX WRONG+    compile exp@(App _ _ _) = fmap PExp $ compile exp+    compile exp@(Syn _ _) = fmap PExp $ compile exp+    compile exp = compError exp++compError :: forall a b. Compile a b => a -> Comp b+compError = die $ "Compile error -- invalid "+    ++ (show $ typeOf (undefined :: b))++{-| Compiles a 'Val' to a 'PIL_Literal'. -}+instance Compile Val PIL_Literal where+    compile (VList vs) = return $ PVal (VList (filter isSimple vs))+        where+        isSimple (VRef _) = False+        isSimple _        = True+    compile (VRef _) = return $ PVal VUndef+    compile val = return $ PVal val++-- utility functions+padSort :: (String, a) -> (String, a) -> Ordering+padSort (a, _) (b, _)+    | (head a == ':' && head b == '&') = LT+    | (head b == ':' && head a == '&') = GT+    | otherwise = compare a b++varText :: String -> Doc+varText ('$':name)  = text $ "s__" ++ escaped name+varText ('@':name)  = text $ "a__" ++ escaped name+varText ('%':name)  = text $ "h__" ++ escaped name+varText ('&':name)  = text $ "c__" ++ escaped name+varText x           = error $ "invalid name: " ++ x++initTEnv :: Eval TEnv+initTEnv = do+    initReg <- io $ newTVarIO (0, "")+    initLbl <- io $ newTVarIO 0+    return $ MkTEnv+        { tLexDepth = 0+        , tTokDepth = 0+        , tCxt      = tcVoid+        , tReg      = initReg+        , tLabel    = initLbl+        }+
+ src/Pugs/Compile/Pugs.hs view
@@ -0,0 +1,228 @@+{-# OPTIONS_GHC -fglasgow-exts -fallow-overlapping-instances -fparr #-}++module Pugs.Compile.Pugs (genPugs) where+import Pugs.AST+import Pugs.Types+import Pugs.Internals+-- import qualified Data.ByteString.UTF8 as Str+import qualified Data.ByteString.Char8 as Str -- XXX+import qualified Data.Map as Map+import qualified Data.Set as Set++type Str = Str.ByteString+type Comp a = WriterT [a] Eval a++class (Show x) => Compile x where+    compile :: x -> Comp Str+    compile x = fail ("Unrecognized construct: " ++ show x)+    compileList :: [x] -> Comp Str+    compileList xs = do+        xsC <- mapM compile xs+        return $ Str.concat [bl, joinMany xsC, br]++joinMany :: [Str] -> Str+joinMany xs = Str.intercalate cm (filter (not . Str.null) xs)++instance (Compile x) => Compile [x] where+    compile = compileList++instance (Compile x) => Compile [:x:] where+    compile xs = compWith "toP" [compileList (fromP xs)]++instance (Compile x) => Compile (Set x) where+    compile xs = compWith "Set.fromDistinctAscList" [compileList (Set.toAscList xs)]++instance Compile (Maybe Exp) where+    compile Nothing = return $ Str.pack "Nothing"+    compile (Just exp) = compWith "Just" [compile exp]++pl, pr, bl, br, cm :: Str+pl = Str.pack "("+pr = Str.pack ")"+bl = Str.pack "["+br = Str.pack "]"+cm = Str.pack ", "++ret :: String -> Comp Str+ret = return . Str.pack++compWith :: String -> [Comp Str] -> Comp Str+compWith con xs = do+    xsC <- sequence xs+    return $ Str.concat [pl, Str.unwords (Str.pack con:concatMap (\x -> [pl, x, pr]) xsC), pr]++instance Compile Exp where+    compile (App exp1 exp2 exps) = do+        compWith "App" [compile exp1, compile exp2, compile exps]+    compile (Syn syn exps) = do+        compWith "Syn" [ret (show syn), compile exps]+    compile (Ann ann exp) = do+        compWith "Ann" [ret (show ann), compile exp]+    compile (Stmts exp1 exp2) = do+        compWith "Stmts" [compile exp1, compile exp2]+    compile (Val val) = do+        compWith "Val" [compile val]+    compile (Var var) = do+        compWith "Var" [compile var]+    compile exp = ret $ "(" ++ show exp ++ ")"++instance Compile Var where+    compile var = ret $ "(cast " ++ show var ++ ")"++instance Compile (Var, PadEntry) where+    compile (x, y) = do+        xC  <- compile x+        yC  <- compile y+        return $ Str.concat [pl, xC, cm, yC, pr]++instance Compile (Map Var PadEntry) where+    compile xs = do+        symsC <- mapM compile (Map.toAscList xs)+        return $ Str.concat [Str.pack "(Map.fromDistinctAscList [", joinMany symsC, Str.pack "])"]++instance Compile Pad where+    compile pad = do+        symsC <- mapM compile syms+        return $ Str.concat [Str.pack "(mkPad [", joinMany symsC, Str.pack "])"]+        where+        syms = padToList pad++instance Compile IHash where+    compile map = error (show map)+++instance Compile (Var, [(TVar Bool, TVar VRef)]) where+    compile (var, tvars)+        | SType <- v_sigil var, isGlobalVar var = return Str.empty+        | otherwise = do+            tvarsC <- fmap (filter (not . Str.null)) $ mapM compile tvars+            if null tvarsC then return Str.empty else do+            return $ Str.concat [pl, (Str.pack ("cast " ++ show (cast var :: String))), Str.pack ", [", joinMany tvarsC, br, pr]++instance (Typeable a) => Compile (Maybe (TVar a)) where+    compile = const . ret $ "Nothing"++instance Compile (TVar Bool, TVar VRef) where+    compile (fresh, tvar) = do+        tvarC  <- compile tvar+        if Str.null tvarC then return Str.empty else do+        freshC <- compile fresh+        return $ Str.concat [pl, freshC, cm, tvarC, pr]++instance Compile Bool where+    compile bool = ret $ "(" ++ show bool ++ ")"++instance Compile a => Compile (Map VStr a) where+    compile map | Map.null map = ret $ "(Map.empty)"+    compile map = error (show map) ++instance Compile (IVar VScalar) where+    compile iv = do+        val     <- lift $ readIVar iv+        valC    <- compile val+        return $ Str.concat [Str.pack "(newScalar ", valC, pr]++instance (Typeable a, Compile a) => Compile (TVar a) where+    compile fresh = do+        vref    <- io $ atomically (readTVar fresh)+        vrefC   <- compile vref+        if Str.null vrefC then return Str.empty else do+        tv      <- io $ fmap (Str.pack . ('t':) . show . hashUnique) newUnique+        tell [Str.concat [tv, Str.pack " <- io (newTVarIO ", vrefC, Str.pack ");\n"]]+        return tv++instance Compile PadEntry where+    compile c@PEConstant{} = return $ Str.pack (show c)+    compile (PEStatic typ ref flags tv) = compWith "PEStatic" [compile typ, compile ref, ret (show flags), compile tv]+    compile (PELexical typ ref flags tv) = compWith "PELexical" [compile typ, compile ref, ret (show flags), compile tv]++instance Compile VRef where+    compile (MkRef (ICode cv))+        | Just (MkMultiCode t x y z w) <- fromTypeable cv = do+            vsubC   <- compWith "MkMultiCode" [compile t, ret (show x), ret (show y), ret (show z), compile w]+            return $ Str.concat [Str.pack "(MkRef (ICode ", vsubC, pr, pr]+        | otherwise = do+            vsub    <- lift $ code_fetch cv+            vsubC   <- compile vsub+            if Str.null vsubC then return Str.empty else do+            return $ Str.concat [Str.pack "(MkRef (ICode ", vsubC, pr, pr]+    compile (MkRef (IScalar sv)) | scalar_iType sv == mkType "Scalar::Const" = do+        sv  <- lift $ scalar_fetch sv+        svC <- compile sv+        if Str.null svC then return Str.empty else do+        return $ Str.concat [Str.pack "(MkRef (IScalar ", svC, pr, pr]+    compile ref = do+        objc   <- io $ fmap (Str.pack . ('o':) . show . hashUnique) newUnique+        tell [Str.append objc (Str.pack (" <- newObject (mkType \"" ++ showType (refType ref) ++ "\");\n"))]+        return objc++instance Compile Val where+    compile (VCode code) = do+        compWith "VCode" [compile code]+    compile (VObject obj) = do+        compWith "VObject" [compile obj]+    compile val = ret $ "(" ++ show val ++ ")"++instance Compile VObject where+    compile (MkObject typ attrs Nothing _) = do+        attrsC <- compile attrs+        uniq   <- io $ fmap (Str.pack . ('u':) . show . hashUnique) newUnique+        tell [Str.append uniq (Str.pack " <- io newUnique;\n")]+        return $ Str.unwords [pl, Str.pack "MkObject", Str.pack (show typ), attrsC, Str.pack "Nothing", uniq, pr]+    compile obj = fail $ "Cannot compile Object of Dynamic type: " ++ show obj++instance Compile VType where+    compile typ = ret $ "(mkType " ++ show typ ++ ")"++-- Haddock can't cope with Template Haskell+instance Compile VCode where+    -- compile MkCode{ subBody = Prim _ } = return $ text "return mkPrim"+    compile MkCode{ subBody = Prim _ } = return Str.empty+    -- XXX - Ew. This signature can't be right.+    compile _ = error "XXX"+    {-do +     -(MkCode v1 v2 v3 _ v4 v5 v6 v7 v8 v9 v10 _ _ _ _ _ _ _ _ _ _ _ _)+        compWith "MkCode"+            [ compile v1+            , ret (show v2)+            , ret (show v3)+            , ret "Nothing"+            , ret (show v4)+            , ret (show v5)+            , ret (show v6)+            , ret (show v7)+            , ret (show v8)+            , compile v9+            , compile v10+            , ret "Nothing"+            ]+    -}++genPugs :: FilePath -> Eval Val+genPugs file = do+    exp             <- asks envBody+    glob            <- askGlobal+    (globC, globT)  <- runWriterT $ compile glob+    (expC, expT)    <- runWriterT $ compile exp+    return . VStr . unlines $+        [ "{-# OPTIONS_GHC -fglasgow-exts -fno-warn-unused-imports -fno-warn-unused-binds #-}"+        , "module Main where"+        , "import Pugs.Run"+        , "import Pugs.AST"+        , "import Pugs.Types"+        , "import Pugs.Internals"+        , "import qualified Data.Map as Map"+        , "import qualified Data.Set as Set"+        , ""+        , "-- compiled from " ++ file ++ " with -CPugs"+        , ""+        , "main = do"+        , "    glob <- globC"+        , "    exp  <- expC"+        , "    runAST glob exp"+        , ""+        , "globC = do {" ++ Str.unpack (Str.concat globT) ++ "return " ++ Str.unpack globC ++ "}"+        , ""+        , "expC = do {" ++ Str.unpack (Str.concat expT) ++ "return " ++ Str.unpack expC ++ "}"+        , ""+        ]
+ src/Pugs/Config.hs view
@@ -0,0 +1,74 @@+{-# OPTIONS -fglasgow-exts #-}++{-+    *** NOTE ***+    DO NOT EDIT THIS FILE.+    This module is generated by util/PugsConfig.pm.+-}++{-|+    Pugs System Configuration.++>   Alive without breath;+>   as cold as death;+>   never thirsting, ever drinking;+>   clad in mail, never clinking.+-}+++module Pugs.Config (+    config,+    getConfig+) where++import qualified Data.Map as Map+import qualified Pugs.Version++config :: Map.Map String String+config = Map.fromList+    [("archlib", "/usr/local/lib/perl6/darwin-2level"),+    ("archname", "darwin-2level"),+    ("bin", "/usr/local/bin"),+    ("cc", "i686-apple-darwin8-gcc-4.0.1 (GCC) 4.0.1 (Apple Computer, Inc. build 5367)"),+    ("embedded", "/usr/local/bin/perl5.9.5 noparrot nohaskell"),+    ("exe_ext", ""),+    ("file_sep", "/"),+    ("ghc", "/usr/local/bin/ghc 6.8.20070912 readline nohsplugins threads"),+    ("installarchlib", "/usr/local/lib/perl6/darwin-2level"),+    ("installbin", "/usr/local/bin"),+    ("installman1dir", "/usr/local/share/man/man1"),+    ("installman3dir", "/usr/local/share/man/man3"),+    ("installprivlib", "/usr/local/lib/perl6"),+    ("installscript", "/usr/local/bin"),+    ("installsitearch", "/usr/local/lib/perl6/site_perl/darwin-2level"),+    ("installsitebin", "/usr/local/bin"),+    ("installsitelib", "/usr/local/lib/perl6/site_perl"),+    ("installsiteman1dir", "/usr/local/share/man/man1"),+    ("installsiteman3dir", "/usr/local/share/man/man3"),+    ("osname", "darwin"),+    ("pager", "/usr/bin/less"),+    ("path_sep", ":"),+    ("perl5_path", "/usr/local/bin/perl5.9.5"),+    ("perl_compiler", "pugs"),+    ("perl_revision", "6"),+    ("perl_subversion", "0"),+    ("perl_version", "0"),+    ("prefix", "/usr/local"),+    ("privlib", "/usr/local/lib/perl6"),+    ("pugspath", "/usr/local/bin/pugs"),+    ("regex_engine", "default"),+    ("scriptdir", "/usr/local/bin"),+    ("sitearch", "/usr/local/lib/perl6/site_perl/darwin-2level"),+    ("sitebin", "/usr/local/bin"),+    ("sitelib", "/usr/local/lib/perl6/site_perl"),+    ("siteprefix", "/usr/local"),+    ("sitescript", "/usr/local/bin"),+    ("sourcedir", "/Users/audreyt/work/pugs"),+    ("uname", "Darwin 8.10.1 i386")+    ,("pugs_versnum", Pugs.Version.versnum)+    ,("pugs_version", Pugs.Version.version)+    ,("pugs_revision", Pugs.Version.revnum)+    ]++getConfig :: String -> String+getConfig key = Map.findWithDefault "" key config
+ src/Pugs/Cont.hs view
@@ -0,0 +1,47 @@+{-# OPTIONS_GHC -fglasgow-exts -fno-warn-unused-binds #-}++{-|+    Continuation with shift and reset operators.++>   The Road goes ever on and on+>   Down from the door where it began.+>   Now far ahead the Road has gone,+>   And I must follow, if I can...+-}++module Pugs.Cont (+    callCCT, shift, reset, shiftT, resetT,+    module Control.Monad.Cont,+) where++import qualified Control.Monad.Cont as C (lift)+import Control.Monad.Cont (mapContT, withContT, mapCont, withCont, Cont(..), ContT(..), MonadCont(..))++-- Cont' m a is the type of a continuation expecting an a within the +-- continuation monad Cont m+type Cont' m a = forall r. a -> m r++callCCT :: forall a m. MonadCont m => (Cont' m a -> m a) -> m a+callCCT f = callCC f' where+  f' :: (a -> m (EmptyMonad m)) -> m a+  f' g = f g' where+    g' :: a -> m b+    g' = (=<<) runEmptyMonad . g++-- ghc doesn't allow something like m (forall c. m c)+newtype EmptyMonad m = EmptyMonad { runEmptyMonad :: forall c. m c }++-- shift/reset for the Cont monad+shift :: ((a -> Cont s r) -> Cont r r) -> Cont r a+shift e = Cont $ \k -> e (return . k) `runCont` id++reset :: Cont a a -> Cont r a +reset e = return $ e `runCont` id++-- shiftT/resetT for the ContT monad transformer+shiftT :: Monad m => ((a -> ContT r m s) -> ContT s m s) -> ContT s m a+shiftT e = ContT $ \k -> e (C.lift . k) `runContT` return++resetT :: Monad m => ContT a m a -> ContT r m a+resetT e = C.lift $ e `runContT` return+
+ src/Pugs/Embed.hs view
@@ -0,0 +1,37 @@+{-# OPTIONS_GHC -fglasgow-exts -cpp #-}++{-|+    Embedded interpreters.++>   As Beren looked into her eyes+>   Within the shadows of her hair,+>   The trembling starlight of the skies+>   He saw there mirrored shimmering...+-}++module Pugs.Embed (+    module Pugs.Embed.Perl5,+    module Pugs.Embed.Haskell,+    module Pugs.Embed.Parrot,+    module Pugs.Embed.Pugs,+    evalEmbedded+    -- module Pugs.Embed.Ponie,+) where+import Pugs.Embed.Perl5+import Pugs.Embed.Haskell+import Pugs.Embed.Parrot+import Pugs.Embed.Pugs++evalEmbedded :: String -> String -> IO ()+evalEmbedded "Pir" = evalParrot+evalEmbedded "PIR" = evalParrot+evalEmbedded "Parrot" = evalParrot+evalEmbedded "Pugs" = evalPugs+{- evalEmbedded "Haskell" code = do+    evalHaskell code+    return () -}+evalEmbedded "Perl5" = \code -> do+    interp <- initPerl5 "" Nothing+    evalPerl5 code nullEnv 0+    freePerl5 interp+evalEmbedded s = const . fail $ "Cannot evaluate in " ++ s
+ src/Pugs/Embed/Haskell.hs view
@@ -0,0 +1,29 @@+{-# OPTIONS_GHC -fglasgow-exts -cpp -package plugins #-}++module Pugs.Embed.Haskell where++-- #include "../pugs_config.h"+#if !defined(PUGS_HAVE_HSPLUGINS)++import Pugs.AST++evalHaskell :: String -> Eval Val+evalHaskell _ = fail "need hs-plugins for eval_haskell"++#else++import qualified System.Eval+import Pugs.AST++evalHaskell :: String -> Eval Val+evalHaskell code = do+    let imports = []+    -- eval_ code [import] [flags] [package.confs] [load paths]+    --   -> IO (Either [error-strings] (Maybe a))+    ret <- io $ System.Eval.eval_ code imports [] [] []+    case ret of+        Right (Just x) -> return $ VStr x+        Right Nothing  -> fail "Something strange happened"+        Left x         -> fail $ unlines x++#endif
+ src/Pugs/Embed/Parrot.hs view
@@ -0,0 +1,133 @@+{-# INCLUDE "Parrot_hsc.h" #-}+{-# LINE 1 "Parrot.hsc" #-}+{-# OPTIONS_GHC -fglasgow-exts -cpp -fno-full-laziness -fno-cse #-}+{-# LINE 2 "Parrot.hsc" #-}++{-# LINE 3 "Parrot.hsc" #-}++module Pugs.Embed.Parrot where+import Data.IORef+import System.Cmd+import System.Process+import System.Directory+import System.IO+import System.IO.Unsafe+import Data.Maybe+import Control.Monad+import Pugs.Compat (getEnv, _PUGS_HAVE_POSIX)+import Pugs.Internals (encodeUTF8)++findExecutable' :: String -> IO (Maybe FilePath)+findExecutable' cmd = do+    dir <- getEnv "PARROT_PATH"+    if isJust dir then (do+        rv  <- findExecutableInDirectory (fromJust dir) cmd+        if isJust rv then return rv else findExecutable'') else do+    findExecutable''+    where+    findExecutable'' = do+        rv  <- findExecutable cmd+        if isJust rv then return rv else do+        cwd <- getCurrentDirectory+        rv  <- findExecutableInDirectory cwd cmd+        if isJust rv then return rv else do+        return Nothing++findExecutableInDirectory :: FilePath -> FilePath -> IO (Maybe FilePath)+findExecutableInDirectory dir cmd = do+    let file | _PUGS_HAVE_POSIX = dir ++ ('/':cmd)+             | otherwise        = dir ++ ('\\':cmd) ++ ".exe"+    ok <- doesFileExist file+    return $ if ok then (Just file) else Nothing++findParrot :: IO FilePath+findParrot = do+    rv <- findExecutable' "parrot"+    case rv of+        Nothing     -> fail "Cannot find the parrot executable in PATH"+        Just cmd    -> return cmd++evalParrotFile :: FilePath -> IO ()+evalParrotFile file = do+    cmd <- findParrot+    -- parrot -j is fatal on systems where jit is not supported,+    -- so we use the next fastest CGP core.+    args <- getEnv "PUGS_PARROT_OPTS"+    let args' | isJust args && fromJust args /= "" = fromJust args+              | otherwise                          = "-f"+    rawSystem cmd [args', file]+    return ()++evalParrot :: String -> IO ()+evalParrot str = do+    tmp         <- getTemporaryDirectory+    (file, fh)  <- openTempFile tmp "pugs.pir"+    hPutStr fh str+    hClose fh+    evalParrotFile file+    removeFile file++evalPGE :: FilePath -> String -> String -> [(String, String)] -> IO String+evalPGE path match rule subrules = do+    (inp, out, err, pid) <- initPGE path+    (`mapM` subrules) $ \(name, rule) -> do+        let nameStr = escape name+            ruleStr = escape rule+        hPutStrLn inp $ unwords+            ["add_rule", show (length nameStr), show (length ruleStr)]+        hPutStrLn inp nameStr+        hPutStrLn inp ruleStr+    let matchStr = escape match+        ruleStr  = escape rule+    hPutStrLn inp $ unwords+        ["match", show (length matchStr), show (length ruleStr)]+    hPutStrLn inp $ matchStr+    hPutStrLn inp $ ruleStr+    hFlush inp+    rv <- hGetLine out+    case rv of+        ('O':'K':' ':sizeStr) -> do+            size <- readIO sizeStr+            rv   <- sequence (replicate size (hGetChar out))+            ln   <- hGetLine out+            return $ rv ++ ln+        _ -> do+            errMsg  <- hGetContents err+            rv      <- waitForProcess pid+            writeIORef _ParrotInterp Nothing+            let msg | null errMsg = show rv+                    | otherwise   = errMsg+            fail $ "*** Running external 'parrot' failed:\n" ++ msg+    where+    escape = escape . encodeUTF8+    _escape "" = ""+    _escape ('\\':xs) = "\\\\" ++ _escape xs+    _escape ('\n':xs) = "\\n" ++ _escape xs+    _escape (x:xs) = (x:_escape xs)++initPGE :: FilePath -> IO ParrotInterp+initPGE path = do+    rv <- readIORef _ParrotInterp+    case rv of+        Just interp@(_, _, _, pid) -> do+            gone <- getProcessExitCode pid+            if isNothing gone then return interp else do+            writeIORef _ParrotInterp Nothing+            initPGE path+        Nothing -> do+            cmd <- findParrot+            interp <- runInteractiveProcess cmd ["run_pge.pir"] (Just path) Nothing +            writeIORef _ParrotInterp (Just interp)+            return interp++type ParrotInterp = (Handle, Handle, Handle, ProcessHandle)++{-# NOINLINE _ParrotInterp #-}+_ParrotInterp :: IORef (Maybe ParrotInterp)+_ParrotInterp = unsafePerformIO $ newIORef Nothing++_DoCompile :: Maybe (IORef (String -> FilePath -> String -> IO String))+_DoCompile = Nothing+++{-# LINE 387 "Parrot.hsc" #-}
+ src/Pugs/Embed/Perl5.hs view
@@ -0,0 +1,381 @@+{-# OPTIONS_GHC -fglasgow-exts -cpp -optc-w #-}++#ifndef PUGS_HAVE_PERL5+module Pugs.Embed.Perl5 +    ( InvokePerl5Result(..)+    , svToVBool, svToVInt, svToVNum, svToVStr, vstrToSV, vintToSV, svToVal, bufToSV, svUndef+    , vnumToSV, mkValRef, mkValPtr, mkEnv, PerlSV, nullSV, nullEnv, evalPerl5, invokePerl5+    , initPerl5, freePerl5, canPerl5+    , evalPCR, pugs_SvToVal+    )+where+import Foreign.C.Types+import System.Directory+import Pugs.Internals +import qualified Data.ByteString.UTF8 as Str++evalPCR :: FilePath -> String -> String -> [(String, String)] -> IO String+evalPCR path match rule subrules = do+    (inp, out, err, pid) <- initPCR path+    (`mapM` subrules) $ \(name, rule) -> do+        let nameStr = escape name+            ruleStr = escape rule+        hPutStrLn inp $ unwords+            ["add_rule", show (length nameStr), show (length ruleStr)]+        hPutStrLn inp nameStr+        hPutStrLn inp ruleStr+    let matchStr = escape match+        ruleStr  = escape rule+    hPutStrLn inp $ unwords+        ["match", show (length matchStr), show (length ruleStr)]+    hPutStrLn inp $ matchStr+    hPutStrLn inp $ ruleStr+    hFlush inp+    rv <- hGetLine out+    case rv of+        ('O':'K':' ':_) -> do+            -- size <- readIO sizeStr+            -- rv   <- sequence (replicate size (hGetChar out))+            ln   <- hGetLine out+            ln2  <- hGetLine out+            return $ ln ++ ln2+        _ -> do+            errMsg  <- fmap (rv ++) (hGetContents err)+            rc      <- waitForProcess pid+            writeIORef _Perl5Interp Nothing+            let msg | null errMsg = show rc+                    | otherwise   = errMsg+            fail $ "*** Running external 'perl' failed:\n" ++ msg+    where+    escape "" = ""+    escape ('\\':xs) = "\\\\" ++ escape xs+    escape ('\n':xs) = "\\n" ++ escape xs+    escape (x:xs) = (x:escape xs)++initPCR :: FilePath -> IO Perl5Interp+initPCR path = do+    rv <- readIORef _Perl5Interp+    case rv of+        Just interp@(_, _, _, pid) -> do+            gone <- getProcessExitCode pid+            if isNothing gone then return interp else do+            writeIORef _Perl5Interp Nothing+            initPCR path+        Nothing -> do+            cmd <- findPerl5+            interp <- runInteractiveProcess cmd+                [ "-Iperl5/Pugs-Compiler-Rule/lib"+                , "-MPugs::Runtime::Match::HsBridge"+                , "-ePugs::Runtime::Match::HsBridge::__CMD__"+                ] (Just path) Nothing +            writeIORef _Perl5Interp (Just interp)+            return interp+    where+    findPerl5 :: IO FilePath+    findPerl5 = do+        rv <- findExecutable "perl"+        case rv of+            Nothing     -> do+                rv' <- findExecutable "perl.exe"+                case rv' of+                    Just cmd    -> return cmd+                    Nothing     -> fail "Cannot find the parrot executable in PATH"+            Just cmd    -> return cmd++type Perl5Interp = (Handle, Handle, Handle, ProcessHandle)++{-# NOINLINE _Perl5Interp #-}+_Perl5Interp :: IORef (Maybe Perl5Interp)+_Perl5Interp = unsafePerformIO $ newIORef Nothing++type PerlInterpreter = ()+data PerlSV = MkPerlSV -- phantom type+    deriving (Show, Eq, Ord, Typeable)+type PugsVal = PerlSV+type PugsEnv = PerlSV++data InvokePerl5Result+    = Perl5ReturnValues [PerlSV]+    | Perl5ErrorString String+    | Perl5ErrorObject PerlSV+    deriving (Show, Typeable)++constFail :: a -> IO b+constFail = const $ fail "perl5 not embedded"++initPerl5 :: String -> Maybe a -> IO PerlInterpreter+initPerl5 _ _ = return ()++freePerl5 :: PerlInterpreter -> IO ()+freePerl5 _ = return ()++evalPerl5 :: String -> PugsEnv -> CInt -> IO PerlSV+evalPerl5 _ _ = constFail++svToVStr :: PerlSV -> IO String+svToVStr = constFail++svToVInt :: (Num a) => PerlSV -> IO a+svToVInt = constFail++svToVNum :: (Fractional a) => PerlSV -> IO a+svToVNum = constFail++svToVBool :: PerlSV -> IO Bool+svToVBool = constFail++svToVal :: PerlSV -> IO a+svToVal = constFail++mkValPtr :: (Show a) => a -> IO PugsVal+mkValPtr = constFail++mkEnv :: a -> IO PugsVal+mkEnv = constFail++mkValRef :: a -> String -> IO PerlSV+mkValRef _ = constFail++vstrToSV :: String -> IO PerlSV+vstrToSV = constFail++svUndef :: IO PerlSV+svUndef = error "perl5 not embedded"++bufToSV :: ByteString -> IO PerlSV+bufToSV = constFail++vintToSV :: (Integral a) => a -> IO PerlSV+vintToSV = constFail++vnumToSV :: (Real a) => a -> IO PerlSV+vnumToSV = constFail++invokePerl5 :: PerlSV -> PerlSV -> [PerlSV] -> PugsEnv -> CInt -> IO InvokePerl5Result+invokePerl5 _ _ _ _ = constFail++canPerl5 :: PerlSV -> ByteString -> IO Bool+canPerl5 MkPerlSV = constFail++pugs_SvToVal :: PerlSV -> IO PugsVal+pugs_SvToVal = constFail++nullSV :: PerlSV+nullSV = error "perl5 not embedded"++nullEnv :: PugsVal+nullEnv = error "perl5 not embedded"++-- Below are unused++-- mkSV :: IO PerlSV -> IO PerlSV+-- mkSV = id++-- perl5_SvROK :: IO PerlSV -> IO Bool+-- perl5_SvROK _ = return False++#else+#undef RETURN++{-# INCLUDE "../../perl5/p5embed.h" #-}+{-# INCLUDE "../../perl5/pugsembed.h" #-}++module Pugs.Embed.Perl5 where+import Pugs.Internals+import Foreign+import Foreign.C.Types+import Foreign.C.String+import {-# SOURCE #-} Pugs.AST.Internals+import qualified UTF8 as Str+import qualified Pugs.Val as Val++type PerlInterpreter = Ptr ()+type PerlSV = Ptr ()+type PugsVal = StablePtr Val+type PugsEnv = StablePtr Env++foreign import ccall "perl_alloc"+    perl_alloc :: IO PerlInterpreter+foreign import ccall "perl_construct"+    perl_construct :: PerlInterpreter -> IO ()+foreign import ccall "perl_run"+    perl_run :: PerlInterpreter -> IO CInt+foreign import ccall "perl_destruct"+    perl_destruct :: PerlInterpreter -> IO CInt+foreign import ccall "perl_free"+    perl_free :: PerlInterpreter -> IO ()+{-+foreign import ccall "boot_DynaLoader"+    boot_DynaLoader :: Ptr () -> IO ()+-}+foreign import ccall "perl5_finalize"+    perl5_finalize :: PerlSV -> IO ()+foreign import ccall "perl5_SvPV"+    perl5_SvPV :: PerlSV -> IO CString+foreign import ccall "perl5_SvIV"+    perl5_SvIV :: PerlSV -> IO CInt+foreign import ccall "perl5_SvNV"+    perl5_SvNV :: PerlSV -> IO CDouble+foreign import ccall "perl5_SvTRUE"+    perl5_SvTRUE :: PerlSV -> IO Bool+foreign import ccall "perl5_SvROK"+    perl5_SvROK :: PerlSV -> IO Bool+foreign import ccall "perl5_newSVpvn"+    perl5_newSVpvn :: CString -> CInt -> IO PerlSV+foreign import ccall "perl5_newSViv"+    perl5_newSViv :: CInt -> IO PerlSV+foreign import ccall "perl5_newSVnv"+    perl5_newSVnv :: CDouble -> IO PerlSV+foreign import ccall "perl5_sv_undef"+    perl5_sv_undef :: IO PerlSV+foreign import ccall "perl5_get_sv"+    perl5_get_sv :: CString -> IO PerlSV+foreign import ccall "perl5_apply"+    perl5_apply :: PerlSV -> PerlSV -> Ptr PerlSV -> PugsEnv -> CInt -> IO (Ptr PerlSV)+foreign import ccall "perl5_can"+    perl5_can :: PerlSV -> CString -> IO Bool+foreign import ccall "perl5_eval"+    perl5_eval :: CString -> PugsEnv -> CInt -> IO PerlSV+foreign import ccall "perl5_init"+    perl5_init :: CInt -> Ptr CString -> IO PerlInterpreter++foreign import ccall "pugs_getenv"+    pugs_getenv :: IO PugsEnv+foreign import ccall "pugs_setenv"+    pugs_setenv :: PugsEnv -> IO ()++foreign import ccall "pugs_SvToVal"+    pugs_SvToVal :: PerlSV -> IO PugsVal+foreign import ccall "pugs_MkValRef"+    pugs_MkValRef :: PugsVal -> CString -> IO PerlSV++initPerl5 :: String -> Maybe Env -> IO PerlInterpreter+initPerl5 str env = do+    withCString "-e" $ \prog -> withCString str $ \cstr -> do+        withArray [prog, prog, cstr] $ \argv -> do+            interp <- perl5_init 3 argv+            case env of+                Just val    -> pugs_setenv =<< mkEnv val+                Nothing     -> return ()+            modifyIORef _GlobalFinalizer (>> perl_free interp)+            return interp++mkValPtr :: Val -> IO PugsVal+mkValPtr x = do+    -- warn "Creating nonblessed stable pointer for " (showVal x)+    newStablePtr x++mkEnv :: Env -> IO PugsEnv+mkEnv = newStablePtr++svToVStr :: PerlSV -> IO String+svToVStr sv = peekCString =<< perl5_SvPV sv++svToVInt :: (Num a) => PerlSV -> IO a+svToVInt sv = fmap fromIntegral $ perl5_SvIV sv++svToVNum :: (Fractional a) => PerlSV -> IO a+svToVNum sv = fmap realToFrac $ perl5_SvNV sv++svToVBool :: PerlSV -> IO Bool+svToVBool = perl5_SvTRUE++svToVal :: PerlSV -> IO Val+svToVal sv = do+    ptr <- pugs_SvToVal sv+    deRefStablePtr ptr++mkValRef :: Val -> String -> IO PerlSV+mkValRef x typ = do+    -- warn "Creating stable pointer for " (showVal x)+    val <- mkValPtr x+    withCString typ (pugs_MkValRef val)++svUndef :: IO PerlSV+svUndef = perl5_sv_undef++vstrToSV :: String -> IO PerlSV+vstrToSV str = Str.useAsCStringLen (cast str) $ \(cstr, len) -> perl5_newSVpvn cstr (toEnum len)++bufToSV :: ByteString -> IO PerlSV+bufToSV str = Str.useAsCStringLen str $ \(cstr, len) -> perl5_newSVpvn cstr (toEnum len)++vintToSV :: (Integral a) => a -> IO PerlSV+vintToSV int = perl5_newSViv (fromIntegral int)++vnumToSV :: (Real a) => a -> IO PerlSV+vnumToSV int = perl5_newSVnv (realToFrac int)+++data InvokePerl5Result+    = Perl5ReturnValues [PerlSV]+    | Perl5ErrorString String+    | Perl5ErrorObject PerlSV+    deriving (Show, Typeable)++invokePerl5 :: PerlSV -> PerlSV -> [PerlSV] -> PugsEnv -> CInt -> IO InvokePerl5Result+invokePerl5 sub inv args env cxt = do+    withArray0 nullPtr args $ \argv -> do+        rv  <- perl5_apply sub inv argv env cxt+        svs <- peekArray0 nullPtr rv++        -- If it's empty, no error occured (see p5embed.c on out[0]).+        -- Otherwise, the second slot may be a stringified version we should use.+        case svs of+            []      -> fmap Perl5ReturnValues $ peekArray0 nullPtr (rv `advancePtr` 1)+            [err]   -> return $ Perl5ErrorObject err+            (_:x:_) -> do+                str <- svToVStr x+                return $ Perl5ErrorString str+            +canPerl5 :: PerlSV -> ByteString -> IO Bool+canPerl5 sv meth = Str.useAsCString meth $ \cstr -> perl5_can sv cstr++mkSV :: IO PerlSV -> IO PerlSV+mkSV action = action+{-+ - do+    sv <- action +    addFinalizer sv (perl5_finalize sv)+    return sv+-}++evalPerl5 :: String -> PugsEnv -> CInt -> IO PerlSV+evalPerl5 str env cxt = mkSV $ Str.useAsCString (cast str) $ \cstr -> perl5_eval cstr env cxt++freePerl5 :: PerlInterpreter -> IO ()+freePerl5 my_perl = do+    perl_destruct my_perl+    return ()++nullSV :: PerlSV+nullSV = nullPtr++{-# NOINLINE nullEnv #-}+nullEnv :: PugsEnv+nullEnv = unsafePerformIO (newStablePtr (error "undefined environment"))++evalPCR :: FilePath -> String -> String -> [(String, String)] -> IO String+evalPCR path match rule subrules = do+    let bridgeMod   = "Pugs::Runtime::Match::HsBridge"+        bridgeFile  = "Pugs/Runtime/Match/HsBridge.pm";+    inv     <- evalPerl5 (unlines+        [ "if (!$INC{'"++bridgeFile++"'}) {"+        , "    unshift @INC, '"++path++"';"+        , "    eval q[require '"++bridgeFile++"'] or die $@;"+        , "}"+        , "'"++bridgeMod++"'"+        ]) nullEnv 1+    meth    <- vstrToSV "__RUN__"+    args    <- mapM vstrToSV $ concatMap (\(x, y) -> [x, y]) ((match, rule):subrules)+    rv      <- invokePerl5 meth inv args nullEnv 1+    case rv of+        Perl5ReturnValues []    -> return ""+        Perl5ReturnValues (x:_) -> svToVStr x+        Perl5ErrorString err    -> return $ "Error: " ++ err+        Perl5ErrorObject obj    -> do+            err <- svToVStr obj+            return $ "Error: " ++ err++#endif+
+ src/Pugs/Embed/Pugs.hs view
@@ -0,0 +1,17 @@+{-# OPTIONS_GHC -fglasgow-exts #-}++module Pugs.Embed.Pugs where+import System.Cmd+import System.Directory+import System.IO++evalPugs :: String -> IO ()+evalPugs str = do+    tmp         <- getTemporaryDirectory+    (file, fh)  <- openTempFile tmp "pugs.hs"+    hPutStr fh str+    hClose fh+    rv          <- findExecutable "runghc"+    case rv of+        Nothing -> removeFile file >> fail "Cannot find runghc in PATH"+        Just p  -> rawSystem p [file] >> removeFile file
+ src/Pugs/Eval.hs view
@@ -0,0 +1,1585 @@+{-# OPTIONS_GHC -fglasgow-exts -cpp -fno-warn-deprecations -fallow-overlapping-instances -fparr #-}++{-|+    Evaluation and reduction engine.++>   Home is behind, the world ahead,+>   And there are many paths to tread+>   Through shadows to the edge of night,+>   Until the stars are all alight.+>   Then world behind and home ahead,+>   We'll wander back to home and bed...++This module takes an /abstract syntax tree/ and recursively evaluates it,+thereby evaluating the program.++The AST is represented as a hierarchy of nested 'Exp' expressions+(see "Pugs.AST").  Some understanding of 'Exp' and "Pugs.AST" in will help in+understanding this module.+-}++module Pugs.Eval (+    evaluate,+    emptyEnv, evaluateMain,+    enterLValue, enterRValue,+    runWarn+) where+import Pugs.Internals+import Prelude hiding ( exp )+import qualified Data.Map as Map+import qualified StringTable.AtomMap as AtomMap++import Pugs.AST+import Pugs.Junc+import Pugs.Bind+import Pugs.Prim+import Pugs.Prim.List (op0Zip, op0Cat, op0Each, op0RoundRobin)+import Pugs.Monads+import Pugs.Pretty+import Pugs.Types+import Pugs.External+import Pugs.Eval.Var+import DrIFT.YAML ()+import GHC.PArr+import qualified Data.ByteString.UTF8 as Str+import qualified Data.ByteString.Char8 as Buf+++{-|+Construct a new, \'empty\' 'Env' (evaluation environment).++See the source of 'Pugs.Prims.initSyms' for a list of symbols that are+initially present in the global 'Pad'.+-}+emptyEnv :: (MonadIO m, MonadSTM m) +         => String             -- ^ Name associated with the environment+         -> [STM PadMutator]   -- ^ List of 'Pad'-mutating transactions used+                               --     to declare an initial set of global+                               --     variables+         -> m Env+emptyEnv name genPad = stm $ do+    pad  <- sequence genPad+    ref  <- newTVar Map.empty+    syms <- initSyms+    let globPad = combine (pad ++ syms) $ mkPad []+    glob <- newMPad globPad+    init <- newTVar $ MkInitDat { initPragmas=[] }+    maxi <- newTVar $ MkObjectId 1+    return $ MkEnv+        { envContext = CxtVoid+        , envLexical = emptyPad+        , envLexPads = []+        , envCaller  = Nothing+        , envCompPad = Nothing+        , envLValue  = False+        , envGlobal  = length (show (padKeys globPad)) `seq` glob -- force eval of all sym names+        , envPackage = cast "Main"+        , envEval    = evaluate+        , envFrames  = emptyFrames+        , envBody    = Val undef+        , envDebug   = Just ref -- Set to "Nothing" to disable debugging+        , envPos     = MkPos (cast name) 1 1 1 1+        , envPragmas = []+        , envInitDat = init+        , envMaxId   = maxi+        , envAtomic  = False+        }++-- Evaluation ---------------------------------------------------------------++{-|+Emits a runtime warning.+-}+-- XXX: This should cache so that you don't warn in the same place twice+--   (even though Perl 5 doesn't do this).+--   It should also respond to lexical warnings pragmata.+runWarn :: String -> Eval ()+runWarn msg = do +    enterEvalContext CxtVoid $+        App (_Var "&warn") Nothing [Val (VStr msg)]+    return ()++type DebugCache = TVar (Map ID String)++{-# SPECIALIZE debug :: DebugCache -> ID -> (String -> String) -> String -> String -> Eval () #-}+debug :: Pretty a => DebugCache -> ID -> (String -> String) -> String -> a -> Eval ()+debug ref key fun str a = do+    val <- stm $ do+        fm <- readTVar ref+        let val = fun $ Map.findWithDefault "" key fm+        writeTVar ref (Map.insert key val fm)+        return val+    when (length val > 100) $ do+        stm . unsafeIOToSTM $ putStrLn "*** Warning: deep recursion"+    stm . unsafeIOToSTM $ putStrLn ("***" ++ val ++ str ++ encodeUTF8 (pretty a))++evaluateMain :: Exp -> Eval Val+evaluateMain exp = do+    -- S04: INIT {...}*      at run time, ASAP+    initAV   <- reduceVar $ cast "@*INIT"+    initSubs <- fromVals initAV+    enterContext CxtVoid $ do+        mapM_ evalExp [ App (Val sub) Nothing [] | sub@VCode{} <- initSubs ]+    evalExp (Syn "=" [_Var "@*INIT", Syn "," []])+    -- The main runtime+    tryT (evaluate exp) `finallyM` do+        -- S04: END {...}       at run time, ALAP+        endAV       <- reduceVar $ cast "@*END"+        endSubs     <- fromVals endAV+        endMainAV   <- reduceVar $ cast "@Main::END"+        endMainSubs <- fromVals endMainAV+        enterContext CxtVoid $ do+            mapM_ evalExp [ App (Val sub) Nothing [] | sub@VCode{} <- endMainSubs ++ endSubs ]++{-|+Evaluate an expression.++This function mostly just delegates to 'reduce'.+-}+evaluate :: Exp -- ^ The expression to evaluate+         -> Eval Val+evaluate (Val val) = reduceVal val+evaluate exp = do+    debugRef <- asks envDebug+    case debugRef of+        Just ref -> do+            want <- asks envWant+            debug ref (cast "indent") ('-':) (" Evl [" ++ want ++ "]:\n") exp+            val <- local (\e -> e{ envBody = exp }) $ reduce exp+            debug ref (cast "indent") (\x -> if null x then [] else tail x) "- Ret: " val+            trapVal val (return val)+        Nothing -> local (\e -> e{ envEval = evaluate' }) (evaluate' exp)++evaluate' :: Exp -> Eval Val+evaluate' exp = do+    val <- reduce exp+    trapVal val (return val)++-- Reduction ---------------------------------------------------------------++retItem :: Val -> Eval Val+retItem val = do+    ifListContext+        (return $ VList [val])+        (return $ val)++{-|+Add a symbol to the global 'Pad'.++Used by 'reduceSym'.+-}+addGlobalSym :: PadMutator -- ^ 'Pad'-transformer that will insert the new+                           --     symbol+             -> Eval ()+addGlobalSym newSym = do+    glob <- asks envGlobal+    modifyMPad glob newSym++trapVal :: Val -> Eval a -> Eval a+trapVal val action = case val of+    VError str posList -> do+        pos <- asks envPos+        retShift $ VError str (pos:posList)+    VControl c      -> retControl c+    _               -> action++evalRef :: VRef -> Eval Val+evalRef ref = do+    if refType ref == (mkType "Thunk") then forceRef ref else do+    val <- catchT $ \(esc :: Val -> Eval ()) -> do+        MkEnv{ envContext = cxt, envLValue = lv } <- ask+        let typ = typeOfCxt cxt+            isCollectionRef = isaType "List" (refType ref)+        -- If RValue, read from the reference+        unless lv $ do+            when (isCollectionRef && isItemCxt cxt) $ do+                -- auto-enreference+                esc $ VRef ref+            case ref of+                MkRef IPair{}   -> esc (VRef ref)+                _               -> esc =<< readRef ref+        -- LValue here+        when isCollectionRef $ esc (castV ref)+        val <- readRef ref+        let isAutovivify = and $+                [ isItemCxt cxt+                , isUndefinedVal val+                , (typ ==) `any` [mkType "Array", mkType "Hash"]+                ]+            isUndefinedVal VUndef   = True+            isUndefinedVal VType{}  = True+            isUndefinedVal _        = False+            -- Here we ensutre "my Hash $x" can only vivify into Hash no matter how it's asked.+            typ' = case val of+                VType t -> t+                _       -> typ +        when isAutovivify $ do+            ref' <- newObject typ'+            writeRef ref (VRef ref')+        return $ castV ref+    return val++{-|+Reduce an expression into its value.++This function dispatches to the relevant @reduce*@ function for the type of+expression given.+-}+reduce :: Exp -- ^ The expression to reduce+       -> Eval Val++reduce (Val v) = reduceVal v++reduce (Var name) = reduceVar name++reduce (Stmts this rest) = reduceStmts this rest++reduce (Ann (Prag prag) exp) = reducePrag prag exp++reduce (Ann (Pos pos) exp) = reducePos pos exp++reduce (Ann (Cxt cxt) exp) = reduceCxt cxt exp++reduce (Ann _ exp) = reduce exp++-- reduce (Pad scope lexEnv exp) = reducePad scope lexEnv exp++reduce (Sym scope name flags init rest) = reduceSym scope name flags init rest++-- Reduction for no-operations+reduce Noop = retEmpty++reduce (Syn name subExps) = reduceSyn name subExps++reduce (App subExp inv args) = reduceApp subExp inv args++reduce exp = die "Invalid expression" exp++reduceVal :: Val -> Eval Val+reduceVal v@(VRef (MkRef IPair{})) = return v++-- Reduction for mutables+reduceVal v@(VRef var) = do+    lv <- asks envLValue+    if lv then return v else readRef var++-- Reduction for constants+reduceVal v = evalVal v++isStrict :: Eval Bool+isStrict = fromVal =<< readVar (cast "$*STRICT")++-- Reduction for variables+reduceVar :: Var -> Eval Val+reduceVar var@MkVar{ v_sigil = sig, v_twigil = twi, v_name = name, v_package = pkg }+    | TAttribute <- twi+    = reduceSyn (show sig ++ "{}") [ Syn "{}" [_Var "$__SELF__", Val (VStr $ cast name)] ]+    | TPrivate <- twi+    = reduceSyn (show sig ++ "{}") [ Syn "{}" [_Var "$__SELF__", Val (VStr $ cast name)] ]+    | otherwise = do+        v <- findVar var+        case v of+            Just ref -> evalRef ref+            Nothing+                | SType <- sig      -> return . VType . cast $ if isQualifiedVar var+                    then cast $ Buf.intercalate (__"::") [cast pkg, cast name]+                    else name+                | isGlobalVar var || pkg `notElem` [emptyPkg, callerPkg, outerPkg, contextPkg] -> do+                    -- '$Qualified::Var' is not found.  Vivify at lvalue context.+                    lv <- asks envLValue+                    if not lv then retEmpty else evalExp (Sym SOur var mempty Noop (Var var))+                | otherwise -> do+                    s <- isStrict+                    if s then do +                            lex     <- asks envLexical+                            pads    <- asks envLexPads+                            die "Undeclared variable" (var, lex, pads)+                         else do+                            lv <- asks envLValue+                            if lv then evalExp (Sym SOur var mempty Noop (Var var)) else retEmpty++reduceStmts :: Exp -> Exp -> Eval Val+reduceStmts Noop rest           = reduce rest+reduceStmts (Ann _ Noop) rest   = reduce rest+reduceStmts this Noop           = reduce this+reduceStmts this (Ann _ Noop)   = reduce this++-- XXX - Hack to get context propagating to "return"+reduceStmts this@(App (Var var) _ _) _ | var == varReturn = reduce this+reduceStmts this@(Ann _ (App (Var var) _ _)) _ | var == varReturn = reduce this++reduceStmts this (Syn "continuation" []) = do+    val <- reduce this+    trapVal val . callCC $ \cc -> do+        env <- ask+        return . VControl $ ControlContinuation env val cc++reduceStmts this rest = do+    let withCxt = case this of+            App (Var var) _ _         | var == varYield -> id+            Ann _ (App (Var var) _ _) | var == varYield -> id+            _  -> enterContext cxtVoid+    val <- withCxt (reduce this)+    trapVal val (reduce rest)++reducePrag :: [Pragma] -> Exp -> Eval Val+reducePrag prag exp = do+    local (\e -> e{ envPragmas = prag }) $ do+        evalExp exp++varYield :: Var+varYield = cast "&yield"++varReturn :: Var+varReturn = cast "&return"++{-|+Reduce a 'Pos' expression by reducing its subexpression in a new 'Env', which+holds the 'Pos'\'s position.+-}+reducePos :: Pos -> Exp -> Eval Val+reducePos pos exp = do+    local (\e -> e{ envPos = pos }) $ do+        evalExp exp++{-+reducePad STemp lex exp = do+    tmps <- mapM (\(sym, _) -> evalExp $ App (_Var "&TEMP") (Just $ Var sym) []) $ padToList lex+    -- default to nonlocal exit+    isNonLocal  <- io $ newTVarIO True+    val <- tryT $ do+        -- if the stm is reached, exp evaluated without error; no need to shift out+        evalExp exp `finallyM` stm (writeTVar isNonLocal False)+    mapM_ (\tmp -> evalExp $ App (Val tmp) Nothing []) tmps+    isn <- stm $ readTVar isNonLocal+    (if isn then retShift else return) val++reducePad SLet lex exp = do+    tmps <- mapM (\(sym, _) -> evalExp $ App (_Var "&TEMP") (Just $ Var sym) []) $ padToList lex+    -- default to nonlocal exit+    isNonLocal  <- io $ newTVarIO True+    val <- tryT $ do+        -- if the stm is reached, exp evaluated without error; no need to shift out+        evalExp exp `finallyM` stm (writeTVar isNonLocal False)+    when (isFailure val) $ do+        mapM_ (\tmp -> evalExp $ App (Val tmp) Nothing []) tmps+    isn <- stm $ readTVar isNonLocal+    if isn then retShift val else return val+    where+    isFailure (VControl ControlLeave{ leaveValue = v }) = isFailure v+    isFailure VControl{}    = True+    isFailure VUndef        = True+    isFailure VError{}      = True+    isFailure (VRef r)      = refType r == mkType "Failure"+    isFailure _             = False+-}++reduceSym :: Scope -> Var -> EntryFlags -> Exp -> Exp -> Eval Val+reduceSym scope var flags init rest+    | not (isLexicalVar var) = do+        qn  <- toQualified var+        ref <- createRef+        sym <- genSymScoped scope qn ref flags+        addGlobalSym sym+        evalExp rest+    | SOur <- scope = do+        ref     <- createRef+        entry   <- genPadEntryScoped scope ref flags+        qn      <- toQualified var+        addGlobalSym (mkPadMutator qn entry ref)+        enterLex [ mkPadMutator var entry ref ] $ evalExp rest+    | otherwise = do+        ref <- createRef+        sym <- genSymScoped scope var ref flags+        enterLex [ sym ] $ evalExp rest+    where+    createRef | Noop <- init = newObject (typeOfSigilVar var)+              | otherwise    = fromVal =<< enterLValue (evalExp init)++-- Context forcing+reduceCxt :: Cxt -> Exp -> Eval Val+reduceCxt cxt exp = do+    val <- enterEvalContext cxt exp+    enterEvalContext cxt (Val val) -- force casting++{-|+Reduce a 'Syn' expression, i.e. a syntactic construct that cannot (yet) be+expressed using 'App' (regular sub application).++Theoretically, 'Syn' will one day be deprecated when 'App' becomes powerful+enough to make it redundant.+-}+reduceSyn :: String -> [Exp] -> Eval Val++reduceSyn "" [Syn "block" [Val (VCode code)]] = do +    -- Reclose all global pads!+    glob    <- asks envGlobal+    stm $ do+        pad     <- readMPad glob+        pad'    <- reclosePad pad+        writeMPad glob pad'+        fmap VCode (recloseCode code)++reduceSyn "named" [keyExp, valExp] = do+    key <- enterEvalContext cxtItemAny keyExp+    val <- enterEvalContext cxtItemAny valExp+    retItem $ castV (key, val)++reduceSyn "continuation" [] = callCC $ \cc -> do+    env <- ask+    return . VControl $ ControlContinuation env undef cc++reduceSyn "block" [exp]+    | Syn "sub" [Val (VCode sub@MkCode{ subType = SubBlock })] <- unwrap exp = do+        unless (isEmptyParams (subParams sub)) $+            fail "Blocks with implicit params cannot occur at statement level"+        enterSub AKInline sub . reduce $ case unwrap (subBody sub) of+            Syn "block" [exp] -> case unwrap exp of+                -- Here we have a nested statement-level block: "{ { 3 } }";+                -- we actually want to create two OUTER blocks, so reduce normally.+                Syn "sub" [Val (VCode MkCode{ subType = SubBlock })] -> subBody sub+                _   -> exp+            _                   -> subBody sub+    | otherwise = enterBlock $ reduce exp+    +reduceSyn "block-perl5" args = do+    -- XXX - 0th approximation.+    reduceApp (_Var "&Pugs::Internals::eval_perl5") Nothing args++reduceSyn "sub" [exp] = do+    sub  <- fromCodeExp exp+    env  <- ask+    cont <- if subType sub /= SubCoroutine then return Nothing else stm $ do+        tvar <- newTVar (error "empty sub")+        let thunk = (`MkThunk` anyType) . fix $ \redo -> do+            evalExp $ subBody sub+            stm $ writeTVar tvar thunk+            redo+        writeTVar tvar thunk+        return $ Just tvar++    -- Close over outer lexical scope.+    -- add &?BLOCK &?ROUTINE etc here+    started     <- if isCompileTime env then return Nothing else fmap Just (stm $ newTVar False)+    inner       <- clonePad (subInnerPad sub) +    return $ VCode sub+        { subCont       = cont+        , subOuterPads  = if isCompileTime env then subOuterPads sub else envLexPads env+        , subInnerPad   = inner+        , subStarted    = started+        }+    where+    clonePad pad = stm $ do+        fmap listToPad $ forM (padToList pad) $ \(var, entry) -> do+            let preserveContent   = readTVar . pe_store+                regenerateContent = cloneRef . pe_proto+            entry' <- clonePadEntry entry $ case v_sigil var of+                SType       -> preserveContent+                SCode       -> preserveContent+                _           -> regenerateContent+            return (var, entry')+    clonePadEntry x@PEConstant{} _ = return x+    clonePadEntry x f = do+        tvar'   <- newTVar =<< f x+        return x{ pe_store = tvar' }++reduceSyn "but" [obj, block] = do+    evalExp $ App (_Var "&Pugs::Internals::but_block") Nothing [obj, block]++reduceSyn "maybe" blocks = do+    env     <- ask+    subs    <- mapM fromCodeExp blocks+    let runInSTM sub = runEvalSTM env (applyInline sub Nothing [])+    guardSTM $ foldl1 orElse (map runInSTM subs)++reduceSyn "if" [cond, bodyIf, bodyElse] = do+    vbool     <- enterRValue $ enterEvalContext (cxtItem "Bool") cond+    vb        <- fromVal vbool+    reduce $ if vb then bodyIf else bodyElse++reduceSyn "cond" [cond, bodyIf, bodyElse] = do+    topic <- enterRValue $ enterEvalContext (cxtItem "Bool") cond+    vb    <- fromVal topic+    sub   <- fromCodeExp $ if vb then bodyIf else bodyElse+    applyInline sub Nothing [App (_Var "&VAR") (Just (Val topic)) []]++reduceSyn "for" [list, body] = enterLoop $ do+    av    <- enterLValue $ enterEvalContext cxtSlurpyAny list+    sub   <- fromCodeExp body+    -- XXX this is wrong -- should use Array.next+    elms  <- case av of+        VRef (MkRef sv@IScalar{})   -> return [sv]+        VList xs                    -> return . (`map` xs) $ \x -> case x of+            VRef (MkRef sv@IScalar{})   -> sv+            _                           -> (IScalar x)+        _                           -> join $ doArray av array_fetchElemAll+    -- This makes "for @x { ... }" into "for @x -> $_ is rw {...}"+    let arity = length (subParams sub)+        runBody [] _ _ = return undef+        runBody vs sub' isFirst = do+            let (these, rest) = (max 1 arity) `splitAt` vs+                realSub+                    = (`afterLeave` if null rest then subLastBlocks else const [])+                    . (`beforeLeave` subNextBlocks)+                    $ if isFirst then sub' `beforeEnter` subFirstBlocks else sub'+            rv <- applyInline realSub Nothing $ map (Val . VRef . MkRef) (take arity these)+            case rv of+                VControl (ControlLoop LoopRedo) -> runBody vs sub' isFirst+                VControl (ControlLoop LoopLast) -> return undef+                _                               -> runBody rest sub' False+    runBody elms sub True++reduceSyn "gather" [exp] = do+    sub     <- fromVal =<< evalExp exp+    globTV  <- asks envGlobal+    glob    <- readMPad globTV+    oldAV   <- findSymRef takeVar glob+    oldSym  <- genSym takeVar oldAV+    newAV   <- newObject (mkType "Array")+    newSym  <- genSym takeVar newAV+    writeMPad globTV (newSym glob)+    enterGather $ applyInline sub Nothing []+    readRef newAV `finallyM` stm (modifyMPad globTV oldSym)+    where+    takeVar = cast "$*TAKE"++reduceSyn "loop" exps = enterLoop $ do+    let [pre, cond, post, body] = case exps of { [_] -> exps'; _ -> exps }+        exps' = [emptyExp, Val (VBool True), emptyExp] ++ exps+        evalCond | unwrap cond == Noop = return True+                 | otherwise = fromVal =<< enterEvalContext (cxtItem "Bool") cond+    sub     <- fromCodeExp body+    evalExp pre+    vb      <- evalCond+    if not vb then retEmpty else fix $ \runBody -> do+        valBody <- applyInline (sub `beforeLeave` subNextBlocks) Nothing []+        let runNext = do+                valPost <- evalExp post+                vb      <- evalCond+                trapVal valPost $ if vb then runBody else retEmpty+        case valBody of+            VControl (ControlLoop LoopRedo) -> runBody+            VControl (ControlLoop LoopLast) -> retEmpty+            VControl (ControlLoop LoopNext) -> runNext+            _                               -> trapVal valBody runNext++reduceSyn "given" [topic, body] = enterGiven $ do+    sub     <- fromCodeExp body+    applyInline sub Nothing [App (_Var "&VAR") (Just topic) []]++reduceSyn "when" [match, body] = do+    result  <- reduce $ case unwrap match of+        App _ (Just (Var var)) _    | var == varTopic -> match+        Syn _ [Var var, _]          | var == varTopic -> match+        _ -> App (_Var "&*infix:~~") Nothing [Var varTopic, match]+    rb      <- fromVal result+    if not rb then retEmpty else do+        sub     <- fromCodeExp body+        enterWhen $ applyInline sub Nothing []++reduceSyn "default" [body] = do+    sub     <- fromCodeExp body+    enterWhen $ applyInline sub Nothing []++reduceSyn name [cond, body]+    | "while" <- name = doWhileUntil id False+    | "until" <- name = doWhileUntil not False+    | "postwhile" <- name = doWhileUntil id True+    | "postuntil" <- name = doWhileUntil not True+    where+    -- XXX The "first" loop should be merged into the normal runloop+    doWhileUntil :: (Bool -> Bool) -> Bool -> Eval Val+    doWhileUntil f postloop = enterLoop $ do+        origSub <- fromVal =<< (enterRValue $ enterEvalContext (cxtItem "Code") body)+        let sub = origSub `beforeLeave` subNextBlocks+        rv  <- if not postloop then retEmpty else fix $ \runBody -> do+            rv <- applyInline sub Nothing [Val $ castV undef]+            case rv of+                VControl (ControlLoop LoopRedo) -> runBody+                _                               -> return rv+        case rv of+            VError{}                        -> return rv+            VControl (ControlLoop LoopLast) -> retEmpty+            _                               -> do+                ($ rv) . fix $ \runLoop prev -> do+                    vbool <- enterEvalContext (cxtItem "Bool") cond+                    vb    <- fromVal vbool+                    if f vb+                        then fix $ \runBody -> do+                            rv <- applyInline sub Nothing [Val vbool]+                            case rv of+                                VControl (ControlLoop LoopRedo) -> runBody+                                VControl (ControlLoop LoopLast) -> return prev+                                VError{}    -> return rv+                                _           -> runLoop prev+                        else case prev of+                            VControl ControlLoop{}  -> retEmpty+                            _                       -> evalVal rv++reduceSyn "=" [lhs, rhs] = do+    refVal  <- enterLValue $ evalExp lhs+    ref     <- fromVal refVal+    let typ = refType ref+        cxt | isaType "List" typ = cxtSlurpyAny+            | otherwise = cxtItem $ takeWhile (/= ':') . show $ refType ref+    val <- enterRValue $ enterEvalContext cxt rhs+    writeRef ref val+    lv      <- asks envLValue+    if lv then return refVal else+        ifListContext (readRef ref) $+            if cxt == cxtSlurpyAny+                then evalVal refVal+                else readRef ref++reduceSyn ":=" exps+    | [Syn "," vars, Syn "," vexps] <- unwrap exps = do+        when (length vars > length vexps) $ do+            fail $ "Wrong number of binding parameters: "+                ++ (show $ length vexps) ++ " actual, "+                ++ (show $ length vars) ++ " expected"+        -- env' <- cloneEnv env -- FULL THUNKING+        names <- forM vars $ \var -> case unwrap var of+            Var name -> return name+            Syn [sigil,':',':','(',')'] [vexp]+                | Val (VStr name) <- unwrap vexp -> return $ possiblyFixOperatorName (cast (sigil:name))+            _        -> die "Cannot bind this as lhs" var+        bindings <- forM (names `zip` vexps) $ \(var, vexp) -> enterLValue $ do+            {- FULL THUNKING+            let ref = thunkRef . MkThunk $ do+                    local (const env'{ envLValue = True }) $ do+                        enterEvalContext (cxtOfSigil $ head name) vexp+            -}+            val  <- enterEvalContext (cxtOfSigilVar var) vexp+            ref  <- fromVal val+            rv   <- findVarRef var+            case rv of+                Just tvar -> return (tvar, ref)+                _ | isGlobalVar var || v_package var `notElem` [emptyPkg, callerPkg, outerPkg, contextPkg] -> do+                    -- '$Qualified::Var' is not found.  Vivify at lvalue context.+                    evalExp (Sym SOur var mempty Noop Noop)+                    rv' <- findVarRef var+                    case rv' of+                        Just PEConstant{}    -> die "Bind to constant variable" var+                        Just entry              -> return (entry, ref)+                        _                       -> die "Bind to undeclared variable" var+                _   -> die "Bind to undeclared variable" var+        forM_ bindings $ \(entry, ref) -> writePadEntry entry ref+        return $ case map (VRef . snd) bindings of+            [v] -> v+            vs  -> VList vs++reduceSyn ":=" [Syn "{}" [conExp, keyExp], valExp] = enterLValue $ do+    ref     <- fromVal =<< enterEvalContext cxtItemAny valExp+    con     <- enterEvalContext (cxtItem "Hash") conExp+    key     <- fromVal =<< enterEvalContext (cxtItem "Str") keyExp+    doBind  <- doHash con hash_storeElem+    doBind key ref+    return (castV ref)++reduceSyn ":=" [Syn "[]" [conExp, keyExp], valExp] = enterLValue $ do+    ref     <- fromVal =<< enterEvalContext cxtItemAny valExp+    con     <- enterEvalContext (cxtItem "Array") conExp+    key     <- fromVal =<< enterEvalContext (cxtItem "Int") keyExp+    doBind  <- doArray con array_storeElem+    doBind key ref+    return (castV ref)++reduceSyn ":=" [var, vexp] = do+    let expand e | e'@(Syn "," _) <- unwrap e = e'+        expand e = Syn "," [e]+    reduce (Syn ":=" [expand var, expand vexp])++reduceSyn "*" [] = return (VNum (1/0))++{-+reduceSyn "[,]" [exp] = do+    val <- enterRValue $ enterEvalContext cxtSlurpyAny exp+    return . VList =<< fromVal val+    -- vals <- fromVals val+    -- return $ VList $ concat vals+-}++reduceSyn "," exps = do+    vals <- mapM (enterEvalContext cxtSlurpyAny) exps+    return . VList . concat $ map castList vals+    where+    castList (VList vs) = vs+    castList v = [v]++reduceSyn "val" [exp] = do+    enterRValue $ evalExp exp++reduceSyn "\\{}" [exp] = do+    v   <- enterRValue . enterBlock $ enterEvalContext cxtSlurpyAny exp+    hv  <- newObject (mkType "Hash")+    writeRef hv v+    evalVal $ VRef hv++reduceSyn "\\[]" [exp] = do+    v   <- enterRValue $ enterEvalContext cxtSlurpyAny exp+    av  <- newObject (mkType "Array")+    writeRef av v+    retItem $ VRef av++reduceSyn "[]" exps+    -- XXX evil hack for infinite slices+    | [lhs, App (Var var) invs args] <- unwrap exps+    , var == cast "&postfix:..."+    , [idx] <- maybeToList invs ++ args+--  , not (envLValue env)+    = reduce (Syn "[...]" [lhs, idx])+    | [lhs, App (Var var) invs args] <- unwrap exps+    , var == cast "&infix:.."+    , [idx, Val (VNum n)] <- maybeToList invs ++ args+    , n == 1/0+--  , not (envLValue env)+    = reduce (Syn "[...]" [lhs, idx])+    | otherwise = do+        let [listExp, indexExp] = exps+        varVal  <- enterLValue $ enterEvalContext (cxtItem "Array") listExp+        idxCxt  <- inferExpCxt indexExp +        idxVal  <- enterRValue $ enterEvalContext idxCxt indexExp+        lv      <- asks envLValue+        doFetch (mkFetch $ doArray varVal array_fetchElem)+                (mkFetch $ doArray varVal array_fetchVal)+                (fromVal idxVal) lv $ case idxVal of+                    VList {} -> False+                    _        -> True++reduceSyn "[...]" [listExp, indexExp] = do+    idxVal  <- enterRValue $ enterEvalContext (cxtItem "Int") indexExp+    idx     <- fromVal idxVal+    listVal <- enterRValue $ enterEvalContext cxtSlurpyAny listExp+    list    <- fromVal listVal+    -- elms    <- mapM fromVal list -- flatten+    return $ VList (drop idx $ list)++-- XXX - Wrong!+reduceSyn "|" [exp] = evalExp exp++reduceSyn "@{}" [exp] = do+    val     <- enterEvalContext (cxtItem "Array") exp+    ivar    <- doArray val IArray+    evalRef (MkRef ivar)++reduceSyn "%{}" [exp] = do+    val     <- enterEvalContext (cxtItem "Hash") exp+    ivar    <- doHash val IHash+    evalRef (MkRef ivar)++reduceSyn "&{}" [exp] = do+    val     <- enterEvalContext (cxtItem "Code") exp+    sub     <- fromVal val+    return $ VCode sub++reduceSyn "${}" [exp] = do+    val     <- enterEvalContext (cxtItem "Scalar") exp+    ref     <- fromVal val+    evalRef ref++reduceSyn (sigil:"::()") exps = do+    -- These are all parts of the name+    parts   <- mapM fromVal =<< mapM evalExp exps+    -- Now we only have to add the sigil in front of the string and join+    -- the parts with "::".+    let varname = sigil:(concat . (intersperse "::") $ parts)+    -- Finally, eval the varname.+    reduceVar (possiblyFixOperatorName (cast varname))++reduceSyn "{}" [listExp, indexExp] = do+    varVal  <- enterLValue $ enterEvalContext (cxtItem "Hash") listExp+    idxCxt  <- inferExpCxt indexExp +    idxVal  <- enterRValue $ enterEvalContext idxCxt indexExp+    lv      <- asks envLValue+    doFetch (mkFetch $ doHash varVal hash_fetchElem)+        (mkFetch $ doHash varVal hash_fetchVal)+        (fromVal idxVal) lv $ case idxVal of+            VList {} -> False+            _        -> True++reduceSyn "rx" [exp, adverbs] = do+    hv      <- fromVal =<< evalExp adverbs+    val     <- enterEvalContext (cxtItem "Str") exp+    str     <- fromVal val+    p5      <- fromAdverb hv ["P5", "Perl5", "perl5"]+    p5flags <- fromAdverb hv ["P5", "Perl5", "perl5"]+    flag_g  <- fromAdverb hv ["g", "global"]+    flag_i  <- fromAdverb hv ["i", "ignorecase"]+    flag_s  <- fromAdverb hv ["s", "sigspace"]+    flag_r  <- fromAdverb hv ["ratchet"]+    flag_tilde  <- fromAdverb hv ["stringify"] -- XXX hack+    adverbHash  <- reduce adverbs+    let g = ('g' `elem` p5flags || flag_g)+        mkP5RE = do+            rv <- compilePCRE compOpts execBlank (encodeUTF8 str)+            case rv of+                Left err -> fail (show err)+                Right rx -> return rx+            where+            compOpts = sum+                [ compUTF8+                , ('i' `elem` p5flags || flag_i) `implies` compCaseless+                , ('m' `elem` p5flags) `implies` compMultiline+                , ('s' `elem` p5flags) `implies` compDotAll+                , ('x' `elem` p5flags) `implies` compExtended+                ]+        p6re = combine+            [ if flag_s then (\x -> ":sigspace(1)[" ++ x ++ "]") else id+            , if flag_r then (\x -> ":ratchet(1)[" ++ x ++ "]") else id+            ] str+        {-+        p6re | null p6reAdvs = str+             | ':':_ <- str  = p6reAdvs ++ str+             | otherwise     = p6reAdvs ++ "::" ++ str+        -}+        rx | p5 = mkP5RE >>= \p5re -> return $ MkRulePCRE p5re g (getNumSubs p5re) flag_tilde str adverbHash+           | otherwise = return $ MkRulePGE p6re g flag_tilde adverbHash+    io $ fmap VRule rx+    where+    implies True  = id+    implies False = const 0+    fromAdverb _ [] = fromVal undef+    fromAdverb hv (k:ks) = case lookup k hv of+        Just v  -> fromVal v+        Nothing -> fromAdverb hv ks++reduceSyn "//" exps = reduceSyn "match" exps -- XXX - this is wrong++reduceSyn "match" exps = do+    immediate <- isImmediateMatchContext+    if immediate+        then reduceApp (_Var "&infix:~~") Nothing [Var varTopic, Syn "rx" exps]+        else reduceSyn "rx" exps++reduceSyn "subst" [exp, subst, adverbs] = do+    (VRule rx)  <- reduce (Syn "rx" [exp, adverbs])+    return $ VSubst (MkSubst rx subst)++reduceSyn "trans" (fromExp:toExp:_) = do+    from <- fromVal =<< reduce fromExp+    to   <- fromVal =<< reduce toExp+    return $ VSubst (MkTrans from to)++reduceSyn "package" [kind, exp] = reduceSyn "namespace" [kind, exp, emptyExp]++reduceSyn "namespace" [_kind, exp, body] = do+    val <- evalExp exp+    str <- fromVal val+    let forbiddenNamespaces = ["CALLER", "COMPILING",+                               "CONTEXT", "GLOBAL",+                               "MY", "OUR", "OUTER",+                               "PROCESS", "SUPER"]+        in when (str `elem` forbiddenNamespaces) $ do+           fail $ "Cannot use " ++ str ++ " as a namespace"+    enterPackage (cast str) $ evalExp body++reduceSyn "inline" [langExp, _] = do+    langVal <- evalExp langExp+    lang    <- fromVal langVal+    when (lang /= "Haskell") $+        die "Inline: Unknown language" langVal+    pkg     <- asks envPackage -- full module name here+    let file = (`concatMap` cast pkg) $ \v -> case v of+                    '-' -> "__"+                    _ | isAlphaNum v -> [v]+                    _ -> "_"+    externRequire "Haskell" (file ++ ".o")+    retEmpty++reduceSyn "=>" [keyExp, valExp] = do+    key <- enterEvalContext cxtItemAny keyExp+    val <- enterEvalContext cxtItemAny valExp+    retItem $ castV (key, val)++reduceSyn syn [lhsExp, rhsExp]+    | last syn == '=' = do+        let op = "&infix:" ++ init syn+        lhs <- enterLValue $ evalExp lhsExp+        val <- readRef =<< fromVal lhs+        evalExp $ Syn "=" [Val lhs, App (_Var op) Nothing [Val val, rhsExp]]++reduceSyn "q:code" [ body ] = expToEvalVal body++reduceSyn "CCallDyn" (Val (VStr quant):methExp:invExp:args) = do+    -- Experimental support for .*$meth, assuming single inheritance.+    str     <- fromVal =<< enterEvalContext (cxtItem "Str") methExp+    let meth = cast ('&':str)+    invVal  <- enterRValue . enterEvalContext cxtItemAny $ invExp+    found   <- findSub meth (Just (Val invVal)) args+    case found of+        Left{}      -> do+            let klugedInv = case unwrap invExp of+                    App{}  -> Val invVal    -- no re-evaluation+                    Syn{}  -> Val invVal    -- no re-evaluation+                    _      -> invExp        -- re-evaluation assumed to be ok+            foundSub    <- findSub meth Nothing (klugedInv:args)+            case foundSub of+                Left{}      -> case quant of+                    "+" -> do+                        typ     <- fromVal invVal+                        die ("No such method in class " ++ showType typ) meth+                    _   -> do+                        retEmpty+                Right sub   -> applySub sub Nothing (klugedInv:args)+        Right sub | SubMethod <- subType sub, quant /= "?" -> do+            typ     <- fromVal invVal+            subs    <- findAccum meth{ v_package = nextPkg } typ -- Given type, get all methods+            rvs     <- forM (nub (sub:subs)) $ \sub -> applySub sub (Just (Val invVal)) args+            return (VList rvs)+        Right sub   -> do+            -- XXX - Walk multi variants+            applySub sub (Just (Val invVal)) args+    where+    findAccum meth typ = do+        found <- findSub meth (Just (Val (VType typ))) args+        case found of+            Right sub -> do+                rest <- findAccum meth (cast (subPackage sub))+                return (sub:rest)+            _         -> return []++reduceSyn name exps =+    die "Unknown syntactic construct" (Syn name exps)++data SpecialApp+    = AppInv        !(Exp -> Eval Val)+    | AppSub        !([Exp] -> Eval Val)+    | AppMeth       !(Exp -> [Exp] -> Eval Val)+    | AppSubMeth    !(Maybe Exp -> [Exp] -> Eval Val)+    deriving (Typeable)++class SpecialAppHelper a where+    (...) :: String -> a -> (Var, SpecialApp)++instance SpecialAppHelper (Maybe Exp -> [Exp] -> Eval Val) where+    n ... f = (cast n, AppSubMeth f)++instance SpecialAppHelper (Val -> Eval Val) where+    n ... f = (cast n, AppInv (\exp -> evalExp exp >>= f))++instance SpecialAppHelper (Exp -> Eval Val) where+    n ... f = (cast n, AppInv f)++instance SpecialAppHelper ([Exp] -> Eval Val) where+    n ... f = (cast n, AppSub f)++instance SpecialAppHelper (Exp -> [Exp] -> Eval Val) where+    n ... f = (cast n, AppMeth f)++specialApp :: Map Var SpecialApp+specialApp = Map.fromList+    [ "&VAR"        ... \invs args -> do+        res <- forM (maybeToList invs ++ args) $ \exp -> do+            enterLValue (enterEvalContext cxtItemAny exp)+        case res of+            [x] -> return x+            _   -> return $ VList res+    , "&HOW"        ... (./ "")+    , "&LIST"       ... (./ "LIST")+    , "&ITEM"       ... (./ "ITEM")+    -- XXX - XXX - everything above should be macros - XXX - XXX --+    , "&hash"       ... (enterEvalContext cxtItemAny . Syn "\\{}" . (:[]) . Syn ",")+    , "&list"       ... listMeth+    , "&item"       ... itemMeth+    , "&cat"        ... \args -> do+        vals <- mapM (enterRValue . enterEvalContext (cxtItem "Array")) args+        op0Cat vals+    , "&each"       ... \args -> do+        vals <- mapM (enterRValue . enterEvalContext (cxtItem "Array")) args+        op0Each vals+    , "&roundrobin" ... \args -> do+        vals <- mapM (enterRValue . enterEvalContext (cxtItem "Array")) args+        op0RoundRobin vals+    , "&zip"        ... \args -> do+        vals <- mapM (enterRValue . enterEvalContext (cxtItem "Array")) args+        op0Zip vals+    , "&yield"     ... \args -> do+        (op1Yield . retControl . ControlLeave (<= SubRoutine) 0) =<<+            case args of+                []      -> retEmpty+                [arg]   -> evalExp arg+                args    -> evalExp (Syn "," args)+    , "&return"     ... \args -> do+        (op1Return . retControl . ControlLeave (<= SubRoutine) 0) =<<+            case args of+                []      -> retEmpty+                [arg]   -> evalExp arg+                args    -> evalExp (Syn "," args)+    , "&nextwith"       ... \inv args -> do+        sub     <- fromCodeExp inv+        let callerEnv :: Env -> Env+            callerEnv env = let caller = maybe env id (envCaller env) in+                env{ envCaller  = envCaller caller+                   , envPackage = envPackage caller+                   , envContext = envContext caller+                   , envLValue  = envLValue caller+                   , envFrames  = envFrames caller+                   , envPos     = envPos caller+                   }+        local callerEnv $ do+            val <- applyDisplaced sub Nothing args+            retShift =<< evalVal val+            retEmpty+    , "&callwith"       ... \inv args -> do+        sub     <- fromCodeExp inv+        let callerEnv :: Env -> Env+            callerEnv env = let caller = maybe env id (envCaller env) in+                env{ envCaller  = envCaller caller+                   , envPackage = envPackage caller+                   , envContext = envContext caller+                   , envLValue  = envLValue caller+                   , envFrames  = envFrames caller+                   , envPos     = envPos caller+                   }+        vcap <- case args of+            []      -> return (CaptSub { c_feeds = [::] })+            (x:_)   -> castVal =<< fromVal =<< enterRValue (enterEvalContext (cxtItem "Capture") x)+        local callerEnv $ applyCapture sub vcap+    , "&assuming"   ... \inv args -> do+        sub     <- fromCodeExp inv+        case bindSomeParams sub Nothing args of+            Left errMsg      -> fail errMsg+            Right curriedSub -> return . castV $ curriedSub+    , "&infix:=>"   ... reduceSyn "=>"+    , "&circumfix:\\( )" ... \invs args -> do+        feeds <- argsFeed [::] Nothing [args]+        case invs of+            Just i' -> do+                invVal  <- reduce i'+                vv      <- fromVal invVal+                return . VV . mkVal $ CaptMeth{ c_invocant = vv, c_feeds = feeds }+            Nothing -> do+                return . VV . mkVal $ CaptSub{ c_feeds = feeds }+    , "&prefix:|<<" ... reduceSyn "," -- XXX this is wrong as well - should handle at args level+    ]+    where+    listMeth args = enterEvalContext cxtSlurpyAny $ case args of+        []    -> Val (VList [])+        [exp] -> exp+        exps  -> Syn "," exps+    itemMeth args = enterRValue . enterEvalContext cxtItemAny $ case args of+        [exp] -> exp+        _     -> Syn "," args++reduceApp :: Exp -> Maybe Exp -> [Exp] -> Eval Val+reduceApp (Var var) invs args+    | SCode <- sig = case Map.lookup var specialApp of+        Just (AppInv f)     | Just inv <- invs, null args -> f inv+        Just (AppSub f)     | Nothing <- invs   -> f args+        Just (AppMeth f)    | Just inv <- invs  -> f inv args+        Just (AppSubMeth f)                     -> f invs args+        _                                       -> doCall var invs args+    | otherwise = normalDispatch+    where+    sig = v_sigil var+    normalDispatch  = doCall var invs args++reduceApp subExp invs args = do+    vsub <- enterEvalContext (cxtItem "Code") subExp+    (`juncApply` [ApplyArg dummyVar vsub False]) $ \[arg] -> do+        sub  <- fromVal $ argValue arg+        applyDisplaced sub invs args++applyCapture :: VCode -> ValCapt -> Eval Val+applyCapture sub capt = applyDisplaced sub inv (fromP argsPos ++ argsNam)+    where+    argsPos = mapP (Val . castV) (f_positionals feed)+    argsNam = [ Syn "named" [Val (VStr (cast k)), Val (castV (vs !: lst))] | (k, vs) <- AtomMap.toList (f_nameds feed), let lst = lengthP vs - 1, lst >= 0 ]+    feed = concatFeeds (c_feeds capt)+    inv  = case capt of +        CaptMeth { c_invocant = val }   -> Just (Val (castV val))+        _                               -> Nothing++argsFeed :: [:ValFeed:] -> Maybe ValFeed -> [[Exp]] -> Eval [:ValFeed:]+argsFeed fAcc Nothing [] =   return fAcc+argsFeed fAcc Nothing [[]]  = return fAcc+argsFeed fAcc (Just x) []   = return $ fAcc +:+ [:x:]+argsFeed fAcc (Just x) [[]] = return $ fAcc +:+ [:x:]+argsFeed fAcc aAcc (argl:als) = do+    acc <- af aAcc argl+    argsFeed fAcc (Just acc) als+    where+    -- af :: Maybe (Feed Val) -> [Exp] -> Eval (Feed Val)+    af res [] = return $ feed res+    -- I'm not sure how much reduction should go on here? E.g. call reduceNamedArg, but what about the val?+    af res (n:args)+        | Syn "named" _ <- unwrapN = do+            Syn "named" [Val (VStr key), valExp] <- reduceNamedArg n+            argVal  <- fromVal =<< reduce valExp+            af (Just $ resFeed{ f_nameds = addNamed (f_nameds resFeed) key argVal }) args+        | Syn "|" (capExp:_) <- unwrapN = do+            cap <- castVal =<< fromVal =<< enterRValue (enterEvalContext (cxtItem "Capture") capExp)+            af (Just (mconcat (resFeed:fromP (c_feeds cap)))) args+        | App (Var var) Nothing capExps <- unwrapN+        , var == cast "&prefix:|<<" = do+            caps    <- mapM castVal =<< fromVals =<< (enterRValue $ enterEvalContext (cxtSlurpy "Capture") (Syn "," capExps))+            af (Just (mconcat (resFeed:concatMap (fromP . c_feeds) caps))) args+        | otherwise = do+            argVal  <- fromVal =<< reduce n+            af (Just resFeed{ f_positionals = (f_positionals resFeed) +:+ [:argVal:] }) args+        where+        unwrapN = unwrap n+        resFeed = feed res+    feed res = maybe emptyFeed id res+    addNamed :: AtomMap [:a:] -> VStr -> a -> AtomMap [:a:]+    addNamed mp k v =+        let id = cast k in+        AtomMap.insertWith (flip (+:+)) id [:v:] mp++dummyVar :: Var+dummyVar = cast "$"++chainFun :: Params -> Exp -> Params -> Exp -> [Val] -> Eval Val+chainFun p1 f1 p2 f2 (v1:v2:vs) = do+    v1' <- forceThunk v1+    v2' <- forceThunk v2+    val <- juncApply (\args -> applyExp SubPrim args f1) (chainArgs p1 [v1', v2'])+    vb  <- fromVal val+    case vb of+        False -> return val+        True  -> do+            vs' <- case vs of+                (v3:rest)   -> do+                    v3' <- forceThunk v3+                    return (v3':rest)+                _           -> return vs+            juncApply (\args -> applyExp SubPrim args f2) (chainArgs p2 (v2':vs'))+    where+    chainArgs prms vals =+        [ ApplyArg name v False+        | name  <- map paramName (prms ++ repeat (last prms))+        | v     <- vals+        ]+    forceThunk (VRef (MkRef (IThunk tv)))   = thunk_force tv+    forceThunk x                            = return x+chainFun _ _ _ _ _ = fail "Impossible: Chained function with less than 2 arguments?"++interpolateExp :: Exp -> Eval [Exp]+interpolateExp exp+    | Syn "|" [x] <- unwrapped      = do+        val <- enterRValue (enterEvalContext (cxtItem "Capture") x)+        interpolateVal val+--  | Syn "|<<" [x] <- unwrapped    = do+--      fail "moose"+    | otherwise                     = return [exp]+    where+    unwrapped = unwrap exp++interpolateVal :: Val -> Eval [Exp]+interpolateVal (VRef (MkRef (IArray av))) = do+    vs <- array_fetch av+    return (map Val vs)+interpolateVal (VRef (MkRef (IHash hv))) = do+    vs <- hash_fetch hv+    return [ Syn "named" [Val (VStr k), Val v] | (k, v) <- Map.toList vs ]+interpolateVal (VRef (MkRef (IPair pv))) = do+    (k, v) <- pair_fetch pv+    return [ Syn "named" [Val k, Val v] ]+interpolateVal (VV vv) | Just (CaptSub{ c_feeds = feeds } :: ValCapt) <- castVal vv = return . fromP $+    [: Val (castV v) | v <- concatMapP f_positionals feeds :]+    +:+ [: Syn "named" [Val (VStr $ cast k), Val (concatNamed v)] | (k, v) <- concatMapP (toP . AtomMap.toList . f_nameds) feeds :]+    where+    concatNamed [:x:] = castV x+    concatNamed xs    = VList (fromP (mapP castV xs))+interpolateVal val = return [Val val]++isInterpolated :: Exp -> Bool+isInterpolated (Ann _ exp)      = isInterpolated exp+isInterpolated (Syn "|" _)      = True+isInterpolated (Syn "|<<" _)    = True+isInterpolated _                = False++evalInvocant :: Exp -> Eval Val+evalInvocant exp+    | Syn "," xs <- unwrap exp = do+        enterLValue . enterEvalContext cxtItemAny $+            Syn "," (map (\x -> Syn "val" [x]) xs)+    | otherwise = enterLValue $ enterEvalContext cxtItemAny exp++doCall :: Var -> Maybe Exp -> [Exp] -> Eval Val+doCall var invs origArgs = do+    -- First, reduce the invocant fully in item context.+    invs'   <- fmapM (fmap Val . evalInvocant) invs++    -- Support for |$foo here+    args    <- if any isInterpolated origArgs+        then fmap concat (mapM interpolateExp origArgs)+        else return origArgs++    sub     <- findSub var invs' args++    -- XXX - Consider this case:+    --      sub f (*@_) { @_ }+    --      =$fh.f; # App+    --      @foo.f; # Var+    -- We can't go back and re-evaluate the =$fh call under list context+    -- after it failed its method lookup; however, we really need to go back+    -- and re-evaluate @foo under list context.  So we use a klugy heuristic+    -- before this is resolved (by explicit "method is export" and removal+    -- of the one-arg-fallback-to-method altogether):+    let klugedInvs = case fmap unwrap invs of+            Just App{}  -> invs' -- no re-evaluation+            Just Syn{}  -> invs' -- no re-evaluation+            _           -> invs  -- re-evaluation assumed to be ok+    case sub of+        Right s -> applySub s klugedInvs args+        _ | [Syn "," args'] <- unwrap args -> do+            sub <- findSub var klugedInvs args'+            either err (fail errSpcMessage) sub+        -- If a method called failed, fallback to sub call+        Left e@NoSuchMethod{} | Just inv <- klugedInvs -> do+            sub' <- findSub var Nothing (inv:args)+            case sub' of+                Right s'            -> applySub s' klugedInvs args+                Left NoSuchSub{}    -> err e+                Left e'             -> err e'+        Left NoSuchSub{} | Just (Val inv') <- invs' -> do+            typ <- fromVal inv'+            err (NoSuchMethod typ)+        Left failure -> err failure+    where+    errSpcMessage = "Extra space found after " ++ cast var ++ " (...) -- did you mean " ++ cast var ++ "(...) instead?"+    err NoMatchingMulti    = die "No compatible multi variant found" var+    err NoSuchSub          = die "No such subroutine" var+    err (NoSuchMethod typ) = die ("No such method in class " ++ showType typ) var++applySub :: VCode -> (Maybe Exp) -> [Exp] -> Eval Val+applySub sub invs args+    -- list-associativity+    | MkCode{ subAssoc = A_list }           <- sub+    , (App (Var var') Nothing args'):rest   <- args+    , C_infix <- v_categ var'+    , cast (subName sub) == v_name var'+    = applySub sub invs (args' ++ rest)+    -- fix subParams to agree with number of actual arguments+    | MkCode{ subAssoc = A_list, subParams = (p:_) }   <- sub+    = applyDisplaced sub{ subParams = length args `replicate` p } invs args+    -- chain-associativity+    | MkCode{ subAssoc = A_chain }      <- sub+    , Nothing                           <- invs+    = case args of+        (App (Var _) Nothing _:_) -> mungeChainSub sub args+        _                         -> applyChainSub sub args+    -- normal application+    | otherwise+    = applyDisplaced sub invs args+    where+    mungeChainSub :: VCode -> [Exp] -> Eval Val+    mungeChainSub sub args = do+        let MkCode{ subAssoc = A_chain, subParams = [_,_] } = sub+            (App (Var name') invs' args'):rest = args+        theSub   <- findSub name' invs' args'+        case theSub of+            Right sub' | A_chain <- subAssoc sub'+                -> augmentChainSub sub sub' args' rest+            _ -> applyChainSub sub args+    augmentChainSub :: VCode -> VCode -> [Exp] -> [Exp] -> Eval Val+    augmentChainSub sub sub' args' rest = do+        let MkCode{ subBody = fun, subParams = prm } = sub+            MkCode{ subBody = fun', subParams = prm' } = sub'+            augmentedSub = sub+                { subParams = prm' ++ [(last prm){ isLazy = True }]+                , subBody   = Prim $ chainFun prm' fun' prm fun+                }+        applySub augmentedSub Nothing (args' ++ rest)+    applyChainSub :: VCode -> [Exp] -> Eval Val+    applyChainSub sub args = tryAnyComprehension [] args+        where+        vanillaApply = applyDisplaced sub' Nothing args+        tryAnyComprehension _ [] = vanillaApply+        tryAnyComprehension pre (pivot:post)+            | App (Var var') _ _    <- unwrap pivot+            , var' == cast "&list" = do+                -- List comprehension!  This:+                --      1 < list(@x) < 2+                -- Becomes this:+                --      list(@x).grep:{ 1 < $_ < 2 }+                -- Except we don't introduce a $_ variable, as to avoid shadowing.+                items <- fromVal =<< reduce pivot+                fmap VList . (`filterM` items) $ \item -> do+                    vbool <- enterRValue . enterContext (cxtItem "Bool") $ do+                        applyDisplaced sub' Nothing (reverse pre ++ (Val item:post))+                    fromVal vbool+            | otherwise = do+                -- Accumulate pre and scan to the next.  Note pre must be reversed as above.+                tryAnyComprehension (pivot:pre) post+        prms    = subParams sub+        -- Align the argument number against the parameter number+        sub'    = sub{ subParams = take (length args) (prms ++ repeat (last prms)) }++applyExp :: SubType -> [ApplyArg] -> Exp -> Eval Val+applyExp _ bound (Prim f) =+    f [ argValue arg | arg <- bound, (argName arg) /= cast "%_" ]+applyExp styp [] body = do+    applyThunk styp [] $ MkThunk (evalExp body) anyType+applyExp styp bound@(invArg:_) body = do+    let (attribute, normal) = partition isAttribute bound+        invocant            = argValue invArg+    -- For each $!foo or $.bar in arg list, assign back to the object directly.+    forM attribute $ \arg -> do+        let name  = dropWhile (not . isAlpha) (cast $ argName arg)+            value = argValue arg+        evalExp $ Syn "=" [Syn "{}" [Val invocant, Val (VStr name)], Val value]+    -- Otherwise we write back to the bindings.+    applyThunk styp normal $ MkThunk (evalExp body) anyType+    where+    isAttribute arg = case v_twigil (argName arg) of+        TAttribute  -> True+        TPrivate    -> True+        _           -> False++applyThunk :: SubType -> [ApplyArg] -> VThunk -> Eval Val+applyThunk _ [] thunk = thunk_force thunk+applyThunk styp bound@(arg:_) thunk = do+    -- introduce self and $_ as the first invocant.+    {-+    inv     <- case styp of+        SubPointy               -> aliased [cast "$_"]+        _ | styp <= SubMethod   -> aliased [cast "&self"]+        _                       -> return []+    -}+    let withInv | styp <= SubMethod = (ApplyArg (cast "$__SELF__") (argValue arg) False:)+                | otherwise         = id+    sequence_ [ bindVar var val+              | ApplyArg var val _ <- withInv bound+              -- Don't generate pad entries for siglets such as "$" and "@".+              , v_name var /= nullID+              ]+    thunk_force thunk++bindVar :: Var -> Val -> Eval ()+bindVar var val+    | isLexicalVar var  = do+        -- warn "Binding lexical" var+        doBindVar (asks envLexical)+    | otherwise         = do+        -- warn "Binding global" var+        doBindVar askGlobal+    where+    doBindVar askPad = do+        pad <- askPad+        case lookupPad var pad of+            Just PEConstant{} -> fail $ "Cannot rebind constant: " ++ show var+            Just c -> do+                -- warn "Binding lexical on" (var, c)+                ref <- fromVal val+                stm $ writeTVar (pe_store c) ref+            _  -> fail $ "Cannot bind to non-existing variable: " ++ show var++{-|+Apply a sub (or other code object) to an (optional) invocant, and+a list of arguments.  Does not create a CALLER frame.+-}+applyInline :: VCode       -- ^ The sub to apply+      -> (Maybe Exp) -- ^ Explicit invocant+      -> [Exp]       -- ^ List of arguments (not including explicit invocant)+      -> Eval Val+applyInline = doApply AKInline++applyDisplaced :: VCode       -- ^ The sub to apply+      -> (Maybe Exp) -- ^ Explicit invocant+      -> [Exp]       -- ^ List of arguments (not including explicit invocant)+      -> Eval Val+applyDisplaced vcode = case subType vcode of+    SubPrim -> doApply AKInline vcode+    _       -> doApply AKDisplaced vcode++-- XXX not entirely sure how this evaluation should proceed+reduceNamedArg :: Exp -> Eval Exp+reduceNamedArg (Syn "named" [keyExp, val]) = do+    key    <- fmap VStr $ fromVal =<< enterEvalContext cxtItemAny keyExp+    return $ Syn "named" [Val key, val]+reduceNamedArg other = return other++        ++-- XXX - faking application of lexical contexts+-- XXX - what about defaulting that depends on a junction?+{-|+Apply a sub (or other code object) to an (optional) invocants, and a list of+arguments, in the specified environment.+-}+doApply :: ApplyKind   -- ^ Whether if it's an inline application+        -> VCode       -- ^ The sub to apply+        -> (Maybe Exp) -- ^ Explicit invocant+        -> [Exp]       -- ^ List of arguments (not including explicit invocant)+        -> Eval Val+doApply appKind origSub@MkCode{ subCont = cont, subBody = fun, subType = typ } invs args = do+    realInvs <- fmapM reduceNamedArg invs+    realArgs <-  mapM reduceNamedArg args  +    case bindParams origSub realInvs realArgs of+        Left errMsg -> fail errMsg+        Right sub   -> do+            forM_ (subSlurpLimit sub) $ \limit@(n, _) -> do+                extra <- checkSlurpyLimit limit+                unless (null extra) $ do+                    fail $+                        "Too many slurpy arguments for " ++ cast (subName sub) ++ ": "+                        ++ show ((genericLength (take 1000 extra)) + n) ++ " actual, "+                        ++ show n ++ " expected"+            bound <- mapM doBind (subBindings sub)+            -- trace (show bound) $ return ()+            val <- localEnv $ do+                (`juncApply` bound) $ \realBound -> do+                    enterSub appKind sub $ do+                        lex     <- asks envLexical+                        recRef  <- fromVal (VCode origSub)+                        let tryRecBind var+                                | Just{} <- lookupPad var (subInnerPad sub)+                                , Just c <- lookupPad var lex+                                = writePadEntry c recRef +                                | otherwise = return ()+                        tryRecBind (cast "&?BLOCK")+                        tryRecBind (cast "&?ROUTINE")+                        case cont of+                            Just tvar   -> do+                                thunk <- stm $ readTVar tvar+                                applyThunk (subType sub) realBound thunk+                            Nothing     -> applyExp (subType sub) realBound fun+            case typ of +                SubMacro    -> applyMacroResult val +                _           -> evalVal val+    where+    applyMacroResult :: Val -> Eval Val+    applyMacroResult (VObject o)+        | objType o == mkType "Code::Exp" = reduce (fromObject o)+    applyMacroResult code@VStr{}    = reduceApp (_Var "&eval") (Just $ Val code) []+    applyMacroResult code@VCode{}   = reduceApp (Val code) Nothing []+    applyMacroResult VUndef         = retEmpty+    applyMacroResult _              = fail "Macro did not return an AST, a Str or a Code!"+    localEnv = case appKind of+        AKDisplaced  -> enterCaller+        _            -> id+    fixSub sub env = env+        { envPackage = subPackage sub+        , envLexPads = subOuterPads sub+        }+    doBind :: (Param, Exp) -> Eval ApplyArg -- ([PadMutator], [ApplyArg])+    doBind (prm, exp) = do+        let var = paramName prm+            cxt = cxtOfSigilVar var+        (val, coll) <- enterContext cxt $ case exp of+            Syn "param-default" [exp, Val (VCode sub)] -> do+                localEnv . local (fixSub sub) $ expToVal prm exp+            _  -> expToVal prm exp+        -- traceM ("==> " ++ (show val))+        -- boundRef <- fromVal val+        -- newSym   <- genSym var boundRef+        return $ ApplyArg var val coll+    expToVal :: Param -> Exp -> Eval (Val, Bool)+    expToVal MkOldParam{ isLazy = thunk, isLValue = lv, paramContext = cxt, paramName = var, isWritable = rw } exp = do+        env <- ask -- freeze environment at this point for thunks+        let eval = local (const env{ envLValue = lv }) $ do+                enterEvalContext cxt exp+            thunkify = do+                memo    <- io $ newTVarIO Nothing+                let forceThunk = do+                        res <- eval+                        stm $ writeTVar memo (Just res)+                        return res+                    evalThunk = do+                        cur <- stm $ readTVar memo+                        maybe forceThunk return cur+                return . VRef . thunkRef $ MkThunk evalThunk anyType+        val <- if thunk then thunkify else do+            v   <- eval+            typ <- evalValType v+            if isaType "Junction" typ then return v else do+            case (lv, rw) of+                (True, True)    -> return v+                (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+                            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+                            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+                            VRef (MkRef IScalar{}) -> return (VRef $ scalarRef v) +                            VRef _ -> return v -- XXX - preserving ref+                            _ -> return (VRef $ scalarRef v) +                (False, False)  -> return v -- XXX reduce to val?+                (False, True)   -> do+                    -- make a copy+                    ref <- newObject (typeOfSigilVar var)+                    writeRef ref v+                    return (VRef ref)+        return (val, (isSlurpyCxt cxt || isCollapsed (typeOfCxt cxt)))+    checkSlurpyLimit :: (VInt, Exp) -> Eval [Val]+    checkSlurpyLimit (n, exp) = do+        listVal <- enterLValue $ enterEvalContext (cxtItem "Array") exp+        list    <- fromVal listVal+        elms    <- mapM fromVal list -- flatten+        return $ genericDrop n (concat elms :: [Val])+    isCollapsed :: Type -> Bool+    isCollapsed typ+        | isaType "Bool" typ        = True+        | isaType "Junction" typ    = True+        | otherwise                 = False++doFetch :: (Val -> Eval (IVar VScalar))+        -> (Val -> Eval Val)+        -> (forall v. (Value v) => Eval v)+        -> Bool+        -> Bool+        -> Eval Val+doFetch fetchElem fetchVal fetchIdx isLV isSV = case (isLV, isSV) of+    (True, True) -> do+        -- LValue, Scalar context+        idx <- fetchIdx+        elm <- fetchElem idx+        retIVar elm+    (True, False) -> do+        -- LValue, List context+        idxList <- fetchIdx+        elms    <- mapM fetchElem idxList+        retIVar $ IArray elms+    (False, True) -> do+        -- RValue, Scalar context+        idx <- fetchIdx+        fetchVal idx+    (False, False) -> do+        -- RValue, List context+        idxList <- fetchIdx+        fmap VList $ mapM fetchVal idxList++mkFetch :: (Value n) => Eval (n -> Eval t) -> Val -> Eval t+mkFetch f v = do+    f' <- f+    v' <- fromVal v+    f' v'++afterLeave :: VCode -> (TraitBlocks -> [VCode]) -> VCode+afterLeave code@MkCode{ subBody = Syn "block" [Val (VCode code')] } f =+    code{ subBody = Syn "block" [Val (VCode (afterLeave code' f))] }+afterLeave code@MkCode{ subTraitBlocks = blocks } f = code{ subTraitBlocks = blocks{ subLeaveBlocks = subLeaveBlocks blocks ++ f blocks } }++beforeLeave :: VCode -> (TraitBlocks -> [VCode]) -> VCode+beforeLeave code@MkCode{ subBody = Syn "block" [Val (VCode code')] } f =+    code{ subBody = Syn "block" [Val (VCode (afterLeave code' f))] }+beforeLeave code@MkCode{ subTraitBlocks = blocks } f = code{ subTraitBlocks = blocks{ subLeaveBlocks = f blocks ++ subLeaveBlocks blocks } }++beforeEnter :: VCode -> (TraitBlocks -> [VCode]) -> VCode+beforeEnter code@MkCode{ subBody = Syn "block" [Val (VCode code')] } f =+    code{ subBody = Syn "block" [Val (VCode (beforeEnter code' f))] }+beforeEnter code@MkCode{ subTraitBlocks = blocks } f = code{ subTraitBlocks = blocks{ subEnterBlocks = f blocks ++ subEnterBlocks blocks } }++fromCodeExp :: Exp -> Eval VCode+fromCodeExp x = case x of+    Syn "block" [Val VCode{}]   -> fromClosure x+    Syn "block" [_]             -> do+        return $ mkCode+            { -- subEnv        = Just env - XXX+              subType       = SubPrim   -- This is a pseudoblock with no scope+            , subParams     = []+            , subBody       = x+            }+    Noop                        -> fromCodeExp (Syn "block" [Noop])+    _                           -> fromClosure x+    where+    fromClosure = (fromVal =<<) . enterRValue . enterEvalContext (cxtItem "Code")+
+ src/Pugs/Eval/Var.hs view
@@ -0,0 +1,652 @@+{-# OPTIONS_GHC -fglasgow-exts -fallow-overlapping-instances -funbox-strict-fields -fparr #-}++module Pugs.Eval.Var (+    findVar, findVarRef, findSub,+    inferExpType,  inferExpCxt, FindSubFailure(..),+    packageOf, toPackage, toQualified,+) where+import qualified Data.Map as Map+import qualified StringTable.AtomMap as AtomMap+import Pugs.Internals+import Pugs.AST+import Pugs.Types+import Pugs.Bind+import Pugs.Prim.List (op2Reduce, op1HyperPrefix, op1HyperPostfix, op2Hyper)+import Pugs.Prim.Param (foldParam)+import Pugs.Pretty+import Pugs.Config+import Pugs.Monads+import Pugs.Class hiding (Val)+import qualified Pugs.Val as Val+import qualified Data.ByteString.Char8 as Buf++findVar :: Var -> Eval (Maybe VRef)+findVar var+    | SType <- v_sigil var+    , not (isGlobalVar var)+    = return Nothing+    | otherwise = do+        rv <- findVarRef var+        case rv of+            Just ref    -> fmap Just (readPadEntry ref)+            Nothing     -> return Nothing++constPadEntry :: VRef -> PadEntry+constPadEntry r = PEConstant{ pe_type = refType r, pe_proto = r, pe_flags = mempty }++lookupShellEnvironment :: ByteString -> Eval (Maybe PadEntry)+lookupShellEnvironment name = do+    exists <- evalExp $ App (_Var "&exists") (Just (_Var "%*ENV")) [Val (VStr $ cast name)]+    case exists of+        VBool False -> do+            die "no such ENV variable" name+        _           -> do+            rv   <- enterLValue (evalExp $ Syn "{}" [_Var "%*ENV", Val (VStr $ cast name)])+            ref  <- fromVal rv+            return (Just (constPadEntry ref))++findVarRef :: Var -> Eval (Maybe PadEntry)+findVarRef var@MkVar{ v_sigil = sig, v_twigil = twi, v_name = name, v_package = pkg }+    | Just var' <- dropVarPkg (__"CALLER") var = do+        maybeCaller <- asks envCaller+        case maybeCaller of+            Just env -> local (const env) $ findVarRef var'+            Nothing -> die "cannot access CALLER:: in top level" var++    | Just var' <- dropVarPkg (__"ENV") var = fix $ \upLevel -> do+        maybeCaller <- asks envCaller+        case maybeCaller of+            Just env -> local (const env) $ do+                rv <- findVarRef var'+                if isJust rv then return rv else upLevel+            -- final callback: try an "environment" lookup+            -- XXX: how does "@+PATH" differ from "$+PATH"?+            -- XXX: how to tell empty env from nonexistent env?+            --      should we allow writes?+            Nothing -> lookupShellEnvironment (cast name)++    | Just var' <- dropVarPkg (__"OUTER") var = ($ var') . fix $ \outerLevel v -> do+        mpads <- asks envLexPads+        case mpads of+            (_:outers@(outer:_))  -> local (\env -> env{ envLexPads = outers }) $ do+                case dropVarPkg (__"OUTER") v of+                    Just v' -> outerLevel v'+                    _       -> do+                        pad <- case outer of+                            PRuntime p  -> return p+                            PCompiling p-> readMPad p+                        return (lookupPad v pad)+            _       -> die "cannot access OUTER:: in top level" name++    | pkg /= emptyPkg = doFindVarRef var++    | TMagical <- twi = do+        rv  <- getMagical var+        case rv of+            Nothing  -> doFindVarRef var+            Just val -> return (Just (constPadEntry (MkRef . constScalar $ val)))++    | SHash <- sig, nullID == name = do+        {- %CALLER::, %OUTER::, %Package::, etc, all recurse to here. -}+        pad <- asks envLexical+        let plist   = padToList pad+        hlist <- mapM padEntryToHashEntry plist+        let hash    = IHash $ Map.fromList hlist+        return $ Just (constPadEntry $ MkRef hash)+    | otherwise = doFindVarRef var+    where+    padEntryToHashEntry :: (Var, PadEntry) -> Eval (VStr, Val)+    padEntryToHashEntry (key, entry) = do+        vref   <- readPadEntry entry+        let val = VRef vref+        return (cast key, val)++doFindVarRef :: Var -> Eval (Maybe PadEntry)+doFindVarRef var = do+    lexSym  <- fmap (lookupPad 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 scope.+    glob    <- readMPad . envGlobal =<< ask+    var'    <- toQualified var+    let globSym = lookupPad var' glob+    if isJust globSym then return globSym else do+    -- XXX - ditto for globals+    let globSym = lookupPad (toGlobalVar var) glob+    if isJust globSym then return globSym else do+    return Nothing+++{-|+  The findSub dispatch system:++  The Eval.Var findSub dispatch system was written before S12's+  dispatch order was specced clearly.  Back then there were no clear+  distinction between single and multiple dispatch, and so both were+  lumped in a single findSub loop.  So "$x.foo.bar" is no different+  from bar(foo($x)), rather, bar(foo($x:):).  But MMD dictates that+  you have to find which of the candidate &bar to be dispatched to+  before you fully evaluate its argument foo($x:) under its specified+  context.  But you can't find out which candidates of &bar to+  dispatch to, unless you know the type of foo($x).  That's a+  chicken-egg problem.  So I wrote a tiny type inferencer to guess a+  type of an Exp without actually evaluating its side effects.  The+  idea is that foo($x) is first inferred, then uses that inferred type+  to decide which bar() to call, and finally evaluate foo($x) in full.+  Using the argument type expected by bar().  But the infer engine+  didn't handle indexed expressions well.  $x[0] etc.  In any case,+  that tiny inferencer is obsolete under the new (November 2005) S12+  and docs/notes/multimethods.pod.  Which would be implemented at PIL+  layer.  The inferencer fix I just committed (r8874) for indexed+  expressions, just checks if both the indice and indexee are simple+  expressions (i.e. things that can be evaluated without side+  effects), and if so, it just evaluates them to find out their actual+  type.++-}++data FindSubFailure+    = NoMatchingMulti+    | NoSuchSub+    | NoSuchMethod !Type+    deriving (Show)++_SUPER :: ByteString+_SUPER = __"SUPER"++_NEXT :: ByteString+_NEXT = __"NEXT"+++-- This no longer handles multi dispatch now. Yay!+findSub :: Var        -- ^ Name, with leading @\&@.+        -> Maybe Exp  -- ^ Invocant+        -> [Exp]      -- ^ Other arguments+        -> Eval (Either FindSubFailure VCode)+findSub _var _invs _args+    | Nothing <- _invs = do+        findBuiltinSub NoMatchingMulti _var+    | not (isQualifiedVar _var) = do+        case unwrap _inv of+            Val vv@VV{}     -> withExternalCall callMethodVV vv+            Val sv@PerlSV{} -> withExternalCall callMethodVV sv+            inv' -> do+                typ <- evalInvType inv'+                if typ == mkType "Scalar::Perl5" -- code for "VV"+                    then evalExp inv' >>= withExternalCall callMethodVV+                    else findTypedSub (cast typ) _var+    | Just var' <- dropVarPkg _SUPER _var = do+        pkg <- asks envPackage+        findSuperSub pkg var'+    | Just var' <- dropVarPkg _NEXT _var = do+        typ <- evalInvType _inv+        findSuperSub (cast typ) var'+    | otherwise = do+        findBuiltinSub NoMatchingMulti _var+    where+    _inv = fromJust _invs++    -- findSuperSub :: (_var :: Var, _invs :: Maybe Exp, _args :: [Exp])+    --     => Pkg -> Var -> Eval (Either FindSubFailure VCode)+    findSuperSub pkg var = do+        subs    <- findWithSuper pkg var+        subs'   <- either (flip findBuiltinSub var) (return . Right) subs+        case subs' of+            -- Recursion prevention -- SUPER::foo should not go back to ThisClas::foo+            Right sub | cast (Buf.cons '&' $ subName sub) == var{ v_package = pkg } -> do+                return (Left . NoSuchMethod $ cast pkg)+            _   -> do+                return subs'++    -- findTypedSub :: (_var :: Var, _invs :: Maybe Exp, _args :: [Exp])+    --     => Pkg -> Var -> Eval (Either FindSubFailure VCode)+    findTypedSub pkg var = do+        subs    <- findWithPkg pkg var+        either (flip findBuiltinSub var) (return . Right) subs++    evalInvType :: Exp -> Eval Type+    evalInvType x = inferExpType x++    withExternalCall callMeth inv = do+        fmap (err . NoSuchMethod $ valType inv) $ do+            metaSub <- possiblyBuildMetaopVCode _var+            if isJust metaSub then return metaSub else callMeth++    -- callMethodVV :: (_var :: Var, _invs :: Maybe Exp, _args :: [Exp])+    --     => Eval (Maybe VCode)+    callMethodVV = do+        let methName = cast (v_name _var)+        -- Look up the proto for the method in VV land right here+        -- Whether it matched or not, it's the proto's signature+        -- that's available to the inferencer, not any of its children's+        -- (this is because MMD in newland is performed _after_ everything+        -- has been reduced.)+        return . Just $ mkPrim+            { subName     = methName+            , subParams   = makeParams ["Object", "List", "Named"]+            , subReturns  = mkType "Any"+            , subBody     = Prim $ \(inv:named:pos:_) -> do+                invVV   <- fromVal inv      :: Eval Val.Val+                posVVs  <- fromVals pos     :: Eval [Val.Val]+                namVVs  <- do+                    list <- fromVal named+                    fmap AtomMap.fromList $ forM list $ \(k, v) -> do+                        key <- fromVal k+                        val <- fromVal v+                        return (key, val)   :: Eval (ID, Val.Val)+                rv <- tryT $ VV invVV ./ (methName, posVVs, namVVs)+                case rv of+                    VError (VStr s) _+                        | "Can't locate object method" `isPrefixOf` s || "Can't call method" `isPrefixOf` s -> do+                        let capt = mi_arguments (cast (methName, (invVV:posVVs), namVVs) :: Call)+                        rv' <- tryT . evalExp $ App (Var _var) Nothing [Syn "|" [Val (VV (mkVal capt))]]+                        case rv' of+                            VError (VStr s') _ | "No compatible subroutine found" `isPrefixOf` s' -> EvalT $ return (RException rv)+                            VError{} -> EvalT $ return (RException rv')+                            _ -> return rv'+                    VError{} -> EvalT $ return (RException rv)+                    _ -> return rv+            }++    -- callMethodPerl5 :: (_var :: Var, _invs :: Maybe Exp, _args :: [Exp])+    --     => Eval (Maybe VCode)+    -- findWithPkg :: (_var :: Var, _invs :: Maybe Exp, _args :: [Exp])+    --     => Pkg -> Var -> Eval (Either FindSubFailure VCode)+    findWithPkg pkg var = do+        subs <- findSub' var{ v_package = pkg }+        maybe (findWithSuper pkg var) (return . Right) subs++    -- findWithSuper :: (_var :: Var, _invs :: Maybe Exp, _args :: [Exp])+    --     => Pkg -> Var -> Eval (Either FindSubFailure VCode)+    findWithSuper pkg var = do+        -- get superclasses+        attrs <- fmap (fmap (filter (/= pkg) . nub)) $ findAttrs pkg+        if isNothing attrs || null (fromJust attrs) then fmap (err NoMatchingMulti) (findSub' var) else do+        -- XXX - "reverse" below is a crude hack before we have C3 dispatch;+        --     - this is such that "class X is Object is Moose" can dispatch with Moose first.+        (`fix` (reverse $ fromJust attrs)) $ \run pkgs -> do+            if null pkgs then return (Left $ NoSuchMethod (cast pkg)) else do+            subs <- findWithPkg (head pkgs) var+            either (const $ run (tail pkgs)) (return . Right) subs++    -- findSub' :: (_var :: Var, _invs :: Maybe Exp, _args :: [Exp]) => Var -> Eval (Maybe VCode)+    findSub' var = do+        subSyms     <- findCodeSyms var+        lens        <- mapM argSlurpLen _invs_args+        doFindSub lens subSyms++    argSlurpLen :: Exp -> Eval Int+    argSlurpLen (Val val) = valSlurpLen val+    argSlurpLen (Var name) = do+        val <- enterLValue $ evalExp (Var name)+        valSlurpLen val+    argSlurpLen (Syn "," list) = return $ length list+    argSlurpLen (Syn "named" _) = return 0+    argSlurpLen _ = return 1 -- XXX++    valSlurpLen :: Val -> Eval Int+    valSlurpLen (VList list) = return $ length list+    valSlurpLen (VRef (MkRef (IArray av))) = array_fetchSize av+    valSlurpLen (VRef (MkRef (IHash hv))) = hash_fetchSize hv+    valSlurpLen _  = return 1 -- XXX++    -- doFindSub :: (_var :: Var, _invs :: Maybe Exp, _args :: [Exp])+    --     => Int -> [(Var, Val)] -> Eval (Maybe VCode)+    doFindSub slurpLens subSyms = do+        subs' <- subs slurpLens subSyms+        -- warn (unlines $ map (\(x, y) -> show (x, subParams y)) subs') ""+        return $ case sort subs' of+            ((_, sub):_)    -> Just sub+            _               -> Nothing++    _invs_args = map unwrap (maybe _args (:_args) _invs)++    -- subs :: (_invs :: Maybe Exp, _args :: [Exp])+    --     => Int -> [(Var, Val)] -> Eval [((Bool, Bool, Int, Int), VCode)]+    subs slurpLens subSyms = fmap catMaybes . forM subSyms $ \sub@MkCode{ subReturns = ret } -> do+        let (named, positional) = partition isNamedArg _invs_args+            isNamedArg (Syn "named" _) = True+            isNamedArg _               = False+            rv = return $ arityMatch sub (length positional) (length named) slurpLens++        maybeM rv $ \fun -> do+            -- if deltaFromCxt ret == 0 then return Nothing else do+            (deltaArgs, deltaCxt) <- case bindParams sub _invs _args of+                Left{}  -> return ([maxBound], 0)+                Right s -> do+                    ds  <- forM (subBindings s) $ \(prm, arg) -> case arg of+                        Syn "param-default" _   -> return Nothing+                        _  | isSlurpy prm       -> return Nothing+                        _                       -> do+                            argType <- inferExpType arg+                            return (Just $ deltaType (typeOfParam prm) argType)+                    cxt <- asks envContext+                    return (catMaybes ds, deltaType (typeOfCxt cxt) ret)+            return ((isMulti sub, sum deltaArgs, -(length deltaArgs), deltaCxt), fun)++    -- findBuiltinSub :: (_var :: Var, _invs :: Maybe Exp, _args :: [Exp])+    --     => FindSubFailure -> Var -> Eval (Either FindSubFailure VCode)+    findBuiltinSub failure var = do+        subSyms     <- findCodeSyms var+        if null subSyms then (fmap (err NoSuchSub) (possiblyBuildMetaopVCode var)) else do+        lens        <- mapM argSlurpLen _invs_args+        sub         <- doFindSub lens subSyms+        maybe (fmap (err failure) $ possiblyBuildMetaopVCode var) (return . Right) sub++    -- firstArg :: (_args :: [Exp]) => [Exp]+    firstArg = [maybe (Val undef) id (listToMaybe _args)]+    firstTwoArgs+        | [] <- _args       = [Val undef, Val undef]+        | [arg] <- _args    = [arg, Val undef]+        | otherwise         = take 2 _args++    metaPrim = mkPrim+        { subName = cast (v_name _var)+        , subType     = SubPrim+        , subReturns  = mkType "List"+        }++    buildPrefixHyper var = do+        let rv = fmap (either (const Nothing) Just) $+                findSub var Nothing firstArg+        maybeM rv (return . makePrefixHyperCode)+        +    makePrefixHyperCode code = metaPrim+        { subAssoc    = subAssoc code+        , subParams   = subParams code+        , subBody     = Prim+            (\x -> op1HyperPrefix code (listArg x))+        }++    buildPostfixHyper var = do+        let rv = fmap (either (const Nothing) Just) $+                findSub var Nothing firstArg+        maybeM rv $ \code -> return $ metaPrim+            { subAssoc    = subAssoc code+            , subParams   = subParams code+            , subBody     = Prim+                (\x -> op1HyperPostfix code (listArg x))+            }++    buildInfixHyper var = do+        let rv = fmap (either (const Nothing) Just) $+                findSub var Nothing firstTwoArgs+        maybeM rv (return . makeInfixHyperCode)++    makeInfixHyperCode code = metaPrim+        { subAssoc    = subAssoc code+        , subParams   = makeParams ["Any", "Any"]+        , subBody     = Prim (\[x, y] -> op2Hyper code x y)+        }++    buildReduce var foldOrScan nilOrHyper nilOrPost = do+        let rv = fmap (either (const Nothing) Just) $+                findSub var Nothing firstTwoArgs+        maybeM rv $ \code -> return . maybePost $ metaPrim+            { subAssoc    = ANil+            , subParams   = makeParams $+                if any isLValue (subParams code)+                    then ["rw!List"] -- XXX - does not yet work for the [=] case+                    else ["List"]+            , subReturns  = anyType+            , subBody     = Prim $ \[vs] -> do+                list_of_args <- fromVal vs+                op2Reduce (foldOrScan == MScan) list_of_args . VCode $ case nilOrHyper of+                    MHyper  -> makeInfixHyperCode code+                    _       -> code+            }+        where+        maybePost +            | MPost <- nilOrPost    = makePrefixHyperCode+            | otherwise             = id++    -- possiblyBuildMetaopVCode :: (_args :: [Exp]) => Var -> Eval (Maybe VCode)+    possiblyBuildMetaopVCode var@MkVar{ v_meta = meta } = case meta of+        MPost           -> buildPrefixHyper var'                    -- +<<+        MPre            -> buildPostfixHyper var'                   -- >>++        MHyper          -> buildInfixHyper var'                     -- >>+<<+        MFold           -> buildReduce varInfix MFold MNil MNil     -- [+]+        MScan           -> buildReduce varInfix MScan MNil MNil     -- [\+]+--      MFoldPost       -> buildReduce varInfix MFold MNil MPost    -- [+]+--      MScanPost       -> buildReduce varInfix MScan MNil MPost    -- [\+]+        MHyperFold      -> buildReduce varInfix MFold MHyper MNil   -- [>>+<<]+        MHyperScan      -> buildReduce varInfix MScan MHyper MNil   -- [>>+<<]+--      MHyperFoldPost  -> buildReduce varInfix MFold MHyper MPost  -- [>>+<<]+--      MHyperScanPost  -> buildReduce varInfix MScan MHyper MPost  -- [>>+<<]+        _               -> return Nothing+        where+        var' = var{ v_meta = MNil }+        varInfix = var{ v_meta = MNil, v_categ = C_infix }++metaVar :: Pkg -> Var+-- metaVar = MkVar SType TNil globalPkg CNil . cast+metaVar pkg = cast (':':'*':cast pkg)+    {-+MkVar+    { v_sigil   = SType+    , v_twigil  = TGlobal+    , v_package = emptyPkg+    , v_categ   = CNil+    , v_name    = cast pkg+    }+    -}++err :: b -> Maybe a -> Either b a+err _ (Just j) = Right j+err x Nothing  = Left x++listArg :: [Val] -> Val+listArg [x] = x+listArg xs = VList xs++makeParams :: [String] -> [Param]+makeParams = map (\p -> p{ isWritable = isLValue p }) . foldr foldParam [] . map takeWord+    where+    takeWord = takeWhile isWord . dropWhile (not . isWord)+    isWord   = not . (`elem` "(),:")++findAttrs :: Pkg -> Eval (Maybe [Pkg])+findAttrs pkg = do+    maybeM (findVar $ metaVar pkg) $ \ref -> do+        meta    <- readRef ref+        fetch   <- doHash meta hash_fetchVal+        fmap (map (cast :: String -> Pkg)) (fromVal =<< fetch "is")++{-|+Take an expression, and attempt to predict what type it will evaluate to+/without/ actually evaluating it.+-}+inferExpType :: Exp -> Eval Type+inferExpType exp@(Var var)+    | TAttribute <- v_twigil var = fromVal =<< evalExp exp+    | TPrivate <- v_twigil var   = fromVal =<< evalExp exp+    | otherwise = do+        rv  <- findVar var+        case rv of+            Nothing  -> return $ typeOfSigilVar var+            Just ref -> do+                let typ = refType ref+                if isaType "List" typ+                    then return typ+                    else fromVal =<< readRef ref+inferExpType (Val val) = fromVal val+inferExpType (App (Val val) _ _) = do+    sub <- fromVal val+    return $ subReturns sub+inferExpType (App (Var var) (Just inv) _)+    | var == cast "&new"+    = inferExpType $ unwrap inv+inferExpType (App (Var name) invs args) = do+    sub <- findSub name invs args+    return (either (const anyType) subReturns sub)+inferExpType (Ann (Cxt cxt) _) | typeOfCxt cxt /= (mkType "Any") = return $ typeOfCxt cxt+inferExpType (Ann _ exp) = inferExpType exp+inferExpType (Sym _ _ _ _ exp) = inferExpType exp+inferExpType (Stmts _ exp) = inferExpType exp+inferExpType (Syn "," _)    = return $ mkType "List"+inferExpType (Syn "\\[]" _) = return $ mkType "Array"+inferExpType (Syn "\\{}" _) = return $ mkType "Hash"+inferExpType (Syn "&{}" _)  = return $ mkType "Code"+inferExpType (Syn "@{}" _)  = return $ mkType "Array"+inferExpType (Syn "%{}" _)  = return $ mkType "Hash"+inferExpType (Syn "=>" _)   = return $ mkType "Pair"+inferExpType (Syn "named" [_, exp])   = inferExpType exp+inferExpType (Syn "rx" _)   = return $ mkType "Regex"+inferExpType (Syn "match" _)= return $ mkType "Match"+inferExpType (Syn "//" _)   = return $ mkType "Regex" -- XXX Wrong+inferExpType exp@(Syn "{}" [_, idxExp]) = if isSimpleExp exp+    then fromVal =<< enterRValue (evalExp exp)+    else fmap typeOfCxt (inferExpCxt idxExp)+inferExpType exp@(Syn "[]" [_, idxExp]) = if isSimpleExp exp+    then fromVal =<< enterRValue (evalExp exp)+    else fmap typeOfCxt (inferExpCxt idxExp)+inferExpType (Syn "sub" [exp]) = inferExpType exp+inferExpType _ = return anyType++isSimpleExp :: Exp -> Bool+isSimpleExp Var{}           = True+isSimpleExp Val{}           = True+isSimpleExp (Ann _ x)       = isSimpleExp x+isSimpleExp (Syn _ xs)      = all isSimpleExp xs+isSimpleExp _               = False+++{-|+Return the context that an expression bestows upon a hash or array+subscript. See 'reduce' for @\{\}@ and @\[\]@.+-}+inferExpCxt :: Exp -> Eval Cxt+inferExpCxt exp = return $ if isScalarLValue exp+    then cxtItemAny+    else cxtSlurpyAny++{-|+Evaluate the \'magical\' variable associated with a given name. Returns +@Nothing@ if the name does not match a known magical.+-}+getMagical :: Var -- ^ Name of the magical var to evaluate+           -> Eval (Maybe Val)+getMagical var = Map.findWithDefault (return Nothing) var magicalMap++magicalMap :: Map Var (Eval (Maybe Val))+magicalMap = Map.fromList+    [ (cast "$?FILE"     , posSym ((cast . posName) :: Pos -> String))+    , (cast "$?LINE"     , posSym posBeginLine)+    , (cast "$?COLUMN"   , posSym posBeginColumn)+    , (cast "$?POSITION" , posSym pretty)+    , (cast "$?MODULE"   , constSym "Main")+    , (cast "$?OS"       , constSym (getConfig "osname"))+    , (cast "$?CLASS"    , fmap (Just . VType . cast) (asks envPackage))+    , (cast ":?CLASS"    , fmap (Just . VType . cast) (asks envPackage))+    , (cast "$?PACKAGE"  , fmap (Just . VType . cast) (asks envPackage))+    , (cast ":?PACKAGE"  , fmap (Just . VType . cast) (asks envPackage))+    , (cast "$?ROLE"     , fmap (Just . VType . cast) (asks envPackage))+    , (cast ":?ROLE"     , fmap (Just . VType . cast) (asks envPackage))+    ]++posSym :: Value a => (Pos -> a) -> Eval (Maybe Val)+posSym f = fmap (Just . castV . f) $ asks envPos++constSym :: String -> Eval (Maybe Val)+constSym = return . Just . VStr++-- Find symbols, up and including multis.+findCodeSyms :: Var -> Eval [VCode]+findCodeSyms var+    | isGlobalVar var    = findWith findGlobal+    | isQualifiedVar var = case dropVarPkg (__"OUTER") var of+        Just var'       -> die "outer - not yet implemented" var'+        _               -> findWith findQualified+    | otherwise          = do+        rv <- findWith findLexical+        if null rv then findWith findPackage else return rv+    where+    findWith f = runMaybeT f >>= maybe (return []) return++    -- $x should look up $x in the current pad first.+    findLexical :: MaybeT Eval [VCode]+    findLexical = do+        lex <- lift $ asks envLexical+        padSym lex var+        +    -- $Foo::x is just $Foo::x, or maybe $*Foo::x.+    findQualified :: MaybeT Eval [VCode]+    findQualified = do+        glob <- lift $ askGlobal+        padSym glob var+            `mplus` padSym glob (toGlobalVar var)++    -- $x then fallbacks to $This::Package::x, or maybe $*x.+    findPackage :: MaybeT Eval [VCode]+    findPackage = do+        -- XXX - This is bogus; pending Pad fixup code in Pugs.Parser+        glob <- lift $ askGlobal+        pkg  <- lift $ asks envPackage+        padSym glob (toPackage pkg var)+            `mplus` padSym glob (toGlobalVar var)++    -- $*Foo::x is just that.+    findGlobal :: MaybeT Eval [VCode]+    findGlobal = do+        glob <- lift $ askGlobal+        padSym glob (toGlobalVar var)++    padSym :: Pad -> Var -> MaybeT Eval [VCode]+    padSym pad var = do+        case lookupPad var pad of+            Just entry -> lift $ do+                ref     <- readPadEntry entry+                readCodesFromRef ref+            Nothing -> mzero++data ArityMatchData = MkArityMatchData+    { d_reqLen      :: !Int+    , d_optLen      :: !Int+    , d_slurpLen    :: !Int+    , d_hasArray    :: !Bool+    , d_hasHash     :: !Bool+    }++arityMatch :: VCode -> Int -> Int -> [Int] -> Maybe VCode+arityMatch sub@MkCode{ subAssoc = assoc, subParams = prms } posLen namLen argSlurpLens+    | A_list    <- assoc = Just sub+    | A_chain   <- assoc = Just sub++    | argLen >= reqLen+    , hasArray || ((if hasHash then posLen else argLen) <= (reqLen + optLen + slurpLen))+    , if hasArray then slurpLen <= argSlurpLen else slurpLen == argSlurpLen+    = Just sub++    | otherwise+    = Nothing+    where+    argLen      = posLen + namLen+    argSlurpLen = sum (drop (reqLen + optLen) argSlurpLens)+    ~(MkArityMatchData reqLen optLen slurpLen hasArray hasHash) = foldl unwindPrm initArityMatchData prms++initArityMatchData :: ArityMatchData+initArityMatchData = MkArityMatchData 0 0 0 False False++unwindPrm :: ArityMatchData -> Param -> ArityMatchData+unwindPrm dat p+    | isSlurpy p = case v_sigil (paramName p) of+        SArray  -> dat{ d_hasArray = True }+        SHash   -> dat{ d_hasHash  = True }+        _       -> dat{ d_slurpLen = succ (d_slurpLen dat) }+    | isOptional p  = dat{ d_optLen = succ (d_optLen dat) }+    | otherwise     = dat{ d_reqLen = succ (d_reqLen dat) }++toPackage :: Pkg -> Var -> Var+toPackage pkg var+    | isGlobalVar var = var+    | otherwise       = var{ v_package = pkg }++packageOf :: Var -> Pkg+packageOf = v_package++toQualified :: Var -> Eval Var+toQualified var@MkVar{ v_twigil = TNil, v_package = pkg }+    | pkg == emptyPkg = do+        currentPkg <- asks envPackage+        return var{ v_package = currentPkg }+toQualified var = return var+
+ src/Pugs/Exp.hs view
@@ -0,0 +1,74 @@+{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances -fallow-overlapping-instances -cpp #-}+{-! global : YAML_Pos, Perl6Class, MooseClass !-}++{-| Capture-enabled "new" Pugs AST+ -}++module Pugs.Exp where++import Pugs.Pretty+import Text.PrettyPrint+import Pugs.Internals+import Pugs.Val+import Pugs.Types (Var)+import qualified Pugs.AST.Internals (Exp)+++type ExpVar = Var+type ExpVal = Val+type ExpCapt = Capt Exp++newtype ExpEmeritus = MkExpEmeritus { ee :: Pugs.AST.Internals.Exp }++instance Eq ExpEmeritus where _ == _ = True+instance Ord ExpEmeritus where compare _ _ = EQ+instance Show ExpEmeritus where show _ = "<Exp.Emeritus>"++-- | AST for an expression.+data Exp+    = ENoop                            -- ^ No-op+    | EVar      ExpVar                 -- ^ Variable+    | EVal      ExpVal                 -- ^ Value+    | EDeref    ExpVar                 -- ^ Dereference+    | EBind     Exp  Exp               -- ^ Bind, i.e., :=+    | EAssign   Exp  Exp               -- ^ Assignment, =+    | EControl  ExpControl             -- ^ Control structure, e.g. if, while+    | EFlatten  [Exp]                  -- ^ Wrapper for expressions forced into+                                       --   slurpy context+    | EE ExpEmeritus+    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos, Perl6Class, MooseClass!-}++prettyExp :: Exp -> Doc+prettyExp (EE e) = formatQuite (ee e)+prettyExp exp    = text (show exp)+++-- | Control statement, such as "if".+data ExpControl+    = CCall        ID     ExpCapt       -- ^ lookup a routine, call it+    | CCallDyn     Exp    ExpCapt       -- ^ call with a dynamically calculated name+    | CApply       Exp    ExpCapt       -- ^ apply a Code without lookup+    | CCond        Exp    Code          -- ^ 2 if 1+    | CTrenaryCond Exp    Code  Code    -- ^ 1 ?? 2 !! 3+    | CCondBlock   (Exp, Code) [(Exp, Code)] (Maybe Code)+                                        -- ^ if 1 { 2 } else { 3 } or in general,+                                        --   if 1 { 2 } elsif 3 { 4 } elsif 5 { 6 } 7+                                        -- ^ &statement_control:<if>+    | CGoto        ID                   -- ^ &statement_control:<goto>+    | CWhile       Exp  Code            -- ^ &statement_control:<while>+    | CGiven       Exp  Code            -- ^ given+    | CWhen        Exp  Code            -- ^ when+    | CForeign                          -- ^ &statement_control:<mycontrol>+    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos, Perl6Class, MooseClass!-}++-- | AST for a statement. The top level of an AST is a list of Stmt.+data Stmt = MkStmt+    { label      :: Maybe ID+    , pragmas    :: Table+    , expression :: Exp+    } deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos, Perl6Class, MooseClass!-}++-- | Carry over last pragmas and create a new statement out of an expression+nextStmt :: Stmt -> Exp -> Stmt+nextStmt MkStmt{ pragmas=prag } exp = MkStmt{ label=Nothing, pragmas=prag, expression=exp }+
+ src/Pugs/Exp.hs-boot view
@@ -0,0 +1,9 @@+{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances -fallow-overlapping-instances -cpp #-}++module Pugs.Exp where+import Text.PrettyPrint++data Exp+data Stmt++prettyExp :: Exp -> Doc
+ src/Pugs/External.hs view
@@ -0,0 +1,52 @@+{-# OPTIONS_GHC -fglasgow-exts -cpp -fallow-overlapping-instances #-}++{-|+    External call utilities.++>   To the Sea, to the Sea! The white gulls are crying,+>   The wind is blowing, and the white foam is flying.+>   West, west away, the round sun is falling.+>   Grey ship, grey ship, do you hear them calling?+-}++module Pugs.External where+import Pugs.Internals+import Pugs.AST+import Pugs.External.Haskell (externalizeHaskell, loadHaskell)++externalize :: String -> Exp -> IO String+externalize mod stmts = externExternalize backend mod code+    where+    (backend, code)+        | null things   = error "no inline found"+        | [_] <- things = head things+        | otherwise     = error "multiple inline found"+    things = [ (backend, code)+             | (Syn "inline" [Val (VStr backend), Val (VStr code)]) <- flatten stmts+             ]+    flatten (Stmts cur rest) = (cur:flatten rest)+    flatten exp = [exp]+++externExternalize :: String -> String -> String -> IO String+externExternalize "Haskell" = externalizeHaskell+externExternalize backend   = error $ "Unrecognized inline backend: " ++ backend++externLoad :: String -> FilePath -> IO [(String, [Val] -> Eval Val)]+externLoad "Haskell" = loadHaskell+externLoad backend   = error $ "Unrecognized inline backend: " ++ backend++externRequire :: String -> FilePath -> Eval ()+externRequire lang name = do+    glob        <- asks envGlobal+    bindings    <- io $ externLoad lang name+    stm $ do+        newSyms     <- mapM gen bindings+        modifyMPad glob (\pad -> combine newSyms pad)+    where+    gen (name, fun) = genSym (cast ('&':name)) . codeRef $ mkPrim+        { subName       = cast name+        , subParams     = [buildParam "List" "" "*@?1" (Val VUndef)]+        , subBody       = (Prim fun)+        }+
+ src/Pugs/External/Haskell.hs view
@@ -0,0 +1,121 @@+{-# OPTIONS_GHC -fglasgow-exts -cpp #-}++-- -fth -cpp -package plugins #-}++module Pugs.External.Haskell where+import Pugs.AST++#undef PUGS_HAVE_TH+-- #include "../pugs_config.h"+#if !defined(PUGS_HAVE_TH) || !defined(PUGS_HAVE_HSPLUGINS)+externalizeHaskell :: String -> String -> IO String+externalizeHaskell  = error "Template Haskell support not compiled in"+loadHaskell :: FilePath -> IO [(String, [Val] -> Eval Val)]+loadHaskell         = error "Template Haskell support not compiled in"+#else++import Language.Haskell.TH as TH+import Language.Haskell.Parser+import Language.Haskell.Syntax+import System.Plugins+import Pugs.Config+import Pugs.Internals++{- ourPackageConfigs :: [PackageConfig]+ourPackageConfigs = [+    PackageConfig {+        hs_libraries = ["Unicode.o"]+        extra_libraries = ["UnicodeC.o"]+    }+] -}+ourPackageConfigs :: [a]+ourPackageConfigs = []++loadOrDie +     :: FilePath                -- ^ object file+     -> [FilePath]              -- ^ any include paths+     -> [FilePath]              -- ^ list of package.conf paths+     -> String                  -- ^ symbol to find+     -> IO (a)+loadOrDie obj includes configs symbol = do+    stat <- load obj includes configs symbol+    case stat of+        LoadFailure errs -> error $ unlines $ ["Error loading "++symbol++" from "++obj] ++ errs+        LoadSuccess _ a  -> return a++loadHaskell :: FilePath -> IO [(String, [Val] -> Eval Val)]+loadHaskell file = do+    let coredir   = getConfig "installarchlib" ++ "/CORE/pugs/"+        objDir    = getConfig "installsitearch"+        objFile   = (objDir ++ "/" ++ file)+        loadpaths = [coredir, objDir]+    -- For Unicode+    loadRawObject $ coredir++"UnicodeC.o"+    -- For RRegex+    loadRawObject $ coredir++"pcre/pcre.o"+    +    -- AST has early requirements and late requirements, because of recrusivity.  +    -- The logic for this should probably be moved to hs-plugins, but do it here +    -- for now.+    {-+    mapM +        (\n -> load (coredir++n++".o") loadpaths ourPackageConfigs "")+        ["Compat", "Cont", "Embed", "Embed/Perl5", "Internals", "RRegex", "RRegex/PCRE", "RRegex/Syntax", "Rule/Pos", "UTF8", "Unicode", "AST"]+    -}++    (extern :: [String]) <- loadOrDie objFile loadpaths ourPackageConfigs "extern__"+    -- print (">"++(show extern)++"<")+    (`mapM` extern) $ \name -> do+        func <- loadOrDie objFile loadpaths ourPackageConfigs ("extern__" ++ name)+        return (name, func)++externalizeHaskell :: String -> String -> IO String+#ifndef HADDOCK+externalizeHaskell mod code = do+    let names = map snd exports+    symTable <- runQ [d|+        extern__ :: [String]+        extern__ = names+        |]+    symDecls <- mapM wrap names+    return $ unlines $+        [ "module " ++ mod ++ " where"+        , "import Internals"+        , "import GHC.Base"+        , "import AST"+        , ""+        , code+        , ""+        , "-- below are automatically generated by Pugs --"+        , TH.pprint symTable+        , TH.pprint symDecls+        ] +    where+    exports :: [(HsQualType, String)]+    exports = concat [ [ (typ, name) | HsIdent name <- names ]+                     | HsTypeSig _ names typ <- parsed+                     ]+    parsed = case parseModule code of+        ParseOk (HsModule _ _ _ _ decls) -> decls+        ParseFailed _ err -> error err+#endif++wrap :: String -> IO Dec+#ifndef HADDOCK+wrap fun = do+    [quoted] <- runQ [d|+            name :: [Val] -> Eval Val+            name = \[v] -> do+                s <- fromVal v+                return (castV ($(dyn fun) s))+        |]+    return $ munge quoted ("extern__" ++ fun)+#endif++munge :: Dec -> String -> Dec+munge (ValD _ x y) name = ValD (VarP (mkName name)) x y+munge _ _ = error "impossible"++++#endif
+ src/Pugs/Help.hs view
@@ -0,0 +1,90 @@+{-# OPTIONS_GHC -fglasgow-exts #-}++{-|+    Online help and banner text.++>   But if of ships I now should sing,+>   what ship would come to me,+>   What ship would bear me ever back+>   across so wide a Sea?+-}++-- #include "pugs_config.h"++module Pugs.Help (printInteractiveHelp, printCommandLineHelp,+             banner, versnum, version, revnum,+             copyright, intro) where+import Pugs.Version+import Pugs.CodeGen (backends)+import Data.List (sort, intersperse)++printInteractiveHelp :: IO ()+printInteractiveHelp+   = putStrLn $ unlines+        [ "Commands available from the prompt:"+        , ":h              = show this help message"+        , ":q              = quit"+        , ":r              = reset the evaluation environment"+        , ":l <filename>   = load a pugs file"+        , ":d <exp>        = show syntax tree of an expression"+        , ":D <exp>        = show raw syntax tree of an expression"+        , ":e <exp>        = run a command, and ugly-print the result"+        , ":er <exp>       = same, in a pristine environment"+        , ":E <exp>        = same, but evaluate in small steps"+        , ":ER <exp>       = same, in a pristine environment"+        , "<exp>           = run a command"+        ]++{- FIXME: Somebody with more UI skillz should make this nicer -}+printCommandLineHelp :: IO ()+printCommandLineHelp+   = putStrLn $ unlines+        [ "Usage: pugs [switches] [programfile] [arguments]"+        , "Command-line flags:"+        , "-e program       one line of program (several -e's allowed, omit programfile)"+        , "-n               wrap the -e fragments in a 'while(=<>){...}' loop"+        , "-p               wrap the -e fragments in a 'while(=<>){...;say}' loop"+        , "-c               parse the file or -e, but do not run it"+        , "-d               run the program with debug tracing"+        , "-Bbackend        execute using the compiler backend"+        , "-Cbackend        compile using the compiler backend"+        , "                 (valid backends are: " ++ backendsStr ++ ")"+        , "-Mmodule         execute 'use module' before running the program"+        , "-Ipath           add path to module search paths in @*INC"+        , "-h or --help     give this message"+        , "-V               long configuration information & version"+        , "-V:item          short configuration information for item"+        , "-v or --version  version"+        , "-l and -w are ignored for compatibility with Perl 5"+        , "See documentation of pugs::run for more help."+        ]+    where+    backendsStr = concat . intersperse ", " $ sort ("JS":backends)++versionFill :: Int -> String+versionFill n = fill ++ vstr+    where+    fill = replicate (n - vlen) ' '+    vlen = length vstr+    vstr = "Version: " ++ versnum ++ revision++banner :: IO ()+banner = putStrLn $ unlines+    [ "   ______                                                           "+    , " /\\   __ \\                                                        "+    , " \\ \\  \\/\\ \\ __  __  ______  ______     (P)erl 6                "+    , "  \\ \\   __//\\ \\/\\ \\/\\  __ \\/\\  ___\\    (U)ser's           "+    , "   \\ \\  \\/ \\ \\ \\_\\ \\ \\ \\/\\ \\ \\___  \\   (G)olfing      "+    , "    \\ \\__\\  \\ \\____/\\ \\____ \\/\\_____\\  (S)ystem           "+    , "     \\/__/   \\/___/  \\/___/\\ \\/____/                           "+    , "                       /\\____/   " ++ versionFill 27+    , "                       \\/___/    " ++ copyright+    , "--------------------------------------------------------------------"+    , " Web: http://pugscode.org/           Email: perl6-compiler@perl.org "+    ]++intro :: IO ()+intro = putStrLn $ unlines+    [ "Welcome to Pugs -- " ++ name+    , "Type :h for help."+    ]
+ src/Pugs/Internals.hs view
@@ -0,0 +1,18 @@+{-# OPTIONS_GHC -fglasgow-exts -fno-warn-orphans -fallow-undecidable-instances -fallow-overlapping-instances -fparr #-}++{-|+    Internal utilities and library imports.++>   Though here at journey's end I lie+>   in darkness buried deep,+>   beyond all towers strong and high,+>   beyond all mountains steep,+>   above all shadows rides the Sun+>   and Stars for ever dwell:+>   I will not say the Day is done,+>   nor bid the Stars farewell.+-}++module Pugs.Internals ( module Pugs.Compat ) where++import Pugs.Compat
+ src/Pugs/Junc.hs view
@@ -0,0 +1,228 @@+{-# OPTIONS_GHC -fglasgow-exts #-}++{-|+    Junction logic.++>   Still round the corner there may wait+>   A new road or a secret gate,+>   And though we pass them by today,+>   Tomorrow we may come this way...+-}++module Pugs.Junc (+    ApplyArg(..),+    opJunc, opJuncNone, opJuncAll, opJuncAny, opJuncOne,+    juncApply,+) where+import Pugs.Types+import Pugs.Internals+import Pugs.AST+import qualified Data.Set as Set++{-|+Construct a @none(...)@ junction from a list of values.++Delegates to 'opJunc'.+-}+opJuncNone :: [Val] -> Val+opJuncNone = opJunc JNone++{-|+Construct an @all(...)@ junction from a list of values.++Delegates to 'opJunc'.+-}+opJuncAll :: [Val] -> Val+opJuncAll = opJunc JAll++{-|+Construct a n@any(...)@ junction from a list of values.++Delegates to 'opJunc'.+-}+opJuncAny :: [Val] -> Val+opJuncAny = opJunc JAny++{-|+Construct a @one(...)@ junction from a list of values.++Does /not/ delegate to 'opJunc'!+-}+opJuncOne :: [Val] -> Val+opJuncOne args = VJunc (MkJunc JOne dups vals)+    where+    vals = Set.fromList [ v | [v] <- groups ]+    dups = Set.fromList [ v | (v:_:_) <- groups ]+    groups = group $ sort args++{-|+Construct a junction of the specified junctive type, containing all the+values in the list.+-}+opJunc :: JuncType -> [Val] -> Val+opJunc t vals = VJunc $ MkJunc t Set.empty (joined `Set.union` Set.fromList vs)+    where+    joined = Set.unions $ map (\(VJunc s) -> juncSet s) js+    (js, vs) = partition sameType vals+    sameType (VJunc (MkJunc t' _ _))  = t == t'+    sameType _                      = False++{-|+Merge the contents of two @any@ or @one@ junctions into a single, combined +junction value.++For 'Pugs.Internals.JAny', values are simply collapsed into @Set@s (duplicate+values are discarded).++For 'Pugs.Internals.JOne', newly-created duplicates are extracted from the +combined list of values and moved into the combined set of duplicates.+-}+mergeJunc :: JuncType -- ^ Type of the junctions being combined+          -> [Val]    -- ^ Concatenated list of duplicates (only used for @one@)+          -> [Val]    -- ^ Concatenated list of regular values+          -> VJunc+mergeJunc j ds vs+    = case j of+       JAny -> MkJunc j (Set.fromList ds) (Set.fromList vs)+       JOne -> MkJunc j dups vals+       x    -> internalError $ "mergeJunc pattern failure: " ++ (show x)+    where+    vals = Set.fromList [ v | [v] <- group $ sort vs ]+    dups = Set.fromList (ds ++ [ v | (v:_:_) <- group $ sort (vs ++ ds) ])++-- OK... Now let's implement the hideously clever autothreading algorithm.+-- First pass - thread thru all() and none()+-- Second pass - thread thru any() and one()++{-|+Core of the \"hideously clever\" autothreading algorithm.++This function scans through the list of 'ApplyArg's, finds the first+uncollapsed junction, and transposes e.g. @foo($a|$b|$c)@ into+@( foo($a) | foo($b) | foo($c) )@.++It then recursively applies itself to each of those newly-created \'threads\', +so ultimately all the call's arguments are properly collapsed.++The scanning process will thread through @all@ and @none@ before it threads+through @any@ and @one@.++>[09:09] <scook0> any specific reason for all() & none() getting autothreaded before one() & any()?+>[09:10] <autrijus> scook0: specced this way.+>[09:10] <autrijus> I don't think S09 gives reasons++<http://dev.perl.org/perl6/doc/design/syn/S09.html>++Once all the args /are/ collapsed, we call the (Haskell) function that +'juncApply'\'s was given, passing to it the final list of collapsed args.+This happens once for /each/ possible combination of (collapsed) arguments.+The function is expected to perform the actual subroutine call.++Note that 'juncApply' takes place /after/ parameter binding (because it must),+but /before/ we actually introduce any bindings into the sub's lexical scope+(because otherwise we wouldn't know which value to bind).+-}+juncApply :: ([ApplyArg] -> Eval Val) -- ^ Function to call once we know the+                                      --     collapsed arg values+          -> [ApplyArg]               -- ^ List of arguments to autothread over+          -> Eval Val+juncApply f args+    | this@(_, (pivot:_)) <- break isTotalJunc args+    , VJunc (MkJunc j dups vals) <- argValue pivot+    = do+        vals' <- appList this vals+        return $ VJunc (MkJunc j dups (Set.fromList vals'))+    | this@(_, (pivot:_)) <- break isPartialJunc args+    , VJunc (MkJunc j dups vals) <- argValue pivot+    = do+        dups' <- appList this dups+        vals' <- appList this vals+        return $ VJunc (mergeJunc j dups' vals')+    | (val:_) <- [ val | (ApplyArg _ val@(VError _ _) _) <- args ]+    = return val+    | otherwise+    = f args+    where+    appList :: ([ApplyArg], [ApplyArg]) -> Set Val -> Eval [Val]+    appList (before, (ApplyArg name _ coll):after) vs = do+        env <- ask+        io $ do+            mvars   <- forM (Set.elems vs) $ \v -> do+                mv  <- newEmptyMVar+                forkIO $ do+                    val <- runEvalIO env $ juncApply f (before ++ (ApplyArg name v coll:after))+                    putMVar mv val+                return mv+            mapM takeMVar mvars+    appList _ _ = internalError "appList: list doesn't begin with ApplyArg"++{-|+Return @True@ if the given 'ApplyArg' (autothreaded argument) represents a+junction value that is @all@ or @none@, /and/ still needs to autothreaded.++Other junctions, total junctions that don't need collapsing, and non-junction+values will all produce @False@.+-}+isTotalJunc :: ApplyArg -> Bool+isTotalJunc arg+    | (ApplyArg _ (VJunc j) b) <- arg+    , (juncType j ==) `any` [JAll, JNone]+    = not b+    | otherwise+    = False++{-|+Return @True@ if the given 'ApplyArg' (autothreaded argument) represents a+junction value that is @one@ or @any@, /and/ still needs to be autothreaded.++Other junctions, partial junctions that don't need collapsing, and non-junction+values will all produce @False@.+-}+isPartialJunc :: ApplyArg -> Bool+isPartialJunc arg+    | (ApplyArg _ (VJunc j) b) <- arg+    , (juncType j ==) `any` [JOne, JAny]+    = not b+    | otherwise+    = False++{-|+Represents a sub argument during the junction autothreading process.++Note that 'argCollapsed' is set to @True@ only if the corresponding sub param+is explicitly specified as accepting the Perl 6 type @Junc@.+-}+data ApplyArg = ApplyArg+    { argName       :: !Var     -- ^ Name of the param that this arg is for+    , argValue      :: !Val     -- ^ Actual argument value, which may still be+                                --     a junction+    , argCollapsed  :: !Bool    -- ^ @True@ if we have confirmed that this arg+                                --     doesn't need any further autothreading+    }+    deriving (Show, Eq, Ord)++---------------------++{-++bool = ["0", "1"]+test = do+    sequence [ testJunc out inn nest | out <- junc, inn <- junc, nest <- [True, False] ]++testJunc out inn nest = do+    let foo = [ blah a b c out inn nest | a <- bool, b <- bool, c <- bool ]+    when (all id foo) $ if nest+        then print (out, inn)+        else print (out)++junc = ["any", "one", "all", "none"]+out1 = "any"+inn1 = "any"++blah a b c out inn nest = want == has+    where+    want = opEval emptyEnv $ "? " ++ out1 ++ "( " ++ inn1 ++ "( " ++ a ++ ", " ++ b ++ " ), " ++ inn1 ++ "( " ++ b ++ ", " ++ " " ++ c ++ " ) )"+    has | nest = opEval emptyEnv $ "? " ++ out ++ "( " ++ b ++ ", " ++ inn ++ "(" ++ a ++ ", " ++ c ++ "))"+        | otherwise = opEval emptyEnv $ "? " ++ out ++ "( " ++ b ++ ", " ++ a ++ ", " ++ c ++ ")"+-}+
+ src/Pugs/Lexer.hs view
@@ -0,0 +1,566 @@+{-# OPTIONS_GHC -fglasgow-exts -optc-w -cpp #-}++{-|+    Lexical analyzer.++>   No words were laid on stream or stone+>   When Durin woke and walked alone.+>   He named the nameless hills and dells;+>   He drank from yet untasted wells...+-}++module Pugs.Lexer (+    wordAlpha, wordAny, isWordAlpha, isWordAny,+    maybeParens, parens, whiteSpace, mandatoryWhiteSpace, lexeme, identifier, identLetter,+    braces, brackets, angles, balancedDelim, decimal,++    ruleVerbatimIdentifier, ruleDelimitedIdentifier, ruleQualifiedIdentifier,++    symbol, interpolatingStringLiteral, escapeCode,++    rule, verbatimRule, literalRule,+    tryRule, tryVerbatimRule,+    tryChoice, ruleComma, ++    ruleScope, ruleTrait, ruleTraitName, ruleBareTrait, ruleType,+    verbatimParens, verbatimBrackets, verbatimBraces, eof+) where+import Pugs.Internals+import Pugs.AST+import Pugs.Rule+import Pugs.Types+import Pugs.Parser.Types+import Pugs.Parser.Charnames+import Text.ParserCombinators.Parsec.Pos (sourceColumn, sourceLine)+import qualified Text.ParserCombinators.Parsec as Parsec (eof)++eof :: RuleParser ()+eof = Parsec.eof <?> ""++identStart, identLetter :: RuleParser Char+identStart  = satisfy isWordAlpha+identLetter = satisfy isWordAny++wordAlpha   :: RuleParser Char+wordAny     :: RuleParser Char+wordAlpha   = satisfy isWordAlpha <?> "alphabetic word character"+wordAny     = satisfy isWordAny <?> "word character"++isWordAny   :: Char -> Bool+isWordAlpha :: Char -> Bool+isWordAny x = (isAlphaNum x || x == '_')+isWordAlpha x = (isAlpha x || x == '_')++maybeParens :: RuleParser a -> RuleParser a+maybeParens p = choice [ parens p, p ]++parens, braces, angles, brackets :: RuleParser a -> RuleParser a+parens p        = between (lexeme (char '(')) (lexeme (char ')')) p+braces p        = between (lexeme (char '{')) (lexeme (char '}')) p+angles p        = between (lexeme (char '<')) (lexeme (char '>')) p+brackets p      = between (lexeme (char '[')) (lexeme (char ']')) p++mandatoryWhiteSpace :: RuleParser ()+mandatoryWhiteSpace = skipMany1 (simpleSpace <|> comment)++balancedDelim :: Char -> Char+balancedDelim c = case c of+    '\x0028' -> '\x0029'; '\x003C' -> '\x003E'; '\x005B' -> '\x005D';+#ifndef HADDOCK+    '\x007B' -> '\x007D'; '\x00AB' -> '\x00BB'; '\x0F3A' -> '\x0F3B';+    '\x0F3C' -> '\x0F3D'; '\x169B' -> '\x169C'; '\x2039' -> '\x203A';+    '\x2045' -> '\x2046'; '\x207D' -> '\x207E'; '\x208D' -> '\x208E';+    '\x2208' -> '\x220B'; '\x2209' -> '\x220C'; '\x220A' -> '\x220D';+    '\x2215' -> '\x29F5'; '\x223C' -> '\x223D'; '\x2243' -> '\x22CD';+    '\x2252' -> '\x2253'; '\x2254' -> '\x2255'; '\x2264' -> '\x2265';+    '\x2266' -> '\x2267'; '\x2268' -> '\x2269'; '\x226A' -> '\x226B';+    '\x226E' -> '\x226F'; '\x2270' -> '\x2271'; '\x2272' -> '\x2273';+    '\x2274' -> '\x2275'; '\x2276' -> '\x2277'; '\x2278' -> '\x2279';+    '\x227A' -> '\x227B'; '\x227C' -> '\x227D'; '\x227E' -> '\x227F';+    '\x2280' -> '\x2281'; '\x2282' -> '\x2283'; '\x2284' -> '\x2285';+    '\x2286' -> '\x2287'; '\x2288' -> '\x2289'; '\x228A' -> '\x228B';+    '\x228F' -> '\x2290'; '\x2291' -> '\x2292'; '\x2298' -> '\x29B8';+    '\x22A2' -> '\x22A3'; '\x22A6' -> '\x2ADE'; '\x22A8' -> '\x2AE4';+    '\x22A9' -> '\x2AE3'; '\x22AB' -> '\x2AE5'; '\x22B0' -> '\x22B1';+    '\x22B2' -> '\x22B3'; '\x22B4' -> '\x22B5'; '\x22B6' -> '\x22B7';+    '\x22C9' -> '\x22CA'; '\x22CB' -> '\x22CC'; '\x22D0' -> '\x22D1';+    '\x22D6' -> '\x22D7'; '\x22D8' -> '\x22D9'; '\x22DA' -> '\x22DB';+    '\x22DC' -> '\x22DD'; '\x22DE' -> '\x22DF'; '\x22E0' -> '\x22E1';+    '\x22E2' -> '\x22E3'; '\x22E4' -> '\x22E5'; '\x22E6' -> '\x22E7';+    '\x22E8' -> '\x22E9'; '\x22EA' -> '\x22EB'; '\x22EC' -> '\x22ED';+    '\x22F0' -> '\x22F1'; '\x22F2' -> '\x22FA'; '\x22F3' -> '\x22FB';+    '\x22F4' -> '\x22FC'; '\x22F6' -> '\x22FD'; '\x22F7' -> '\x22FE';+    '\x2308' -> '\x2309'; '\x230A' -> '\x230B'; '\x2329' -> '\x232A';+    '\x23B4' -> '\x23B5'; '\x2768' -> '\x2769'; '\x276A' -> '\x276B';+    '\x276C' -> '\x276D'; '\x276E' -> '\x276F'; '\x2770' -> '\x2771';+    '\x2772' -> '\x2773'; '\x2774' -> '\x2775'; '\x27C3' -> '\x27C4';+    '\x27C5' -> '\x27C6'; '\x27D5' -> '\x27D6'; '\x27DD' -> '\x27DE';+    '\x27E2' -> '\x27E3'; '\x27E4' -> '\x27E5'; '\x27E6' -> '\x27E7';+    '\x27E8' -> '\x27E9'; '\x27EA' -> '\x27EB'; '\x2983' -> '\x2984';+    '\x2985' -> '\x2986'; '\x2987' -> '\x2988'; '\x2989' -> '\x298A';+    '\x298B' -> '\x298C'; '\x298D' -> '\x298E'; '\x298F' -> '\x2990';+    '\x2991' -> '\x2992'; '\x2993' -> '\x2994'; '\x2995' -> '\x2996';+    '\x2997' -> '\x2998'; '\x29C0' -> '\x29C1'; '\x29C4' -> '\x29C5';+    '\x29CF' -> '\x29D0'; '\x29D1' -> '\x29D2'; '\x29D4' -> '\x29D5';+    '\x29D8' -> '\x29D9'; '\x29DA' -> '\x29DB'; '\x29F8' -> '\x29F9';+    '\x29FC' -> '\x29FD'; '\x2A2B' -> '\x2A2C'; '\x2A2D' -> '\x2A2E';+    '\x2A34' -> '\x2A35'; '\x2A3C' -> '\x2A3D'; '\x2A64' -> '\x2A65';+    '\x2A79' -> '\x2A7A'; '\x2A7D' -> '\x2A7E'; '\x2A7F' -> '\x2A80';+    '\x2A81' -> '\x2A82'; '\x2A83' -> '\x2A84'; '\x2A8B' -> '\x2A8C';+    '\x2A91' -> '\x2A92'; '\x2A93' -> '\x2A94'; '\x2A95' -> '\x2A96';+    '\x2A97' -> '\x2A98'; '\x2A99' -> '\x2A9A'; '\x2A9B' -> '\x2A9C';+    '\x2AA1' -> '\x2AA2'; '\x2AA6' -> '\x2AA7'; '\x2AA8' -> '\x2AA9';+    '\x2AAA' -> '\x2AAB'; '\x2AAC' -> '\x2AAD'; '\x2AAF' -> '\x2AB0';+    '\x2AB3' -> '\x2AB4'; '\x2ABB' -> '\x2ABC'; '\x2ABD' -> '\x2ABE';+    '\x2ABF' -> '\x2AC0'; '\x2AC1' -> '\x2AC2'; '\x2AC3' -> '\x2AC4';+    '\x2AC5' -> '\x2AC6'; '\x2ACD' -> '\x2ACE'; '\x2ACF' -> '\x2AD0';+    '\x2AD1' -> '\x2AD2'; '\x2AD3' -> '\x2AD4'; '\x2AD5' -> '\x2AD6';+    '\x2AEC' -> '\x2AED'; '\x2AF7' -> '\x2AF8'; '\x2AF9' -> '\x2AFA';+    '\x2E02' -> '\x2E03'; '\x2E04' -> '\x2E05'; '\x2E09' -> '\x2E0A';+    '\x2E0C' -> '\x2E0D'; '\x2E1C' -> '\x2E1D'; '\x3008' -> '\x3009';+    '\x300A' -> '\x300B'; '\x300C' -> '\x300D'; '\x300E' -> '\x300F';+    '\x3010' -> '\x3011'; '\x3014' -> '\x3015'; '\x3016' -> '\x3017';+    '\x3018' -> '\x3019'; '\x301A' -> '\x301B'; '\x301D' -> '\x301E';+    '\xFD3E' -> '\xFD3F'; '\xFE17' -> '\xFE18'; '\xFE35' -> '\xFE36';+    '\xFE37' -> '\xFE38'; '\xFE39' -> '\xFE3A'; '\xFE3B' -> '\xFE3C';+    '\xFE3D' -> '\xFE3E'; '\xFE3F' -> '\xFE40'; '\xFE41' -> '\xFE42';+    '\xFE43' -> '\xFE44'; '\xFE47' -> '\xFE48'; '\xFE59' -> '\xFE5A';+    '\xFE5B' -> '\xFE5C'; '\xFE5D' -> '\xFE5E'; '\xFF08' -> '\xFF09';+    '\xFF1C' -> '\xFF1E'; '\xFF3B' -> '\xFF3D'; '\xFF5B' -> '\xFF5D';+    '\xFF5F' -> '\xFF60'; '\xFF62' -> '\xFF63'; other    -> other+#endif++{-+-- balanced: parses an open/close delimited expression of any non-alphanumeric character+balanced :: RuleParser String+balanced = do+    notFollowedBy alphaNum+    opendelim <- anyChar+    contents <- many $ satisfy (/= balancedDelim opendelim)+    char $ balancedDelim opendelim+    return contents++-- The \b rule.+_ruleWordBoundary :: RuleParser ()+_ruleWordBoundary = do+    prev <- getPrevCharClass+    case prev of+        SpaceClass -> return ()+        _  -> do+            curr <- getCurrCharClass+            guard (prev /= curr)++-- The <ws> rule.+ruleWs :: RuleParser ()+ruleWs = do+    prev <- getPrevCharClass+    case prev of+        SpaceClass -> whiteSpace+        _  -> do+            curr <- getCurrCharClass+            if prev == curr then mandatoryWhiteSpace else case curr of+                SpaceClass  -> whiteSpace+                _           -> return ()+-}++{-|+Match one or more identifiers, separated internally by the given delimiter.++Returns a list of the identifiers matched, discarding the delimiters.  You+can always recreate them using \"@concat $ intersperse delim@\" if you want,+or else use 'ruleQualifiedIdentifier'.+-}+ruleDelimitedIdentifier :: String -- ^ Delimiter (e.g. \'@::@\')+                        -> RuleParser [String]+ruleDelimitedIdentifier delim = verbatimRule "delimited identifier" $ do+    -- Allowing the leading delim actually leads to subtle oddness with things+    -- like `use jsan:.Foo` and `use pugs:::Foo`, so I took it out.+    --option "" (try $ string delim) -- leading delimiter+    ruleVerbatimIdentifier `sepBy1` (try $ string delim)++ruleQualifiedIdentifier :: RuleParser String+ruleQualifiedIdentifier = verbatimRule "qualified identifier" $ do+    chunks <- ruleDelimitedIdentifier "::"+    return $ concat (intersperse "::" chunks)++ruleVerbatimIdentifier :: RuleParser String+ruleVerbatimIdentifier = verbatimRule "identifier" $ do+    c  <- identStart+    cs <- many identLetter+    return (c:cs)++{-+{-|+Match any amount of whitespace (not including newlines), followed by a newline+(as matched by 'ruleEndOfLine').+-}+ruleWhiteSpaceLine :: RuleParser ()+ruleWhiteSpaceLine = do+    many $ satisfy (\x -> isSpace x && x /= '\n')+    ruleEndOfLine++{-|+Match either a single newline, or EOF (which constitutes the termination of a+line anyway).+-}+ruleEndOfLine :: RuleParser ()+ruleEndOfLine = choice [ do { char '\n'; return () }, eof ]+-}++symbol :: String -> RuleParser String+symbol s = try $ do+    rv <- string s+    let lastCh  = last s+        ahead f = lookAhead (satisfy (f lastCh)) <|> (eof >> return ' ')+    if isWordAny lastCh+        then ahead aheadWord >> whiteSpace >> notFollowedBy (try (char '=' >> char '>'))+        else ahead aheadSym >> whiteSpace+    return rv+    where+    aheadWord x  '=' = not $ x `elem` "xXZ"+    aheadWord _  y   = not $ isWordAny y+    aheadSym '-' '>' = False -- XXX hardcode+    aheadSym '!' '~' = False -- XXX hardcode+    aheadSym '\\''(' = False -- XXX hardcode+    aheadSym '|' '<' = False -- XXX hardcode+    aheadSym x   '=' = not (x `elem` "!~+-*&/|.%^")+    aheadSym '?' y   = not (y `elem` "&|^?")+    aheadSym '+' y   = not (y `elem` "&|^+")+    aheadSym '~' y   = not (y `elem` "&|^~")+    aheadSym '^' y   = not (y `elem` "^.")+    aheadSym x   y   = y `elem` ";!" || x /= y++interpolatingStringLiteral :: RuleParser String -- ^ Opening delimiter+                           -> RuleParser String -- ^ Closing delimiter+                           -> RuleParser Exp    -- ^ Interpolator+                           -> RuleParser Exp    -- ^ Entire string+                                                --     (without delims)+interpolatingStringLiteral startRule endRule interpolator = do+    list <- stringList 0+    return $ Ann (Cxt (CxtItem $ mkType "Str")) (homogenConcat list)+    where+    homogenConcat :: [Exp] -> Exp+    homogenConcat [] = Val (VStr "")+    homogenConcat [v@(Val (VStr _))] = v+    homogenConcat (Val (VStr x):Val (VStr y):xs)+        = homogenConcat (Val (VStr (x ++ y)) : xs)+    homogenConcat (x:xs)+        = App (_Var "&infix:~") Nothing [x, homogenConcat xs]++    stringList :: Int -> RuleParser [Exp]+    stringList i = choice+        [ do+            parse <- interpolator+            rest  <- stringList i+            return (parse:rest)+        , do+            ch    <- try endRule+            if i == 0+                then return []+                else do+                    rest <- stringList (i-1)+                    return (Val (VStr ch):rest)+        , do+            ch   <- try startRule+            rest <- stringList (i+1)+            return (Val (VStr ch):rest)+        , do+            char <- anyChar+            rest <- stringList i+            return (Val (VStr [char]):rest)+        ]++-- | Backslashed non-alphanumerics (except for @\^@) translate into themselves.+escapeCode      :: RuleParser String+escapeCode      = charNum <|> ch charEsc <|> ch charAscii <|> ch charControl <|> ch anyChar+                <?> "escape code"+    where+    ch = fmap (:[])++charControl :: RuleParser Char+charControl = do+    char 'c'+    code <- upper <|> oneOf "@["+    case code of+        '[' -> do+            charName <- many (satisfy (/= ']'))+            char ']'+            case nameToCode charName of+                Just c  -> return (chr c)+                _       -> error $ "Invalid unicode character name: " ++ charName+        _   -> return (toEnum (fromEnum code - fromEnum '@'))++-- This is currently the only escape that can return multiples.+charNum :: RuleParser String+charNum = do+    codes <- choice+        [ many1 digit >>= \ds -> case ds of+            "0" -> return [0]+            -- "\08..." and "\09..." are treated as "\0" and then "8..." or "9...".+            ('0':xs@(x:_)) | x == '8' || x == '9' -> return (0:map (toInteger . ord) xs)+            _   -> error ("Error: Invalid escape sequence \\" ++ ds ++ "; write as decimal \\d" ++ ds ++ " or octal \\o" ++ ds ++ " instead") -- return [read ds]+        , based 'o'  8 octDigit+        , based 'x' 16 hexDigit+        , based 'd' 10 digit+        ]+    return $ map (toEnum . fromInteger) codes+    where+    based ch num p = do+        char ch+        choice [ verbatimBrackets (number num p `sepEndBy1` ruleComma)+               , fmap (:[]) (number num p)+               ]++ruleComma :: RuleParser ()+ruleComma = do+    lexeme (char ',')+    return ()++number :: Integer -> RuleParser Char -> RuleParser Integer+number base baseDigit+    = do{ digits <- many1 baseDigit+        ; let n = foldl (\x d -> base*x + toInteger (digitToInt d)) 0 digits+        ; seq n (return n)+        }++charEsc         :: RuleParser Char+charEsc         = choice (map parseEsc escMap)+                where+                  parseEsc (c,code)     = do{ char c; return code }++charAscii       :: RuleParser Char+charAscii       = choice (map parseAscii asciiMap)+                where+                  parseAscii (asc,code) = try (do{ string asc; return code })+++-- escape code tables+escMap          :: [(Char, Char)]+escMap          = zip ("abfnrtv\\\"\'") ("\a\b\f\n\r\t\v\\\"\'")+asciiMap        :: [(String, Char)]+asciiMap        = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2)++ascii2codes     :: [String]+ascii2codes     = ["BS","HT","LF","VT","FF","CR","SO","SI","EM",+                   "FS","GS","RS","US","SP"]+ascii3codes     :: [String]+ascii3codes     = ["NUL","SOH","STX","ETX","EOT","ENQ","ACK","BEL",+                   "DLE","DC1","DC2","DC3","DC4","NAK","SYN","ETB",+                   "CAN","SUB","ESC","DEL"]++ascii2          :: [Char]+ascii2          = ['\BS','\HT','\LF','\VT','\FF','\CR','\SO','\SI',+                   '\EM','\FS','\GS','\RS','\US','\SP']+ascii3          :: [Char]+ascii3          = ['\NUL','\SOH','\STX','\ETX','\EOT','\ENQ','\ACK',+                   '\BEL','\DLE','\DC1','\DC2','\DC3','\DC4','\NAK',+                   '\SYN','\ETB','\CAN','\SUB','\ESC','\DEL']++rule :: String -> RuleParser a -> RuleParser a+rule name = (<?> name) . lexeme++verbatimRule :: String -> RuleParser a -> RuleParser a+verbatimRule name = (<?> name)++literalRule :: String -> RuleParser a -> RuleParser a+literalRule name = (<?> name) . postSpace++tryRule :: String -> RuleParser a -> RuleParser a+tryRule name = (<?> name) . lexeme . try++tryVerbatimRule :: String -> RuleParser a -> RuleParser a+tryVerbatimRule name = (<?> name) . try++ruleScope :: RuleParser Scope+ruleScope = rule "scope" $ do+    scope <- ruleScopeName+    return $ readScope scope+    where+    readScope "state"   = SState+    readScope "has"     = SHas+    readScope "my"      = SMy+    readScope "our"     = SOur+    readScope "constant"= SConstant+    readScope _         = SState++ruleScopeName :: RuleParser String+ruleScopeName = choice $ map symbol scopeNames++scopeNames :: [String]+scopeNames = map (map toLower) . map (tail . show) $ ([minBound .. maxBound] :: [Scope])++postSpace :: RuleParser a -> RuleParser a+postSpace rule = try $ do+    rv <- rule+    notFollowedBy wordAny+    whiteSpace+    return rv++ruleTrait :: [String] -> RuleParser (String, String)+ruleTrait auxs = rule "trait" $ do+    aux <- choice $ map symbol auxs+    trait <- do+        optional $ string "::" -- XXX Bad Hack+        ruleQualifiedIdentifier+    -- XXX: For now, we *only* *parse* "is export(...)". The arguments are+    -- thrown away. So module writers can give a sensible export lists now,+    -- as otherwise+    -- <Aankhen``> Otherwise, it'll be a pain to go back to every module and+    --             change it all once the proper behaviour is implemented.+    optional $ verbatimParens $ many $ satisfy (/= ')')+    return (aux, trait)++ruleTraitName :: String -> RuleParser String+ruleTraitName trait = rule "named trait" $ do+    symbol "is"+    symbol trait+    ruleQualifiedIdentifier++ruleBareTrait :: String -> RuleParser String+ruleBareTrait trait = rule "bare trait" $ do+    choice [ ruleTraitName trait+           , do symbol trait+                str <- ruleQualifiedIdentifier+                -- Hierarchical types like Hash of Str -- not yet recognised+                many . try $ do { whiteSpace; symbol "of"; ruleQualifiedIdentifier }+                return str+           ]++ruleType :: RuleParser String+ruleType = literalRule "context" $ do+    -- Valid type names: Foo, Bar::Baz, ::Grtz, ::?CLASS, but not :Foo+    lead    <- count 1 wordAlpha <|> (string "::" >> return [])+    rest    <- many (wordAny <|> oneOf ":&|?")+    return (lead ++ rest)++{-|+Attempt each of the given parsers in turn until one succeeds, but if one of+them fails we backtrack (i.e. retroactively consume no input) before trying+the next one.+-}+tryChoice :: [RuleParser a] -- ^ List of candidate parsers+          -> RuleParser a+tryChoice = choice . map try++{-|+Match '@(@', followed by the given parser, followed by '@)@'.+-}+verbatimParens :: RuleParser a -> RuleParser a+verbatimParens = between (lexeme $ char '(') (char ')')++{-|+Match '@\[@', followed by the given parser, followed by '@\]@'.+-}+verbatimBrackets :: RuleParser a -> RuleParser a+verbatimBrackets = between (lexeme $ char '[') (char ']')++{-|+Match '@{@', followed by the given parser, followed by '@}@'.+-}+verbatimBraces :: RuleParser a -> RuleParser a+verbatimBraces = between (lexeme $ char '{') (char '}')+++-----------------------------------------------------------+-- Chars & Strings+-----------------------------------------------------------+-----------------------------------------------------------+-- Numbers+-----------------------------------------------------------++decimal :: RuleParser Integer+decimal         = number 10 digit++-----------------------------------------------------------+-- Identifiers & Reserved words+-----------------------------------------------------------+identifier, ident :: RuleParser String+identifier = lexeme . try $ ident++ident+    = do{ c <- identStart+        ; cs <- many identLetter+        ; return (c:cs)+        }+    <?> "identifier"++-----------------------------------------------------------+-- White space & symbols+-----------------------------------------------------------+lexeme :: RuleParser a -> RuleParser a+lexeme p+    = do{ x <- p; whiteSpace; return x  }+++whiteSpace :: RuleParser ()+whiteSpace = skipMany (simpleSpace <|> comment)++comment :: RuleParser ()+comment = do+    char '#' <?> ""+    pos <- getPosition+    if sourceColumn pos /= 2 then multiLineComment <|> skipToLineEnd else do+    -- Beginning of line - parse #line directive+    isPlain <- (<|> return True) $ try $ do+        string "line"+        many1 $ satisfy (\x -> isSpace x && x /= '\n')+        return False+    if isPlain then skipToLineEnd else do+    line <- decimal+    file <- (<|> return Nothing) $ try $ do+        many1 $ satisfy (\x -> isSpace x && x /= '\n')+        fileNameQuoted <|> fileNameBare+    case file of+        Just Nothing    -> skipToLineEnd+        _               -> do+            many $ satisfy (/= '\n')+            setPosition $ pos+                `setSourceLine`     (fromInteger line - 1)+                `setSourceColumn`   1+                `setSourceName`     maybe (sourceName pos) fromJust file++fileNameQuoted :: RuleParser (Maybe (Maybe String))+fileNameQuoted = try $ do+    char '"'+    file <- many (satisfy (/= '"'))+    char '"'+    many $ satisfy (\x -> isSpace x && x /= '\n')+    lookAhead (satisfy (== '\n'))+    return . Just $ Just file++fileNameBare :: RuleParser (Maybe (Maybe String))+fileNameBare = try $ do+    file <- many1 $ satisfy (not . isSpace)+    many $ satisfy (\x -> isSpace x && x /= '\n')+    (<|> return (Just Nothing)) $ try $ do+        lookAhead (satisfy (== '\n'))+        return . Just $ Just file++skipToLineEnd :: RuleParser ()+skipToLineEnd = do+    skipMany (satisfy (/= '\n'))++simpleSpace :: RuleParser ()+simpleSpace = do+    skipMany1 (satisfy isSpace)+    pos <- getPosition+    modify (\s -> s{ s_wsLine = sourceLine pos, s_wsColumn = sourceColumn pos })++multiLineComment :: RuleParser ()+multiLineComment = do+    openOne <- satisfy (\x -> balancedDelim x /= x)+    more    <- many (char openOne)+    let closeOne = balancedDelim openOne+        openAll  = string (openOne:more)+        closeAll = string (replicate (1 + length more) (balancedDelim openOne))+        scanOne  = do+            c <- anyChar+            if c == closeOne then return () else do+            if c == openOne then scanOne >> scanOne else do+            scanOne+        scanAll  = choice+            [ do { try closeAll; return () }+            , do { try openAll; scanAll; scanAll }+            , do { anyChar; scanAll }+            ]+    if null more then scanOne else scanAll
+ src/Pugs/Meta.hs view
@@ -0,0 +1,25 @@+{-# OPTIONS_GHC -fglasgow-exts #-}++{-|+    Perl 6 Meta-object definitions.++>   And though I oft have passed them by,+>   A day will come at last when I+>   Shall take the hidden paths that run+>   West of the Moon, East of the Sun.+-}++module Pugs.Meta+    ( module Pugs.Meta+    , module Pugs.Meta.Str+    , module Pugs.Meta.Perl5+--  , module Pugs.Meta.Class+    ) where++import Pugs.Meta.Str+import Pugs.Meta.Perl5+import Pugs.Meta.Class ()++-- XXX - Stub definition to work around ghci bug+pugsMetaLoaded :: ()+pugsMetaLoaded = ()
+ src/Pugs/Meta/Class.hs view
@@ -0,0 +1,15 @@+{-# OPTIONS_GHC -fglasgow-exts #-}++module Pugs.Meta.Class () where+import Pugs.Val+import Pugs.Class++{-+instance Boxable Eval PureClass where+    classOf _ = _PureClass++_PureClass :: PureClass+_PureClass = mkBoxClass "Class"+    [ "HOW"         ... (const _PureClass :: PureClass -> PureClass)+    ]+-}
+ src/Pugs/Meta/Perl5.hs view
@@ -0,0 +1,60 @@+{-# OPTIONS_GHC -fglasgow-exts #-}++module Pugs.Meta.Perl5 (Perl5Responder) where+import Pugs.Val+import Pugs.Class+import Pugs.Embed.Perl5+import Pugs.Internals+import Data.Typeable (Typeable)+import qualified Data.Map as Map+import qualified StringTable.AtomMap as AtomMap+import Pugs.AST.Internals (envContext, anyToVal, anyFromVal)+import Pugs.Types++data Perl5Responder = Perl5Responder deriving Typeable++instance ResponderInterface Eval Perl5Responder where+    dispatch _          = dispatchPerl5+    fromMethodList _    = return Perl5Responder++instance Boxable PerlSV where+    mkVal sv = MkInvocant sv (MkResponder (return Perl5Responder))+    coerceVal (MkInvocant x _)+        | Just x' <- fromTypeable x = return x'+        | Just x' <- fromTypeable x = liftIO $ vstrToSV x'+        | Just x' <- fromTypeable x = liftIO . bufToSV  $ (cast :: PureStr -> ByteString) x'+        | Just x' <- fromTypeable x = liftIO . vintToSV $ (cast :: PureInt -> Integer)    x'+        | Just x' <- fromTypeable x = liftIO . vnumToSV $ (cast :: PureNum -> Double)     x'+        | Just x' <- fromTypeable x = anyFromVal x'+        | otherwise                 = fail $ "Cannot coerce to SV: " ++ show (typeOf x)++__ITEM__, __LIST__ :: MethodName+__ITEM__    = _cast "ITEM"+__LIST__    = _cast "LIST"++dispatchPerl5 :: Val -> Call -> Eval Val+dispatchPerl5 inv call+    | meth == nullID    = return inv -- XXX - real HOW support --+    | meth == __ITEM__  = return inv -- XXX - real rvalue suport --+    | meth == __LIST__  = return inv -- XXX - real lvalue suport --+    | otherwise = do+        invSV   <- coerceVal inv+        subSV   <- liftIO . bufToSV . cast $ meth+        posSVs  <- mapM coerceVal (fromP $ f_positionals feed)+        namSVs  <- fmap concat . forM (AtomMap.toList (f_nameds feed)) $ \(key, vals) -> do+            keySV   <- liftIO (bufToSV $ cast key)+            fmap concat . forM (fromP vals) $ \v -> do+                valSV   <- coerceVal v+                return [keySV, valSV]+        env     <- ask+        rv      <- liftIO $ do+            envSV   <- mkEnv env+            invokePerl5 subSV invSV (posSVs ++ namSVs) envSV (enumCxt $ envContext env)+        case rv of+            Perl5ReturnValues [x]   -> return $ mkVal x +            Perl5ReturnValues xs    -> return $ mkVal xs+            Perl5ErrorString str    -> fail str+            Perl5ErrorObject err    -> throwError (anyToVal err)+    where+    meth = mi_name call+    feed = concatFeeds (c_feeds (mi_arguments call))
+ src/Pugs/Meta/Str.hs view
@@ -0,0 +1,37 @@+{-# OPTIONS_GHC -fglasgow-exts -fno-warn-deprecations #-}++module Pugs.Meta.Str (_StrClass) where+import Data.Maybe+import Pugs.Val+import Pugs.Class+-- import qualified Data.ByteString.UTF8 as Str+import qualified Data.ByteString.Char8 as Char8+import qualified Data.ByteString.Char8 as Str -- XXX+import Pugs.Internals++instance Boxable PureStr where+    classOf _ = _StrClass++_StrClass :: PureClass+_StrClass = mkPureClass "Str"+    [ "reverse"     ... Str.reverse+    , "join"        ... Str.intercalate+    , "chop"        ... (\str -> if Str.null str then str else Str.init str)+    , "index"       ... (\str sub pos -> fromMaybe (-1) $ Str.findSubstring sub $ Str.drop pos str)+    , "chars"       ... Str.length   -- UTF8.length, which Does The Right Thing here+    , "bytes"       ... Char8.length -- WRONG! assumes in UTF-8 representation+    , "quotemeta"   ... Str.concatMap (cast . toQuoteMeta)+    , "split"       ... _split_str []+    ]++-- XXX: this is inefficient, since it scans the string about twice as+-- many times as really needed. a better implementation would meld the+-- findSubstring and drop steps inside a ByteString scan.+_split_str :: [PureStr] -> PureStr -> PureStr -> [PureStr]+_split_str accum str glue+    | Str.null str = accum+    | otherwise    = _split_str (accum ++ [next]) str' glue+    where+    (next, str') = case Str.findSubstring glue str of+        Just i  -> (Str.take i str, Str.drop (i + Str.length glue) str)+        Nothing -> (str, Str.empty)
+ src/Pugs/Monads.hs view
@@ -0,0 +1,430 @@+{-# OPTIONS_GHC -fglasgow-exts -fallow-overlapping-instances #-}++{-|+    Common operations on Eval monad.+    +>   One Ring to rule them all,+>   One Ring to find them,+>   One Ring to bring them all+>   and in the darkness bind them...++    Note that the actual monads are defined elsewhere -- try looking at+    "Pugs.AST.SIO" and "Pugs.AST.Internals".+-}++module Pugs.Monads (+    ApplyKind(..),++    enterLValue, enterRValue,+    enterLex, enterContext, enterEvalContext, enterPackage, enterCaller,+    enterGiven, enterWhen, enterLoop, enterGather, genSymPrim, genSymCC,+    enterBlock, enterSub,+    evalVal,++    enterFrame, assertFrame, emptyFrames,++    reclosePad, recloseCode, recloseVal,+    +    MaybeT, runMaybeT+) where+import Pugs.Internals+import Pugs.AST+import Pugs.Types+import qualified Data.Set as Set++newtype MaybeT m a = MaybeT { runMaybeT :: m (Maybe a) }++instance (Monad m) => Monad (MaybeT m) where+    (MaybeT mon) >>= f =+        MaybeT (mon >>= maybe (return Nothing) (runMaybeT . f))+    return              = MaybeT . return . Just++instance MonadTrans MaybeT where+    lift mon = MaybeT (mon >>= return . Just)++instance (MonadIO m) => MonadIO (MaybeT m) where+    liftIO ma = MaybeT $ do+        a <- liftIO ma+        return (Just a)++instance (Monad m) => MonadPlus (MaybeT m) where+    mzero                       = MaybeT (return Nothing)+    mplus (MaybeT a) (MaybeT b) = MaybeT $ do+        ma <- a+        case ma of+            Nothing -> b+            _       -> return ma ++{-|+Perform the given evaluation in an /LValue/ context.+-}+enterLValue :: Eval a -> Eval a+enterLValue = local (\e -> e{ envLValue = True })+{-|+Perform the given evaluation in an /RValue/ (i.e. non-/LValue/) context.+-}+enterRValue :: Eval a -> Eval a+enterRValue = local (\e -> e{ envLValue = False })++{-|+Create a new lexical scope by applying the list of 'Pad'-transformers+(which install new bindings), then perform the specified evaluation in that+new scope.++(Subsequent chained 'Eval's do /not/ see this new scope.)+-}+enterLex :: [PadMutator] -- ^ Transformations on current 'Pad' to produce the+                         --     new 'Pad'.+         -> Eval a       -- ^ Evaluation to be performed in the new scope+         -> Eval a       -- ^ Resulting evaluation (lexical scope enter & exit+                         --     are encapsulated)+enterLex newSyms = local (\e -> e{ envLexical = combine newSyms (envLexical e) })++{-|+Perform the specified evaluation in the specified (Perl 6) context ('Cxt').++(Subsequent chained 'Eval's do /not/ see this new scope.)+-}+enterContext :: Cxt -> Eval a -> Eval a+enterContext cxt = local (\e -> e{ envContext = cxt })++{-|+Evaluate the specified expression in the specified (Perl 6) context ('Cxt').++(Subsequent chained 'Eval's do /not/ see this new scope.)+-}+enterEvalContext :: Cxt -> Exp -> Eval Val+enterEvalContext cxt = enterContext cxt . evalExp++{-|+Perform the specified evaluation in the specified package.++(Subsequent chained 'Eval's do /not/ see this package.)+-}+enterPackage :: ByteString -> Eval a -> Eval a+enterPackage pkg = local (\e -> e{ envPackage = cast pkg })++{-|+Enter a new environment and mark the previous one as 'Caller'.+Also swap in the new one's lexical environment.+-}+enterCaller :: Eval a -> Eval a+enterCaller = local envEnterCaller++envEnterCaller :: Env -> Env+envEnterCaller env = env+    { envCaller = Just env+    , envFrames = FrameRoutine `Set.insert` envFrames env+    }++{-|+Register the fact that we are inside a specially marked control block.+-}+enterFrame :: Frame -> Eval a -> Eval a+enterFrame f = local (\e -> e{ envFrames = f `Set.insert` envFrames e})++enterGather, enterLoop, enterGiven :: Eval Val -> Eval Val+enterGather = enterFrame FrameGather+enterLoop   = enterFrame FrameLoop+enterGiven  = id++assertFrame :: Frame -> Eval a -> Eval a+assertFrame f action = do+    frames <- asks envFrames+    if Set.member f frames+        then action+        else fail ("Cannot use this control structure outside a '" ++ (map toLower (drop 5 (show f))) ++ "' structure")++emptyFrames :: Set Frame+emptyFrames = Set.empty++{-|+Note that this function is /not/ responsible for performing the actual @when@+test, nor is it responsible for adding the implicit @break@ to the end of the+@when@'s block--those are already taken care of by 'Pugs.Eval.reduce'+(see the entry for @('Syn' \"when\" ... )@).+-}+enterWhen :: Eval Val -- ^ The @when@'s body block, as an evaluation+          -> Eval Val+enterWhen action = do+    rv  <- enterFrame FrameWhen action+    case rv of+        VControl (ControlWhen WhenContinue)   -> retEmpty+        VControl (ControlWhen WhenBreak)      -> retShiftEmpty+        _                                     -> retShift rv++{-|+Generate a new Perl 6 operation from a Haskell function, give it a name, and+generate a @('Pad' -> 'Pad')@ transformer that can be used to install it into+a pad.++This transformer is passed into a given \'action\' function, which is+expected to apply the pad-transformer (e.g. in a new lexical scope), then+perform some evaluation in that scope.++Most of the time, this \'action\' is an anonymous function that passes its+argument into 'enterLex'.+-}+genSymPrim :: (MonadSTM m) +           => String                -- ^ Name installed in 'Pad'+                                    --     (must have leading @&@ sigil)+           -> ([Val] -> Eval Val)   -- ^ The actual primitive to wrap+           -> (PadMutator -> m t)   -- ^ A (lambda) function that the 'Pad'+                                    --     transformer is given to+           -> m t -- ^ Result of passing the pad-transformer to the \'action\'+genSymPrim symName@('&':name) prim action = do+    newSym <- genSym (cast symName) . codeRef $ mkPrim+        { subName = cast name+        , subBody = Prim prim+        }+    action newSym+genSymPrim _ _ _ = error "need a &name"++{-|+Generate a Perl 6 primitive that, when called, will activate the /current/+continuation (i.e. one that can be used to immediately break out of whatever +evaluation we are about to perform). This is great for @&last@ and the like.++This produces a pad-transformer @('Pad' -> 'Pad')@. This transformer is given+to an \'action\' function, which is expected to apply it (e.g. in a lexical+scope), then perform some evaluation in that scope.+-}+genSymCC :: String -- ^ Name of the primitive in the symbol table ('Pad').+         -> (PadMutator -> Eval Val)   -- ^ An \'action\' function that will+                                       --     take the pad-transformer and use+                                       --     it to perform some evaluation +         -> Eval Val -- ^ Result of passing the pad-transformer to the +                     --     \'action\'+genSymCC symName action = callCC $ \esc -> do+    genSymPrim symName (const $ esc undef) action++{-|+Used by 'Pugs.Eval.reduce' when evaluating @('Syn' \"block\" ... )@ +expressions.+-}+enterBlock :: Eval Val -> Eval Val+enterBlock action = do+    local (\e -> e{ envLexPads = (PRuntime emptyPad:envLexPads e) }) action++recloseLexPad :: LexPad -> STM LexPad+recloseLexPad (PCompiling tv) = do+    pad <- readMPad tv+    return (PRuntime pad)+recloseLexPad lpad  = return lpad++recloseExp :: Exp -> STM Exp+recloseExp (Val val) = fmap Val (recloseVal val)+recloseExp exp       = return exp++recloseVal :: Val -> STM Val+recloseVal (VRef ref)   = do+    fmap VRef (recloseRef ref)+recloseVal (VCode code) = do+    fmap VCode (recloseCode code)+recloseVal (VList list) = do+    fmap VList (mapM recloseVal list)+recloseVal val          = return val+++recloseTraitBlocks :: TraitBlocks -> STM TraitBlocks+recloseTraitBlocks (MkTraitBlocks a b c d e f g h i j k) = do+    [a', b', c', d', e', f', g', h', i', j', k'] <- mapM (mapM recloseCode) [a, b, c, d, e, f, g, h, i, j, k]+    return $ MkTraitBlocks a' b' c' d' e' f' g' h' i' j' k'++recloseCode :: VCode -> STM VCode+recloseCode vcode+    | Nothing    <- subStarted vcode = do+--  , subType vcode /= SubPrim = do+        outers'     <- mapM recloseLexPad (subOuterPads vcode)+        inner'      <- reclosePad (subInnerPad vcode)+        body'       <- transformExp recloseExp (subBody vcode)+        started'    <- newTVar False+        traits'     <- recloseTraitBlocks (subTraitBlocks vcode)+        return $ vcode+            { subOuterPads   = outers'+            , subInnerPad    = inner'+            , subBody        = body'+            , subStarted     = Just started'+            , subTraitBlocks = traits'+            }+recloseCode vcode = return vcode++recloseRef :: VRef -> STM VRef+recloseRef (MkRef (ICode cv))+    | Just (vcode :: VCode) <- fromTypeable cv = do+        vcode'   <- recloseCode vcode+        return . MkRef . ICode $ vcode'+recloseRef ref = return ref++reclosePad :: Pad -> STM Pad+reclosePad pad = fmap listToPad . forM (padToList pad) $ \(name, entry) -> do+    entry' <- case v_twigil name of+        TMagical    -> return entry -- XXX - Prevent &?ROUTINE recursion+        _           -> do+            case entry of+                PEStatic{ pe_proto = proto, pe_store = store } -> do+                    proto'  <- recloseRef proto+                    ref     <- readTVar store+                    ref'    <- recloseRef ref+                    writeTVar store ref'+                    return entry{ pe_proto = proto' }+                PELexical{ pe_proto = proto, pe_store = store } -> do+                    proto'  <- recloseRef proto+                    ref     <- readTVar store+                    ref'    <- recloseRef ref+                    writeTVar store ref'+                    return entry{ pe_proto = proto' }+                PEConstant{ pe_proto = proto } -> do+                    proto'  <- recloseRef proto+                    return entry{ pe_proto = proto' }+    return (name, entry')++data ApplyKind = AKInline | AKDisplaced deriving (Show)++enterSub :: ApplyKind -> VCode -> Eval Val -> Eval Val+enterSub appKind sub action = do+    env <- ask+    pad <- case subStarted sub of+        Just tvar   -> do+            started <- stm $ readTVar tvar+            if started+                then refreshPad (subInnerPad sub)+                    -- `finallyM` warn "======= REFRESHED ==========" (subInnerPad sub, sub)+                else (stm $ do+                    writeTVar tvar True+                    reclosePad (subInnerPad sub))+                    -- `finallyM` warn "======= RECLOSED ==========" (tvar, subInnerPad sub)+        _           -> do+            -- warn "==== NOTHING ====" (subInnerPad sub)+            return (subInnerPad sub)+    rv  <- case typ of+        -- For coroutines, we secretly store a continuation into subCont+        -- whenever "yield" occurs in it.  However, the inner CC must be+        -- delimited on the subroutine boundary, otherwise the resuming+        -- continuation will continue into the rest of the program,+        -- which is now how coroutines are supposed to work.+        -- On the other hand, the normal &?CALLER_CONTINUATION must still+        -- work as an undelimiated continuation, which is why callCC here+        -- occurs before resetT.+        SubCoroutine -> tryT . callCC $ \cc -> resetT $ do+            doFix <- fixEnv cc env pad+            local doFix runAction++--      _ | typ >= SubBlock -> tryT $ do+        _ -> tryT $ do+            doFix <- fixEnv return env pad+            local doFix runAction+{-+        _ -> tryT . callCC $ \cc -> do+            doFix <- fixEnv cc env pad+            local doFix runAction+-}++    -- warn "XXX" ()+    doFix <- fixEnv return env pad+    local doFix $ do+        runBlocks (filter (rejectKeepUndo rv . subName) . subLeaveBlocks)+        when (rv == VControl (ControlLoop LoopLast)) $+            -- We won't have a chance to run the LAST block+            -- once we exit outside the lexical block, so do it now+            runBlocks subLastBlocks+        assertBlocks subPostBlocks "POST"+    case rv of+        VControl l@(ControlLeave ftyp depth val) -> do+            let depth' = if ftyp typ then depth - 1 else depth+            if depth' < 0+                then return val+                else retControl l{ leaveDepth = depth' }+        VControl ControlExit{}  -> retShift rv+        VError{}                -> retShift rv -- XXX - Implement CATCH block here+        _ -> return rv+    where+    rejectKeepUndo VUndef     = (/= __"KEEP")+    rejectKeepUndo (VControl (ControlLeave _ _ val)) = \n -> rejectKeepUndo val n && (n /= __"NEXT")+    rejectKeepUndo (VControl (ControlLoop LoopNext)) = (/= __"KEEP")+    rejectKeepUndo VControl{} = \n -> (n /= __"KEEP") && (n /= __"NEXT")+    rejectKeepUndo VError{}   = \n -> (n /= __"KEEP") && (n /= __"NEXT")+    rejectKeepUndo _          = (/= __"UNDO")+    runAction = do+        assertBlocks subPreBlocks "PRE"+        runBlocks subEnterBlocks+        action+    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)+    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+    doCC cc [v] = cc =<< evalVal v+    doCC _  _   = internalError "enterSub: doCC list length > 1"+    orig :: VCode -> VCode+    orig sub = sub { subBindings = [], subParams = (map fst (subBindings sub)) }++    fixEnv :: (Val -> Eval Val) -> Env -> Pad -> Eval (Env -> Env)+    fixEnv _cc env pad+        | SubPrim <- typ = do+            return $ \e -> e+                { envLexical = pad `mappend` envLexical env+                , envLexPads = (PRuntime pad:envLexPads env)+                }+        | AKInline <- appKind = do+            -- Entering an inline call.+            return $ \e -> e+                { envLexical = pad `mappend` envLexical env+                , envPackage = subPackage sub+                , envLexPads = (PRuntime pad:envLexPads env)+                }+        | otherwise = do+            -- callerRec <- genSym (cast "&?CALLER_CONTINUATION") (codeRef $ ccSub cc env)+            pad'      <- fmap (pad `mappend`) $ mergeLexPads (subOuterPads sub)+            return $ \e -> e+                { envLexical = pad' -- combine ([callerRec]) pad'+                , envPackage = subPackage sub+                , envLexPads = (PRuntime pad':subOuterPads sub)+                }+    ccSub :: (Val -> Eval Val) -> Env -> VCode+    ccSub cc env = mkPrim+        { subName = __"CALLER_CONTINUATION"+        , subParams = makeParams env+        , subBody = Prim $ doCC cc+        }++makeParams :: Env -> [Param]+makeParams MkEnv{ envContext = cxt, envLValue = lv }+    = [ MkOldParam+        { isInvocant = False+        , isOptional = True+        , isNamed    = False+        , isLValue   = lv+        , isWritable = lv+        , isLazy     = False+        , paramName  = cast $ case cxt of+            CxtSlurpy _ -> "@?0"+            _           -> "$?0"+        , paramContext = cxt+        , paramDefault = Val VUndef+        } ]++evalVal :: Val -> Eval Val+evalVal val@VV{} = do+    env <- ask+    let cxt = envContext env+        lv  = envLValue env+    if lv || cxt == CxtVoid then return val else val ./ cxt+evalVal val@(VRef ref) = do+    lv  <- asks envLValue+    if lv+        then return val+        else if refType ref == mkType "Scalar::Const"+            then evalVal =<< readRef ref+            else do+                typ <- evalValType val+                if isaType "Junction" typ+                    then evalVal =<< readRef ref+                    else return val+evalVal val = return val
+ src/Pugs/PIL1.hs view
@@ -0,0 +1,123 @@+{-# OPTIONS_GHC -fglasgow-exts -funbox-strict-fields -fallow-overlapping-instances -fno-warn-orphans -fno-warn-incomplete-patterns -fallow-undecidable-instances -cpp #-}++{-|+    Pugs Intermediate Language, version 1.++>   Again she fled, but swift he came.+>   Tinúviel! Tinúviel!+>   He called her by her elvish name;+>   And there she halted listening.++-}+++module Pugs.PIL1 (+    PIL_Environment(..),+    PIL_Stmts(..), PIL_Stmt(..), PIL_Decl(..),+    PIL_Expr(..), PIL_Literal(..), PIL_LValue(..),+    TParam(..), TCxt(..), TEnv(..),+) where+import Pugs.AST hiding (Prim)+import Pugs.Internals hiding (get, put)+import Pugs.Types+import Language.PIR++-- import DrIFT.XML+-- {-! global : Haskell2Xml !-}++{-! global : Perl5, JSON, YAML !-}++{-|+    The plan here is to first compile the environment (subroutines,+    statements, etc.) to an abstract syntax tree ('PIL' -- Pugs Intermediate+    Language) using the 'compile' function and 'Compile' class.+-}++data PIL_Environment = PIL_Environment+    { pilGlob :: [PIL_Decl]+    , pilMain :: PIL_Stmts+    }+    deriving (Show, Eq, Ord, Typeable)++data PIL_Stmts = PNil+    | PStmts+        { pStmt  :: !PIL_Stmt+        , pStmts :: !PIL_Stmts+        }+    | PPad+        { pScope :: !Scope+        , pSyms  :: ![(VarName, PIL_Expr)]+        , pStmts :: !PIL_Stmts+        }+    deriving (Show, Eq, Ord, Typeable)++data PIL_Stmt = PNoop | PStmt { pExpr :: !PIL_Expr } | PPos+        { pPos  :: !Pos+        , pExp  :: !Exp+        , pNode :: !PIL_Stmt+        }+    deriving (Show, Eq, Ord, Typeable)++data PIL_Expr+    = PRawName { pRawName :: !VarName }+    | PExp { pLV  :: !PIL_LValue }+    | PLit { pLit :: !PIL_Literal }+    | PThunk { pThunk :: !PIL_Expr }+    | PCode+        { pType    :: !SubType+        , pParams  :: ![TParam]+        , pLValue  :: !Bool+        , pIsMulti :: !Bool+        , pBody    :: !PIL_Stmts+        }+    deriving (Show, Eq, Ord, Typeable)++data PIL_Decl = PSub+    { pSubName      :: !SubName+    , pSubType      :: !SubType+    , pSubParams    :: ![TParam]+    , pSubLValue    :: !Bool+    , pSubIsMulti   :: !Bool+    , pSubBody      :: !PIL_Stmts+    }+    deriving (Show, Eq, Ord, Typeable)++data PIL_Literal = PVal { pVal :: Val }+    deriving (Show, Eq, Ord, Typeable)++data PIL_LValue = PVar { pVarName :: !VarName }+    | PApp +        { pCxt  :: !TCxt+        , pFun  :: !PIL_Expr+        , pInv  :: !(Maybe PIL_Expr)+        , pArgs :: ![PIL_Expr]+        }+    | PAssign+        { pLHS  :: ![PIL_LValue]+        , pRHS  :: !PIL_Expr+        }+    | PBind+        { pLHS  :: ![PIL_LValue]+        , pRHS  :: !PIL_Expr+        }+    deriving (Show, Eq, Ord, Typeable)++data TParam = MkTParam+    { tpParam   :: !Param+    , tpDefault :: !(Maybe (PIL_Expr))+    }+    deriving (Show, Eq, Ord, Typeable)++data TCxt+    = TCxtVoid | TCxtLValue !Type | TCxtItem !Type | TCxtSlurpy !Type+    | TTailCall !TCxt+    deriving (Show, Eq, Ord, Typeable)++data TEnv = MkTEnv+    { tLexDepth :: !Int                 -- ^ Lexical scope depth+    , tTokDepth :: !Int                 -- ^ Exp nesting depth+    , tCxt      :: !TCxt                -- ^ Current context+    , tReg      :: !(TVar (Int, String))-- ^ Register name supply+    , tLabel    :: !(TVar Int)          -- ^ Label name supply+    }+    deriving (Show, Eq, Ord, Typeable)
+ src/Pugs/PIL1/Instances.hs view
@@ -0,0 +1,373 @@+{-# OPTIONS_GHC -fglasgow-exts -funbox-strict-fields -fallow-overlapping-instances -fno-warn-orphans -fno-warn-incomplete-patterns -fallow-undecidable-instances -cpp #-}+++++{- +-- WARNING WARNING WARNING --++This is an autogenerated file from src/Pugs/PIL1.hs.++Do not edit this file.++All changes made here will be lost!++-- WARNING WARNING WARNING --+-}++#ifndef HADDOCK++++++++++module Pugs.PIL1.Instances ()+where+import Pugs.PIL1+import Data.Yaml.Syck+import DrIFT.YAML+import DrIFT.JSON+import DrIFT.Perl5+import DrIFT.Perl6Class+import Control.Monad+import qualified Data.ByteString as Buf++{-* Generated by DrIFT : Look, but Don't Touch. *-}+instance Perl5 PIL_Environment where+    showPerl5 (PIL_Environment aa ab) =+	      showP5HashObj "PIL::Environment"+	      [("pilGlob", showPerl5 aa) , ("pilMain", showPerl5 ab)]++instance JSON PIL_Environment where+    showJSON (PIL_Environment aa ab) = showJSHashObj "PIL_Environment"+	     [("pilGlob", showJSON aa), ("pilMain", showJSON ab)]++instance YAML PIL_Environment where+    fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of+	"PIL_Environment" -> do+	    let EMap assocs = e+	    let [aa, ab] = map snd assocs+	    liftM2 PIL_Environment (fromYAML aa) (fromYAML ab)+	_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["PIL_Environment"] ++ " in node " ++ show e+    fromYAML _ = fail "no tag found"+    asYAML (PIL_Environment aa ab) = asYAMLmap "PIL_Environment"+	   [("pilGlob", asYAML aa), ("pilMain", asYAML ab)]++instance Perl5 PIL_Stmts where+    showPerl5 (PNil) = showP5Class "PNil"+    showPerl5 (PStmts aa ab) = showP5HashObj "PStmts"+	      [("pStmt", showPerl5 aa) , ("pStmts", showPerl5 ab)]+    showPerl5 (PPad aa ab ac) = showP5HashObj "PPad"+	      [("pScope", showPerl5 aa) , ("pSyms", showPerl5 ab) ,+	       ("pStmts", showPerl5 ac)]++instance JSON PIL_Stmts where+    showJSON (PNil) = showJSScalar "PNil"+    showJSON (PStmts aa ab) = showJSHashObj "PStmts"+	     [("pStmt", showJSON aa), ("pStmts", showJSON ab)]+    showJSON (PPad aa ab ac) = showJSHashObj "PPad"+	     [("pScope", showJSON aa), ("pSyms", showJSON ab),+	      ("pStmts", showJSON ac)]++instance YAML PIL_Stmts where+    fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of+	"PNil" -> do+	    return PNil+	"PStmts" -> do+	    let EMap assocs = e+	    let [aa, ab] = map snd assocs+	    liftM2 PStmts (fromYAML aa) (fromYAML ab)+	"PPad" -> do+	    let EMap assocs = e+	    let [aa, ab, ac] = map snd assocs+	    liftM3 PPad (fromYAML aa) (fromYAML ab) (fromYAML ac)+	_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["PNil","PStmts","PPad"] ++ " in node " ++ show e+    fromYAML _ = fail "no tag found"+    asYAML (PNil) = asYAMLcls "PNil"+    asYAML (PStmts aa ab) = asYAMLmap "PStmts"+	   [("pStmt", asYAML aa), ("pStmts", asYAML ab)]+    asYAML (PPad aa ab ac) = asYAMLmap "PPad"+	   [("pScope", asYAML aa), ("pSyms", asYAML ab),+	    ("pStmts", asYAML ac)]++instance Perl5 PIL_Stmt where+    showPerl5 (PNoop) = showP5Class "PNoop"+    showPerl5 (PStmt aa) = showP5HashObj "PStmt"+	      [("pExpr", showPerl5 aa)]+    showPerl5 (PPos aa ab ac) = showP5HashObj "PPos"+	      [("pPos", showPerl5 aa) , ("pExp", showPerl5 ab) ,+	       ("pNode", showPerl5 ac)]++instance JSON PIL_Stmt where+    showJSON (PNoop) = showJSScalar "PNoop"+    showJSON (PStmt aa) = showJSHashObj "PStmt"+	     [("pExpr", showJSON aa)]+    showJSON (PPos aa ab ac) = showJSHashObj "PPos"+	     [("pPos", showJSON aa), ("pExp", showJSON ab),+	      ("pNode", showJSON ac)]++instance YAML PIL_Stmt where+    fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of+	"PNoop" -> do+	    return PNoop+	"PStmt" -> do+	    let EMap assocs = e+	    let [aa] = map snd assocs+	    liftM PStmt (fromYAML aa)+	"PPos" -> do+	    let EMap assocs = e+	    let [aa, ab, ac] = map snd assocs+	    liftM3 PPos (fromYAML aa) (fromYAML ab) (fromYAML ac)+	_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["PNoop","PStmt","PPos"] ++ " in node " ++ show e+    fromYAML _ = fail "no tag found"+    asYAML (PNoop) = asYAMLcls "PNoop"+    asYAML (PStmt aa) = asYAMLmap "PStmt" [("pExpr", asYAML aa)]+    asYAML (PPos aa ab ac) = asYAMLmap "PPos"+	   [("pPos", asYAML aa), ("pExp", asYAML ab), ("pNode", asYAML ac)]++instance Perl5 PIL_Expr where+    showPerl5 (PRawName aa) = showP5HashObj "PRawName"+	      [("pRawName", showPerl5 aa)]+    showPerl5 (PExp aa) = showP5HashObj "PExp" [("pLV", showPerl5 aa)]+    showPerl5 (PLit aa) = showP5HashObj "PLit" [("pLit", showPerl5 aa)]+    showPerl5 (PThunk aa) = showP5HashObj "PThunk"+	      [("pThunk", showPerl5 aa)]+    showPerl5 (PCode aa ab ac ad ae) = showP5HashObj "PCode"+	      [("pType", showPerl5 aa) , ("pParams", showPerl5 ab) ,+	       ("pLValue", showPerl5 ac) , ("pIsMulti", showPerl5 ad) ,+	       ("pBody", showPerl5 ae)]++instance JSON PIL_Expr where+    showJSON (PRawName aa) = showJSHashObj "PRawName"+	     [("pRawName", showJSON aa)]+    showJSON (PExp aa) = showJSHashObj "PExp" [("pLV", showJSON aa)]+    showJSON (PLit aa) = showJSHashObj "PLit" [("pLit", showJSON aa)]+    showJSON (PThunk aa) = showJSHashObj "PThunk"+	     [("pThunk", showJSON aa)]+    showJSON (PCode aa ab ac ad ae) = showJSHashObj "PCode"+	     [("pType", showJSON aa), ("pParams", showJSON ab),+	      ("pLValue", showJSON ac), ("pIsMulti", showJSON ad),+	      ("pBody", showJSON ae)]++instance YAML PIL_Expr where+    fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of+	"PRawName" -> do+	    let EMap assocs = e+	    let [aa] = map snd assocs+	    liftM PRawName (fromYAML aa)+	"PExp" -> do+	    let EMap assocs = e+	    let [aa] = map snd assocs+	    liftM PExp (fromYAML aa)+	"PLit" -> do+	    let EMap assocs = e+	    let [aa] = map snd assocs+	    liftM PLit (fromYAML aa)+	"PThunk" -> do+	    let EMap assocs = e+	    let [aa] = map snd assocs+	    liftM PThunk (fromYAML aa)+	"PCode" -> do+	    let EMap assocs = e+	    let [aa, ab, ac, ad, ae] = map snd assocs+	    liftM5 PCode (fromYAML aa) (fromYAML ab) (fromYAML ac) (fromYAML ad) (fromYAML ae)+	_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["PRawName","PExp","PLit","PThunk","PCode"] ++ " in node " ++ show e+    fromYAML _ = fail "no tag found"+    asYAML (PRawName aa) = asYAMLmap "PRawName"+	   [("pRawName", asYAML aa)]+    asYAML (PExp aa) = asYAMLmap "PExp" [("pLV", asYAML aa)]+    asYAML (PLit aa) = asYAMLmap "PLit" [("pLit", asYAML aa)]+    asYAML (PThunk aa) = asYAMLmap "PThunk" [("pThunk", asYAML aa)]+    asYAML (PCode aa ab ac ad ae) = asYAMLmap "PCode"+	   [("pType", asYAML aa), ("pParams", asYAML ab),+	    ("pLValue", asYAML ac), ("pIsMulti", asYAML ad),+	    ("pBody", asYAML ae)]++instance Perl5 PIL_Decl where+    showPerl5 (PSub aa ab ac ad ae af) = showP5HashObj "PSub"+	      [("pSubName", showPerl5 aa) , ("pSubType", showPerl5 ab) ,+	       ("pSubParams", showPerl5 ac) , ("pSubLValue", showPerl5 ad) ,+	       ("pSubIsMulti", showPerl5 ae) , ("pSubBody", showPerl5 af)]++instance JSON PIL_Decl where+    showJSON (PSub aa ab ac ad ae af) = showJSHashObj "PSub"+	     [("pSubName", showJSON aa), ("pSubType", showJSON ab),+	      ("pSubParams", showJSON ac), ("pSubLValue", showJSON ad),+	      ("pSubIsMulti", showJSON ae), ("pSubBody", showJSON af)]++instance YAML PIL_Decl where+    fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of+	"PSub" -> do+	    let liftM6 f m1 m2 m3 m4 m5 m6 = do+		{x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; x6 <- m6; return (f x1 x2 x3 x4 x5 x6)}+	    let EMap assocs = e+	    let [aa, ab, ac, ad, ae, af] = map snd assocs+	    liftM6 PSub (fromYAML aa) (fromYAML ab) (fromYAML ac) (fromYAML ad) (fromYAML ae) (fromYAML af)+	_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["PSub"] ++ " in node " ++ show e+    fromYAML _ = fail "no tag found"+    asYAML (PSub aa ab ac ad ae af) = asYAMLmap "PSub"+	   [("pSubName", asYAML aa), ("pSubType", asYAML ab),+	    ("pSubParams", asYAML ac), ("pSubLValue", asYAML ad),+	    ("pSubIsMulti", asYAML ae), ("pSubBody", asYAML af)]++instance Perl5 PIL_Literal where+    showPerl5 (PVal aa) = showP5HashObj "PVal" [("pVal", showPerl5 aa)]++instance JSON PIL_Literal where+    showJSON (PVal aa) = showJSHashObj "PVal" [("pVal", showJSON aa)]++instance YAML PIL_Literal where+    fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of+	"PVal" -> do+	    let EMap assocs = e+	    let [aa] = map snd assocs+	    liftM PVal (fromYAML aa)+	_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["PVal"] ++ " in node " ++ show e+    fromYAML _ = fail "no tag found"+    asYAML (PVal aa) = asYAMLmap "PVal" [("pVal", asYAML aa)]++instance Perl5 PIL_LValue where+    showPerl5 (PVar aa) = showP5HashObj "PVar"+	      [("pVarName", showPerl5 aa)]+    showPerl5 (PApp aa ab ac ad) = showP5HashObj "PApp"+	      [("pCxt", showPerl5 aa) , ("pFun", showPerl5 ab) ,+	       ("pInv", showPerl5 ac) , ("pArgs", showPerl5 ad)]+    showPerl5 (PAssign aa ab) = showP5HashObj "PAssign"+	      [("pLHS", showPerl5 aa) , ("pRHS", showPerl5 ab)]+    showPerl5 (PBind aa ab) = showP5HashObj "PBind"+	      [("pLHS", showPerl5 aa) , ("pRHS", showPerl5 ab)]++instance JSON PIL_LValue where+    showJSON (PVar aa) = showJSHashObj "PVar"+	     [("pVarName", showJSON aa)]+    showJSON (PApp aa ab ac ad) = showJSHashObj "PApp"+	     [("pCxt", showJSON aa), ("pFun", showJSON ab),+	      ("pInv", showJSON ac), ("pArgs", showJSON ad)]+    showJSON (PAssign aa ab) = showJSHashObj "PAssign"+	     [("pLHS", showJSON aa), ("pRHS", showJSON ab)]+    showJSON (PBind aa ab) = showJSHashObj "PBind"+	     [("pLHS", showJSON aa), ("pRHS", showJSON ab)]++instance YAML PIL_LValue where+    fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of+	"PVar" -> do+	    let EMap assocs = e+	    let [aa] = map snd assocs+	    liftM PVar (fromYAML aa)+	"PApp" -> do+	    let EMap assocs = e+	    let [aa, ab, ac, ad] = map snd assocs+	    liftM4 PApp (fromYAML aa) (fromYAML ab) (fromYAML ac) (fromYAML ad)+	"PAssign" -> do+	    let EMap assocs = e+	    let [aa, ab] = map snd assocs+	    liftM2 PAssign (fromYAML aa) (fromYAML ab)+	"PBind" -> do+	    let EMap assocs = e+	    let [aa, ab] = map snd assocs+	    liftM2 PBind (fromYAML aa) (fromYAML ab)+	_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["PVar","PApp","PAssign","PBind"] ++ " in node " ++ show e+    fromYAML _ = fail "no tag found"+    asYAML (PVar aa) = asYAMLmap "PVar" [("pVarName", asYAML aa)]+    asYAML (PApp aa ab ac ad) = asYAMLmap "PApp"+	   [("pCxt", asYAML aa), ("pFun", asYAML ab), ("pInv", asYAML ac),+	    ("pArgs", asYAML ad)]+    asYAML (PAssign aa ab) = asYAMLmap "PAssign"+	   [("pLHS", asYAML aa), ("pRHS", asYAML ab)]+    asYAML (PBind aa ab) = asYAMLmap "PBind"+	   [("pLHS", asYAML aa), ("pRHS", asYAML ab)]++instance Perl5 TParam where+    showPerl5 (MkTParam aa ab) = showP5HashObj "MkTParam"+	      [("tpParam", showPerl5 aa) , ("tpDefault", showPerl5 ab)]++instance JSON TParam where+    showJSON (MkTParam aa ab) = showJSHashObj "MkTParam"+	     [("tpParam", showJSON aa), ("tpDefault", showJSON ab)]++instance YAML TParam where+    fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of+	"MkTParam" -> do+	    let EMap assocs = e+	    let [aa, ab] = map snd assocs+	    liftM2 MkTParam (fromYAML aa) (fromYAML ab)+	_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["MkTParam"] ++ " in node " ++ show e+    fromYAML _ = fail "no tag found"+    asYAML (MkTParam aa ab) = asYAMLmap "MkTParam"+	   [("tpParam", asYAML aa), ("tpDefault", asYAML ab)]++instance Perl5 TCxt where+    showPerl5 (TCxtVoid) = showP5Class "TCxtVoid"+    showPerl5 (TCxtLValue aa) = showP5ArrayObj "TCxtLValue"+	      [showPerl5 aa]+    showPerl5 (TCxtItem aa) = showP5ArrayObj "TCxtItem" [showPerl5 aa]+    showPerl5 (TCxtSlurpy aa) = showP5ArrayObj "TCxtSlurpy"+	      [showPerl5 aa]+    showPerl5 (TTailCall aa) = showP5ArrayObj "TTailCall"+	      [showPerl5 aa]++instance JSON TCxt where+    showJSON (TCxtVoid) = showJSScalar "TCxtVoid"+    showJSON (TCxtLValue aa) = showJSArrayObj "TCxtLValue"+	     [showJSON aa]+    showJSON (TCxtItem aa) = showJSArrayObj "TCxtItem" [showJSON aa]+    showJSON (TCxtSlurpy aa) = showJSArrayObj "TCxtSlurpy"+	     [showJSON aa]+    showJSON (TTailCall aa) = showJSArrayObj "TTailCall" [showJSON aa]++instance YAML TCxt where+    fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of+	"TCxtVoid" -> do+	    return TCxtVoid+	"TCxtLValue" -> do+	    let ESeq [aa] = e+	    liftM TCxtLValue (fromYAML aa)+	"TCxtItem" -> do+	    let ESeq [aa] = e+	    liftM TCxtItem (fromYAML aa)+	"TCxtSlurpy" -> do+	    let ESeq [aa] = e+	    liftM TCxtSlurpy (fromYAML aa)+	"TTailCall" -> do+	    let ESeq [aa] = e+	    liftM TTailCall (fromYAML aa)+	_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["TCxtVoid","TCxtLValue","TCxtItem","TCxtSlurpy","TTailCall"] ++ " in node " ++ show e+    fromYAML _ = fail "no tag found"+    asYAML (TCxtVoid) = asYAMLcls "TCxtVoid"+    asYAML (TCxtLValue aa) = asYAMLseq "TCxtLValue" [asYAML aa]+    asYAML (TCxtItem aa) = asYAMLseq "TCxtItem" [asYAML aa]+    asYAML (TCxtSlurpy aa) = asYAMLseq "TCxtSlurpy" [asYAML aa]+    asYAML (TTailCall aa) = asYAMLseq "TTailCall" [asYAML aa]++instance Perl5 TEnv where+    showPerl5 (MkTEnv aa ab ac ad ae) = showP5HashObj "MkTEnv"+	      [("tLexDepth", showPerl5 aa) , ("tTokDepth", showPerl5 ab) ,+	       ("tCxt", showPerl5 ac) , ("tReg", showPerl5 ad) ,+	       ("tLabel", showPerl5 ae)]++instance JSON TEnv where+    showJSON (MkTEnv aa ab ac ad ae) = showJSHashObj "MkTEnv"+	     [("tLexDepth", showJSON aa), ("tTokDepth", showJSON ab),+	      ("tCxt", showJSON ac), ("tReg", showJSON ad),+	      ("tLabel", showJSON ae)]++instance YAML TEnv where+    fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of+	"MkTEnv" -> do+	    let EMap assocs = e+	    let [aa, ab, ac, ad, ae] = map snd assocs+	    liftM5 MkTEnv (fromYAML aa) (fromYAML ab) (fromYAML ac) (fromYAML ad) (fromYAML ae)+	_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["MkTEnv"] ++ " in node " ++ show e+    fromYAML _ = fail "no tag found"+    asYAML (MkTEnv aa ab ac ad ae) = asYAMLmap "MkTEnv"+	   [("tLexDepth", asYAML aa), ("tTokDepth", asYAML ab),+	    ("tCxt", asYAML ac), ("tReg", asYAML ad), ("tLabel", asYAML ae)]++--  Imported from other files :-+++#endif
+ src/Pugs/Parser.hs view
@@ -0,0 +1,2139 @@+{-# OPTIONS_GHC -cpp -fglasgow-exts -funbox-strict-fields -fno-full-laziness -fno-cse -fallow-overlapping-instances #-}++{-|+    Higher-level parser for building ASTs.++>   I sang of leaves, of leaves of gold, and leaves of gold there grew:+>   Of wind I sang, a wind there came and in the branches blew.+>   Beyond the Sun, beyond the Moon, the foam was on the Sea,+>   And by the strand of Ilmarin there grew a golden Tree...+-}++module Pugs.Parser (+    ruleBlockBody,+    possiblyExit,+    module Pugs.Lexer,+    module Pugs.Parser.Types,+    module Pugs.Parser.Unsafe,+    module Pugs.Parser.Operator,++    -- Circularity: Used in Pugs.Parser.Operator+    parseTerm, parseNoParenArgList, ruleSubName, ruleSigil,++    -- Circularity: Used in Pugs.Parser.Literal+    ruleExpression, retInterpolatedBlock,+    ruleArraySubscript, ruleHashSubscript, ruleCodeSubscript,+    ruleInvocationParens, verbatimVarNameString, ruleVerbatimBlock, retVerbatimBlock,+    ruleBlockLiteral, ruleDoBlock, regularVarName, regularVarNameForSigil, ruleNamedMethodCall,++    genParamEntries+) where+import Pugs.Internals+import Pugs.AST+import qualified Pugs.Exp as Exp+import Pugs.Types+import Pugs.Version (versnum)+import Pugs.Lexer+import Pugs.Rule++import Pugs.Parser.Types+import Pugs.Parser.Unsafe+import Pugs.Parser.Export+import Pugs.Parser.Operator+import Pugs.Parser.Doc+import Pugs.Parser.Literal+import Pugs.Parser.Util+import qualified Data.Map as Map+import qualified Data.Set as Set++-- Lexical units --------------------------------------------------++ruleBlock :: RuleParser BlockInfo+ruleBlock = do+    lvl <- gets s_bracketLevel+    case lvl of+        StatementBracket    -> ruleBlock'+        _                   -> lexeme ruleVerbatimBlock+    where+    ruleBlock' = do+        rv <- ruleVerbatimBlock+        -- Implementation of 'line-ending } terminates statement'+        -- See L<S04/Statement-ending blocks>.+        -- We are now at end of closing '}'. Mark the position...+        prevPos <- getPosition+        -- Skip whitespaces.  If we go into another line,+        -- then it's statement-level break+        whiteSpace+        currPos <- getPosition+        if sourceLine prevPos == sourceLine currPos then return rv else do+            -- Manually insert a ';' symbol here!+            insertIntoPosition ";" +            -- Register that this is an eol-block, thus can't be hash composers+            retBlockWith (Ann (Prag [MkPrag "eol-block" 0])) rv++ruleVerbatimBlock :: RuleParser BlockInfo+ruleVerbatimBlock = verbatimRule "block" $ do+    block <- verbatimBraces ruleBlockBody+    retBlockWith (Syn "block" . (:[])) block++ruleEmptyExp :: RuleParser Exp+ruleEmptyExp = (<?> "") . expRule $ do+    symbol ";"+    return emptyExp++ruleBlockBody :: RuleParser BlockInfo+ruleBlockBody = localBlock $ do+    whiteSpace+    ver     <- option "6" (try (symbol "use" >> rulePerlVersion))+    case ver of+        ('5':_) -> do+            let chunk = many1 (noneOf "{}") <|> verbatimBraces block+                block = fmap (\x -> ('{':x) ++ "}") body+                body  = fmap concat (many chunk)+            p5code <- body+            return (Syn "block-perl5" [Val (VStr p5code)])+        _       -> do+            pre     <- many ruleEmptyExp+            body    <- option emptyExp ruleStatementList+            post    <- many ruleEmptyExp+            whiteSpace+            return $ foldl1 mergeStmts (pre ++ [body] ++ post)++{-|+Match a single statement (not including any terminating semicolon).  A+statement consists of a single 'ruleExpression', followed by an optional+statement-modifier (e.g. @if $foo@ or @for \@baz@).++One of the sub-rules used by 'ruleStatementList'.+-}+ruleStatement :: RuleParser Exp+ruleStatement = do+    exp <- ruleExpression+    f   <- ruleStatementModifier <?> ""+    f exp++ruleStatementModifier :: RuleParser (Exp -> RuleParser Exp)+ruleStatementModifier = verbatimRule "statement modifier" . option return $ choice+    [ s_postConditional+    , s_postLoop+    , s_postIterate+    ]++ruleStatementList :: RuleParser Exp+ruleStatementList = rule "statements" .+    enterBracketLevel StatementBracket .+        sepLoop $ do+            optional $ try (ruleVerbatimIdentifier >> char ':' >> mandatoryWhiteSpace)+            choice+                [ noSep     ruleDocBlock+                , nonSep    ruleBlockDeclaration+                , semiSep   ruleDeclaration+                , nonSep    ruleConstruct+                , semiSep   ruleStatement+                ]+    where+    nonSep  = doSep many  -- must be followed by 0+ semicolons+    semiSep = doSep many1 -- must be followed by 1+ semicolons+    noSep r = fmap (\x -> (x, False)) r+    doSep sepCount r = do+        exp <- r+        terminate <- option True $ do+            (sepCount (symbol ";") <?> "")+            return False+        return (exp, terminate)+    sepLoop rule = do+        whiteSpace+        (eof >> return Noop) <|> do+            (exp, terminate) <- rule+            if terminate then return exp else do+            rest <- option Noop (sepLoop rule)+            return $ exp `mergeStmts` rest++-- Declarations ------------------------------------------------++ruleBlockDeclaration :: RuleParser Exp+ruleBlockDeclaration = rule "block declaration" $ choice+    [ ruleRuleDeclaration+    , ruleSubDeclaration+    , ruleClosureTrait False+    , rulePackageBlockDeclaration+    ]++ruleDeclaration :: RuleParser Exp+ruleDeclaration = rule "declaration" $ choice+    [ rulePackageDeclaration+    , ruleMemberDeclaration+    , ruleTraitDeclaration+    , ruleUseDeclaration+    , ruleNoDeclaration+    , ruleInlineDeclaration+    , ruleRequireDeclaration+    , ruleTrustsDeclaration+    ]++data SubModifier = ImplicitNil | ImplicitMulti | ImplicitProto deriving (Eq)++ruleSubHead :: RuleParser (SubModifier, SubType, String)+ruleSubHead = rule "subroutine head" $ do+    prefix <- choice+        [ symbol "multi" >> return ImplicitMulti+        , symbol "proto" >> return ImplicitProto+        , return ImplicitNil+        ]++    -- You're allowed to omit the "sub":+    --   multi sub foo (...) {...}      # legal+    --         sub foo (...) {...}      # legal, too+    let implicitSub | ImplicitNil <- prefix = pzero+                    | otherwise             = return SubRoutine+    styp    <- choice+        [ do symbol "sub"+             return SubRoutine+        , do symbol "coro"+             return SubCoroutine+        , do (symbol "submethod" <|> symbol "method")+             return SubMethod+        , do symbol "macro"+             return SubMacro+        , do symbol "subset"+             return _SubSet_+        ] <|> implicitSub+    name    <- ruleSubName+    return (prefix, styp, name)++-- XXX - Kluged up way to mark a subset parsed as a sub+_SubSet_ :: SubType+_SubSet_ = SubPrim++-- | Scope, context, isMulti, styp, name+type SubDescription = (Scope, String, SubModifier, SubType, String)++ruleSubScopedWithContext :: RuleParser SubDescription+ruleSubScopedWithContext = tryRule "scoped subroutine with context" $ do+    scope   <- ruleScope+    cxt     <- identifier+    (isMulti, styp, name) <- ruleSubHead+    return (scope, cxt, isMulti, styp, name)++ruleSubScoped :: RuleParser SubDescription+ruleSubScoped = tryRule "scoped subroutine" $ do+    scope <- ruleScope+    (isMulti, styp, name) <- ruleSubHead+    return (scope, "Any", isMulti, styp, name)++ruleSubGlobal :: RuleParser SubDescription+ruleSubGlobal = tryRule "global subroutine" $ do+    (isMulti, styp, name) <- ruleSubHead+    return (SOur, "Any", isMulti, styp, name)++ruleRuleDeclaration :: RuleParser Exp+ruleRuleDeclaration = rule "rule declaration" $ do+    (mod, withAdvs, name) <- try $ do+        mod  <- symbol "proto" <|> symbol "multi" <|> return ""+        advs <- ruleRegexDeclarator+        fmap ((,,) mod advs) identifier+    optional (ruleSubParameters ParensMandatory)+    adverbs <- fmap withAdvs ruleQuoteAdverbs+    skipMany (symbol "is" >> regularAdverbPair) -- XXX - context+    if mod == "proto" then return emptyExp else do+    ch      <- char '{'+    expr    <- rxLiteralAny adverbs ch (balancedDelim ch)+    unsafeEvalExp (_Sym SOur ('<':'*':name) mempty (Syn "rx" [expr, adverbs]) Noop)+    insertIntoPosition $ "method " ++ name ++ " ($_) { $_ ~~ m/<" ++ name ++ ">/ };"+    return emptyExp++rulePackageBlockDeclaration :: RuleParser Exp+rulePackageBlockDeclaration = rule "package block declaration" $ do+    -- scope <- option Nothing $ fmap Just ruleScope+    rv <- try $ do+        optional ruleScope -- XXX - not handled yet+        rv <- rulePackageHead+        lookAhead (char '{')+        return rv+    case rv of +        Right (_, kind, pkgVal, env) -> do+            block   <- verbatimBraces ruleBlockBody+            env'    <- ask+            putRuleEnv env'{ envPackage = envPackage env }+            retInterpolatedBlock =<< retBlockWith (\body -> Syn "namespace" [kind, pkgVal, body]) block+        Left err -> fail err++rulePackageDeclaration :: RuleParser Exp+rulePackageDeclaration = rule "package declaration" $ do+    -- scope <- option Nothing $ fmap Just ruleScope+    rv <- try $ do+        optional ruleScope -- XXX - not handled yet+        rulePackageHead+    case rv of+        Right (_, kind, pkgVal, _) -> return $ Syn "package" [kind, pkgVal]+        Left err -> fail err++rulePackageHead :: RuleParser (Either String (String, Exp, Exp, Env))+rulePackageHead = do+    scope   <- option Nothing $ fmap Just ruleScope+    sym     <- choice $ map symbol (words "package module class role grammar")+    name    <- ruleQualifiedIdentifier+    optional ruleVersionPart -- v+    optional ruleAuthorPart  -- a+    whiteSpace+    env <- ask+    newName <- case scope of+        Just SOur -> return $ cast (envPackage env) ++ "::" ++ name+        Nothing   -> return name+        _         -> fail "I only know about package- and global-scoped classes. Sorry."+    traits  <- many $ ruleTrait ["is", "does"]+    let pkgClass = case sym of+                       "package" -> "Package"+                       "module"  -> "Module"+                       "class"   -> "Class"+                       "role"    -> "Class" -- XXX - Wrong - need metamodel+                       "grammar" -> "Grammar"+                       _ -> fail "bug"+        mixinRoles = nub ([ cls | ("does", cls) <- traits])+        parentClasses = nub ("Object":[ cls | ("is", cls) <- traits, cls /= "also" ])+    case () of+        _ | elem name parentClasses -> do+            return (Left $ "Circular class inheritance detected for " ++ sym ++ " '" ++ name ++ "'")+        _ | elem name mixinRoles -> do+            return (Left $ "Circular role composition detected for " ++ sym ++ " '" ++ name ++ "'")+        _ -> do+            unsafeEvalExp (newPackage pkgClass newName parentClasses mixinRoles)+            modify $ \state -> state+                { s_env = (s_env state)+                    { envPackage = cast newName+                    }+                , s_dynParsers = MkDynParsersEmpty+                }+            let pkgVal = Val . VStr $ newName+                kind   = Val . VStr $ sym+            return $ Right (newName, kind, pkgVal, env)++ruleTraitsIsOnly :: RuleParser [String]+ruleTraitsIsOnly = fmap (map snd) . many $ ruleTrait ["is"]++ruleSubDeclaration :: RuleParser Exp+ruleSubDeclaration = rule "subroutine declaration" $ do+    -- namePos <- getPosition+    (scope, typ, isMulti, styp, name) <- choice+        [ ruleSubScopedWithContext+        , ruleSubScoped+        , ruleSubGlobal+        ]+    optional $ do { symbol "handles"; ruleExpression }+    assoc   <- option A_left . try $ do+        symbol "is"+        symbol "assoc"+        lit <- parens qLiteral+        case unwrap lit of+            Val (VStr str) -> case str of+                "left"  -> return A_left+                "right" -> return A_right+                "non"   -> return A_non+                "chain" -> return A_chain+                "list"  -> return A_list+                _       -> fail $ "Invalid associativity: " ++ str+            _   -> fail $ "Invalid associativity: " ++ show lit+    let returnsOrOf = try (ruleBareTrait "returns" <|> ruleBareTrait "of")+    typ'    <- option typ returnsOrOf++    -- Here if it's a subset-parsed-as-sub, escape now+    if styp == _SubSet_ then skipMany (symbol "where" >> parseTerm) >> return emptyExp else do++    formal  <- option Nothing $ ruleSubParameters ParensMandatory+    typ''   <- option typ' returnsOrOf+    traits  <- ruleTraitsIsOnly++    env <- ask+    let pkg = cast (envPackage env)+        nameQualified | ':' `elem` name     = name+                      | isGlobal            = name+                      | isBuiltin           = (head name:'*':tail name)+                      | otherwise           = name+        isGlobal = '*' `elem` name+        isBuiltin = ("builtin" `elem` traits)+        isExported = ("export" `elem` traits)+        mkMulti | isMulti /= ImplicitNil = \x -> (cast x){ v_longname = _cast (cast signature) }+                | otherwise              = cast+        mkSym sub n x = Sym scope (mkMulti n) mempty (Syn "sub" [Val sub]) x+        var = mkMulti nameQualified+        signature = self ++ paramsFor styp formal (maybe [] id formal)+        self | styp > SubMethod = []+             | Just (prm:_) <- formal, isInvocant prm = []+             | otherwise = [selfParam . cast $ envPackage env]++    -- We have the prototype now; install it immediately!+    --   fill in what we can about the sub before getting the block (below)+    let sub@(VCode template) = VCode $ mkCode+            { isMulti       = isMulti /= ImplicitNil+            , subName       = cast nameQualified+            , subOuterPads  = envLexPads env+            , subInnerPad   = emptyPad+            , subParams     = signature+            , subPackage    = envPackage env+            , subType       = if "primitive" `elem` traits+                then SubPrim else styp+            , subAssoc      = case v_categ var of+                C_infix -> assoc+                _       -> ANil+            , subReturns    = mkType typ''+            , subLValue     = "rw" `elem` traits+            , subBindings   = []+            , subSlurpLimit = []+            , subCont       = Nothing+            }++    -- Don't add the sub if it's unsafe and we're in safemode (XXX repeated below)+    newPad <- if ("unsafe" `elem` traits && safeMode) then return (mkPad []) else do+        -- This is ignored for multi-dispatch; see Pugs.Eval.Var comment "PROTO"+        unsafeEvalLexDiff (mkSym sub nameQualified Noop)+            `finallyM` clearDynParsers++    -- Generate init pad for each of our params, as well as for ourselves...+    paramsPad   <- genParamEntries styp signature+    modify $ \s -> s{ s_protoPad = paramsPad }+    block       <- ruleBlock++    let (fun, names, _) = extractNamedPlaceholders styp formal (bi_body block)++    -- Check for placeholder vs formal parameters+    when (isJust formal && (not.null) names) $+        fail "Cannot mix placeholder variables with formal parameters"++    env <- ask++    let template' = template+                { subBody       = case isMulti of+                    ImplicitProto   -> fun -- XXX - Give Proto the tie-breaker status?+                    _               -> fun+                , subOuterPads  = envLexPads env+                , subInnerPad   = bi_pad block+                , subTraitBlocks= bi_traits block (subTraitBlocks template)+                }+        sub = VCode template'+    +    -- Don't add the sub if it's unsafe and we're in safemode.+    if "unsafe" `elem` traits && safeMode then return (Var var) else do+    (`finallyM` clearDynParsers) $ if not (isLexicalVar var)+        then do unsafeEvalExp $ mkSym sub nameQualified (Var var)+        else do+            let doExportCode = if not isExported then return (Var var) else do+                    -- we mustn't perform the export immediately upon parse, because+                    -- then only the first consumer of a module will see it. Instead,+                    -- make a note of this symbol being exportable, and defer the+                    -- actual symbol table manipulation to opEval.+                    -- %*INC<This::Package><exports><&this_sub> = expression-binding-&this_sub+                    --    ==>+                    -- %This::Package::EXPORTS<&this_sub> = expression-binding-&this_sub+                    let VCode cv = sub+                        (exportedSub, exportedName)+                            -- "method foo is export" is exported into "multi foo" here.+                            | SubMethod <- styp = (multiCode, cast var{ v_longname = _cast (cast multiSig) })+                            | otherwise         = (sub, cast var)+                            where+                            multiSig  = map (\x -> x{ isInvocant = False }) (subParams cv)+                            multiCode = VCode cv+                                { isMulti   = True+                                , subParams = multiSig+                                }+                    unsafeEvalExp $ Syn "="+                        [ Syn "{}" [_Var ("%" ++ pkg ++ "::EXPORTS"), Val $ VStr exportedName]+                        , Val exportedSub+                        ]+                    return (Var var)+            case lookupPad var newPad of+                Just entry  -> do+                    Val (VCode code) <- unsafeEvalExp (Syn "sub" [Val sub])+                    let entry'  = entry{ pe_proto = cv' }+                        cv'     = MkRef (ICode code)+                    addBlockPad (adjustPad (const entry') var newPad)+                    result <- doExportCode+                    case entry' of+                        PEConstant{}    -> return result+                        _               -> return $! unsafePerformSTM $! do+                            rv  <- writePadEntry entry' cv'+                            return (rv `seq` result)+                _           -> error "Impossible: Disappearing entry?"++ruleSubNamePossiblyWithTwigil :: RuleParser String+ruleSubNamePossiblyWithTwigil = tryVerbatimRule "subroutine name" $ do+    twigil  <- ruleTwigil+    name    <- ruleOperatorName <|> ruleQualifiedIdentifier+    return $ ('&':twigil) ++ name++ruleSubName :: RuleParser String+ruleSubName = verbatimRule "subroutine name" $ do+    twigil  <- option "" (string "*")+    name <- ruleOperatorName <|> ruleQualifiedIdentifier+    return $ ('&':twigil) ++ name++ruleOperatorName :: RuleParser String+ruleOperatorName = verbatimRule "operator name" $ do+    categ   <- choice (map (try . string) grammaticalCategories) `tryLookAhead` (oneOf "\xAB<{")+    name    <- do+        -- char ':'+        sub <- ruleHashSubscript+        -- Not exactly un-evil+        let (Syn "{}" [_, expr]) = sub (Val VUndef)+        Val (VStr name) <- unsafeEvalExp $+            App (_Var "&*join") +            Nothing +            (Val (VStr " ") : [expr])+        return name+    return $ categ ++ name+++ruleSubParameters :: ParensOption -> RuleParser (Maybe [Param])+ruleSubParameters wantParens = rule "subroutine parameters" $ do+    rv <- ruleParamList wantParens (ruleFormalParam FormalsComplex)+    case rv of+        Just (invs:args:_)  -> return . Just $ map setInv invs ++ args+        _                   -> return Nothing+    where+    setInv e = e { isInvocant = True }++ruleFormalParam :: FormalsOption -> RuleParser Param+ruleFormalParam opt = rule "formal parameter" $ do+    typ     <- option "" $ ruleType+    optional $ char '|'  -- XXX hack to parse arglist (|$foo)+    sigil1  <- option "" $ choice . map symbol $ words " : * "+    name    <- ruleParamName -- XXX support *[...]+    sigil2  <- option "" $ choice . map symbol $ words " ? ! "+    traits  <- ruleTraitsIsOnly+    -- sigil' is the canonical form of sigil1 and sigil2, e.g.+    --   $foo is required -->  !$foo+    --  :$foo             --> ?:$foo+    --  :$foo!            --> !:$foo+    --  :$foo is required --> !:$foo+    isDefaultSpecified <- option False $ do+        lookAhead $ symbol "="+        return True+    let isOptional = isDefaultSpecified+                  || sigil2 == "?"+                  || sigil1 == ":" && sigil2 /= "!" && "required" `notElem` traits+                  || "optional" `elem` traits+    let sigil'      = (if isOptional then '?' else '!'):sigil1+        defaultExp  = case name of+            ('@':_) -> Val (VList [])+            ('%':_) -> Val (VList [])+            _       -> Noop++    -- XXX - RIGHT HERE, add this one to CompPad?+    modify $ \state -> state+        { s_knownVars = Map.insert (cast name) (fromJust . envCompPad $ s_env state) (s_knownVars state) }++    rv <- case opt of+        FormalsSimple   -> option emptyExp $ do+            pseudoAssignment (cxtOfSigilVar var) (Val (VType (if null typ then typeOfSigilVar var else mkType typ)))+            where+            var = cast name+        FormalsComplex  -> ruleParamDefault+    when (opt == FormalsComplex) . optional $ do+        symbol "-->"+        ruleParamList ParensOptional $ choice+            [ ruleType `sepBy1` symbol "of"+            , ruleFormalParam FormalsComplex >> return []+            ]+    let exp = case rv of+            Noop -> defaultExp+            _    -> rv+    return $ foldr appTrait (buildParam typ sigil' name exp) traits+    where+    appTrait "rw"   x = x { isWritable = True }+    appTrait "copy" x = x { isLValue = False, isWritable = True }+    appTrait "lazy" x = x { isLazy = True }+    appTrait "context" x = x { paramName = (paramName x){ v_twigil = TImplicit } }+    appTrait _      x = x -- error "unknown trait"++ruleParamDefault :: RuleParser Exp+ruleParamDefault = rule "default value" $ option emptyExp $ do+    symbol "="+    parseExpWithItemOps++ruleTrustsDeclaration :: RuleParser Exp+ruleTrustsDeclaration = do+    symbol "trusts"+    lexeme ruleQualifiedIdentifier+    return emptyExp++ruleTraitDeclaration :: RuleParser Exp+ruleTraitDeclaration = try $ do+    -- XXX horrible hack! "is eval(...), ..." should *not* be parsed as a trait+    -- declaration. So we check whether we're really statement-level, i.e.+    --   is eval(...) [eof]   # trait+    --   is eval(...);        # trait+    --   is eval(...) }       # trait+    --   is eval(...), ...    # sub call+    (aux, trait) <- ruleTrait ["is", "does"]+    lookAhead (eof <|> (oneOf ";}" >> return ()))+    pkg <- asks envPackage+    let meta = _Var (':':'*':cast pkg)+        expMeta = Syn "="+            [ Syn "{}" [meta, Val (VStr aux)]+            , Syn "," [Syn "@{}" [Syn "{}" [meta, Val (VStr aux)]], Val (VStr trait)]+            ]+        addDoes | "does" <- aux = Stmts (App (_Var "&HOW::does") (Just meta) [Val (VStr trait)])+                | otherwise     = id+    unsafeEvalExp $ Syn "if"+        [ meta+        , addDoes expMeta+        , App (_Var "&die") Nothing [Val (VStr $ "Can't add trait to non-class package: " ++ show pkg)]+        ]+    return Noop++ruleMemberDeclaration :: RuleParser Exp+ruleMemberDeclaration = do+    symbol "has"+    typ  <- option "" $ do+        optional (string "::")+        lexeme $ choice+            [ ruleQualifiedIdentifier+            -- ::?CLASS, ::?ROLE, etc.+            , char '?' >> ruleQualifiedIdentifier >> fmap cast (asks envPackage)+            ]+    attr <- ruleVarName+    (sigil:twigil:key) <- case attr of+        (_:'.':_)   -> return attr+        (_:'!':_)   -> return attr+        (x:xs@(twigil:_))+            | (isAlpha twigil) || twigil == '_'+                    -> return (x:'!':xs)+        _           -> fail $ "Invalid member variable name '" ++ attr ++ "'"+    traits  <- ruleTraitsIsOnly+    optional $ do { symbol "handles"; ruleExpression }+    def     <- ruleParamDefault+    env     <- ask+    let self = selfParam $ cast (envPackage env)+    paramsPad  <- genParamEntries SubMethod [self]+    -- manufacture an accessor, and register this slot into metaobject+    let sub = mkPrim+            { isMulti       = False+            , subName       = cast name+            , subReturns    = if null typ then typeOfSigil (cast sigil) else mkType typ+            , subBody       = fun+            , subParams     = [self]+            , subInnerPad   = paramsPad+            , subLValue     = "rw" `elem` traits+            , subType       = SubMethod+            }+        exp = Syn "sub" [Val $ VCode sub]+        name | twigil == '.' = '&':(pkg ++ "::" ++ key)+             | otherwise     = '&':(pkg ++ "::" ++ (twigil:key))+        fun = Syn (sigil:"{}") [Ann (Cxt (cxtOfSigil $ cast sigil)) (Syn "{}" [_Var "$__SELF__", Val (VStr key)])]+        pkg = cast (envPackage env)+        metaObj = _Var (':':'*':pkg)+        attrDef = Syn "{}" [Syn "{}" [metaObj, Val (VStr "attrs")], Val (VStr key)]+    unsafeEvalExp (_Sym SOur name mempty exp (Syn "=" [attrDef, def]))+    return emptyExp++{-|+Match a @no@ declaration, i.e. the opposite of @use@ (see+'ruleUseDeclaration').++Works by matching \'@no@\', then trying 'ruleNoVersion' and+@'ruleUsePackage' False@.+-}+ruleNoDeclaration :: RuleParser Exp+ruleNoDeclaration = rule "no declaration" $ do+    symbol "no"+    choice [ ruleNoVersion >> return emptyExp+              , ruleUsePackage False+              ]+    return emptyExp++{-|+Match a @use@ declaration.++Works by matching \'@use@\', then trying 'ruleUseVersion' and+@'ruleUsePackage' True@.+-}+ruleUseDeclaration :: RuleParser Exp+ruleUseDeclaration = rule "use declaration" $ do+    symbol "use"+    choice [ try ruleUseVersion >> return emptyExp+           , ruleUsePackage True+           ]++rulePerlVersion :: RuleParser String+rulePerlVersion = rule "perl version" $ do+    optional (string "v" <|> string "Perl-")+    version <- many1 (choice [ digit, char '.' ])+    optional ruleAuthorPart+    {-+    optional $ do+        variant <- ruleAuthorPart+        when (map toLower variant /= "pugs") $ do+            pos <- getPosition+            error $ "Perl implementation " ++ tail variant ++ " required--this is only Pugs v" ++ versnum ++ ", stopped at " ++ (show pos)+    -}+    return version++{-|+Match a Perl version number (as part of a @use@ declaration), and abort if+the version needed is higher than our version.+-}+ruleUseVersion :: RuleParser ()+ruleUseVersion = rule "use version" $ do+    version <- rulePerlVersion+    when (version > versnum) $ do+        pos <- getPosition+        error $ "Perl v" ++ version ++ " required--this is only v" ++ versnum ++ ", stopped at " ++ (show pos)++{-|+Match a Perl version number (as part of a @no@ declaration), and abort if+the version needed is lower than our version.+-}+ruleNoVersion :: RuleParser ()+ruleNoVersion = rule "no version" $ do+    version <- rulePerlVersion+    when (version <= versnum) $ do+        pos <- getPosition+        error $ "Perls since v" ++ version ++ " too modern--this is v" +                  ++ versnum ++ ", stopped at " ++ show pos++{-|+Match the contents of a @use@ or @no@ declaration.++Works by reading the (optional) \'lang\' prefix, then dispatching to either+'ruleUseJSANModule' or 'ruleUsePerlPackage' as appropriate.++It is assumed that the @use@ or @no@ has already been consumed by+'ruleUseDeclaration' or 'ruleNoDeclaration'.+-}+ruleUsePackage :: Bool -- ^ @True@ for @use@; @False@ for @no@+               -> RuleParser Exp+ruleUsePackage use = rule "use package" $ do+    lang <- ruleUsePackageLang+    case lang of+        "jsan" -> if use+                      then ruleUseJSANModule+                      else fail "can't 'no' a JSAN module"+        "jsperl5" -> if use+                      then ruleUseJSPerl5Module+                      else fail "can't 'no' a Perl5 module"+        "java" -> if use+                      then ruleUseJavaModule+                      else fail "can't 'no' a Java module"+        _      -> ruleUsePerlPackage use lang+    where+    ruleUsePackageLang = option "perl6" $ try $ do+        lang <- identifier+        char ':'+        notFollowedBy (char ':')+        return lang+        +{-|+Match the package-name and import-list part of a (non-JSAN) @use@ or @no@+declaration, then perform the actual import.++The parser itself does not yield a useful value; instead it modifies the+'Pugs.AST.Internals.Env' part of the parser's state to reflect the results+of the declaration.  (If the package is a Perl 5 package, the modification+will be different.)++It is assumed that 'ruleUsePackage' has already consumed the \'lang\' prefix,+which is passed in as the second argument.+-}+ruleUsePerlPackage :: Bool   -- ^ @True@ for @use@; @False@ for @no@+                   -> String -- ^ \'lang\' prefix (e.g. \"@perl5@\" or+                             --     \"@perl6@\")+                   -> RuleParser Exp+ruleUsePerlPackage use lang = rule "use perl package" $ do+    -- author and version get thrown away for now+    (names, _, _) <- rulePackageFullName+    let name = concat (intersperse "::" names)+    ruleLoadPerlPackage name use lang++ruleLoadPerlPackage :: String -> Bool -> String -> RuleParser Exp+ruleLoadPerlPackage pkg use lang = do+    when use $ do   -- for &no, don't load code+        env  <- ask+        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+            { s_env = env+                { envGlobal  = envGlobal env'+                }+            , s_dynParsers = MkDynParsersEmpty+            }+    try (do { verbatimParens whiteSpace ; return emptyExp}) <|> do+        imp <- option emptyExp ruleExpression+        let sub = _Var $ ('&':pkg) ++ if use then "::import" else "::unimport"++        Val res <- unsafeEvalExp $ Syn "if"+            [ sub+            , App sub (Just $ Val $ VStr $ pkg) [imp]+            , emptyExp+            ]++        Val (VList exportList) <- res `seq` unsafeEvalExp $ case lang of+            -- map { ~$_, ::Pkg.can($_) }, @importlist+            "perl5" -> App (_Var "&map") Nothing [Syn "sub"+                [ Val . VCode $ mkPrim+                    { subBody       = Syn ","+                        [ App (_Var "&prefix:<~>") (Just $ Var varTopic) []+                        , App (_Var "&can") (Just $ _Var (':':'*':pkg)) [Var varTopic]+                        ]+                    , subParams     = [defaultScalarParam]+                    , subInnerPad   = defaultScalarPad+                    }+                ], imp ]+            -- %Pkg::EXPORTS.kv+            _ -> App (_Var "&kv") (Just $ _Var ('%':pkg ++ "::EXPORTS")) []++        let hardcodedScopeFixme = SMy+            doExportList [] = []+            doExportList [x] = error $ "doExportList [x]: " ++ show x+            doExportList (VStr name:ex:xs) = +                (exportSym hardcodedScopeFixme name ex : doExportList xs)+            doExportList x = error $ "doExportList x: " ++ show x+        sequence_ $ doExportList exportList+        clearDynParsers+        return emptyExp++{-|+Match a JSAN module name, returning an appropriate+sub call 'Pugs.AST.Exp' that will load the module using subs defined in+@PIL2JS::Internals@.++Used by 'ruleUsePackage' after matching \'@use jsan:@\'.++More info about JSAN can be found at <http://www.openjsan.org/>.+-}+ruleUseJSANModule :: RuleParser Exp+ruleUseJSANModule = do+    name <- fmap (Val . VStr) (ruleDotOrColonSeparatedModuleName ".")+    choice+        [ try $ do+            verbatimParens whiteSpace+            return $ App (_Var "&PIL2JS::Internals::use_jsan_module_noimp") Nothing [name]+        , do+            exp <- option emptyExp ruleExpression+            let exp' | exp == emptyExp = []+                     | otherwise       = [exp]+            return $ App (_Var "&PIL2JS::Internals::use_jsan_module_imp") Nothing $ name:exp'+        ] ++ruleUseJavaModule :: RuleParser Exp+ruleUseJavaModule = do+    name <- ruleDotOrColonSeparatedModuleName "::"+    ruleLoadPerlPackage name True "java"++ruleDotOrColonSeparatedModuleName :: String -> RuleParser String+ruleDotOrColonSeparatedModuleName sep = lexeme $ do+    names <- ruleVerbatimIdentifier `sepBy1` (try (string "::" <|> string "."))+    optional ruleVersionPart+    optional ruleAuthorPart+    return . concat $ intersperse sep names++{-|+Match a perl5 module for js backend, returning an appropriate+sub call 'Pugs.AST.Exp' that will load the module using subs defined in+@PIL2JS::Internals@.++-}+ruleUseJSPerl5Module :: RuleParser Exp+ruleUseJSPerl5Module = do+    name <- fmap (Val . VStr) (ruleDotOrColonSeparatedModuleName "::")+    +    choice+        [ try $ do+            verbatimParens whiteSpace+            return $ App (_Var "&PIL2JS::Internals::use_perl5_module_noimp") Nothing [name]+        , do+            exp <- option emptyExp ruleExpression+            let exp' | exp == emptyExp = []+                     | otherwise       = [exp]+            return $ App (_Var "&PIL2JS::Internals::use_perl5_module_imp") Nothing $ name:exp'+        ] +        +{-|+Match a full package name, consisting of:++* A short name, optionally delimited by double colons (@::@)++* An optional version specification++* An optional author specification (e.g. @cpan:JRANDOM@)+-}+rulePackageFullName :: RuleParser ( [String]+                                  , (Maybe String)+                                  , (Maybe String)+                                  )+rulePackageFullName = do+    name    <- ruleDelimitedIdentifier "::"+    version <- option Nothing $ fmap Just ruleVersionPart+    author  <- option Nothing $ fmap Just ruleAuthorPart+    whiteSpace+    return (name, version, author)++-- | The version part of a fully-qualified package name.+ruleVersionPart :: RuleParser String+ruleVersionPart = do -- version - XXX+    char '-'+    str <- many (choice [ digit, char '.', char '(', char ')' ])+    return ('-':str)++-- | The author part of a fully-qualified package name.+ruleAuthorPart :: RuleParser String+ruleAuthorPart = do -- author - XXX+    char '-'+    -- this will break if you specify an author AND an imports list+    str <- many1 (satisfy (/= ';'))+    return ('-':str)+{- end of ruleUseDeclaration -}++ruleInlineDeclaration :: RuleParser Exp+ruleInlineDeclaration = rule "inline declaration" $ do+    symbol "inline"+    args <- ruleExpression+    case args of+        App (Var var) Nothing exp | var == cast "&infix:=>" -> do+            return $ Syn "inline" exp+        _ -> fail "not yet parsed"++{-|+Match a @require@ declaration, returning a sub call 'Pugs.AST.Exp' that will+load the package at runtime.++(This should probably be merged with 'ruleUseDeclaration' & friends, if+anybody has some tuits.)+-}+ruleRequireDeclaration :: RuleParser Exp+ruleRequireDeclaration = tryRule "require declaration" $ do+    symbol "require"+    (names, _, _) <- rulePackageFullName+    return $ App (_Var "&require") Nothing [Val . VStr $ concat (intersperse "::" names)]++ruleDoBlock :: RuleParser Exp+ruleDoBlock = rule "do block" $ do+    sym  <- symbol "do" <|> symbol "gather"+    tree <- choice+        [ ruleDoOnceBlock+        , ruleBlockDeclaration+        , ruleDeclaration+        , ruleConstruct+        , ruleStatement+        ]+    return $ if sym == "gather"+        then App (_Var "&gather") Nothing [Val . VCode $ mkSub { subBody = tree }]+        else tree+    where+    ruleDoOnceBlock = do+        rv <- ruleBareOrPointyBlockLiteralWithoutDefaultParams+        notFollowedBy (ruleStatementModifier >> return ' ')+        return $ Syn "postwhile" [Val (castV False), rv]++ruleClosureTrait :: Bool -> RuleParser Exp+ruleClosureTrait rhs = tryRule "closure trait" $ do+    let rhsTraits = words " BEGIN CHECK INIT START ENTER FIRST "+    let names = words " BEGIN CHECK INIT END START ENTER LEAVE KEEP UNDO FIRST NEXT LAST PRE POST CATCH CONTROL"+    name    <- choice $ map symbol $ names+    block   <- ruleBlock+    popClosureTrait+    when (rhs && not (name `elem` rhsTraits)) $+        fail (name ++ " may only be used at statement level")+    let (fun, params) = extractPlaceholderVars (bi_body block) Set.empty+    -- Check for placeholder vs formal parameters+    unless (Set.null $ Set.delete varTopic params) $+        fail "Closure traits take no formal parameters"+    env <- ask+    let code = mkSub+            { subName       = cast name+            , subType       = SubBlock+            , subBody       = fun+            , subPackage    = envPackage env+            , subInnerPad   = (bi_pad block)+            , subOuterPads  = (PCompiling (fromJust $ envCompPad env):envLexPads env)+            } +    case name of+        "END"   -> do+            -- 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+            rv  <- unsafeEvalExp $ +                App (_Var "&unshift")+                    (Just (_Var (if pkg == mainPkg then "@Main::END" else "@*END")))+                    [Val $ VCode code]+            return (rv `seq` emptyExp)+        "BEGIN" -> do+            -- 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+            let idat = unsafePerformSTM . readTVar $ envInitDat env+            install $ initPragmas idat+            clearDynParsers+            return val+        "CHECK" -> vcode2checkBlock $ VCode code+        "INIT"  -> vcode2initBlock $ VCode code+            -- we need to clone this closure sometimes+        "START" -> vcode2startBlock $ VCode code+        _       -> do +            addClosureTrait name code+            return emptyExp --retBlock SubBlock Nothing False block +            -- XXX Not the right thing to return+    where+    install [] = return $ ()+    install prag = do+        env' <- ask+        let env'' = envCaller env'  -- not sure about this.+        case env'' of+            Just target -> do+                putRuleEnv target { envPragmas = prag ++ envPragmas target }+            _ -> fail "no caller env to install pragma in"++{-| Match a @q:code { ... }@ quotation -}+ruleCodeQuotation :: RuleParser Exp+ruleCodeQuotation = rule "code quotation" $ do+    -- XXX - This is entirely kluge; it drops traits in the body too+    symbol "q:code" >> optional (symbol "(:COMPILING)")+    block <- ruleBlockBody+    return (Syn "q:code" [bi_body block])+    +-- | If we've executed code like @BEGIN { exit }@, we've to run all @\@*END@+--   blocks and then exit. Returns the input expression if there's no need to+--   exit.+{-# NOINLINE possiblyExit #-}+possiblyExit :: Exp -> RuleParser Exp+possiblyExit (Val (VControl (ControlExit exit))) = do+    -- Run all @*END blocks...+    rv <- unsafeEvalExp $ Stmts (Syn "for"+        [ _Var "@Main::END"+        , Syn "sub"+            [ Val . VCode $ mkPrim+                { subBody       = App (Var varTopic) Nothing []+                , subParams     = [defaultScalarParam]+                , subInnerPad   = defaultScalarPad+                }+            ]+        ]) (_Var "@Main::END")+    -- ...and then exit.+    return $ unsafePerformIO $ exitWith (rv `seq` exit)+possiblyExit x = return x++vcode2memoized :: VCode -> RuleParser VCode+vcode2memoized code = do+    -- Ok. Now the tricky thing.+    -- This is the general idea:+    -- START { 42 } is transformed into+    -- {+    --   # XXX these should not be $? vars!!!+    --   state $?START_RESULT;+    --   state $?START_RUN;+    --   $?START_RUN++ ?? $?START_RESULT !! $?START_RESULT = { 42 }();+    -- }+    -- These are the two state variables we need.+    -- This will soon add our two state vars to our pad++    lexDiff <- unsafeEvalLexDiff $+        (_Sym SState "$?START_RESULT" mempty emptyExp) .+        (_Sym SState "$?START_RUN" mempty emptyExp) $ emptyExp++    let body' = Syn "if"+                    [ App (_Var "&postfix:++") Nothing [_Var "$?START_RUN"]+                    , _Var "$?START_RESULT"+                    , Syn "=" [_Var "$?START_RESULT", subBody code]+                    ]   --  { $?START_RUN++; $?START_RESULT = 42 };++    return $ code+        { subBody     = body'+        , subInnerPad = subInnerPad code `mappend` lexDiff+        }++vcode2startBlock :: Val -> RuleParser Exp+vcode2startBlock ~(VCode code) = do+    code'   <- vcode2memoized code+    return $ App (Syn "sub" [Val (VCode code')]) Nothing []++vcode2initBlock :: Val -> RuleParser Exp+vcode2initBlock ~(VCode code) = do+    code'   <- vcode2memoized code+    Val res <- unsafeEvalExp $+        App (_Var "&push") (Just $ _Var "@*INIT") [ Val (VCode code') ]+    return (res `seq` App (Val (VCode code')) Nothing [])++vcode2checkBlock :: Val -> RuleParser Exp+vcode2checkBlock ~(VCode code) = do+    code'   <- vcode2memoized code+    Val res <- unsafeEvalExp $+        App (_Var "&unshift") (Just $ _Var "@*CHECK") [ Val (VCode code') ]+    return (res `seq` App (Val (VCode code')) Nothing [])++-- Constructs ------------------------------------------------++ruleConstruct :: RuleParser Exp+ruleConstruct = rule "construct" $ choice+    [ ruleForConstruct+    , ruleLoopConstruct+    , ruleRepeatConstruct+    , ruleCondConstruct+    , ruleWhileUntilConstruct+    , ruleStandaloneBlock+    , ruleWhenConstruct+    , ruleMaybeConstruct+    , ruleDefaultConstruct+    , yadaLiteral+    ]++ruleStandaloneBlock :: RuleParser Exp+ruleStandaloneBlock = tryVerbatimRule "" $ do+    body <- ruleBlock+    whiteSpace+    lookAhead ((oneOf ";}" >> return ()) <|> eof)+    retVerbatimBlock SubBlock Nothing False body++ruleForConstruct :: RuleParser Exp+ruleForConstruct = rule "loop construct" $ do+    sym     <- symbol "for" <|> symbol "given"+    cond    <- ruleCondPart+    body    <- enterBracketLevel ParensBracket $ ruleBlockLiteral+    return $ Syn sym [cond, body]++ruleLoopConstruct :: RuleParser Exp+ruleLoopConstruct = rule "loop construct" $ do+    symbol "loop"+    choice [ ruleSemiLoopConstruct, ruleBareLoopConstruct ]++ruleSemiLoopConstruct :: RuleParser Exp+ruleSemiLoopConstruct = rule "for-like loop construct" $ do+    conds <- parens $ do+        a <- option emptyExp ruleExpression+        symbol ";"+        b <- option emptyExp ruleExpression+        symbol ";"+        c <- option emptyExp ruleExpression+        return [a,b,c]+    block <- retBlockWithoutDefaultParams SubBlock Nothing False =<< ruleBlock+    return $ Syn "loop" (conds ++ [block])++ruleBareLoopConstruct :: RuleParser Exp+ruleBareLoopConstruct = rule "for-like loop construct" $ do+    block <- ruleBareBlock+    return $ Syn "loop" [block]++ruleBareBlock :: RuleParser Exp+ruleBareBlock = do+    retBlockWithoutDefaultParams SubBlock Nothing False =<< ruleBlock++ruleRepeatConstruct :: RuleParser Exp+ruleRepeatConstruct = rule "postfix loop construct" $ do+    symbol "repeat"+    choice [ ruleRepeatPostConstruct, ruleRepeatPreConstruct ]++ruleRepeatPostConstruct :: RuleParser Exp+ruleRepeatPostConstruct = rule "repeat postfix construct" $ do+    block   <- enterBracketLevel ParensBracket $ ruleBareOrPointyBlockLiteralWithoutDefaultParams+    name    <- choice [ symbol "while", symbol "until" ]+    cond    <- ruleExpression+    return $ Syn ("post" ++ name) [cond, block]++ruleRepeatPreConstruct :: RuleParser Exp+ruleRepeatPreConstruct = rule "repeat prefix construct" $ do+    name    <- choice [ symbol "while", symbol "until" ]+    cond    <- ruleCondPart+    block   <- enterBracketLevel ParensBracket $ ruleBareOrPointyBlockLiteralWithoutDefaultParams+    return $ Syn ("post" ++ name) [ cond, block ]++ruleCondConstruct :: RuleParser Exp+ruleCondConstruct = rule "conditional construct" $ do+    csym <- choice [ symbol "if", symbol "unless" ]+    ruleCondBody $ csym++ruleCondBody :: String -> RuleParser Exp+ruleCondBody csym = rule "conditional expression" $ do+    cond     <- ruleCondPart+    enterBracketLevel ParensBracket $ do+        body     <- ruleBareOrPointyBlockLiteralWithoutDefaultParams+        bodyElse <- option emptyExp ruleElseConstruct+        case csym of+            "if"    -> return $ Syn "cond" [cond, body, bodyElse]+            _       -> if bodyElse == emptyExp then+                             return $ Syn "cond" [cond, bodyElse, body]+                        else fail "no else after unless"+++ruleCondPart :: RuleParser Exp+ruleCondPart = enterBracketLevel ConditionalBracket ruleExpression++ruleMaybeConstruct :: RuleParser Exp+ruleMaybeConstruct = rule "maybe construct" $ do+    symbol "maybe"+    blocks  <- enterBracketLevel ParensBracket (ruleBareBlock `sepBy` symbol "maybe")+    return (Syn "maybe" blocks)++ruleElseConstruct :: RuleParser Exp+ruleElseConstruct = rule "else or elsif construct" $+    do+        symbol "else"+        ruleBareOrPointyBlockLiteralWithoutDefaultParams+    <|> do+        symbol "elsif"+        body    <- ruleCondBody "if"+        return (Syn "block" [body])++ruleWhileUntilConstruct :: RuleParser Exp+ruleWhileUntilConstruct = rule "while/until construct" $ do+    sym     <- choice [ symbol "while", symbol "until" ]+    cond    <- ruleCondPart+    body    <- enterBracketLevel ParensBracket $ ruleBareOrPointyBlockLiteralWithoutDefaultParams+    return $ Syn sym [ cond, body ]++ruleWhenConstruct :: RuleParser Exp+ruleWhenConstruct = rule "when construct" $ do+    sym     <- symbol "when"+    match   <- ruleCondPart+    body    <- ruleBareBlock+    return $ Syn sym [ match, body ]++-- XXX: make this translate into when true, when smartmatch+-- against true works+ruleDefaultConstruct :: RuleParser Exp+ruleDefaultConstruct = rule "default construct" $ do+    sym     <- symbol "default"+    body    <- ruleBareBlock+    return $ Syn sym [ body ]++-- Expressions ------------------------------------------------++ruleExpression :: RuleParser Exp+ruleExpression = (<?> "expression") $ parseExpWithOps++{-|+Match a statement's /conditional/ statement-modifier,+e.g. '@say \"hello\" if \$cheerful@' or '@die unless +\@arguments@'.++Returns a function that will take the statement proper, and enclose it in an+appropriate 'Pugs.AST.Internals.Syn' (either @\"if\"@ or @\"unless\"@).+-}+s_postConditional :: RuleParser (Exp -> RuleParser Exp)+s_postConditional = rule "postfix conditional" $ do+    cond <- choice $ map symbol ["if", "unless"]+    exp <- ruleExpression+    return $ \body -> return $ case cond of+        "if"    -> Syn "cond" [exp, Syn "block" [body], Syn "block" [emptyExp]]+        _       -> Syn "cond" [exp, Syn "block" [emptyExp], Syn "block" [body]]++{-|+Match a statement's /looping/ statement-modifier,+e.g. '@procrastinate while $bored@' or '@eat until $full@'.++Returns a function that will take the statement proper, and enclose it in an+appropriate 'Pugs.AST.Internals.Syn' (either @\"while\"@ or @\"until\"@).+-}+s_postLoop :: RuleParser (Exp -> RuleParser Exp)+s_postLoop = rule "postfix loop" $ do+    cond    <- choice $ map symbol ["while", "until"]+    exp     <- ruleExpression+    return $ \body -> do+        block <- retBlockWithoutDefaultParams SubBlock Nothing False (emptyBlockInfo{ bi_body = body })+        return $ Syn cond [exp, block]++{-|+Match a statement's /iterating/ statement-modifier,+e.g. '@say for 1..10@'.++Returns a function that will take the statement proper, and enclose it in+@'Pugs.AST.Internals.Syn' \"for\"@.+-}+s_postIterate :: RuleParser (Exp -> RuleParser Exp)+s_postIterate = rule "postfix iteration" $ do+    cond <- choice $ map symbol ["for", "given"]+    exp <- ruleExpression+    return $ \body -> do+        block <- retBlock SubBlock Nothing False (emptyBlockInfo{ bi_body = body })+        return $ Syn cond [exp, block]++ruleBareOrPointyBlockLiteralWithoutDefaultParams :: RuleParser Exp+ruleBareOrPointyBlockLiteralWithoutDefaultParams = rule "bare or pointy block construct" $ do+    (styp, formal, lvalue) <- option (SubBlock, Nothing, False) ruleBlockFormalPointy+    -- Cancel out the default $_ on blocks+    body    <- ruleBlock+    retBlockWithoutDefaultParams styp formal lvalue body++retBlockWithoutDefaultParams :: SubType -> Maybe [Param] -> Bool -> BlockInfo -> RuleParser Exp+retBlockWithoutDefaultParams styp formal lvalue block = do+    rv <- retVerbatimBlock styp formal lvalue block+    case unwrap rv of+        (Syn "sub" [Val (VCode sub@MkCode{ subParams = prms })]) -> do+            return (Syn "sub" [Val $ VCode sub{ subParams = maybe [] (const $ prms) formal}])+        _ -> error (show rv)++ruleBareOrPointyBlockLiteral :: RuleParser Exp+ruleBareOrPointyBlockLiteral = rule "bare or pointy block construct" $+    ruleBlockVariants [ ruleBlockFormalPointy ]++ruleBlockLiteral :: RuleParser Exp+ruleBlockLiteral = rule "block construct" $+    ruleBlockVariants [ ruleBlockFormalPointy, ruleBlockFormalStandard ]++ruleBlockVariants :: [RuleParser (SubType, Maybe [Param], Bool)] -> RuleParser Exp+ruleBlockVariants variants = do+    (styp, formal, lvalue) <- option (SubBlock, Nothing, False) $ choice variants++    paramsPad  <- genParamEntries styp (maybe (defaultParamFor styp) id formal)+    modify $ \s -> s{ s_protoPad = paramsPad }++    block <- ruleBlock+    retBlock styp formal lvalue block++retBlock :: SubType -> Maybe [Param] -> Bool -> BlockInfo -> RuleParser Exp+retBlock SubBlock Nothing lvalue block = do+    isHash  <- hashComposerCheck (bi_body block)+    if not isHash then retVerbatimBlock SubBlock Nothing lvalue block else do+        retInterpolatedBlock (block{ bi_body = Syn "\\{}" [bi_body block] })+retBlock typ formal lvalue block = retVerbatimBlock typ formal lvalue block++retInterpolatedBlock :: BlockInfo -> RuleParser Exp+retInterpolatedBlock block = do+    exp <- retVerbatimBlock SubBlock Nothing False block+    return (App exp Nothing [])++retVerbatimBlock :: SubType -> Maybe [Param] -> Bool -> BlockInfo -> RuleParser Exp+retVerbatimBlock styp formal lvalue block = expRule $ do+    let (fun, names, params) = extractNamedPlaceholders styp formal (bi_body block)+    -- Check for placeholder vs formal parameters+    when (isJust formal && (not.null) names) $+        fail "Cannot mix placeholder variables with formal parameters"+    env <- ask+    let sub = mkCode+            { isMulti       = False+            , subName       = __"<anon>"+            , subPackage    = envPackage env+            , subOuterPads  = envLexPads env+            , subInnerPad   = bi_pad block+            , subType       = styp+            , subAssoc      = ANil+            , subReturns    = anyType+            , subLValue     = lvalue+            , subParams     = paramsFor styp formal params+            , subBindings   = []+            , subSlurpLimit = []+            , subBody       = fun+            , subCont       = Nothing+            , subTraitBlocks= bi_traits block emptyTraitBlocks+            }+    return $ case styp of+        SubPrim -> Syn "block" [Val $ VCode sub]+        _       -> Syn "sub" [Val $ VCode sub]++ruleBlockFormalStandard :: RuleParser (SubType, Maybe [Param], Bool)+ruleBlockFormalStandard = rule "standard block parameters" $ do+    styp <- choice+        [ do { symbol "sub";   return SubRoutine }+        , do { symbol "coro";  return SubCoroutine }+        , do { symbol "macro"; return SubMacro }+        ]+    params <- option Nothing $ ruleSubParameters ParensMandatory+    traits <- ruleTraitsIsOnly+    return $ (styp, params, "rw" `elem` traits)++ruleBlockFormalPointy :: RuleParser (SubType, Maybe [Param], Bool)+ruleBlockFormalPointy = rule "pointy block parameters" $ do+    symbol "->"+    params <- ruleSubParameters ParensOptional+    traits <- ruleTraitsIsOnly+    return $ (SubPointy, params, "rw" `elem` traits)++genNameTypeEntries :: Scope -> [(String, VType, EntryFlags, Exp)] -> RuleParser Pad+genNameTypeEntries scope nameTypes = do+    unsafeEvalLexDiff $ combine (map makeBinding nameTypes) emptyExp+    where+    makeBinding (name, typ, flag, def)+        | SConstant <- scope                                    = mkConstSym+        | ('$':_) <- name, typ /= anyType, scope /= SConstant   = mkSym . bindSym+        | otherwise                                             = mkSym+        where+        mkSym       = _Sym scope name flag emptyExp+        mkConstSym  = _Sym scope name flag def+        bindSym     = Stmts (Syn "=" [_Var name, Val (VType typ)])++paramsToNameTypes :: [Param] -> String -> [(String, Type, EntryFlags, Exp)]+paramsToNameTypes params defType = [ (n, t, f, d) | n <- names | t <- types | f <- flags | d <- defs ]+    where+    vars  = map paramName params+    names = map (\v -> cast v{ v_twigil = TNil }) vars+    types = map (maybeDefaultType . typeOfCxt . paramContext) params+    flags = map (MkEntryFlags . (== TImplicit) . v_twigil) vars+    defs  = map paramDefault params+    maybeDefaultType t+        | t == anyType, defType /= ""   = mkType defType+        | otherwise                     = t++genParamEntries :: SubType -> Params -> RuleParser Pad+genParamEntries styp params = genNameTypeEntries SMy (foldl' withImplicit nameTypes implicitNames)+    where+    params'+        | SubMethod <- styp = (defaultSelfParam:params)+        | otherwise         = params+    nameTypes       = paramsToNameTypes params' ""+    names           = Set.fromList $ map (\(n, _, _, _) -> n) nameTypes+    implicitNames   = case styp of+        SubPrim     -> []+        SubPointy   -> ["&?BLOCK"] -- , "$/", "$!"]+        SubBlock    -> ["$_", "&?BLOCK"] -- , "$/", "$!"]+        _           -> ["$_", "&?BLOCK", "&?ROUTINE"] -- , "$/", "$!"]+    withImplicit ntys name+        | Set.member (cast name) names  = ntys+        | otherwise                     = (((cast name), anyType, MkEntryFlags True, Noop):ntys)+    defaultSelfParam = buildParam "" "" "$__SELF__" (Val VUndef)++ruleVarDecl :: RuleParser Exp+ruleVarDecl = rule "variable declaration" $ do+    scope   <- ruleScope+    -- XXX - the treatment in the cases below is wrong; "is context"+    --       should be made part of the Pad annotations, as with the+    --       constraints; for now we abuse ruleFormalParam to add an+    --       extra "+" as part of the name when "is context" is seen,+    --       so we can rewrite the declarator to SEnv, but it's Wrong.+    (isOne, nameTypes, accessors) <- try oneDecl <|> manyDecl+    lexDiff <- genNameTypeEntries scope nameTypes++    -- Now hoist the lexDiff to the current block+    addBlockPad lexDiff+    forM_ accessors makeAccessor+    initializers <- mapM (makeInitializer scope) nameTypes+    return . Ann (Decl scope) $ case filter (/= Noop) initializers of+        []          -> Noop+        [x] | isOne -> x+        xs          -> Syn "," xs+    where+    oneDecl = do+        param <- ruleFormalParam FormalsSimple+        let var  = paramName param+            name = cast var{ v_twigil = TNil }+            flag = MkEntryFlags { ef_isContext = (v_twigil var == TImplicit) }+            typ  = typeOfCxt (paramContext param)+            nameType = (name, typ, flag, paramDefault param)+            accessors+                | TAttribute <- v_twigil var    = [param]+                | otherwise                     = []+        return (True, [nameType], accessors)+    manyDecl = do+        defType <- option "" $ ruleType+        optional (char ':')+        params  <- verbatimParens . enterBracketLevel ParensBracket $+            ruleFormalParam FormalsComplex `sepBy1` ruleComma+        let accessors = filter ((== TAttribute) . v_twigil . paramName) params+        return (False, paramsToNameTypes params defType, accessors)+    makeAccessor prm = do+        -- Generate accessor for class attributes.+        pkg         <- asks envPackage+        paramsPad   <- genParamEntries SubPrim [selfParam $ cast pkg]+        let sub = mkPrim+                { isMulti       = False+                , subName       = _cast (cast accessor)+                , subReturns    = typeOfParam prm+                , subBody       = if isWritable prm then fun else Syn "val" [fun]+                , subParams     = [selfParam $ cast pkg]+                , subLValue     = isWritable prm+                , subType       = SubMethod+                , subInnerPad   = paramsPad+                }+            fun = Var var{ v_twigil = TNil }+            var = paramName prm+            accessor = var{ v_package = pkg, v_sigil = SCode, v_twigil = TNil }+        unsafeEvalExp $ Syn ":=" [Var accessor, Syn "sub" [Val $ VCode sub]]+    -- Note that the reassignment below is _wrong_ when scope is SState.+    makeInitializer SState (name, _, _, def)+        | def /= Noop, def /= Val (VList []) = do+        assign <- vcode2startBlock (VCode $ mkSub { subBody = Syn "=" [_Var name, def]})+        return $ Stmts assign (_Var name)+    makeInitializer SConstant (name, _, _, _) = return (_Var name)+    makeInitializer _ (name, _, _, def)+        | def /= Noop, def /= Val (VList []) = do+        return $ Syn "=" [_Var name, def]+    makeInitializer _ (name, _, _, _) = return (_Var name)++parseTerm :: RuleParser Exp+parseTerm = rule "term" $! do+    term <- choice+        [ ruleDereference+        , ruleSignatureVal  -- must come before ruleTypeVar+        , ruleVarDecl+        , ruleVar+        , ruleApply True    -- Folded metaoperators+        , ruleLit+--      , ruleBarewordMethod+        , ruleClosureTrait True+        , ruleCodeQuotation+        , ruleTypeVar+--      , ruleTypeLiteral+        , ruleApply False   -- Normal application+        -- Hack - use an empty Syn to defeat isScalarLValue checking+        --        so that ($x) = f() gives list context.+        , fmap (Ann Parens) (verbatimParens ruleBracketedExpression)+        ] +    pos <- getPosition+    col <- gets s_wsColumn+    -- If we terminated on whitespace, don't apply postterms.+    if (col == sourceColumn pos)+        then do+            ln  <- gets s_wsLine+            if ln == sourceLine pos+                then return term+                else do+                    fs <- many s_postTerm+                    return (combine (reverse fs) term)+        else do+            -- s_postTerm returns an (Exp -> Exp) that we apply to the original term+            fs <- many s_postTerm+            return (combine (reverse fs) term)++ruleSignatureVal :: RuleParser Exp+ruleSignatureVal = rule "signature value" $ do+    between (symbol ":(") (lexeme $ char ')') ruleSignature++data ParamDeclaration = MkParamDeclaration+    { p_param      :: SigParam+    , p_isNamed    :: Bool+    , p_isRequired :: Bool+    , p_isSlurpy   :: Bool+    }+    deriving (Show)++ruleSignature :: RuleParser Exp+ruleSignature = rule "signature" $ do+    -- Note that :(:$x) is naturally one named parameter here.+    (inv, params) <- option (Nothing, []) $ do+        first <- ruleParam+        option (Nothing, [first]) $ do+            sep     <- lexeme (oneOf ":,")+            rest    <- ruleParam `sepEndBy` (lexeme $ char ',')+            return $ case sep of+                ':' -> (Just $ p_param first, rest)+                ',' -> (Nothing, first:rest)+                _   -> error "Can't happen"+    whiteSpace+    reqPosC <- validateRequired True params+    let reqNms   = Set.fromList+            [ p_label p | MkParamDeclaration{ p_param = p, p_isNamed = True, p_isRequired = True } <- params]+        nmSt     = Map.fromList+            [ (p_label p, p) | MkParamDeclaration{ p_param = p, p_isNamed = True } <- params]+        posLs    = [ p | MkParamDeclaration{ p_param = p, p_isNamed = False } <- params ]+        slpScLs  = []+        slpArrLs = Nothing+        slpHsh   = Nothing+        slpCd    = Nothing+        slpCapt  = Nothing+    return . Val . VV . mkVal $ MkSig inv reqPosC reqNms posLs nmSt slpScLs slpArrLs slpHsh slpCd slpCapt+    where+        validateRequired _     []     = return 0+        validateRequired False (x:_)+            | isReqPos x              = fail $ "Required parameter cannot come after optional ones: " ++ show x+        validateRequired _     (x:xs) = do+            next <- validateRequired (isReqPos x) xs+            return $ (fromEnum $ isReqPos x) + next+        isReqPos x = p_isRequired x && (not $ p_isNamed x)++ruleParam :: RuleParser ParamDeclaration+ruleParam = rule "parameter" $ do+    staticTypes            <- rStaticTypes+    isSlurpy               <- option False (char '*' >> return True)+    (name, label, isNamed) <- rParamName+    isOptional             <- choice+        [ lexeme $ char '!' >> return False+        , lexeme $ char '?' >> return True+        , whiteSpace >> lookAhead anyChar >>= return . ('=' ==) -- XXX: is this horribly inefficient?+        ]+    def           <- rDefault isOptional+    traits        <- many $ ruleTrait ["is", "does"]+    unpacking     <- rPostVarUnpacking+    code          <- rCode+    {- setTrait scans the traits list for "interesting" values, weeding+     - them out. The last interesting value is returned.+     - We can't let-shadow 'traits', because it's an action :-(+     - XXX - Eventually rewrite with foldr. -}+    let (traits',   access') = setTrait access  AccessRO traits+    let (traits'',  ref')    = setTrait ref     False    traits'+    let (traits''', lazy')   = setTrait lazy    False    traits''+    let (traits'''',context')= setTrait context False    traits'''+    let slots = Map.fromList [(cast t, mkVal $ (cast True :: PureBit)) | ("is", t) <- traits'''']+    let isRequired = (not isSlurpy) && ((not isOptional) || (Map.member (cast "required") slots))+    when (isOptional && isRequired) failReqDef -- XXX is required(False)+    let p = MkParam { p_variable    = cast name+                    , p_types       = staticTypes+                    , p_constraints = code+                    , p_unpacking   = unpacking+                    , p_default     = def+                    , p_label       = label+                    , p_slots       = slots+                    , p_hasAccess   = access'+                    , p_isRef       = ref'+                    , p_isLazy      = lazy'+                    , p_isContext   = context'+                    }+    return MkParamDeclaration+        { p_param       = p+        , p_isRequired  = isRequired+        , p_isSlurpy    = isSlurpy+        , p_isNamed     = isNamed+        }+    where+    rStaticTypes = do+        ty <- many $ lexeme ruleQualifiedIdentifier+        return $ map (MkType . cast) ty+    rParamName = choice+        [ do -- named parameter+            char ':'+            choice+                [ do  -- with implicit label+                    name <- regularVarName+                    return (name, label name, True)+                , do  -- with explicit label+                    explicitLabel <- many1 identLetter+                    name <- verbatimParens regularVarName+                    return (name, cast explicitLabel, True)+                ]+        , do -- positional parameter+            name <- regularVarWithOptionalName+            return (name, label name, False)+        ]+        where+        label = cast . dropWhile (not . isAlpha)+    rDefault True = lexeme $ option (MkParamDefault Nothing) $ do+        symbol "="+        fmap (MkParamDefault . Just . Exp.EE . Exp.MkExpEmeritus) parseTerm+    rDefault False = do+        ch <- lookAhead anyChar+        when (ch == '=') failReqDef+        return $ MkParamDefault Nothing+    rPostVarUnpacking = lexeme $ option Nothing $ try $ do+        optional $ char ':'+        (Val (VV (sig'))) <- verbatimParens ruleSignature+        (sig :: Sig) <- castVal sig'+        return $ Just sig+    rCode = lexeme $ do+        many $ do+            symbol "where"+            lexeme $ ruleVerbatimBlock+        return [] -- We don't have Exp -> Pugs.Val.Code, too bad.+    setTrait :: (a -> Maybe b) -> b -> [a] -> ([a], b)+    setTrait f d' l = doSetTrait d' [] l where+        doSetTrait d acc []     = (acc, d)+        doSetTrait d acc (x:xs) = case f x of+            Just rv -> doSetTrait rv acc xs+            Nothing -> doSetTrait d (acc ++ [x]) xs+    access ("is", "ro")   = Just AccessRO+    access ("is", "rw")   = Just AccessRW+    access ("is", "copy") = Just AccessCopy+    access _              = Nothing+    ref    ("is", "ref")  = Just True+    ref    _              = Nothing+    lazy   ("is", "lazy") = Just True+    lazy   _              = Nothing+    context   ("is", "context") = Just True+    context   _                 = Nothing+    failReqDef = fail "required parameters cannot have default values"++ruleTypeVar :: RuleParser Exp+ruleTypeVar = rule "type" $ do+    -- We've to allow symbolic references with type vars, too.+    string "::"+    -- XXX - Instead of handling &postfix:<::>, we directly turn ::Foo::+    --       into a package literal -- which is to say a string -- for now.+    nameExps <- (`sepEndBy1` string "::") $ do+        verbatimParens ruleExpression <|> (fmap (Val . VStr . concat) $ sequence [ruleTwigil, many1 wordAny])++    -- Optimization: We don't have to construct a symbolic deref syn (":::()"),+    -- but can use a simple Var, if nameExps consists of only one expression+    -- and this expression is a plain string, i.e. it is not a+    -- (...)-expression.+    return $ case mergeSimpleName nameExps of+        Just name -> Val (VType (mkType name)) -- _Var $ ":" ++ name+        _         -> Syn (":::()") nameExps+    where+    mergeSimpleName :: [Exp] -> Maybe String+    mergeSimpleName [] = Nothing+    mergeSimpleName [Val (VStr name)] = Just name+    mergeSimpleName (Val (VStr name):xs) = do+        rest <- mergeSimpleName xs+        Just $ name ++ "::" ++ rest+    mergeSimpleName _ = Nothing++s_postTerm :: RuleParser (Exp -> Exp)+s_postTerm = verbatimRule "term postfix" $ do+    hasDot <- option Nothing $ choice [try hyperDot, dotChar, try bangChar]+    choice $ case hasDot of+        Just '.' -> (ruleAssignInvocation:ruleMetaInvocation:ruleInvocation:postTerms)+        Just '!' -> (bangKludged ruleInvocation:postTerms)+        Just '>' -> map hyperKludged (ruleAssignInvocation:ruleInvocation:postTerms)+        _        -> postTerms+    where+    postTerms = +        [ ruleArraySubscript+        , ruleHashSubscript+        , ruleCodeSubscript+        ]+    hyperDot = (<?> "") $ do+        ruleHyperPre+        ruleDot+        return (Just '>')+    dotChar = do+        ruleDot+        option (Just '.') $ do+            ruleHyperPre+            optional ruleDot+            return (Just '>')+    bangChar = do { char '!'; lookAhead ruleSubName; return $ Just '!' }+    ruleAssignInvocation = do+        symbol "="+        f       <- ruleInvocation+        return $ \x -> Syn "=" [x, f x]+    ruleMetaInvocation = do+        char '^'+        f       <- ruleInvocation+        return $ \x -> f (App (_Var "&HOW") (Just x) [])+    -- XXX - this should happen only in a "trusts" class!+    bangKludged p = do+        f <- p+        return $ \x -> case f x of+            App (Var var) (Just inv) [] | ('&':name) <- cast var ->+                Syn "{}" [inv, Val (VStr name)]+            e -> e+    hyperKludged p = do+        f <- p+        return (transformHyper . f)+    transformHyper (Ann ann exp)+        = Ann ann (transformHyper exp)+    transformHyper (App (Var var) (Just inv) args)+        = App (Var var{ v_meta = MPre }) (Just inv) args+    transformHyper (Syn syn [lhs, rhs])+        = Syn "for" [lhs, Syn "block" [Syn syn [Var varTopic, rhs]]]+    transformHyper x = x++ruleInvocation :: RuleParser (Exp -> Exp)+ruleInvocation = ruleInvocationCommon False++-- used only by 'qInterpolatorPostTerm'?+ruleInvocationParens :: RuleParser (Exp -> Exp)+ruleInvocationParens = ruleInvocationCommon True++ruleNamedMethodCall :: RuleParser (Maybe Char, String)+ruleNamedMethodCall = do+    let quantifieableName   = simpleMethName <|> ruleVarName +        simpleMethName      = fmap ('&':) (ruleOperatorName <|> ruleQualifiedIdentifier)+    choice+        [ fmap ((,) Nothing) quantifieableName                                  -- .meth+        , try (oneOf "*+?" >>= \q -> fmap ((,) (Just q)) quantifieableName )    -- .+meth+        , fmap ((,) Nothing) (parseExpWithCachedParser dynParsePrePost)         -- .++        ]++ruleInvocationCommon :: Bool -> RuleParser (Exp -> Exp)+ruleInvocationCommon mustHaveParens = do+    (quant, name)   <- ruleNamedMethodCall -- XXX - .'+'?+    ruleInvocationArguments quant name mustHaveParens++ruleInvocationArguments :: Maybe Char -> String -> Bool -> RuleParser (Exp -> Exp)+ruleInvocationArguments quant name mustHaveParens = do+    (invs, args)    <- if mustHaveParens+        then do+            ruleParenArgs                          -- .foo()+            <|> (lookAhead (ruleDot >> ruleInvocationParens) >> return (Nothing, [])) -- .foo.bar()+        else do  --  $obj.foo: arg1, arg2    # listop method call+                 -- we require whitespace after the colon (but not before)+                 -- so that @list.map:{...} doesn't get interpreted the+                 -- wrong way.+            listcolon <- option False $ try $ do { char ':'; mandatoryWhiteSpace; return True }+            if listcolon+                then parseNoParenArgList+                else option (Nothing,[]) $ parseParenArgList+    when (isJust invs) $ fail "Only one invocant allowed"+    return $ \x -> case name of+        ('&':rest) -> case quant of+            Just q  -> Syn "CCallDyn" ((Val (castV [q])):Val (VStr rest):x:args)        -- '$x.*meth'+            _       -> App (_Var name) (Just x) args                                    -- '$x.meth'+        _       -> Syn "CCallDyn" (Val (castV (maybeToList quant)):_Var name:x:args)    -- '$x.$meth'++ruleArraySubscript :: RuleParser (Exp -> Exp)+ruleArraySubscript = verbatimRule "array subscript" $ do+    between (symbol "[") (char ']') $ option id $ do+        exp <- ruleExpression; return $ \x -> Syn "[]" [x, exp]++ruleHashSubscript :: RuleParser (Exp -> Exp)+ruleHashSubscript = verbatimRule "hash subscript" $ do+    choice [ ruleHashSubscriptBraces, ruleHashSubscriptQW ]++ruleHashSubscriptBraces :: RuleParser (Exp -> Exp)+ruleHashSubscriptBraces = do+    verbatimBraces $ option id $ do+        exp <- ruleExpression; return $ \x -> Syn "{}" [x, exp]++ruleHashSubscriptQW :: RuleParser (Exp -> Exp)+ruleHashSubscriptQW = do+    exp <- angleBracketLiteral+    return $ case exp of+        Syn "," []  -> id   -- %x<> means the same as %x{}+        _           -> \x -> Syn "{}" [x, exp]++ruleCodeSubscript :: RuleParser (Exp -> Exp)+ruleCodeSubscript = verbatimRule "code subscript" $ do+    (invs, args) <- ruleParenArgs+    return $ \x -> App x invs args++{-|+Match a sub application, returning the appropriate 'App' expression.++Note that this only handles regular sub application (@foo(\$bar)@) and+implicit-invocant calls (@.foo@); regular method invocation (@\$obj.foo@) is+handled by 'ruleInvocation' as a post-term ('s_postTerm').++The boolean argument is @True@ if we're trying to parse a reduce-metaop+application (e.g. @[+] 1, 2, 3@), and @False@ otherwise.++/NOTE: This is where the dot-slash and dot-colon statement+forms get parsed, so if they need to be changed\/killed, this is the place./+-}+ruleApply :: Bool -- ^ @True@ if we are parsing for the reduce-metaop+          -> RuleParser Exp+ruleApply isFolded = verbatimRule "apply" $ +    if isFolded+        then ruleApplySub True+        else ruleApplyImplicitMethod <|> ruleApplySub False++ruleApplyImplicitMethod :: RuleParser Exp+ruleApplyImplicitMethod = do+    ch <- do+        char '.'+        option '.' (char '=') -- allow ".=foo" as a term to parse as "$_ .= $_.foo".+    insertIntoPosition "."+    -- prevChar <- gets s_char+    fs <- many s_postTerm+    -- when (prevChar == '}') $ do+    --     pos <- getPosition+    --     traceM ("Warning: '{...}.method' treated as '{...}; .method' at " ++ show pos)+    let rv = (combine (reverse fs) (Var varTopic))+    return $ case ch of+        '=' -> Syn "=" [Var varTopic, rv]+        _   -> rv++ruleSubNameWithoutPostfixModifier :: RuleParser Var+ruleSubNameWithoutPostfixModifier = try $ do+    name <- ruleSubName+    case name of+        "&if"       -> fail "postfix op"+        "&unless"   -> fail "postfix op"+        "&while"    -> fail "postfix op"+        "&until"    -> fail "postfix op"+        "&given"    -> fail "postfix op"+        "&for"      -> fail "postfix op"+        _           -> return (cast name)++ruleApplySub :: Bool -> RuleParser Exp+ruleApplySub isFolded = do+    var    <- if isFolded+        then ruleFoldOp+        else ruleSubNameWithoutPostfixModifier++    (paramListInv, args) <- choice $+        [ (ruleDot `tryLookAhead` char '(') >> ruleParenArgs+        , parseParenArgList+        , mandatoryWhiteSpace >> parseNoParenArgList+        , return (Nothing, [])+        ]+    possiblyApplyMacro $ App (Var var) paramListInv args+{-+    -- True for `foo. .($bar)`-style applications+    let takeArguments = do+            (paramListInv, args) <- choice $+                [ (ruleDot `tryLookAhead` char '(') >> ruleParenArgs+                , parseParenArgList+                , mandatoryWhiteSpace >> parseNoParenArgList+                ] ++ (if isFolded then [return (Nothing, [])] else [])+            possiblyApplyMacro $ App (Var name) paramListInv args+    takeArguments+        <|> possiblyTypeLiteral name+        <|> possiblyApplyMacro (App (Var name) Nothing [])+-}++-- used only by 'ruleCodeSubscript'!+parseParenArgList :: RuleParser (Maybe Exp, [Exp])+parseParenArgList = parseParenArgListCommon True++parseParenArgListCommon :: Bool -> RuleParser (Maybe Exp, [Exp])+parseParenArgListCommon mustHaveParens = do+    leading     <- option [] $ try $ many namedAdverb+    params      <- option Nothing . fmap Just $ ruleParenArgs+    trailing    <- option [] $ try $ many pairOrBlockAdverb+    when (mustHaveParens && isNothing params && null trailing && null leading) $ fail ""+    let (inv, args) = fromMaybe (Nothing, []) params+    return (inv, leading ++ args ++ trailing)+    +-- initial helpers for demagicalized pairs+-- to DISABLE special parsing for pairs in argument-lists, replace this+-- definition with `id`+named :: RuleParser Exp -> RuleParser Exp+named parser = try $ do+    result <- parser+    case unwrap result of+        (App (Var var) Nothing [key, val])+            | var == cast "&infix:=>" -> return (Syn "named" [key, val])+        _                             -> fail "internal error--was expecting a pair"++namedArg :: RuleParser Exp+namedArg = named pairLiteral++namedArgOr :: RuleParser Exp -> RuleParser Exp+namedArgOr other = try namedArg <|> other++namedAdverb :: RuleParser Exp+namedAdverb = named pairAdverb++pairOrBlockAdverb :: RuleParser Exp+pairOrBlockAdverb = choice [ namedAdverb, blockAdverb ]++blockAdverb :: RuleParser Exp+blockAdverb = do+    char ':' `tryLookAhead` char '{'+    ruleBlockLiteral++ruleParenArgs :: RuleParser (Maybe Exp, [Exp])+ruleParenArgs = verbatimParens . enterBracketLevel ParensBracket $ do+    -- formal :: [[Exp]]+    -- outer level of listness provided by `sepEndBy`+    -- the inner (`fix`ed) part returns [Exp]+    formal <- (`sepEndBy` symbol ":") $ fix $ \rec -> do+        rv <- option Nothing $ do+            fmap Just $ choice+                [ try $ do+                    -- e.g. f( :$x :$y :$z );+                    x <- pairOrBlockAdverb+                    whiteSpace+                    return ([x], optional ruleCommaOrSemicolon)+                , do x <- namedArgOr parseExpWithItemOps+                     a <- option [] $ try $ many pairOrBlockAdverb+                     return (x:a, ruleCommaOrSemicolon)+                ]+        case rv of+            Nothing           -> return []+            Just (exp, trail) -> do+                rest <- option [] $ do { trail; rec }+                return (exp ++ rest)+    processFormals formal+-- FAILED PARSER PATCH+{-+ruleParenArgs = (<?> "paren arg-list") $ try $ verbatimParens $ do+    invocant        <- option Nothing $ try $ do+        inv <- parseExpWithItemOps+        doParseInvocantColon+        return $ Just inv+        +    leadingAdverbs  <- doParseAdverbs+    +    -- use 'sepEndBy', because `foo($bar, $baz,)` is legal+    arguments       <- parseExpWithItemOps `sepEndBy` ruleComma+    +    trailingAdverbs <- doParseAdverbs+    +    return (invocant, leadingAdverbs ++ arguments ++ trailingAdverbs)+    where+    doParseAdverbs = option [] $ try $ many pairOrBlockAdverb+    doParseInvocantColon = do+        -- make sure it's really an invocant colon, and not a :foo() or ::Foo+        -- colon+        -- To get this to work, I had to tweak 'notFollowedBy'+        notFollowedBy pairOrBlockAdverb+        notFollowedBy $ symbol "::"+        symbol ":"+-}+       ++{-+Used by:+~~~~~~~~+parseParamList (after trying parseParenArgList)+ruleInvocationParens (<= qInterpolatorPostTerm)+ruleApply (when `foo .($bar)`?) (after whitespace when there's no implicit-inv)++The only difference with parseParamList is that NoParens has to be careful not+to swallow `{}.blah`.++-}+parseNoParenArgList :: RuleParser (Maybe Exp, [Exp])+parseNoParenArgList = do+    lvl <- gets s_bracketLevel+    formal <- formalSegment lvl `sepEndBy1` (symbol ":")+    processFormals formal++formalSegment :: BracketLevel -> RuleParser [Exp]+formalSegment lvl = do+    rv <- option Nothing . fmap Just . choice $ segmentPart+    case rv of+        Nothing           -> return []+        Just (exp, trail) -> do+            rest <- option [] $ do { trail; formalSegment lvl }+            return (exp ++ rest)+    where+    segmentPart+        | ConditionalBracket <- lvl =+            [ argBlockWith pairOrBlockAdverb+            , notFollowedBy (char '{') >> argVanilla+            ]+        | otherwise = +            [ argListEndingBlock+            , argBlockWith pairOrBlockAdverb+            , argVanilla+            ]+    argListEndingBlock = do+        x <- ruleBareOrPointyBlockLiteral+        (ruleComma >> return ([x], return ())) <|> do+            -- Unless terminated by a comma, block always end the list right there.+            return ([x], mzero)+    argBlockWith :: RuleParser a -> RuleParser ([a], RuleParser ())+    argBlockWith rule = do+        x <- rule+        optional ruleComma+        return ([x], return ())+    argVanilla :: RuleParser ([Exp], RuleParser ())+    argVanilla = do+        x <- namedArgOr parseExpWithTightOps+        a <- option [] $ try $ many pairOrBlockAdverb+        return (x:a, ruleComma)+        +ruleParamName :: RuleParser String+ruleParamName = literalRule "parameter name" $ do+    -- Valid param names: $foo, @bar, &baz, %grtz, ::baka+    sigil   <- choice [ fmap show ruleSigil, string "::" ]+    if sigil == "&"+        then ruleSubNamePossiblyWithTwigil+        else do twigil <- ruleTwigil+                name   <- case twigil of+                    ""  -> many1 wordAny <|> string "/" <|> string "¢"+                    "!" -> many wordAny+                    _   -> many1 wordAny+                return $ sigil ++ twigil ++ name++-- XXX - Eventually return "Var" here and verbatimVarNameString can be the "String" form+ruleVarName :: RuleParser String+ruleVarName = lexeme verbatimVarNameString++verbatimVarNameString :: RuleParser String+verbatimVarNameString = verbatimRule "variable name" $ tryChoice+    [ string "$/"   -- match object+    , string "$µ"   -- proposed match object+    , ruleMatchPos+    , ruleMatchNamed+    , regularVarName+    , string "$!"   -- error variable+    , string "$¢"   -- match "continuation" variable+    ]++ruleSigil :: RuleParser VarSigil+ruleSigil = do+    ch  <- oneOf "$@%&"+    case cast ch of+        SArray -> option SArray (char '@' >> return SArrayMulti)+        sig -> return sig++regularVarName :: RuleParser String+regularVarName = do+    sigil   <- ruleSigil+    regularVarNameForSigil sigil++regularVarWithOptionalName :: RuleParser String+regularVarWithOptionalName = do+    sigil   <- ruleSigil+    option (show sigil) (regularVarNameForSigil sigil)++-- Twigil: ^ placeholder, * global, ? magical, . member, ! private member+-- XXX - ruleQualifiedIdentifier doesn't handle names /beginning/ with "::"+regularVarNameForSigil :: VarSigil -> RuleParser String+regularVarNameForSigil SCode = do+    name    <- ruleSubNamePossiblyWithTwigil+    sig     <- option "" $ do+        Val (VV obj) <- ruleSignatureVal+        return (show obj)+    return (name ++ sig)+regularVarNameForSigil sigil = do+    twi <- ruleTwigil+    idt <- ruleQualifiedIdentifier+    return $ shows sigil (twi ++ idt)++ruleDereference :: RuleParser Exp+ruleDereference = try $ do+    sigil   <- ruleSigil+    exp     <- ruleDereference <|> ruleSigiledVar <|> verbatimParens (option (_Var "$/") ruleExpression)+    return $ Syn (shows sigil "{}") [exp]++ruleSigiledVar :: RuleParser Exp+ruleSigiledVar = (<|> ruleSymbolicDeref) $ do+    name <- verbatimVarNameString+    let (sigil, rest) = span isSigilChar name+    case rest of+        [] -> return (makeVar name)+        _ | any (not . isWordAny) rest -> return (makeVar name)+        _ | all isDigit rest           -> return (makeVar name)+        -- XXX - Required by Test::Harness which uses @INC instead @*INC+        "INC" | "@" <- sigil           -> return (makeVar name)+        _ -> do+            -- Plain and simple variable -- do a lexical check.+            state <- get++            let var         = cast name+                env         = s_env state+                lexPads     = envLexPads env+                compPad     = envCompPad env+                outerVars   = s_outerVars state+                knownVars   = s_knownVars state++            case Map.lookup var knownVars of+                Just mpad   -> do+                    unless (Just mpad == compPad) $ do+                        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 }+                    return (makeVar name)+                _           -> do+                    -- If the variable is already defined as global, resolve it as such here.+                    foundInGlobal <- return $! unsafePerformSTM $! do+                        globPad <- readMPad (envGlobal env)+                        return $ isJust (lookupPad (toGlobalVar var) globPad)+                    when (not foundInGlobal) $ do+                        pos <- getPosition+                        when (sourceName pos /= "-e") $ do+                            fail $ "Variable " ++ show var ++ " requires predeclaration or explicit package name"+                    return (Var $ toGlobalVar var)++ruleVar :: RuleParser Exp+ruleVar = do+    exp <- ruleSigiledVar+    case exp of+        Var var -> case v_twigil var of+            TAttribute -> do+                let methName = ('&':cast (v_name var))+                postApp <- ruleInvocationArguments Nothing methName False+                return $ Syn (shows (v_sigil var) "{}") [postApp (_Var "$__SELF__")]+            TImplicit -> do+                knowns <- gets s_knownVars+                case Map.lookup var knowns of+                    Just pad -> do+                        cpad <- asks envCompPad+                        when (Just pad /= cpad) $ addImplicitVarToPad var+                    _   -> addImplicitVarToPad var+                return exp+            _   -> return exp+        _   -> return exp++addImplicitVarToPad :: Var -> RuleParser ()+addImplicitVarToPad v = do+    genNameTypeEntries SMy [(cast v{ v_twigil = TNil }, typeOfSigilVar v, mempty, Noop)]+        >>= addBlockPad++ruleSymbolicDeref :: RuleParser Exp+ruleSymbolicDeref = do+    sigil    <- ruleSigil+    nameExps <- many1 $ do+        string "::"+        -- nameExp is the expression which will yield the varname.+        -- We've to include ruleTwigil here to make $::?SELF parse.+        -- XXX: This looks slightly odd to me -- is one forced to say+        --  $::("?SELF") instead?+        (verbatimParens ruleExpression) <|> (fmap (Val . VStr) $ do+            choice+                [ string "!"  --  $!+                , string "/"  --  $/+                , fmap concat $ sequence [ruleTwigil, many1 wordAny] ])+    return $ Syn (shows sigil "::()") nameExps+
+ src/Pugs/Parser.hs-boot view
@@ -0,0 +1,24 @@+module Pugs.Parser where+import Pugs.AST+import Pugs.Parser.Types+import Pugs.Types++parseTerm :: RuleParser Exp+parseNoParenArgList :: RuleParser (Maybe Exp, [Exp])++ruleExpression :: RuleParser Exp+ruleSubName :: RuleParser String+ruleArraySubscript :: RuleParser (Exp -> Exp)+ruleHashSubscript :: RuleParser (Exp -> Exp)+ruleCodeSubscript :: RuleParser (Exp -> Exp)+ruleInvocationParens :: RuleParser (Exp -> Exp)+verbatimVarNameString :: RuleParser String+retInterpolatedBlock :: BlockInfo -> RuleParser Exp+ruleVerbatimBlock :: RuleParser BlockInfo+ruleBlockLiteral :: RuleParser Exp+ruleDoBlock :: RuleParser Exp+ruleNamedMethodCall :: RuleParser (Maybe Char, String)+ruleSigil :: RuleParser VarSigil++regularVarName :: RuleParser String+regularVarNameForSigil :: VarSigil -> RuleParser String
+ src/Pugs/Parser/Charnames.hs view
@@ -0,0 +1,297 @@+{-# OPTIONS_GHC -fglasgow-exts -fno-full-laziness -fno-cse -cpp -fallow-overlapping-instances #-}++module Pugs.Parser.Charnames (nameToCode) where++import Pugs.Internals++#ifdef PUGS_HAVE_PERL5++import Pugs.Embed.Perl5++-- If we do have Perl 5, support for all unicode names via Perl5's charnames::vianame.++nameToCode :: String -> Maybe Int+nameToCode name = inlinePerformIO $ do+    sv      <- evalPerl5 ("use utf8; use charnames ':full'; ord(qq[\\N{"++name++"}])") nullEnv 1+    svToVInt sv >>= \iv -> case iv of+        0 -> svToVStr sv >>= \pv -> case pv of+            "0" -> return (Just 0)+            _   -> return Nothing   -- undef+        x -> return (Just x)++#else++import qualified Data.HashTable as H+import Data.ByteString.Unsafe (unsafePackAddressLen)++-- If we don't have Perl 5, support for names in the 0x00 - 0xFF range only.++nameToCode :: String -> Maybe Int+nameToCode name = inlinePerformIO (H.lookup _NameToCode (cast name))++{-# NOINLINE _NameToCode #-}+_NameToCode :: H.HashTable ByteString Int+_NameToCode = unsafePerformIO $! hashList =<< mapM compute+    [ (unsafePackAddressLen 4 "NULL"#, 0x0000)+    , (unsafePackAddressLen 16 "START OF HEADING"#, 0x0001)+    , (unsafePackAddressLen 13 "START OF TEXT"#, 0x0002)+    , (unsafePackAddressLen 11 "END OF TEXT"#, 0x0003)+    , (unsafePackAddressLen 19 "END OF TRANSMISSION"#, 0x0004)+    , (unsafePackAddressLen 7 "ENQUIRY"#, 0x0005)+    , (unsafePackAddressLen 11 "ACKNOWLEDGE"#, 0x0006)+    , (unsafePackAddressLen 4 "BELL"#, 0x0007)+    , (unsafePackAddressLen 9 "BACKSPACE"#, 0x0008)+    , (unsafePackAddressLen 20 "CHARACTER TABULATION"#, 0x0009)+    , (unsafePackAddressLen 14 "LINE FEED (LF)"#, 0x000A)+    , (unsafePackAddressLen 9 "LINE FEED"#, 0x000A)+    , (unsafePackAddressLen 15 "LINE TABULATION"#, 0x000B)+    , (unsafePackAddressLen 14 "FORM FEED (FF)"#, 0x000C)+    , (unsafePackAddressLen 9 "FORM FEED"#, 0x000C)+    , (unsafePackAddressLen 20 "CARRIAGE RETURN (CR)"#, 0x000D)+    , (unsafePackAddressLen 15 "CARRIAGE RETURN"#, 0x000D)+    , (unsafePackAddressLen 9 "SHIFT OUT"#, 0x000E)+    , (unsafePackAddressLen 8 "SHIFT IN"#, 0x000F)+    , (unsafePackAddressLen 16 "DATA LINK ESCAPE"#, 0x0010)+    , (unsafePackAddressLen 18 "DEVICE CONTROL ONE"#, 0x0011)+    , (unsafePackAddressLen 18 "DEVICE CONTROL TWO"#, 0x0012)+    , (unsafePackAddressLen 20 "DEVICE CONTROL THREE"#, 0x0013)+    , (unsafePackAddressLen 19 "DEVICE CONTROL FOUR"#, 0x0014)+    , (unsafePackAddressLen 20 "NEGATIVE ACKNOWLEDGE"#, 0x0015)+    , (unsafePackAddressLen 16 "SYNCHRONOUS IDLE"#, 0x0016)+    , (unsafePackAddressLen 25 "END OF TRANSMISSION BLOCK"#, 0x0017)+    , (unsafePackAddressLen 6 "CANCEL"#, 0x0018)+    , (unsafePackAddressLen 13 "END OF MEDIUM"#, 0x0019)+    , (unsafePackAddressLen 10 "SUBSTITUTE"#, 0x001A)+    , (unsafePackAddressLen 6 "ESCAPE"#, 0x001B)+    , (unsafePackAddressLen 26 "INFORMATION SEPARATOR FOUR"#, 0x001C)+    , (unsafePackAddressLen 27 "INFORMATION SEPARATOR THREE"#, 0x001D)+    , (unsafePackAddressLen 25 "INFORMATION SEPARATOR TWO"#, 0x001E)+    , (unsafePackAddressLen 25 "INFORMATION SEPARATOR ONE"#, 0x001F)+    , (unsafePackAddressLen 5 "SPACE"#, 0x0020)+    , (unsafePackAddressLen 16 "EXCLAMATION MARK"#, 0x0021)+    , (unsafePackAddressLen 14 "QUOTATION MARK"#, 0x0022)+    , (unsafePackAddressLen 11 "NUMBER SIGN"#, 0x0023)+    , (unsafePackAddressLen 11 "DOLLAR SIGN"#, 0x0024)+    , (unsafePackAddressLen 12 "PERCENT SIGN"#, 0x0025)+    , (unsafePackAddressLen 9 "AMPERSAND"#, 0x0026)+    , (unsafePackAddressLen 10 "APOSTROPHE"#, 0x0027)+    , (unsafePackAddressLen 16 "LEFT PARENTHESIS"#, 0x0028)+    , (unsafePackAddressLen 17 "RIGHT PARENTHESIS"#, 0x0029)+    , (unsafePackAddressLen 8 "ASTERISK"#, 0x002A)+    , (unsafePackAddressLen 9 "PLUS SIGN"#, 0x002B)+    , (unsafePackAddressLen 5 "COMMA"#, 0x002C)+    , (unsafePackAddressLen 12 "HYPHEN-MINUS"#, 0x002D)+    , (unsafePackAddressLen 9 "FULL STOP"#, 0x002E)+    , (unsafePackAddressLen 7 "SOLIDUS"#, 0x002F)+    , (unsafePackAddressLen 10 "DIGIT ZERO"#, 0x0030)+    , (unsafePackAddressLen 9 "DIGIT ONE"#, 0x0031)+    , (unsafePackAddressLen 9 "DIGIT TWO"#, 0x0032)+    , (unsafePackAddressLen 11 "DIGIT THREE"#, 0x0033)+    , (unsafePackAddressLen 10 "DIGIT FOUR"#, 0x0034)+    , (unsafePackAddressLen 10 "DIGIT FIVE"#, 0x0035)+    , (unsafePackAddressLen 9 "DIGIT SIX"#, 0x0036)+    , (unsafePackAddressLen 11 "DIGIT SEVEN"#, 0x0037)+    , (unsafePackAddressLen 11 "DIGIT EIGHT"#, 0x0038)+    , (unsafePackAddressLen 10 "DIGIT NINE"#, 0x0039)+    , (unsafePackAddressLen 5 "COLON"#, 0x003A)+    , (unsafePackAddressLen 9 "SEMICOLON"#, 0x003B)+    , (unsafePackAddressLen 14 "LESS-THAN SIGN"#, 0x003C)+    , (unsafePackAddressLen 11 "EQUALS SIGN"#, 0x003D)+    , (unsafePackAddressLen 17 "GREATER-THAN SIGN"#, 0x003E)+    , (unsafePackAddressLen 13 "QUESTION MARK"#, 0x003F)+    , (unsafePackAddressLen 13 "COMMERCIAL AT"#, 0x0040)+    , (unsafePackAddressLen 22 "LATIN CAPITAL LETTER A"#, 0x0041)+    , (unsafePackAddressLen 22 "LATIN CAPITAL LETTER B"#, 0x0042)+    , (unsafePackAddressLen 22 "LATIN CAPITAL LETTER C"#, 0x0043)+    , (unsafePackAddressLen 22 "LATIN CAPITAL LETTER D"#, 0x0044)+    , (unsafePackAddressLen 22 "LATIN CAPITAL LETTER E"#, 0x0045)+    , (unsafePackAddressLen 22 "LATIN CAPITAL LETTER F"#, 0x0046)+    , (unsafePackAddressLen 22 "LATIN CAPITAL LETTER G"#, 0x0047)+    , (unsafePackAddressLen 22 "LATIN CAPITAL LETTER H"#, 0x0048)+    , (unsafePackAddressLen 22 "LATIN CAPITAL LETTER I"#, 0x0049)+    , (unsafePackAddressLen 22 "LATIN CAPITAL LETTER J"#, 0x004A)+    , (unsafePackAddressLen 22 "LATIN CAPITAL LETTER K"#, 0x004B)+    , (unsafePackAddressLen 22 "LATIN CAPITAL LETTER L"#, 0x004C)+    , (unsafePackAddressLen 22 "LATIN CAPITAL LETTER M"#, 0x004D)+    , (unsafePackAddressLen 22 "LATIN CAPITAL LETTER N"#, 0x004E)+    , (unsafePackAddressLen 22 "LATIN CAPITAL LETTER O"#, 0x004F)+    , (unsafePackAddressLen 22 "LATIN CAPITAL LETTER P"#, 0x0050)+    , (unsafePackAddressLen 22 "LATIN CAPITAL LETTER Q"#, 0x0051)+    , (unsafePackAddressLen 22 "LATIN CAPITAL LETTER R"#, 0x0052)+    , (unsafePackAddressLen 22 "LATIN CAPITAL LETTER S"#, 0x0053)+    , (unsafePackAddressLen 22 "LATIN CAPITAL LETTER T"#, 0x0054)+    , (unsafePackAddressLen 22 "LATIN CAPITAL LETTER U"#, 0x0055)+    , (unsafePackAddressLen 22 "LATIN CAPITAL LETTER V"#, 0x0056)+    , (unsafePackAddressLen 22 "LATIN CAPITAL LETTER W"#, 0x0057)+    , (unsafePackAddressLen 22 "LATIN CAPITAL LETTER X"#, 0x0058)+    , (unsafePackAddressLen 22 "LATIN CAPITAL LETTER Y"#, 0x0059)+    , (unsafePackAddressLen 22 "LATIN CAPITAL LETTER Z"#, 0x005A)+    , (unsafePackAddressLen 19 "LEFT SQUARE BRACKET"#, 0x005B)+    , (unsafePackAddressLen 15 "REVERSE SOLIDUS"#, 0x005C)+    , (unsafePackAddressLen 20 "RIGHT SQUARE BRACKET"#, 0x005D)+    , (unsafePackAddressLen 17 "CIRCUMFLEX ACCENT"#, 0x005E)+    , (unsafePackAddressLen 8 "LOW LINE"#, 0x005F)+    , (unsafePackAddressLen 12 "GRAVE ACCENT"#, 0x0060)+    , (unsafePackAddressLen 20 "LATIN SMALL LETTER A"#, 0x0061)+    , (unsafePackAddressLen 20 "LATIN SMALL LETTER B"#, 0x0062)+    , (unsafePackAddressLen 20 "LATIN SMALL LETTER C"#, 0x0063)+    , (unsafePackAddressLen 20 "LATIN SMALL LETTER D"#, 0x0064)+    , (unsafePackAddressLen 20 "LATIN SMALL LETTER E"#, 0x0065)+    , (unsafePackAddressLen 20 "LATIN SMALL LETTER F"#, 0x0066)+    , (unsafePackAddressLen 20 "LATIN SMALL LETTER G"#, 0x0067)+    , (unsafePackAddressLen 20 "LATIN SMALL LETTER H"#, 0x0068)+    , (unsafePackAddressLen 20 "LATIN SMALL LETTER I"#, 0x0069)+    , (unsafePackAddressLen 20 "LATIN SMALL LETTER J"#, 0x006A)+    , (unsafePackAddressLen 20 "LATIN SMALL LETTER K"#, 0x006B)+    , (unsafePackAddressLen 20 "LATIN SMALL LETTER L"#, 0x006C)+    , (unsafePackAddressLen 20 "LATIN SMALL LETTER M"#, 0x006D)+    , (unsafePackAddressLen 20 "LATIN SMALL LETTER N"#, 0x006E)+    , (unsafePackAddressLen 20 "LATIN SMALL LETTER O"#, 0x006F)+    , (unsafePackAddressLen 20 "LATIN SMALL LETTER P"#, 0x0070)+    , (unsafePackAddressLen 20 "LATIN SMALL LETTER Q"#, 0x0071)+    , (unsafePackAddressLen 20 "LATIN SMALL LETTER R"#, 0x0072)+    , (unsafePackAddressLen 20 "LATIN SMALL LETTER S"#, 0x0073)+    , (unsafePackAddressLen 20 "LATIN SMALL LETTER T"#, 0x0074)+    , (unsafePackAddressLen 20 "LATIN SMALL LETTER U"#, 0x0075)+    , (unsafePackAddressLen 20 "LATIN SMALL LETTER V"#, 0x0076)+    , (unsafePackAddressLen 20 "LATIN SMALL LETTER W"#, 0x0077)+    , (unsafePackAddressLen 20 "LATIN SMALL LETTER X"#, 0x0078)+    , (unsafePackAddressLen 20 "LATIN SMALL LETTER Y"#, 0x0079)+    , (unsafePackAddressLen 20 "LATIN SMALL LETTER Z"#, 0x007A)+    , (unsafePackAddressLen 18 "LEFT CURLY BRACKET"#, 0x007B)+    , (unsafePackAddressLen 13 "VERTICAL LINE"#, 0x007C)+    , (unsafePackAddressLen 19 "RIGHT CURLY BRACKET"#, 0x007D)+    , (unsafePackAddressLen 5 "TILDE"#, 0x007E)+    , (unsafePackAddressLen 6 "DELETE"#, 0x007F)+    , (unsafePackAddressLen 20 "BREAK PERMITTED HERE"#, 0x0082)+    , (unsafePackAddressLen 13 "NO BREAK HERE"#, 0x0083)+    , (unsafePackAddressLen 15 "NEXT LINE (NEL)"#, 0x0085)+    , (unsafePackAddressLen 9 "NEXT LINE"#, 0x0085)+    , (unsafePackAddressLen 22 "START OF SELECTED AREA"#, 0x0086)+    , (unsafePackAddressLen 20 "END OF SELECTED AREA"#, 0x0087)+    , (unsafePackAddressLen 24 "CHARACTER TABULATION SET"#, 0x0088)+    , (unsafePackAddressLen 39 "CHARACTER TABULATION WITH JUSTIFICATION"#, 0x0089)+    , (unsafePackAddressLen 19 "LINE TABULATION SET"#, 0x008A)+    , (unsafePackAddressLen 20 "PARTIAL LINE FORWARD"#, 0x008B)+    , (unsafePackAddressLen 21 "PARTIAL LINE BACKWARD"#, 0x008C)+    , (unsafePackAddressLen 17 "REVERSE LINE FEED"#, 0x008D)+    , (unsafePackAddressLen 16 "SINGLE SHIFT TWO"#, 0x008E)+    , (unsafePackAddressLen 18 "SINGLE SHIFT THREE"#, 0x008F)+    , (unsafePackAddressLen 21 "DEVICE CONTROL STRING"#, 0x0090)+    , (unsafePackAddressLen 15 "PRIVATE USE ONE"#, 0x0091)+    , (unsafePackAddressLen 15 "PRIVATE USE TWO"#, 0x0092)+    , (unsafePackAddressLen 18 "SET TRANSMIT STATE"#, 0x0093)+    , (unsafePackAddressLen 16 "CANCEL CHARACTER"#, 0x0094)+    , (unsafePackAddressLen 15 "MESSAGE WAITING"#, 0x0095)+    , (unsafePackAddressLen 21 "START OF GUARDED AREA"#, 0x0096)+    , (unsafePackAddressLen 19 "END OF GUARDED AREA"#, 0x0097)+    , (unsafePackAddressLen 15 "START OF STRING"#, 0x0098)+    , (unsafePackAddressLen 27 "SINGLE CHARACTER INTRODUCER"#, 0x009A)+    , (unsafePackAddressLen 27 "CONTROL SEQUENCE INTRODUCER"#, 0x009B)+    , (unsafePackAddressLen 17 "STRING TERMINATOR"#, 0x009C)+    , (unsafePackAddressLen 24 "OPERATING SYSTEM COMMAND"#, 0x009D)+    , (unsafePackAddressLen 15 "PRIVACY MESSAGE"#, 0x009E)+    , (unsafePackAddressLen 27 "APPLICATION PROGRAM COMMAND"#, 0x009F)+    , (unsafePackAddressLen 14 "NO-BREAK SPACE"#, 0x00A0)+    , (unsafePackAddressLen 25 "INVERTED EXCLAMATION MARK"#, 0x00A1)+    , (unsafePackAddressLen 9 "CENT SIGN"#, 0x00A2)+    , (unsafePackAddressLen 10 "POUND SIGN"#, 0x00A3)+    , (unsafePackAddressLen 13 "CURRENCY SIGN"#, 0x00A4)+    , (unsafePackAddressLen 8 "YEN SIGN"#, 0x00A5)+    , (unsafePackAddressLen 10 "BROKEN BAR"#, 0x00A6)+    , (unsafePackAddressLen 12 "SECTION SIGN"#, 0x00A7)+    , (unsafePackAddressLen 9 "DIAERESIS"#, 0x00A8)+    , (unsafePackAddressLen 14 "COPYRIGHT SIGN"#, 0x00A9)+    , (unsafePackAddressLen 26 "FEMININE ORDINAL INDICATOR"#, 0x00AA)+    , (unsafePackAddressLen 41 "LEFT-POINTING DOUBLE ANGLE QUOTATION MARK"#, 0x00AB)+    , (unsafePackAddressLen 8 "NOT SIGN"#, 0x00AC)+    , (unsafePackAddressLen 11 "SOFT HYPHEN"#, 0x00AD)+    , (unsafePackAddressLen 15 "REGISTERED SIGN"#, 0x00AE)+    , (unsafePackAddressLen 6 "MACRON"#, 0x00AF)+    , (unsafePackAddressLen 11 "DEGREE SIGN"#, 0x00B0)+    , (unsafePackAddressLen 15 "PLUS-MINUS SIGN"#, 0x00B1)+    , (unsafePackAddressLen 15 "SUPERSCRIPT TWO"#, 0x00B2)+    , (unsafePackAddressLen 17 "SUPERSCRIPT THREE"#, 0x00B3)+    , (unsafePackAddressLen 12 "ACUTE ACCENT"#, 0x00B4)+    , (unsafePackAddressLen 10 "MICRO SIGN"#, 0x00B5)+    , (unsafePackAddressLen 12 "PILCROW SIGN"#, 0x00B6)+    , (unsafePackAddressLen 10 "MIDDLE DOT"#, 0x00B7)+    , (unsafePackAddressLen 7 "CEDILLA"#, 0x00B8)+    , (unsafePackAddressLen 15 "SUPERSCRIPT ONE"#, 0x00B9)+    , (unsafePackAddressLen 27 "MASCULINE ORDINAL INDICATOR"#, 0x00BA)+    , (unsafePackAddressLen 42 "RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK"#, 0x00BB)+    , (unsafePackAddressLen 27 "VULGAR FRACTION ONE QUARTER"#, 0x00BC)+    , (unsafePackAddressLen 24 "VULGAR FRACTION ONE HALF"#, 0x00BD)+    , (unsafePackAddressLen 30 "VULGAR FRACTION THREE QUARTERS"#, 0x00BE)+    , (unsafePackAddressLen 22 "INVERTED QUESTION MARK"#, 0x00BF)+    , (unsafePackAddressLen 33 "LATIN CAPITAL LETTER A WITH GRAVE"#, 0x00C0)+    , (unsafePackAddressLen 33 "LATIN CAPITAL LETTER A WITH ACUTE"#, 0x00C1)+    , (unsafePackAddressLen 38 "LATIN CAPITAL LETTER A WITH CIRCUMFLEX"#, 0x00C2)+    , (unsafePackAddressLen 33 "LATIN CAPITAL LETTER A WITH TILDE"#, 0x00C3)+    , (unsafePackAddressLen 37 "LATIN CAPITAL LETTER A WITH DIAERESIS"#, 0x00C4)+    , (unsafePackAddressLen 38 "LATIN CAPITAL LETTER A WITH RING ABOVE"#, 0x00C5)+    , (unsafePackAddressLen 23 "LATIN CAPITAL LETTER AE"#, 0x00C6)+    , (unsafePackAddressLen 35 "LATIN CAPITAL LETTER C WITH CEDILLA"#, 0x00C7)+    , (unsafePackAddressLen 33 "LATIN CAPITAL LETTER E WITH GRAVE"#, 0x00C8)+    , (unsafePackAddressLen 33 "LATIN CAPITAL LETTER E WITH ACUTE"#, 0x00C9)+    , (unsafePackAddressLen 38 "LATIN CAPITAL LETTER E WITH CIRCUMFLEX"#, 0x00CA)+    , (unsafePackAddressLen 37 "LATIN CAPITAL LETTER E WITH DIAERESIS"#, 0x00CB)+    , (unsafePackAddressLen 33 "LATIN CAPITAL LETTER I WITH GRAVE"#, 0x00CC)+    , (unsafePackAddressLen 33 "LATIN CAPITAL LETTER I WITH ACUTE"#, 0x00CD)+    , (unsafePackAddressLen 38 "LATIN CAPITAL LETTER I WITH CIRCUMFLEX"#, 0x00CE)+    , (unsafePackAddressLen 37 "LATIN CAPITAL LETTER I WITH DIAERESIS"#, 0x00CF)+    , (unsafePackAddressLen 24 "LATIN CAPITAL LETTER ETH"#, 0x00D0)+    , (unsafePackAddressLen 33 "LATIN CAPITAL LETTER N WITH TILDE"#, 0x00D1)+    , (unsafePackAddressLen 33 "LATIN CAPITAL LETTER O WITH GRAVE"#, 0x00D2)+    , (unsafePackAddressLen 33 "LATIN CAPITAL LETTER O WITH ACUTE"#, 0x00D3)+    , (unsafePackAddressLen 38 "LATIN CAPITAL LETTER O WITH CIRCUMFLEX"#, 0x00D4)+    , (unsafePackAddressLen 33 "LATIN CAPITAL LETTER O WITH TILDE"#, 0x00D5)+    , (unsafePackAddressLen 37 "LATIN CAPITAL LETTER O WITH DIAERESIS"#, 0x00D6)+    , (unsafePackAddressLen 19 "MULTIPLICATION SIGN"#, 0x00D7)+    , (unsafePackAddressLen 34 "LATIN CAPITAL LETTER O WITH STROKE"#, 0x00D8)+    , (unsafePackAddressLen 33 "LATIN CAPITAL LETTER U WITH GRAVE"#, 0x00D9)+    , (unsafePackAddressLen 33 "LATIN CAPITAL LETTER U WITH ACUTE"#, 0x00DA)+    , (unsafePackAddressLen 38 "LATIN CAPITAL LETTER U WITH CIRCUMFLEX"#, 0x00DB)+    , (unsafePackAddressLen 37 "LATIN CAPITAL LETTER U WITH DIAERESIS"#, 0x00DC)+    , (unsafePackAddressLen 33 "LATIN CAPITAL LETTER Y WITH ACUTE"#, 0x00DD)+    , (unsafePackAddressLen 26 "LATIN CAPITAL LETTER THORN"#, 0x00DE)+    , (unsafePackAddressLen 26 "LATIN SMALL LETTER SHARP S"#, 0x00DF)+    , (unsafePackAddressLen 31 "LATIN SMALL LETTER A WITH GRAVE"#, 0x00E0)+    , (unsafePackAddressLen 31 "LATIN SMALL LETTER A WITH ACUTE"#, 0x00E1)+    , (unsafePackAddressLen 36 "LATIN SMALL LETTER A WITH CIRCUMFLEX"#, 0x00E2)+    , (unsafePackAddressLen 31 "LATIN SMALL LETTER A WITH TILDE"#, 0x00E3)+    , (unsafePackAddressLen 35 "LATIN SMALL LETTER A WITH DIAERESIS"#, 0x00E4)+    , (unsafePackAddressLen 36 "LATIN SMALL LETTER A WITH RING ABOVE"#, 0x00E5)+    , (unsafePackAddressLen 21 "LATIN SMALL LETTER AE"#, 0x00E6)+    , (unsafePackAddressLen 33 "LATIN SMALL LETTER C WITH CEDILLA"#, 0x00E7)+    , (unsafePackAddressLen 31 "LATIN SMALL LETTER E WITH GRAVE"#, 0x00E8)+    , (unsafePackAddressLen 31 "LATIN SMALL LETTER E WITH ACUTE"#, 0x00E9)+    , (unsafePackAddressLen 36 "LATIN SMALL LETTER E WITH CIRCUMFLEX"#, 0x00EA)+    , (unsafePackAddressLen 35 "LATIN SMALL LETTER E WITH DIAERESIS"#, 0x00EB)+    , (unsafePackAddressLen 31 "LATIN SMALL LETTER I WITH GRAVE"#, 0x00EC)+    , (unsafePackAddressLen 31 "LATIN SMALL LETTER I WITH ACUTE"#, 0x00ED)+    , (unsafePackAddressLen 36 "LATIN SMALL LETTER I WITH CIRCUMFLEX"#, 0x00EE)+    , (unsafePackAddressLen 35 "LATIN SMALL LETTER I WITH DIAERESIS"#, 0x00EF)+    , (unsafePackAddressLen 22 "LATIN SMALL LETTER ETH"#, 0x00F0)+    , (unsafePackAddressLen 31 "LATIN SMALL LETTER N WITH TILDE"#, 0x00F1)+    , (unsafePackAddressLen 31 "LATIN SMALL LETTER O WITH GRAVE"#, 0x00F2)+    , (unsafePackAddressLen 31 "LATIN SMALL LETTER O WITH ACUTE"#, 0x00F3)+    , (unsafePackAddressLen 36 "LATIN SMALL LETTER O WITH CIRCUMFLEX"#, 0x00F4)+    , (unsafePackAddressLen 31 "LATIN SMALL LETTER O WITH TILDE"#, 0x00F5)+    , (unsafePackAddressLen 35 "LATIN SMALL LETTER O WITH DIAERESIS"#, 0x00F6)+    , (unsafePackAddressLen 13 "DIVISION SIGN"#, 0x00F7)+    , (unsafePackAddressLen 32 "LATIN SMALL LETTER O WITH STROKE"#, 0x00F8)+    , (unsafePackAddressLen 31 "LATIN SMALL LETTER U WITH GRAVE"#, 0x00F9)+    , (unsafePackAddressLen 31 "LATIN SMALL LETTER U WITH ACUTE"#, 0x00FA)+    , (unsafePackAddressLen 36 "LATIN SMALL LETTER U WITH CIRCUMFLEX"#, 0x00FB)+    , (unsafePackAddressLen 35 "LATIN SMALL LETTER U WITH DIAERESIS"#, 0x00FC)+    , (unsafePackAddressLen 31 "LATIN SMALL LETTER Y WITH ACUTE"#, 0x00FD)+    , (unsafePackAddressLen 24 "LATIN SMALL LETTER THORN"#, 0x00FE)+    , (unsafePackAddressLen 35 "LATIN SMALL LETTER Y WITH DIAERESIS"#, 0x00FF)+    ]+    where+    hashList :: [(ByteString, a)] -> IO (H.HashTable ByteString a)+    hashList = H.fromList hashByteString+    compute (f, y) = f >>= \x -> return (x, y)++#endif
+ src/Pugs/Parser/Doc.hs view
@@ -0,0 +1,105 @@+{-# OPTIONS_GHC -fglasgow-exts -funbox-strict-fields -fno-full-laziness -fno-cse #-}++module Pugs.Parser.Doc (+    ruleDocBlock,+) where+import Pugs.Internals+import Pugs.AST+import Pugs.Lexer+import Pugs.Rule+import Pugs.Parser.Types+import Pugs.Parser.Unsafe++-- Inline Documentation ----------------------------------------++{-|+Assert that we're at the beginning of a line, but consume no input (and produce+no result).++Used by 'ruleDocIntroducer', because POD-style regions must have their \'@=@\'+at the beginning of a line.+-}+ruleBeginOfLine :: RuleParser ()+ruleBeginOfLine = do+    pos <- getPosition+    when (sourceColumn pos /= 1) $ fail ""+    return ()++{-|+Match a single \'@=@\', but only if it occurs as the first character of a line.+-}+ruleDocIntroducer :: RuleParser Char+ruleDocIntroducer = (<?> "Doc intro") $ do+    ruleBeginOfLine+    char '='++ruleDocBody :: DocHead -> RuleParser [String]+ruleDocBody docHead = (eof >> return []) <|> do+    line    <- ruleDocLine+    case dropTrailingSpaces line of+        "=cut"  -> return []+        "=end"  -> return []+        ('=':'e':'n':'d':' ':sec) | docHead /= Misc, sec == headSection docHead -> return []+        ""  | For{} <- docHead  -> return []+        _       -> do+            lines   <- ruleDocBody docHead+            return (line:lines)++ruleDocLine :: RuleParser String+ruleDocLine = many (satisfy (/= '\n'))+    `finallyM` (eof <|> (newline >> return ()))++dropTrailingSpaces :: String -> String+dropTrailingSpaces = reverse .  dropWhile isSpace . reverse++type Section = String+data DocHead+    = Begin { headSection :: Section }+    | For { headSection :: Section, headText :: String }+    | Cut+    | Misc+    deriving (Eq)++ruleDocBlock :: RuleParser Exp+ruleDocBlock = verbatimRule "Doc block" $ do+    docHead <- try $ do+        ruleDocIntroducer+        introducer <- do+            c   <- wordAlpha+            cs  <- many $ satisfy (not . isSpace)+            return (c:cs)+        section <- option "" $ do+            skipMany1 (char ' ')+            ruleDocLine+        return $ case introducer of+            "begin" | not (null section)    -> Begin (dropTrailingSpaces section)+            "for"   | not (null section)    -> uncurry For (break isSpace section)+            "cut"   | null section          -> Cut+            _                               -> Misc+    case docHead of+        Cut -> do+            fail "=cut does not start a POD block; please remove this line"+            return emptyExp  -- "=cut" does not start a block (unspecced but useful)+        Misc -> do+            ruleDocBody Misc+            whiteSpace+            return emptyExp+        Begin "END" -> do+            setInput ""+            return emptyExp+        _ -> do+            let section = headSection docHead +            rv <- do+                lns <- ruleDocBody docHead+                let lns' | For { headText = (_:txt) } <- docHead = txt:lns+                         | otherwise = lns+                    linesVal    = map VStr lns'+                    linesStr    = unlines lns'+                    linesList   = VList (length linesVal `seq` linesVal)+                unsafeEvalExp $ Stmts+                    (App (_Var "&push") (Just $ _Var ("@=" ++ section)) [Val (VStr linesStr)])+                    $ Stmts +                        (App (_Var "&push") (Just $ _Var ("$=" ++ section)) [Val linesList])+                        (App (_Var "&push") (Just $ Syn "{}" [_Var "%=POD", Val (VStr section)]) [Val linesList])+            whiteSpace+            return (rv `seq` emptyExp)
+ src/Pugs/Parser/Export.hs view
@@ -0,0 +1,24 @@+{-# OPTIONS_GHC -fglasgow-exts #-}++{-|+    Symbol export.+-}++module Pugs.Parser.Export (+    exportSym,+) where+import Pugs.Internals+import Pugs.AST++import Pugs.Parser.Types+import Pugs.Parser.Unsafe+import Pugs.Lexer (isWordAlpha)++exportSym :: Scope -> String -> Val -> RuleParser ()+exportSym scope name@('&':_) ref = do+    pad <- unsafeEvalLexDiff $ _Sym scope name mempty (Val ref) Noop+    addBlockPad pad+exportSym scope subname@(sig:_) ref | isWordAlpha sig = do+    exportSym scope ('&':subname) ref+exportSym _ _ _ = fail "Non-Code exports does not work yet"+--exportSym' scope name sym = other vars...
+ src/Pugs/Parser/Literal.hs view
@@ -0,0 +1,686 @@+{-# OPTIONS_GHC -fglasgow-exts -fallow-overlapping-instances #-}+module Pugs.Parser.Literal where++import Pugs.Internals+import Pugs.AST+import Pugs.Lexer+import Pugs.Rule+import Pugs.Types++import Pugs.Parser.Types+import Pugs.Parser.Operator+import Pugs.Parser.Util+import Pugs.Parser.Number+import {-# SOURCE #-} Pugs.Parser++ruleLit :: RuleParser Exp+ruleLit = do+    lvl <- gets s_bracketLevel+    let blk | ConditionalBracket <- lvl = id+            | otherwise                 = (ruleBlockLiteral:)+    choice ( ruleDoBlock : blk+        [ numLiteral+        , arrayLiteral+        , pairLiteral+        , undefLiteral+        , namedLiteral "NaN"    (VNum $ 0/0)+        , namedLiteral "Inf"    (VNum $ 1/0)+        , namedLiteral "*"      (VNum $ 1/0)+        , yadaLiteral+        , qLiteral+        , rxLiteral+        , rxLiteralBare+        , substLiteral+        , nullaryLiteral+        ])++nullaryLiteral :: RuleParser Exp+nullaryLiteral = parseExpWithCachedParser dynParseNullary++{-|+Match the literal @undef@, returning an expression representing the undefined+value.+-}+undefLiteral :: RuleParser Exp+undefLiteral = do+    symbol "undef"+    return $ Val VUndef++numLiteral :: RuleParser Exp+numLiteral = do+    n <- naturalOrRat+    -- XXX - This is a hack to allow \b to work with numbers+    --       because Parser.Number is currently not a RuleParser+    -- modify $ \state -> state{ s_char = '0' }+    case n of+        Left  i -> return . Val $ VInt i+        Right d -> return . Val $ VRat d++arrayLiteral :: RuleParser Exp+arrayLiteral = try $ do+    item <- verbatimBrackets ruleBracketedExpression+    return $ Syn "\\[]" [item]++ruleBracketedExpression :: RuleParser Exp+ruleBracketedExpression = enterBracketLevel ParensBracket $+    ruleExpression <|> do { whiteSpace; return (Syn "," []) }++{-|+Match a pair literal -- either an arrow pair (@a => 'b'@), or an adverbial pair+(@:foo('bar')@).+-}+pairLiteral :: RuleParser Exp+pairLiteral = choice [ pairArrow, pairAdverb ]++pairArrow :: RuleParser Exp+pairArrow = do+    key <- identifier `tryFollowedBy` symbol "=>"+    val <- parseExpWithTightOps+    return (Val (VStr key), val)+    return $ App (_Var "&infix:=>") Nothing [Val (VStr key), val]++pairAdverb :: RuleParser Exp+pairAdverb = try $ do+    char ':'+    negatedPair <|> shortcutPair <|> regularAdverbPair+    where+    negatedPair = do+        char '!'+        key <- many1 wordAny+        return $ App (_Var "&infix:=>") Nothing [Val (VStr key), Val (VBool False)]+    shortcutPair = do+        (s:ss)              <- fmap reverse (many1 ruleSigil)+        varExp@(Var var)    <- fmap _Var (regularVarNameForSigil s)+        -- This turns ":$$$x" into "x=>$$$x"+        let appCast sig exp = Syn (shows sig "{}") [exp]+        return $ App (_Var "&infix:=>") Nothing+            [ Val (VStr $ cast (v_name var))+            , foldr appCast varExp ss+            ]++regularAdverbPair :: RuleParser Exp+regularAdverbPair = do+    key <- many1 wordAny+    lvl <- gets s_bracketLevel+    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]+        else App (_Var "&infix:=>") Nothing [Val (VStr key), val]+    where+    valueExp lvl = do+        let blk | ConditionalBracket <- lvl = id+                | QuoteAdverbBracket <- lvl = const [verbatimParens ruleBracketedExpression]+                | otherwise                 = (ruleBlockLiteral:)+        choice . blk $+            [ verbatimParens ruleBracketedExpression+            , arrayLiteral+            , angleBracketLiteral+            ]+++{-|+Match one of the \'yada-yada-yada\' placeholder expressions (@...@, @???@ or+@!!!@), returning a call to @&fail@, @&warn@ or @&die@ respectively.+-}+yadaLiteral :: RuleParser Exp+yadaLiteral = expRule $ do+    sym  <- choice . map symbol $ words " ... ??? !!! "+    exp <- option emptyExp ruleExpression+    return $ App (_Var $ doYada sym) Nothing $+        if exp == emptyExp+            then [(Val $ VStr "Unimplemented stub called")]+            else [exp]+    where+    doYada "..." = "&fail"+    doYada "???" = "&warn"+    doYada "!!!" = "&die"+    doYada _ = error "Bad yada symbol"++{-|+Match the given literal string (as a lexeme), returning the second argument in+a 'Pugs.AST.Internals.Val' expression.++Used by 'ruleLit' for @NaN@ and @Inf@.+-}+namedLiteral :: String -- Literal string to match+             -> Val    -- Value to return+             -> RuleParser Exp+namedLiteral n v = do { symbol n; return $ Val v }++ruleCommaOrSemicolon :: RuleParser ()+ruleCommaOrSemicolon = do+    lexeme (oneOf ",;")+    return ()++ruleTwigil :: RuleParser String+ruleTwigil = verbatimRule "twigil" . option "" $ do+    fmap (:[]) (oneOf "^*?.!+;=")++ruleMatchPos :: RuleParser String+ruleMatchPos = verbatimRule "positional match variable" $ do+    sigil   <- oneOf "$@%"+    digits  <- many1 digit+    return $ (sigil:digits)++ruleMatchNamed :: RuleParser String+ruleMatchNamed = verbatimRule "named match variable" $ do+    sigil   <- oneOf "$@%"+    twigil  <- char '<'+    name    <- many (do { char '\\'; anyChar } <|> satisfy (/= '>'))+    char '>'+    return $ (sigil:twigil:name) ++ ">"++ruleDot :: RuleParser ()+ruleDot = verbatimRule "dot" $ do+    try (char '.' >> notFollowedBy (char '.')) <|> ruleLongDot++ruleLongDot :: RuleParser ()+ruleLongDot = verbatimRule "long dot" $ do+    try (char '\\' >> notFollowedBy (char '('))+    whiteSpace+    char '.'+    return ()++{-+-- zero-width, non-consuming word boundary assertion (\b)+ruleWordBoundary :: RuleParser ()+ruleWordBoundary = verbatimRule "word boundary" $ do+    cls <- getPrevCharClass+    look $ if (cls == SpaceClass) then (/=) else (==)+    return ()+    where+    look op = lookAhead (satisfy (\c -> SpaceClass `op` charClassOf c))+-}++-- Interpolating constructs+qInterpolatorChar :: RuleParser Exp+qInterpolatorChar = do+    char '\\'+    nextchar <- escapeCode -- see Lexer.hs+    return (Val $ VStr nextchar)++qInterpolateDelimiter :: Char -> RuleParser Exp+qInterpolateDelimiter protectedChar = do+    char '\\'+    c <- oneOf (protectedChar:"\\")+    return (Val $ VStr [c])++qInterpolateDelimiterBalanced :: Char -> RuleParser Exp+qInterpolateDelimiterBalanced protectedChar = do+    char '\\'+    c <- oneOf (protectedChar:balancedDelim protectedChar:"\\")+    return (Val $ VStr ['\\',c])++qInterpolateQuoteConstruct :: RuleParser Exp+qInterpolateQuoteConstruct = try $ do+    string "\\"+    (qStart, qEnd, flags) <- qStructure+    expr <- interpolatingStringLiteral qStart qEnd (qInterpolator flags)+    return expr++-- If we have dot, always consume it+qInterpolatorPostTerm :: RuleParser (Exp -> Exp)+qInterpolatorPostTerm = do+    choice+        [ ruleDot `tryLookAhead` (oneOf "[{(<\xAB" <|> (ruleNamedMethodCall >> oneOf ".("))+        , notFollowedBy (ruleDot >> return '.')+        ]+    choice+        [ ruleArraySubscript+        , ruleHashSubscript+        , ruleCodeSubscript+        , try ruleInvocationParens+        ]++qInterpolator :: QFlags -> RuleParser Exp+qInterpolator flags = choice [+        closure,+        backslash,+        variable,+        substring+    ]+    where+        substring = if qfSplitWords flags == QS_Protect +            -- "Ann Parens" here means no double-interpolation in q:ww+            then fmap (Ann Parens) (lookAhead (oneOf "'\"") >> qLiteral)+            else mzero+        closure = if qfInterpolateClosure flags+            then retInterpolatedBlock =<< ruleVerbatimBlock+            else mzero+        backslash = case qfInterpolateBackslash flags of+            QB_All -> try qInterpolatorChar+               <|> (try qInterpolateQuoteConstruct)+               <|> (try $ qInterpolateDelimiter $ qfProtectedChar flags)+            QB_Single -> try qInterpolateQuoteConstruct+               <|> (try $ qInterpolateDelimiter $ qfProtectedChar flags)+            QB_Balanced -> try $ qInterpolateDelimiterBalanced $ qfProtectedChar flags+            QB_No -> mzero+        variable = try $ do+            var <- verbatimVarNameString+            fs <- case head var of+                '$' -> if qfInterpolateScalar flags &&+                          notProtected var flags+                    then many qInterpolatorPostTerm+                    else fail ""+                '@' -> if qfInterpolateArray flags+                    then many1 qInterpolatorPostTerm+                    else fail ""+                '%' -> if qfInterpolateHash flags+                    then many1 qInterpolatorPostTerm+                    else fail ""+                '&' -> if qfInterpolateFunction flags+                    then many1 qInterpolatorPostTerm+                    else fail ""+                _   -> fail ""+            return $ combine (reverse fs) (makeVar var)+        notProtected var flags =+            if second == qfProtectedChar flags+                then False --  $ followed by delimiter is protected+                else if qfP5RegularExpression flags &&+                        second `elem` ")]# \t"+                {- XXX this doesn't support Unicode whitespace. I'm not+                   sure this is a problem, because it's primarily meant+                   for legacy Perl 5 code -}+                    then False --  $ followed by )]# or whitespace+                    else True --  $ followed by anything else is interpolated+            where second = head $ tail var++qLiteral :: RuleParser Exp+qLiteral = do -- This should include q:anything// as well as '' "" <>+    (try qLiteralToEof) <|> do+    (qStart, qEnd, flags) <- getQDelim+    if not (qfHereDoc flags) then qLiteral1 qStart qEnd flags else do+        markerExp  <- qLiteral1 qStart qEnd qFlags+        case unwrap markerExp of+            Val (VStr endMarker) -> do+                (restOfLine:restOfInput)    <- fmap lines getInput+                -- When end marker is "END", a line matches it if it looks like "   END".+                let foundEndMarker line+                        = (endMarker `isSuffixOf` line)+                            && (all isSpace (take (length line - length endMarker) line))+                case break foundEndMarker restOfInput of+                    (_, []) -> fail $ "Cannot find heredoc END marker: " ++ show endMarker+                    (pre, (pivot:post)) -> do+                        let indent = indentLevelOf (take (length pivot - length endMarker) pivot)+                        -- Strip indentation from the hereDoc lines+                        strippedLines <- mapM (stripIndent indent) pre+                        setInput (unlines strippedLines)+                        -- Now reparse hereDoc using the original qFlags+                        docExp <- qLiteral1 (fail "") (eof >> return "") flags+                        -- Now restore the original input stream with hereDoc stuffed with \n+                        setInput (restOfLine ++ (replicate (length pre + 1) '\n') ++ unlines post)+                        return docExp+            others -> do+                fail $ "Cannot handle heredoc END marker: " ++ show others++indentLevelOf :: String -> Int+indentLevelOf = foldl doIndentLevelOf 0+    where+    -- XXX - S02 says hard tab _is_ 8 spaces, instead of aligning to 8 spaces.+    -- doIndentLevelOf lvl '\t' = (lvl + 8) `div` 8+    doIndentLevelOf lvl c+        | '\t' <- c  = lvl + 8 +        | isSpace c  = lvl + 1+        | otherwise  = lvl++stripIndent :: Int -> String -> RuleParser String+stripIndent _ ""    = return ""+stripIndent 0 str   = return str+stripIndent lvl cs  = doStripIndent lvl cs+    where+    warnIndent = parserWarn ("Insufficient indent level in heredoc (" ++ show lvl ++ " expected)") cs+    doStripIndent :: Int -> String -> RuleParser String+    doStripIndent 0 str = return str+    doStripIndent _ ""  = warnIndent >> return ""+    doStripIndent lvl ('\t':cs)+        | lvl >= 8  = doStripIndent (lvl - 8) cs+        | otherwise = return $ replicate (8 - lvl) ' ' ++ cs+    doStripIndent lvl str@(c:cs)+        | isSpace c = doStripIndent (lvl - 1) cs+        | otherwise = warnIndent >> return str++qLiteralToEof :: RuleParser Exp+qLiteralToEof = do+    string "q_to_eof()"+    source <- many anyChar+    return $ Val $ VStr $ source++qLiteral1 :: RuleParser String    -- Opening delimiter+             -> RuleParser String -- Closing delimiter+             -> QFlags+             -> RuleParser Exp+qLiteral1 qStart qEnd flags = do+    expr <- interpolatingStringLiteral qStart qEnd (qInterpolator flags)+    -- qEnd+    case qfSplitWords flags of+        -- expr ~~ rx:perl5:g/(\S+)/+        QS_Yes      -> return (doSplitWords expr)+        QS_Protect  -> return $ case unwindGroups (unwindConcat (unwrap expr)) of+            []  -> Syn "," []+            [x] -> x+            xs  -> Syn "," xs+        QS_No       -> return $ case qfExecute flags of+            True -> App (_Var "&Pugs::Internals::runShellCommand") Nothing [expr]+            _    -> expr+    where+    -- Glue toward left/right via "Noop" as separation markers, so << 123'456'789 >> can parse as one.+    unwindConcat :: Exp -> [Exp]+    unwindConcat (App _ Nothing [l, r]) = unwindConcat l ++ unwindConcat r+    unwindConcat (Val (VStr str))+        | null str  = []+        | otherwise = sepBegin (sepEnd (intersperse Noop splitted))+        where+        splitted = map (Val . VStr) (perl6Words str)+        sepBegin = if isBreakingSpace (head str) then (Noop:) else id+        sepEnd   = if isBreakingSpace (last str) then (++ [Noop]) else id+    unwindConcat expr = [expr]++    unwindGroups :: [Exp] -> [Exp]+    unwindGroups es = case dropWhile (== Noop) es of+        []  -> []+        es' -> unwindFirst : unwindGroups rest+            where+            (first, rest) = break (== Noop) es'+            concatFirst = foldr1 (\x y -> App (_Var "&infix:~") Nothing [x, y]) first+            unwindFirst+                | any needSplit first   = splitFirst+                | otherwise             = concatFirst+            splitFirst = Ann (Cxt cxtSlurpyAny) (App (_Var "&infix:~~") Nothing [concatFirst, rxSplit])+            needSplit Val{} = False+            needSplit (Ann Parens _) = False+            needSplit _ = True++    -- words() regards \xa0 as (breaking) whitespace. But \xa0 is+    -- a nonbreaking ws char.+    doSplitWords expr+        | Val (VStr str) <- unwrap expr = doSplitStr perl6Words str+        | otherwise                     = Ann (Cxt cxtSlurpyAny) (App (_Var "&infix:~~") Nothing [expr, rxSplit])+    {-+    -- XXX - Not sure what to do here - should we analyze << "$x" '$x' >> and interpolate differently?+    rxSplitShell = Syn "rx" $+        [ Val $ VStr "'([^']*)'|\"([^\"]*)\"|([^'\"\\x09\\x0a\\x0d\\x20][^\\x09\\x0a\\x0d\\x20]*)"+        , Val $ VList+            [ castV (VStr "P5", VInt 1)+            , castV (VStr "g", VInt 1)+            , castV (VStr "stringify", VInt 1)+            ]+        ]+    -}+    rxSplit = Syn "rx" $+        [ Val $ VStr "([^\\x09\\x0a\\x0d\\x20]+)"+        , Val $ VList+            [ castV (VStr "P5", VInt 1)+            , castV (VStr "g", VInt 1)+            , castV (VStr "stringify", VInt 1)+            ]+        ]+++angleBracketLiteral :: RuleParser Exp+angleBracketLiteral = try $+        do+        symbol "<<"+        qLiteral1 (symbol "<<") (string ">>") $ qqFlags+            { qfSplitWords = QS_Protect, qfProtectedChar = '>' }+    <|> do+        symbol "<"+        qLiteral1 (symbol "<") (string ">") $ qFlags+            { qfSplitWords = QS_Yes, qfProtectedChar = '>' }+    <|> do+        symbol "\xAB"+        qLiteral1 (symbol "\xAB") (string "\xBB") $ qqFlags+            { qfSplitWords = QS_Protect, qfProtectedChar = '\xBB' }++-- Quoting delimitor and flags+-- qfProtectedChar is the character to be+--   protected by backslashes, if+--   qfInterpolateBackslash is Single or All+data QS_Flag = QS_No | QS_Yes | QS_Protect deriving (Show, Eq, Ord, Typeable)+data QB_Flag = QB_No | QB_Balanced | QB_Single | QB_All deriving (Show, Eq, Ord, Typeable)++data QFlags = MkQFlags+    { qfSplitWords              :: !QS_Flag -- No, Yes, Protect+    , qfInterpolateScalar       :: !Bool+    , qfInterpolateArray        :: !Bool+    , qfInterpolateHash         :: !Bool+    , qfInterpolateFunction     :: !Bool+    , qfInterpolateClosure      :: !Bool+    , qfInterpolateBackslash    :: !QB_Flag -- No, Single, All+    , qfProtectedChar           :: !Char+    , qfP5RegularExpression     :: !Bool+    , qfHereDoc                 :: !Bool+    , qfExecute                 :: !Bool+    , qfFailed                  :: !Bool -- Failed parse+    }+    deriving (Show, Eq, Ord, Typeable)++getQFlags :: [String] -> Char -> QFlags+getQFlags flagnames protectedChar =+    (foldr useflag qFlags $ reverse flagnames) { qfProtectedChar = protectedChar }+    where+        -- Additive flags+          useflag "w" qf          = qf { qfSplitWords = QS_Yes }+          useflag "words" qf      = qf { qfSplitWords = QS_Yes }+          useflag "ww" qf         = qf { qfSplitWords = QS_Protect }+          useflag "quotewords" qf = qf { qfSplitWords = QS_Protect }+          useflag "s" qf          = qf { qfInterpolateScalar = True }+          useflag "scalar" qf     = qf { qfInterpolateScalar = True }+          useflag "a" qf          = qf { qfInterpolateArray = True }+          useflag "array" qf      = qf { qfInterpolateArray = True }+          useflag "h" qf          = qf { qfInterpolateHash = True }+          useflag "hash" qf       = qf { qfInterpolateHash = True }+          useflag "f" qf          = qf { qfInterpolateFunction = True }+          useflag "function" qf   = qf { qfInterpolateFunction = True }+          useflag "c" qf          = qf { qfInterpolateClosure = True }+          useflag "closure" qf    = qf { qfInterpolateClosure = True }+          useflag "b" qf          = qf { qfInterpolateBackslash = QB_All }+          useflag "backslash" qf  = qf { qfInterpolateBackslash = QB_All }+          useflag "to" qf         = qf { qfHereDoc = True }+          useflag "heredoc" qf    = qf { qfHereDoc = True }++        -- Zeroing flags+          useflag "n" _           = rawFlags+          useflag "none" _        = rawFlags+          useflag "q" _           = qFlags+          useflag "single" _      = qFlags+          useflag "double" _      = qqFlags+          useflag "qq" _          = qqFlags -- support qq//+          useflag "exec" _        = qqFlags { qfExecute = True }+          useflag "x" _           = qqFlags { qfExecute = True }++        -- in case of unknown flag, we simply abort the parse.+          useflag _ qf            = qf { qfFailed = True }+++openingDelim :: RuleParser (Int, Char)+openingDelim = do+    ch  <- anyChar+    if isWordAny ch then fail ("Invalid quote delimiter: " ++ show ch) else do+    if balancedDelim ch == ch then return (1, ch) else do+    rep <- many (char ch)+    return (length rep + 1, ch)++qStructure :: RuleParser (RuleParser String, RuleParser String, QFlags)+qStructure = +    do char 'q'+       flags <- do+           firstFlag <- option ' ' alphaNum+           notFollowedBy (char '(') -- Special case: q() is always function call+           whiteSpace+           allFlags  <- many oneFlag+           case firstFlag of+               'q' -> return ("qq":allFlags) -- Special case: qq() means q:qq()+               ' ' -> return allFlags+               _   -> return ([firstFlag]:allFlags)+       (rep, delim) <- openingDelim+       let qflags = getQFlags flags $ balancedDelim delim+       when (qfFailed qflags) $ fail ""+       return ( (string (replicate rep delim)), (string (replicate rep $ balancedDelim delim)), qflags)+    where+    oneFlag = lexeme $ do+        char ':'+        many alphaNum++getQDelim :: RuleParser (RuleParser String, RuleParser String, QFlags)+getQDelim = try qStructure+    <|> try (do+        string "<<"+        return (string "<<", string ">>",+            qqFlags { qfSplitWords = QS_Protect, qfProtectedChar = '>' }))+    <|> do+        delim <- oneOf "`\"'<\xab"+        case delim of+            '"'     -> return (string "\"",  string "\"",    qqFlags)+            '\''    -> return (string "'",   string "'",   qFlags)+            '<'     -> return (string "<",   string ">",    qFlags+                { qfSplitWords = QS_Yes, qfProtectedChar = '>' })+            '`'     -> return (string "`",   string "`",    qqFlags+                { qfExecute = True, qfProtectedChar = '`' })+            '\xab'  -> return (string "\xab", string "\xbb", qqFlags+                { qfSplitWords = QS_Protect, qfProtectedChar = '\xbb' })+            _       -> fail ""+++-- | Default flags+qFlags    :: QFlags+qFlags    = MkQFlags QS_No False False False False False QB_Single '\'' False False False False+-- | Default flags+qqFlags   :: QFlags+qqFlags   = MkQFlags QS_No True True True True True QB_All '"' False False False False+-- | Default flags+rawFlags  :: QFlags+rawFlags  = MkQFlags QS_No False False False False False QB_No 'x' False False False False+-- | Default flags+rxP5Flags :: QFlags+rxP5Flags = MkQFlags QS_No True True True True False QB_Balanced '/' True False False False+-- | Default flags+rxP6Flags :: QFlags+rxP6Flags = MkQFlags QS_No False False False False False QB_Balanced '/' False False False False++-- Regexps++-- | A parser returning a regex, given a hashref of adverbs and a closing delimiter.+rxLiteralAny :: Exp -> Char -> Char -> RuleParser Exp+rxLiteralAny adverbs+    | Syn "\\{}" [Syn "," pairs] <- adverbs+    , not (null [+        True+        | (App (Var var) Nothing [Val (VStr name), _]) <- pairs+        , var == cast "&infix:=>"+        , (name ==) `any` words "P5 Perl5 perl5"+        ])+    = rxLiteral5+    | otherwise+    = rxLiteral6++rxLiteral5 :: Char -- ^ Opening delimiter+           -> Char -- ^ Closing delimiter+           -> RuleParser Exp+rxLiteral5 delimStart delimEnd = qLiteral1 (string [delimStart]) (string [delimEnd]) $+    rxP5Flags { qfProtectedChar = delimStart }++rxLiteral6 :: Char -- ^ Opening delimiter+           -> Char -- ^ Closing delimiter+           -> RuleParser Exp+rxLiteral6 delimStart delimEnd = qLiteral1 (string [delimStart]) (string [delimEnd]) $+    rxP6Flags { qfProtectedChar = delimStart }++ruleQuoteAdverbs :: RuleParser Exp+ruleQuoteAdverbs = enterBracketLevel QuoteAdverbBracket $ do+    pairs <- many pairAdverb+    return $ Syn "\\{}" [Syn "," pairs]++substLiteral :: RuleParser Exp+substLiteral = do+    (declarator, pseudo) <- choice+        [ symbol "s"  >> return ("subst", (pseudoAssignment cxtSlurpyAny matchResult <|>))+        , do symbol "ss"+             insertIntoPosition ":sigspace(1)"+             return ("subst", (pseudoAssignment cxtSlurpyAny matchResult <|>))+        , symbol "tr" >> return ("trans", id)+        ]+    adverbs <- case declarator of+        "subst" -> ruleQuoteAdverbs+        _       -> return emptyExp+    (rep, ch)   <- openingDelim+    let endch = balancedDelim ch+    -- XXX - probe for adverbs to determine p5 vs p6+    expr    <- rxLiteralAny adverbs ch endch+    when (ch /= endch) whiteSpace+    subst   <- (if ch /= endch then pseudo else id) $ do+        ch'     <- if ch == endch then return ch else case declarator of+            "subst" -> anyChar+                `finallyM` parserWarn "s{...}{...} is deprecated; write s{...}='...' instead." ()+            _       -> anyChar+        let endch' = balancedDelim ch'+            flags = case declarator of+                "subst" -> qqFlags+                _       -> qFlags+        qLiteral1+            (string $ replicate rep ch)+            (string $ replicate rep endch')+            flags{ qfProtectedChar = endch' }+    return $ Syn declarator [expr, subst, adverbs]+    where+    matchResult = Syn "${}" [_Var "$/"]++pseudoAssignment :: Cxt -> Exp -> RuleParser Exp+pseudoAssignment cxt lhs = verbatimRule "infix assignment" $ do+    ahead <- lookAhead (string ".=" <|> ruleInfixAssignment <|> string "=")+    insertIntoPosition (cast varStub ++ " ")+    item <- parseExpWithTightOps+    return $ case ahead of+        ".=" -> fixPseudo (applyPseudo item)+        _    -> applyPseudo item+    where+    varStub = if isSlurpyCxt cxt then cast "@_" else varTopic+    applyPseudo (Ann ann exp)       = Ann ann (applyPseudo exp)+    applyPseudo (Syn "=" [Var var, exp])+        | var == varStub+        = exp+    applyPseudo (Syn syn [Var var, exp])+        | last syn == '='+        , var == varStub+        = App (_Var ("&infix:" ++ init syn)) Nothing [lhs, exp]+    applyPseudo x = internalError $ "Unknown pseudo-assignment form:" ++ show x+    fixPseudo (Ann ann exp) = Ann ann (fixPseudo exp)+    fixPseudo (App meth (Just (Var var)) args)+        | var == varStub+        = App meth (Just lhs) args+    fixPseudo x = x+++ruleRegexDeclarator :: RuleParser (Exp -> Exp)+ruleRegexDeclarator = verbatimRule "regex expression" $ choice+    [ symbol "rule"     >> return (adv "ratchet" . adv "sigspace")+    , symbol "token"    >> return (adv "ratchet")+    , symbol "regex"    >> return id+    ]+    where+    adv x (Syn "\\{}" [Syn "," pairs]) = Syn "\\{}"+        [Syn "," (App (_Var "&infix:=>") Nothing [Val (VStr x), Val (VBool True)] : pairs)]+    adv _ _ = internalError "unexpected regex adverb specifier"++rxLiteral :: RuleParser Exp+rxLiteral = verbatimRule "regex expression" $ do+    (withAdvs, decl) <- choice+        [ symbol "rx" >> return (id, "rx")+        , symbol "m"  >> return (id, "match")+        , do (symbol "ms" <|> symbol "mm")+             insertIntoPosition ":sigspace(1)"+             return (id, "match")+        , do advs <- ruleRegexDeclarator+             lookAhead (ruleQuoteAdverbs >> char '{')+             return (advs, "rx")+        ]+    adverbs <- fmap withAdvs ruleQuoteAdverbs+    ch      <- anyChar+    expr    <- rxLiteralAny adverbs ch (balancedDelim ch)+    return $ Syn decl [expr, adverbs]++rxLiteralBare :: RuleParser Exp+rxLiteralBare = verbatimRule "regex expressions" $ do+    ch      <- char '/'+    expr    <- rxLiteral6 ch (balancedDelim ch)+    return $ Syn "//" [expr, Val undef]+
+ src/Pugs/Parser/Number.hs view
@@ -0,0 +1,111 @@++module Pugs.Parser.Number (+    parseNatOrRat,+    naturalOrRat,+    signedNaturalOrRat,+) where+import Pugs.Internals+import Pugs.Rule+import Text.ParserCombinators.Parsec.Char++parseNatOrRat :: String -> Either ParseError (Either Integer (Ratio Integer))+parseNatOrRat s = runParser signedNaturalOrRat () "" s++signedNaturalOrRat :: GenParser Char st (Either Integer (Ratio Integer))+signedNaturalOrRat = do+    sig <- sign+    if sig then naturalOrRat else do+        num <- naturalOrRat+        return $ case num of+            Left i  -> Left (-i)+            Right d -> Right (-d)++naturalOrRat :: GenParser Char st (Either Integer (Ratio Integer))+naturalOrRat = (<?> "number") $ do+        try (char '0' >> zeroNumRat)+    <|> decimalRat+    <|> fractRatOnly+    where+    zeroNumRat = do+            n <- hexadecimal <|> decimal <|> octalBad <|> octal <|> binary+            return (Left n)+        <|> decimalRat+        <|> fractRat 0+        <|> return (Left 0)++    decimalRat = do+        n <- decimalLiteral+        option (Left n) (try $ fractRat n)++    fractRatOnly = do+        fract <- try fraction+        expo  <- option (1%1) expo+        return (Right $ fract * expo) -- Right is Rat++    fractRat n = do+            fract <- try fraction+            expo  <- option (1%1) expo+            return (Right $ ((n % 1) + fract) * expo) -- Right is Rat+        <|> do+            expo <- expo+            if expo < 1+                then return (Right $ (n % 1) * expo)+                else return (Right $ (n % 1) * expo)++    fraction = do+            char '.'+            digit  <- satisfy isDigit+            digits <- many (satisfy isWordDigit) <?> "fraction"+            return (digitsToRat $ filter (/= '_') (digit:digits))+        <?> "fraction"+        where+        digitsToRat d = digitsNum d % (10 ^ length d)+        digitsNum d = foldl (\x y -> x * 10 + (toInteger $ digitToInt y)) 0 d+        isWordDigit x = (isDigit x || x == '_')++    expo :: GenParser Char st Rational+    expo = do+            oneOf "eE"+            f <- sign+            e <- decimalLiteral <?> "exponent"+            return (power (if f then e else -e))+        <?> "exponent"+        where+        power e | e < 0      = 1 % (10^abs(e))+                | otherwise  = (10^e) % 1++    decimalLiteral         = number 10+    hexadecimal     = do{ char 'x'; number 16  }+    decimal         = do{ oneOf "_d"; number 10  }+    octal           = do{ char 'o'; number 8 }+    octalBad        = do{ many1 octDigit ; fail "0100 is not octal in perl6 any more, use 0o100 instead." }+    binary          = do{ char 'b'; number 2  }++    number base = do+        d   <- baseDigit base+        ds  <- many (baseDigit base <|> +                do { char '_'; lookAhead (baseDigit base); return '_' })+        let n = foldl (\x d -> base*x + b36DigitToInteger d) 0 digits+            digits = (d : filter (/= '_') ds)+        seq n (return n)+        where+        baseDigit                   = baseDigitInt . fromIntegral+        baseDigitInt b +            | b <= 10               = oneOf $ take b ['0'..'9']+            | b >  10 && b <= 36    = oneOf $ ['0'..'9'] +                                    ++ take (b - 10) ['a'..'z'] +                                    ++ take (b - 10) ['A'..'Z']+            | otherwise             = error "baseDigitInt: base too large"+        b36DigitToInteger           = toInteger . b36DigitToInt+        b36DigitToInt c+            | isDigit c             = fromEnum c - fromEnum '0'+            | c >= 'a' && c <= 'z'  = fromEnum c - fromEnum 'a' + 10+            | c >= 'A' && c <= 'Z'  = fromEnum c - fromEnum 'A' + 10+            | otherwise             = error "b36DigitToInt: not a base 36 digit"++sign :: GenParser Char st Bool+sign = (char '-' >> return False)+   <|> (char '+' >> return True)+   <|> return True++
+ src/Pugs/Parser/Operator.hs view
@@ -0,0 +1,750 @@+{-# OPTIONS_GHC -cpp -fglasgow-exts -funbox-strict-fields -fno-full-laziness -fno-cse -fallow-overlapping-instances -fno-warn-orphans #-}++module Pugs.Parser.Operator where+import Pugs.Internals+import Pugs.AST+import Pugs.Types+import Pugs.Lexer+import Pugs.Rule+import {-# SOURCE #-} Pugs.Parser+import qualified Data.Set as Set+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 GHC.Int (Int32(I32#))++import Pugs.Parser.Types+import Pugs.Parser.Unsafe++listCons :: [RuleOperator Exp]+listCons = listSyn (opWords ",")                         -- List constructor++listInfix :: [RuleOperator Exp]+listInfix = listOps (opWords "Z X minmax ==> <==")  -- List infix++opWords :: String -> Set OpName+opWords xs = Set.fromList (map (MkOpName . cast) (words xs))++newtype OpName = MkOpName ID+    deriving (Show, Eq, Typeable, (:>:) String, (:>:) ByteString, (:<:) ByteString, (:>:) ID, (:<:) String, (:<:) ID)++instance Ord OpName where+    compare (MkOpName x) (MkOpName y)+        = compare (Buf.length (idBuf y)) (Buf.length (idBuf x)) `mappend` compare (idKey y) (idKey x)++instance ((:<:) OpName) ByteString where+    castBack (MkOpName id) = castBack id++-- Not yet transcribed into a full optable parser with dynamic precedence++tightOperators :: RuleParser (TightFunctions, RuleOperatorTable Exp)+tightOperators = do+  tights <- currentTightFunctions+  return $ (,) tights+    ( termLevel                     -- Terms and circumfixes+    : methLevel                     -- Method postfix+    : incrLevel                     -- Auto-Increment+    : expoLevel                     -- Exponentiation+    : (preSymOps (r_pre tights)     -- Symbolic Unary (user-definable)+        ++ postOps (r_post tights)+        ++ symbLevel)+    : multLevel                     -- Multiplicative+    : Map.foldWithKey foldInfix addiLevel (r_infix tights) -- Additive (user-definable)+    : replLevel                     -- Replication+    : concLevel                     -- Concatenation+    : junaLevel                     -- Junctive And+    : junoLevel                     -- Junctive Or+    : (optOps (r_opt tights)        -- Named Unary (user-definable)+      ++ preOps (r_named tights Set.\\ opWords " true not ")+      )+    : staticLevels+    )+    where+    foldInfix :: OpName -> SubAssoc -> [RuleOperator Exp] -> [RuleOperator Exp]+    foldInfix op assoc xs = let op' = Set.singleton op in case assoc of+        A_left  -> leftOps op'  ++ xs+        A_right -> rightOps op' ++ xs+        A_non   -> nonOps op'   ++ xs+        A_chain -> chainOps op' ++ xs+        A_list  -> listOps op'  ++ xs+        _       -> leftOps op'  ++ xs   -- Default to left-assoc+        -- _ -> error $ "Impossible: " ++ show op ++ " has no assoc?"++termLevel, methLevel, incrLevel, expoLevel, symbLevel, multLevel, addiLevel, replLevel, concLevel, junaLevel, junoLevel :: [RuleOperator Exp]+termLevel = circumOps (Set.singleton (MkOpName (cast "\\( )")))+methLevel = methOps (opWords " . .+ .? .* .+ .() .[] .{} .<<>> .= ")+incrLevel = postOps incrOpsPost ++ preOps incrOpsPre+expoLevel = rightOps (opWords " ** ")+symbLevel = preSyn (Set.singleton (MkOpName (cast "|"))) ++ preOps symbPreops+multLevel = leftOps (opWords " * / % +& +< +> ~& ~< ~> ?& ")+addiLevel = leftOps (opWords " + - +| +^ ~| ~^ ?| ?^ ")+replLevel = leftOps (opWords " x xx ")+concLevel = leftOps (opWords " ~ ")+junaLevel = listOps (opWords " & ")+junoLevel = listOps (opWords " ^ | ")++symbPreops :: Set OpName+symbPreops = opWords " = ! + - ~ ? +^ ~^ ?^ \\ ^"++incrOpsPre :: Set OpName+incrOpsPre = opWords " ++ -- "++incrOpsPost :: Set OpName+incrOpsPost = opWords " ++ -- i "++-- The lower levels of immutable ops.  This will be replaced once we have+-- user-defineable precedences.+staticLevels :: [[RuleOperator Exp]]+staticLevels =+    [ nonSyn   (opWords " but does ")                            -- Traits+      ++ nonOps (opWords " leg cmp <=> .. ^.. ..^ ^..^ ff ^ff ff^ ^ff^ fff ^fff fff^ ^fff^ ")  -- Non-chaining Binary+    , chainOps (opWords " != == < <= > >= eqv eq ne lt le gt ge =:= === ")+      ++ matchOps (opWords " ~~ =~ ")+    , leftOps  (opWords "&&")                                    -- Tight And+    , leftOps  (opWords " || ^^ // ")                            -- Tight Or+    , [ternOp "??" "!!" "if"]                                   -- Ternary+    -- Assignment+    , (rightOps (opWords " => ") ++) .                           -- Pair constructor+      (DependentPostfix listAssignment :) .+      (DependentPostfix immediateBinding :) .+      (rightAssignSyn :) .+      (rightDotAssignSyn :) .+      (rightSyn (opWords " := ") ++) $+      rightSyn infixAssignmentOps+    , preOps (opWords " true not ")                              -- Loose unary+    ]++infixAssignmentOps :: Set OpName+infixAssignmentOps = opWords+    ( " ~= += -= *= /= %= x= Z= X= **= xx= ||= &&= //= ^^= "+    ++ " +<= +>= ~<= ~>= +&= +|= +^= ~&= ~|= ~^= ?|= ?^= |= ^= &= "+    )++fromSet :: Set OpName -> [String]+fromSet = cast . Set.toAscList++listAssignment :: Exp -> RuleParser Exp+listAssignment x = do+    try $ do+        char '='+        guard (not (isScalarLValue x))+        notFollowedBy (oneOf "=>" <|> (char ':' >> char '='))+        whiteSpace+    y   <- parseExpWithTightOps+    rhs <- option y $ do+        -- If we see comma, then convert this to a Syn ",".+        ruleComma+        ys <- parseExpWithTightOps `sepEndBy` ruleComma+        return (Syn "," (y:ys))+    return (Syn "=" [forceParens x, rhs])+    where+    -- XXX - Special casing ($x) = 1,2,3 to ($x,) = 1,2,3+    forceParens exp@(Ann Parens inner)+        | Syn "," _ <- unwrap exp   = exp+        | otherwise                 = Ann Parens (Syn "," [inner])+    forceParens (Ann x inner)       = Ann x (forceParens inner)+    forceParens (Sym x y flags init inner) = Sym x y flags init (forceParens inner)+    forceParens exp                 = exp++immediateBinding :: Exp -> RuleParser Exp+immediateBinding x = do+    symbol "::="+    y <- parseExpWithTightOps+    unsafeEvalExp (Syn ":=" [x, y])+    return x++looseOperators :: RuleParser (RuleOperatorTable Exp)+looseOperators = do+    -- names <- currentListFunctions+    return $+        [ -- preOps names                               -- List Operator+          leftOps  (opWords " ==> ")                     -- Pipe Forward+        , leftOps  (opWords " and andthen ")                     -- Loose And+        , leftOps  (opWords " or xor orelse ")              -- Loose Or+        ]++data CurrentFunction = MkCurrentFunction+    { f_var     :: !Var+    , f_assoc   :: !SubAssoc+    , f_params  :: !Params+    }+    deriving (Show)++-- Read just the current state (i.e. not actually consuming anything)+currentFunctions :: RuleParser [CurrentFunction]+currentFunctions = do+    env <- getRuleEnv+    let funs = catMaybes $! inlinePerformSTM $! do+        glob <- readMPad $ envGlobal env+        let vars  = padToList (filterPad cur glob)+                    ++ padToList (filterPad cur (envLexical env))+            pkg   = envPackage env+            cur var@MkVar{ v_sigil = SCode, v_longname = name } | name == nullID = inScope pkg var+            cur _ = False+        mapM (uncurry filterFun) vars+    return (length funs `seq` funs)++{-# NOINLINE _RefToFunction #-}+_RefToFunction :: H.HashTable PadEntry (Maybe CurrentFunction)+_RefToFunction = unsafePerformIO (H.new (==) hashPadEntry)++hashPadEntry :: PadEntry -> Int32+hashPadEntry PEConstant{ pe_proto = v }  = I32# (unsafeCoerce# v)+hashPadEntry x                              = I32# (unsafeCoerce# (pe_store x))++-- hashTVar :: TVar VRef -> Int32+-- hashTVar x = I32# (unsafeCoerce# x)++filterFun :: Var -> PadEntry -> STM (Maybe CurrentFunction)+filterFun var entry = var `seq` do+    res <- unsafeIOToSTM (H.lookup _RefToFunction entry)+    case res of+        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++inScope :: Pkg -> Var -> Bool+inScope pkg var+    | isGlobalVar var           = True+    | not (isQualifiedVar var)  = True+    | pkg == varPkg             = True+    | listPkg == varPkg         = True -- XXX wrong - special case for List::*+    | otherwise                 = False+    where+    varPkg = v_package var++relevantToParsing :: SubType -> SubAssoc -> Bool+relevantToParsing SubMethod  _      = False+relevantToParsing SubPrim    ANil   = True+relevantToParsing SubPrim    _      = False+relevantToParsing _          AIrrelevantToParsing   = False+relevantToParsing _          _      = True++-- XXX Very bad hacky kluge just for Parser.Operator+--     Switch to macro export for push(@x, 1) instead!+listPkg :: Pkg+listPkg = cast (mkType "List")++-- read just the current state+currentTightFunctions :: RuleParser TightFunctions+currentTightFunctions = do+    funs    <- currentFunctions+    let finalResult = foldr splitUnary termResult unary+        termResult  = foldr splitTerm initResult maybeTerm+        initResult  = MkTightFunctions emptySet emptySet emptySet emptySet emptyMap infixOps+        (unary, notUnary)   = partition matchUnary funs+        slurpyNames         = namesFrom (filter matchSlurpy notUnary)+        (maybeTerm, notTerm)= partition matchTerm funs+        nonTermNames        = namesFrom notTerm+        infixOps            = Map.fromList+            [ (MkOpName name, assoc)+            | MkCurrentFunction { f_var = MkVar { v_categ = C_infix, v_name = name }, f_assoc = assoc } <- notUnary+            , name /= commaID+            ]+        splitTerm :: CurrentFunction -> TightFunctions -> TightFunctions+        splitTerm (MkCurrentFunction MkVar{ v_categ = cat, v_name = n } _ _)+            res@MkTightFunctions{ r_term = term }+                | n `Set.member` nonTermNames   = res+                | otherwise                     = res{ r_term = Map.insert (MkOpName n) cat term }++        splitUnary :: CurrentFunction -> TightFunctions -> TightFunctions+        splitUnary (MkCurrentFunction MkVar{ v_categ = cat, v_name = n } _ [param])+            res@MkTightFunctions{ r_opt = opt, r_named = named, r_pre = pre, r_post = post }+                | n `Set.member` slurpyNames    = res+                | isOptional param              = res{ r_opt    = Set.insert (MkOpName n) opt }+                | C_prefix <- cat               = res{ r_pre    = Set.insert (MkOpName n) pre }+                | C_postfix <- cat              = res{ r_post   = Set.insert (MkOpName n) post }+                | otherwise                     = res{ r_named  = Set.insert (MkOpName n) named }+        splitUnary _ res = res+    return finalResult++namesFrom :: [CurrentFunction] -> Set ID+namesFrom = Set.fromList . map (v_name . f_var)++commaID :: ID+commaID = cast ","++data TightFunctions = MkTightFunctions+    { r_opt         :: !(Set OpName)+    , r_named       :: !(Set OpName)+    , r_pre         :: !(Set OpName)+    , r_post        :: !(Set OpName)+    , r_term        :: !(Map OpName VarCateg)+    , r_infix       :: !(Map OpName SubAssoc)+    }++emptySet :: Set OpName+emptySet = Set.empty++emptyMap :: Map OpName VarCateg+emptyMap = Map.empty++matchUnary :: CurrentFunction -> Bool+matchUnary MkCurrentFunction+    { f_assoc = ANil, f_params = [MkOldParam+        { paramContext = CxtItem{}, isNamed = False }] } = True+matchUnary _ = False++matchTerm :: CurrentFunction -> Bool+matchTerm MkCurrentFunction{ f_var = MkVar{ v_categ = C_term } } = True+matchTerm MkCurrentFunction{ f_assoc = ANil, f_params = [] } = True+matchTerm _ = False++matchSlurpy :: CurrentFunction -> Bool+matchSlurpy MkCurrentFunction+    { f_params = (_:_:_) } = True+matchSlurpy MkCurrentFunction+    { f_params = [MkOldParam+        { paramContext = CxtSlurpy{}, paramName = MkVar{ v_sigil = sig } }] }+            = sig == SArray || sig == SArrayMulti+matchSlurpy _ = False++circumOps, rightSyn, chainOps, matchOps, nonSyn, listSyn, preSyn, preOps, preSymOps, postOps, optOps, leftOps, rightOps, nonOps, listOps :: Set OpName -> [RuleOperator Exp]+preSyn      = ops  $ makeOp1 Prefix "" Syn+preOps      = (ops $ makeOp1 Prefix "&prefix:" doApp) . addHyperPrefix+preSymOps   = (ops $ makeOp1 Prefix "&prefix:" doAppSym) . addHyperPrefix+postOps     = (ops $ makeOp1 Postfix "&postfix:" doApp) . addHyperPostfix+optOps      = (ops $ makeOp1 OptionalPrefix "&prefix:" doApp) . addHyperPrefix+leftOps     = (ops $ makeOp2 AssocLeft "&infix:" doApp) . addHyperInfix+rightOps    = (ops $ makeOp2 AssocRight "&infix:" doApp) . addHyperInfix+nonOps      = ops  $ makeOp2 AssocNone "&infix:" doApp+listOps     = ops  $ makeOp2 AssocLeft "&infix:" doApp+matchOps    = (ops $ makeOp2Match AssocLeft "&infix:" doApp) . addHyperInfix . addNegation+chainOps    = (ops $ makeOp2 AssocLeft "&infix:" doApp) . addHyperInfix . addNegation+rightSyn    = ops $ makeOp2 AssocRight "" Syn+nonSyn      = ops $ makeOp2 AssocNone "" Syn+listSyn     = ops $ makeOp0 AssocList "" Syn+circumOps   = ops $ makeCircumOp "&circumfix:"+rightAssignSyn :: RuleOperator Exp+rightAssignSyn = makeOp2Assign AssocRight "" Syn+rightDotAssignSyn :: RuleOperator Exp+rightDotAssignSyn = makeOp2DotAssign AssocRight "" Syn++{-# INLINE ops #-}+{-# SPECIALISE ops :: (String -> RuleOperator Exp) -> Set OpName -> [RuleOperator Exp] #-}+{-# SPECIALISE ops :: (String -> RuleParser String) -> Set OpName -> [RuleParser String] #-}+ops :: (String -> a) -> Set OpName -> [a]+ops f = map f . cast . Set.toAscList++makeOp1 :: (RuleParser (Exp -> Exp) -> RuleOperator Exp) -> +        String -> +        (String -> [Exp] -> Exp) -> +        String -> +        RuleOperator Exp+makeOp1 fixity sigil con name = fixity $ try $ do+    symbol name+    -- `int(3)+4` should not be parsed as `int((3)+4)`+    lookAheadLiterals+    where+    lookAheadLiterals+        | isWordAny (last name) = choice autoquoters+        | otherwise = conOp fullName+    autoquoters = +        [ char '(' >> unexpected "(" +        , string "=>" >> unexpected "=>"+        , conOp fullName+        ]+    fullName+        | isAlpha (head name)+        , "&prefix:" <- sigil+        = ('&':name)+        | otherwise+        = sigil ++ name+    conOp name = return $ \x -> case x of+        Syn "" []   -> con name []+        _           -> con name [x]+++makeCircumOp :: String -> String -> RuleOperator Exp+makeCircumOp sigil op = Term . try $+    between (lexeme $ string opener) (string closer) $+        enterBracketLevel ParensBracket $ do+            (invs, args) <- option (Nothing, []) parseNoParenArgList+            possiblyApplyMacro $ App (_Var name) invs args+    where+    name = sigil ++ opener ++ " " ++ closer+    [opener, closer] = words op++-- Just for the "state $foo = 1" rewriting+makeOp2Assign :: Assoc -> String -> (String -> [Exp] -> Exp) -> RuleOperator Exp+makeOp2Assign prec _ con = (`Infix` prec) $ do+    symbol "="+    return $ \invExp argExp -> (con "=" [invExp, argExp])++-- Rewrite "EXP ~~ .meth" into "?(EXP.meth)"+makeOp2Match :: Assoc -> String -> (String -> [Exp] -> Exp) -> String -> RuleOperator Exp+makeOp2Match prec sigil con name = (`Infix` prec) $ do+    symbol name+    when (name == "=~") $ do+        fail "There is no =~ operator in Perl 6 -- did you mean ~~ (match) or ~= (concat-assign)?"+    return $ \x y -> case y of+        Syn syn [Var var, rhs] | var == varTopic ->+            App (_Var "&prefix:?") Nothing [Syn syn [x, rhs]]+        App app (Just (Var var)) args | var == varTopic ->+            App (_Var "&prefix:?") Nothing [App app (Just x) args]+        _ -> con (sigil ++ name) [x,y]++-- Just for the ".=" rewriting+makeOp2DotAssign :: Assoc -> String -> (String -> [Exp] -> Exp) -> RuleOperator Exp+makeOp2DotAssign prec _ con = (`Infix` prec) $ do+    symbol ".="+    insertIntoPosition "." -- "$x .= foo" becomes "$x .= .foo"+    return $ \invExp argExp -> case argExp of+        -- XXX - App meth _ args -> con ".=" [invExp, App meth Nothing args]+        App meth _ args+            | meth == Var varTopic  -> con "=" [invExp, App invExp Nothing args]+            | otherwise             -> con "=" [invExp, App meth (Just invExp) args]+        _               -> Val (VError (VStr "the right-hand-side of .= must be a function application") [])++makeOp2 :: Assoc -> +           String -> +           (String -> [Exp] -> Exp) -> +           String -> +           RuleOperator Exp+makeOp2 prec sigil con name = (`Infix` prec) $ do+    symbol name+    return $ \x y -> con (sigil ++ name) [x,y]++makeOp0 :: Assoc -> +           String -> +           (String -> [Exp] -> Exp) -> +           String -> +           RuleOperator Exp+makeOp0 prec sigil con name = (`InfixList` prec) $ do+    many1 $ do+        string name+        whiteSpace+    return . con $ sigil ++ name++doApp :: String -> [Exp] -> Exp+doApp str args = App (_Var str) Nothing args++{-|+Take a list of infix-operator names (as a space-separated string), and return+a similar string also containing both Texas-style and French-style infixed+hyperized forms.++For example, the string @\"+ -\"@ would be transformed into+@\"+ >>+\<\< »+« - >>-\<\< »-«\"@.+-}+addHyperInfix :: Set OpName -> Set OpName+addHyperInfix xs = xs `Set.union` hyperTexan `Set.union` hyperFrench+    where+    hyperTexan = Set.mapMonotonic texan xs+    hyperFrench = Set.mapMonotonic french xs+    texan x = cast (Buf.concat [__">>", cast x, __"<<"])+    french x = cast (Buf.concat [__"\187", cast x, __"\171"])++{-|+Similar to 'addHyperInfix', but for prefix ops.++For example, @\"++ --\"@ would become+@\"++ ++\<\< ++« -- --\<\< --«\"@.+-}+addHyperPrefix :: Set OpName -> Set OpName+addHyperPrefix xs = xs `Set.union` hyperTexan `Set.union` hyperFrench+    where+    hyperTexan = Set.mapMonotonic texan xs+    hyperFrench = Set.mapMonotonic french xs+    texan x = cast (cast x +++ __"<<")+    french x = cast (cast x +++ __"\171")++{-|+Similar to 'addHyperInfix', but for postfix ops.++For example, @\"++ --\"@ would become+@\"++ >>++ »++ -- >>-- »--\"@.+-}+addHyperPostfix :: Set OpName -> Set OpName+addHyperPostfix xs = xs `Set.union` hyperTexan `Set.union` hyperFrench+    where+    hyperTexan = Set.mapMonotonic texan xs+    hyperFrench = Set.mapMonotonic french xs+    texan x = cast (__">>" +++ cast x)+    french x = cast (cast "\187" +++ cast x)++{-|+Add prefix \++-}+addScanPrefix :: Set OpName -> Set OpName+addScanPrefix xs = xs `Set.union` scanPrefix+    where+    scanPrefix = Set.mapMonotonic scan xs+    scan x = cast (Buf.cons '\\' (cast x))++addNegation :: Set OpName -> Set OpName+addNegation xs = xs `Set.union` Set.mapMonotonic negation xs+    where+    negation x = let buf = cast x in+        if Buf.head buf == '!'+            then x+            else cast (Buf.cons '!' (cast x))++methOps             :: a -> [b]+methOps _ = []++doAppSym :: String -> [Exp] -> Exp+doAppSym name@(_:'p':'r':'e':'f':'i':'x':':':_) args = App (_Var name) Nothing args+doAppSym (sigil:name) args = App (_Var (sigil:("prefix:"++name))) Nothing args+doAppSym _ _ = error "doAppSym: bad name"+++ternOp :: String -> String -> String -> RuleOperator Exp+ternOp pre post syn = (`Infix` AssocRight) $ do+    symbol pre+    y <- parseExpWithTightOps+    symbol post+    return $ \x z -> Syn syn [x, y, z]+++++emptyTerm :: Exp+emptyTerm = Syn "" []++type TermOperator       = RuleParser Exp+type UnaryOperator      = RuleParser (Exp -> Exp)+type BinaryOperator     = RuleParser (Exp -> Exp -> Exp)+type ListOperator       = RuleParser ([Exp] -> Exp)+type DependentOperator  = Exp -> RuleParser Exp++data OpRow = MkOpRow+    { o_rassoc      :: ![BinaryOperator]+    , o_lassoc      :: ![BinaryOperator]+    , o_nassoc      :: ![BinaryOperator]+    , o_prefix      :: ![UnaryOperator]+    , o_postfix     :: ![UnaryOperator]+    , o_optPrefix   :: ![UnaryOperator]+    , o_listAssoc   :: ![ListOperator]+    , o_depPostfix  :: ![DependentOperator]+    , o_term        :: ![TermOperator]+    }++-----------------------------------------------------------+-- Convert an OperatorTable and basic term parser into+-- a full fledged expression parser+-----------------------------------------------------------+buildExpressionParser :: RuleOperatorTable Exp -> RuleParser Exp -> RuleParser Exp+buildExpressionParser = flip (foldl makeParser)++{-# INLINE makeParser #-}+makeParser :: RuleParser Exp -> [RuleOperator Exp] -> RuleParser Exp+makeParser simpleTerm ops = do+    x <- termP+    rassocP x <|> lassocP x <|> nassocP x <|> listAssocP x <|> return x <?> "operator"+    where+    MkOpRow rassoc lassoc nassoc prefix postfix optPrefix listAssoc depPostfix term+        = foldr splitOp (MkOpRow [] [] [] [] [] [] [] [] []) ops+    rassocOp          = {-# SCC "rassocOp" #-}      choice rassoc <?> ""+    lassocOp          = {-# SCC "lassocOp" #-}      choice lassoc <?> ""+    nassocOp          = {-# SCC "nassocOp" #-}      choice nassoc <?> ""+    prefixOp          = {-# SCC "prefixOp" #-}      choice prefix <?> ""+    postfixOp         = {-# SCC "postfixOp" #-}     choice postfix <?> ""+    optPrefixOp       = {-# SCC "optPrefixOp" #-}   choice optPrefix <?> ""+    listAssocOp       = {-# SCC "listAssocOp" #-}   choice listAssoc <?> ""+    depPostfixOp x    = {-# SCC "depPostfixOp" #-}  choice (map ($ x) depPostfix) <?> ""+    termOp            = {-# SCC "termOp" #-}        choice term <|> (simpleTerm <?> "")++    ambig assoc op    = try+        (op >> fail ("ambiguous use of a " ++ assoc ++ " associative operator"))+    ambigRight        = ambig "right" rassocOp+    ambigLeft         = ambig "left" lassocOp+    ambigNon          = ambig "non" nassocOp++    foldOp = foldr (.) id+    termP = {-# SCC "termP" #-} do+        pres    <-  many $ (fmap Left prefixOp) <|> (fmap Right optPrefixOp)+        -- Here we handle optional-prefix operators.+        x       <- if null pres then termOp else case last pres of+            Left _  -> termOp+            _       -> option emptyTerm termOp+        x'      <- depPostP x+        posts   <- many postfixOp+        fmap (foldOp posts) $ foldM maybeApplyPrefixMacro x' (map liftEither $ reverse pres)++    maybeApplyPrefixMacro t f = {-# SCC "maybeApplyPrefixMacro" #-} possiblyApplyMacro (f t)++    liftEither (Left x) = x+    liftEither (Right x) = x+    depPostP x = (<|> return x) $ do+        x' <- depPostfixOp x +        depPostP x'++    rassocP x  = (do+        f   <- rassocOp+        y   <- rassocP1 =<< termP+        return (f x y)) <|> ambigLeft <|> ambigNon++    rassocP1 x = rassocP x  <|> return x++    lassocP x  = (do+        f   <- lassocOp+        y   <- termP+        lassocP1 (f x y)) <|> ambigRight <|> ambigNon++    lassocP1 x = lassocP x <|> return x++    nassocP x  = do+        f <- nassocOp+        y <- termP+        ambigRight <|> ambigLeft <|> ambigNon <|> return (f x y)++    listAssocP x  = do+        f   <- listAssocOp+        xs  <- option [] $ listAssocP1 =<< termP+        return (f (x:xs))++    listAssocP0 x  = do+        listAssocOp+        xs  <- option [] $ listAssocP1 =<< termP+        return (x:xs)+    listAssocP1 x = listAssocP0 x <|> return [x]++{-# INLINE splitOp #-}+splitOp :: RuleOperator Exp -> OpRow -> OpRow+splitOp col row@(MkOpRow rassoc lassoc nassoc prefix postfix optPrefix listAssoc depPostfix term) = case col of+    Infix op AssocNone      -> row{ o_nassoc    = op:nassoc }+    Infix op AssocLeft      -> row{ o_lassoc    = op:lassoc }+    Infix op AssocRight     -> row{ o_rassoc    = op:rassoc }+    InfixList op AssocList  -> row{ o_listAssoc = op:listAssoc }+    Prefix op               -> row{ o_prefix    = op:prefix }+    Postfix op              -> row{ o_postfix   = op:postfix }+    OptionalPrefix op       -> row{ o_optPrefix = op:optPrefix }+    DependentPostfix op     -> row{ o_depPostfix= op:depPostfix }+    Term op                 -> row{ o_term      = op:term }+    -- FIXME: add AssocChain+    _ -> internalError $ "Unhandled operator type" ++ show (op_assoc col)+++refillCache :: RuleState -> (DynParsers -> RuleParser a) -> RuleParser a+refillCache state f = do+    (tights, opsTight)  <- tightOperators+    opsLoose            <- looseOperators+    let tightExprs  = buildExpressionParser opsTight parseTerm+        parseTight  = expRule tightExprs+        parseFull   = expRule (buildExpressionParser opsFull tightExprs)+        parseLit    = expRule (buildExpressionParser opsLoose tightExprs)+        parsePost   = pp "&postfix:" $ incrOpsPost `Set.union` r_post tights+     -- parsePre    = pp "&prefix:"  $ symbPreops `Set.union` r_pre tights+     -- parsePreNam = pp "&"         $ r_named tights `Set.union` r_opt tights+        pp pre ops  = fmap (pre ++) (tryChoice . map string . fromSet $ ops)+        opParsers   = MkDynParsers parseFull parseTight parseLit parseNullary parsePost -- <|> parsePre <|> parsePreNam)+        opsFull     = listCons:listInfix:opsLoose+        parseNullary= try $ do+            var <- (choice . map parseOneTerm . Map.toAscList $ r_term tights) <?> "term"+            notFollowedBy (char '(' <|> (char ':' >> char ':'))+            possiblyApplyMacro $ App (Var var) Nothing []+        parseOneTerm (name :: OpName, categ) = do+            symbol (cast name)+            return MkVar+                { v_name    = cast name+                , v_sigil   = SCode+                , v_twigil  = TNil+                , v_categ   = categ+                , v_package = emptyPkg+                , v_meta    = MNil+                , v_longname= nullID+                }+    setState state{ s_dynParsers = opParsers }+    f opParsers++-- was: parseOp+parseExpWithOps :: RuleParser Exp+parseExpWithOps = parseExpWithCachedParser dynParseOp++-- was: parseTightOp+parseExpWithTightOps :: RuleParser Exp+parseExpWithTightOps = parseExpWithCachedParser dynParseTightOp++-- Parse something in item context -- i.e. everything minus list-associative ones+parseExpWithItemOps :: RuleParser Exp+parseExpWithItemOps = parseExpWithCachedParser dynParseLitOp++-- was: parseOpWith+parseExpWithCachedParser :: (DynParsers -> RuleParser a) -> RuleParser a+parseExpWithCachedParser f = do+    state <- getState+    case s_dynParsers state of+        MkDynParsersEmpty   -> refillCache state f+        p                   -> f p+++ruleHyperPre :: RuleParser String+ruleHyperPre = ((char '\187' >> return ">>") <|> (string ">>"))++ruleHyperPost :: RuleParser String+ruleHyperPost = ((char '\171' >> return "<<") <|> (string "<<"))++-- XXX - the rulePipeHyper below should be more generic and put all +<< etc to listop level+rulePipeHyper :: RuleParser Var+rulePipeHyper = verbatimRule "" $ do+    -- sig <- (fmap show ruleSigil) <|> string "|"+    char '|'+    ruleHyperPost+    return $ cast "&prefix:|<<"++ruleInfixOp :: RuleParser String+ruleInfixOp = verbatimRule "infix operator" $ do+    -- XXX - Instead of a lookup, add a cached parseInfix here!+    MkTightFunctions{ r_infix = infixOps } <- currentTightFunctions+    choice $ ops (try . string)+        (addScanPrefix (addHyperInfix (Map.keysSet infixOps `Set.union` defaultInfixOps)))++ruleInfixAssignment :: RuleParser String+ruleInfixAssignment = choice $ ops (try . string) infixAssignmentOps++-- XXX !~~ needs to turn into metaop plus ~~+defaultInfixOps :: Set OpName+defaultInfixOps = opWords $ concat+    [ " ** * / % x xx +& +< +> ~& ~< ~> "+    , " + - ~ +| +^ ~| ~^ ?| ?^ , Z X minmax "+    , " & ^ | "+    , " => = "+    , " != == < <= > >= ~~ "+    , " !== !< !<= !> !>= !~~ "+    , " eq ne lt le gt ge =:= === eqv "+    , " !eq !ne !lt !le !gt !ge !=:= !=== !eqv "+    , " && "+    , " || ^^ // "+    , " and or xor orelse andthen "+    , " .[] .{} "+    ]++ruleFoldOp :: RuleParser Var+ruleFoldOp = tryVerbatimRule "reduce metaoperator" $ rulePipeHyper <|> do+    char '['+    name <- ruleInfixOp+    char ']'+--    possiblyHyper <- option "" ruleHyperPost+--+    -- S03: If there is ambiguity between a triangular reduce and an infix operator+    --      beginning with backslash, the infix operator is chosen.+    let var = cast ("&prefix:[" ++ name ++ "]")+        nameID = cast name+    case name of+        ('\\':_)  -> do+            MkTightFunctions{ r_infix = infixOps } <- currentTightFunctions+            return $ if MkOpName nameID `Map.member` infixOps+                then var{ v_name = nameID, v_meta = MFold }+                else var+        _ -> return var+
+ src/Pugs/Parser/Program.hs view
@@ -0,0 +1,210 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+module Pugs.Parser.Program (+    -- Before you would import Pugs.Parser, now you import Pugs.Parser.Program.+    parseProgram,+) where+import Pugs.Internals+import Pugs.AST+import Pugs.Types (isSigilChar)++import Pugs.Parser+import Pugs.Rule+import Text.ParserCombinators.Parsec.Error (showErrorMessages, errorMessages)+import qualified Data.Map as Map++parseProgram :: Env -> FilePath -> String -> Env+parseProgram env path str = runRule env ruleProgram path progWithEOL+    where+    prog = decodeProgram str+    progWithEOL+        | [] <- prog        = "\n"+        | last prog == '\n' = prog+        | otherwise         = prog ++ "\n"++-- Based on: <http://hackage.haskell.org/trac/haskell-prime/wiki/SourceEncodingDetection>+data EncodedSource+    = UTF8 !String+    | UTF16 !Endian !String+    | UTF32 !Endian !String+ -- ... | UserDefined ...++data Endian = LittleEndian | BigEndian++decodeProgram :: String -> String+decodeProgram str = case detectSourceEncoding str of+    UTF8 xs                 -> decodeUTF8 (removeCRLF xs)+    UTF16 LittleEndian xs   -> removeCRLF (decodeUTF16LE xs)+    UTF16 BigEndian xs      -> removeCRLF (decodeUTF16BE xs)+    UTF32 LittleEndian xs   -> removeCRLF (decodeUTF32LE xs)+    UTF32 BigEndian xs      -> removeCRLF (decodeUTF32BE xs)+    where+    removeCRLF ('\r':'\n':xs)   = '\n':removeCRLF xs+    removeCRLF (x:xs)           = x:removeCRLF xs+    removeCRLF []               = []+    decodeUTF16BE (a:b:c:d:xs)+        | a >= '\xD8', a <= '\xDB'  -- High surrogate+        , c >= '\xDC', c <= '\xDF'  -- Low surrogate+        = let rest = decodeUTF16BE xs+              hi   = (ord a - 0xD8) * 0x100 + ord b+              lo   = (ord c - 0xDC) * 0x100 + ord d+        in seq rest (chr (0x10000 + hi * 0x400 + lo) : rest)+    decodeUTF16BE (a:b:xs) = let rest = decodeUTF16BE xs+        in seq rest (chr (ord a * 0x100 + ord b) : rest)+    decodeUTF16BE _ = []+    decodeUTF16LE (a:b:c:d:xs)+        | b >= '\xD8', b <= '\xDB'  -- High surrogate+        , d >= '\xDC', d <= '\xDF'  -- Low surrogate+        = let rest = decodeUTF16LE xs+              hi   = (ord b - 0xD8) * 0x100 + ord a+              lo   = (ord d - 0xDC) * 0x100 + ord c+        in seq rest (chr (0x10000 + hi * 0x400 + lo) : rest)+    decodeUTF16LE (a:b:xs) = let rest = decodeUTF16LE xs+        in seq rest (chr (ord b * 0x100 + ord a) : rest)+    decodeUTF16LE _ = []+    decodeUTF32BE (a:b:c:d:xs) = let rest = decodeUTF32BE xs+        in seq rest (chr (ord a * 0x1000000 + ord b * 0x10000 + ord c * 0x100 + ord d) : rest)+    decodeUTF32BE _ = []+    decodeUTF32LE (a:b:c:d:xs) = let rest = decodeUTF32LE xs+        in seq rest (chr (ord d * 0x1000000 + ord c * 0x10000 + ord b * 0x100 + ord a) : rest)+    decodeUTF32LE _ = []++detectSourceEncoding :: String -> EncodedSource+detectSourceEncoding bytes = case bytes of+    []                                  -> UTF8 []+    ['\x00']                            -> invalidNulls+    xs@[_]                              -> UTF8 xs+    ['\xFF', '\xFE']                    -> UTF16 LittleEndian []+    ('\xFE':'\xFF':xs)                  -> UTF16 BigEndian xs+    ['\x00', '\x00']                    -> invalidNulls+    xs@['\x00', _]                      -> UTF16 BigEndian xs+    xs@[_, '\x00']                      -> UTF16 LittleEndian xs+    xs@[_, _]                           -> UTF8 xs+    ['\x00', '\x00', '\x00']            -> invalidNulls+    xs@[_, _, _]                        -> UTF8 xs+    ('\xEF':'\xBB':'\xBF':xs)           -> UTF8 xs+    ('\x00':'\x00':'\xFE':'\xFF':xs)    -> UTF32 BigEndian xs+    ('\xFF':'\xFE':'\x00':'\x00':xs)    -> UTF32 LittleEndian xs+    ('\xFF':'\xFE':xs)                  -> UTF16 LittleEndian xs+    ('\x00':'\x00':'\x00':'\x00':_)     -> invalidNulls+    xs@('\x00':'\x00':'\x00':_)         -> UTF32 BigEndian xs+    xs@(_:'\x00':'\x00':'\x00':_)       -> UTF32 LittleEndian xs+    ('\x00':'\x00':_)                   -> invalidNulls+    xs@('\x00':_)                       -> UTF16 BigEndian xs+    xs@(_:'\x00':_)                     -> UTF16 LittleEndian xs+    xs                                  -> UTF8 xs+    where+    invalidNulls = error "(invalid nulls)"++makeState :: Env -> RuleState+makeState env = MkState+    { s_env             = env+    , s_parseProgram    = parseProgram+    , s_dynParsers      = MkDynParsersEmpty+    , s_bracketLevel    = StatementBracket+--  , s_char            = ' '+--  , s_name            = nullID+--  , s_pos             = 0+    , s_wsLine          = 0+    , s_wsColumn        = 0+    , s_closureTraits   = [id]+--  , s_freeVars        = Set.empty+    , s_knownVars       = Map.map (const topMPad) (padEntries (envLexical env))+    , s_outerVars       = Map.empty+    , s_protoPad        = emptyPad+    }++-- ^ A fake 'top' MPad for s_knownVars above to refer to things outside the eval scope.+{-# NOINLINE topMPad #-}+topMPad :: MPad+topMPad = unsafePerformIO $ do+    tvar <- newTVarIO emptyPad+    return $ MkMPad (addressOf tvar) tvar++-- XXX - Pending clarification about those 3 -- are they routine-implicit or block-implicit?+{-+protoPad :: Pad+protoPad = mkPad+    [ (cast "$_", PELexical+    , (cast "$/",+    , (cast "$!", +    ]+-}++runRule :: Env -> RuleParser Env -> FilePath -> String -> Env+runRule env p name str =+    case ( runParser p (makeState env) name str ) of+        Left err    -> env { envBody = Val $ VError (VStr msg) [mkPos pos pos] }+            where+            msg = concat (intersperse "\n" (map filterUnexpected $ lines (showErr err)))+            pos = errorPos err+            cur = case takeSameClassWords (dropUntilPos pos str) of+                ""  -> "end of input"+                xs  -> show xs+            filterUnexpected ('!':_)    = "Unexpected " ++ cur+            filterUnexpected line       = line+        Right env'  -> env'++takeSameClassWords :: String -> String+takeSameClassWords "" = ""+takeSameClassWords (x:xs)+    | isSigilChar x = x : takeSameClassWords xs+    | otherwise = case charClassOf x of+        SpaceClass  -> x : takeSameClassWords xs+        cls         -> x : takeWhile ((== cls) . charClassOf) xs++dropUntilPos :: SourcePos -> String -> String+dropUntilPos pos str+    | (curline:_) <- drop (ln - 1) (lines str) = drop (col - 1) curline+    | otherwise = ""+    where+    col = sourceColumn pos+    ln  = sourceLine pos++showErr :: ParseError -> String+showErr err =+      showErrorMessages "or" "unknown parse error"+                        "expecting" "!" "end of input"+                       (errorMessages err)++-- Lexical units --------------------------------------------------++ruleProgram :: RuleParser Env+ruleProgram = rule "program" $ do+    env     <- getRuleEnv++    topPad  <- genParamEntries SubRoutine [defaultArrayParam]+    modify $ \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") } }++    -- Force a reclose-pad evaluation here by way of unsafeEvalExp.+    main'@(Val (VCode vc)) <- unsafeEvalExp $ Syn "" [unwrap main]++    -- S04: CHECK {...}*      at compile time, ALAP+    --  $_() for @*CHECK+    rv <- unsafeEvalExp $ Syn "for"+        [ _Var "@*CHECK"+        , Syn "sub"+            [ Val . VCode $ mkPrim+                { subBody       = App (_Var "$_") Nothing []+                , subParams     = [defaultScalarParam]+                , subInnerPad   = defaultScalarPad+                }+            ]+        ]++    -- If there was a exit() in a CHECK block, we have to exit.+    possiblyExit rv++    env' <- getRuleEnv+    return $ env'+        { envBody       = App (Syn "block" [main']) Nothing (replicate (length $ subParams vc) (_Var "$_")) -- _Var "@*ARGS"]+        , envPackage    = envPackage env+        , envCompPad    = Nothing+        }+
+ src/Pugs/Parser/Types.hs view
@@ -0,0 +1,382 @@+{-# OPTIONS_GHC -fglasgow-exts -funbox-strict-fields #-}++module Pugs.Parser.Types (+    RuleParser, RuleState(..), CharClass(..),+    DynParsers(..), ParensOption(..), FormalsOption(..), BracketLevel(..), OuterLevel,+    BlockInfo(..), emptyBlockInfo,++    RuleOperator, RuleOperatorTable,+    getRuleEnv, modifyRuleEnv, putRuleEnv, insertIntoPosition,+    clearDynParsers, enterBracketLevel, charClassOf,+    addBlockPad, popClosureTrait, addClosureTrait,+    -- Alternate Char implementations that keeps track of s_charClass+    satisfy, string, oneOf, noneOf, char, hexDigit, octDigit,+    digit, upper, anyChar, expRule, parserWarn, mkPos,++    Operator(..), Assoc(..),+) where+import Pugs.AST+import Pugs.Rule+import Pugs.Types+import Pugs.Internals+import Pugs.Pretty (pretty)+import Text.ParserCombinators.Parsec.Pos+import Debug.Trace+import qualified Data.Map as Map+import qualified Data.Set as Set++data BlockInfo = MkBlockInfo+    { bi_pad    :: !Pad+    , bi_traits :: !(TraitBlocks -> TraitBlocks)+    , bi_body   :: !Exp+    }++emptyBlockInfo :: BlockInfo+emptyBlockInfo = MkBlockInfo emptyPad id emptyExp+++{-# INLINE satisfy #-}+satisfy :: (Char -> Bool) -> RuleParser Char+satisfy f = tokenPrim+    (\c -> show [c]) +    (\pos c _ -> updatePosChar pos c) +    -- (Just (\_ c _ state -> state{ s_char = c }))+    (\c -> if f c then Just c else Nothing)++{-# INLINE string #-}+string :: String -> RuleParser String+string s = tokens show updatePosString s+--    `finallyM` modify (\state -> state{ s_char = last s })++{-+_captureNamed :: ID -> RuleParser a -> RuleParser a+_captureNamed newState rule = do+    prev <- gets s_name+    modify $ \state -> state{ s_name = newState }+    rv <- rule+    modify $ \state -> state{ s_name = prev }+    return rv++_capturePositioned :: Int -> RuleParser a -> RuleParser a+_capturePositioned pos rule = do+    prev <- gets s_pos+    modify $ \state -> state{ s_pos = pos }+    rv <- rule+    modify $ \state -> state{ s_pos = prev }+    return rv+-}++charClassOf :: Char -> CharClass+charClassOf c   | isAlphaNum c  = WordClass+                | isSpace c     = SpaceClass+                | '_' <- c      = WordClass+                | otherwise     = SymClass++{-++getCurrCharClass :: RuleParser CharClass+getCurrCharClass = fmap charClassOf (lookAhead anyToken) <|> return SpaceClass++getPrevCharClass :: RuleParser CharClass+getPrevCharClass = do+    p   <- gets s_wsPos+    p'  <- getPosition+    return (if (p == p') then SpaceClass else WordClass)+-}++oneOf, noneOf :: [Char] -> RuleParser Char+oneOf cs    = satisfy (\c -> elem c cs)+noneOf cs   = satisfy (\c -> not (elem c cs))++char :: Char -> RuleParser Char+char c      = satisfy (==c)  <?> show [c]++hexDigit, octDigit, digit, upper :: RuleParser Char+hexDigit    = satisfy (isHexDigit)  <?> "hexadecimal digit"+octDigit    = satisfy (isOctDigit)  <?> "octal digit"++digit       = satisfy (isDigit)     <?> "digit"+upper       = satisfy (isUpper)     <?> "uppercase letter"++{-+whiteSpace  = satisfy (\c -> charClassOf c == SpaceClass)+                                    <?> "whitespace"+-}++{-+perl6WhiteSpace :: RuleParser String+perl6WhiteSpace = do+    cls <- getPrevCharClass +    let mod = if cls == WordClass then many1 else many+    mod whiteSpace <|> (satisfy (\c -> charClassOf c /= WordClass) >> return "")+-}++anyChar :: RuleParser Char+anyChar     = satisfy (const True)++{-|+Cache holding dynamically-generated parsers for user-defined operators.  This+means we don't have to rebuild them for each token.++The cache is generated inside 'Pugs.Parser.parseOpWith'.+It is cleared each time we do compile-time evaluation with+'Pugs.Parser.Unsafe.unsafeEvalExp', by calling 'clearDynParsers'.++Stored inside 'RuleState', the state component of 'RuleParser'.+-}+data DynParsers = MkDynParsersEmpty | MkDynParsers+    { dynParseOp       :: !(RuleParser Exp)+    , dynParseTightOp  :: !(RuleParser Exp)+    , dynParseLitOp    :: !(RuleParser Exp)+    , dynParseNullary  :: !(RuleParser Exp)+    , dynParsePrePost  :: !(RuleParser String)+    }++type OuterLevel = Int++{-|+State object that gets passed around during the parsing process.+-}+data RuleState = MkState+    { s_env           :: Env+    , s_parseProgram  :: (Env -> FilePath -> String -> Env)+    , s_dynParsers    :: DynParsers         -- ^ Cache for dynamically-generated+                                            --     parsers+    , s_bracketLevel  :: !BracketLevel      -- ^ The kind of "bracket" we are in+                                            --     part and has to suppress {..} literals+--  , s_char          :: Char               -- ^ What the previous character contains+--  , s_name          :: !ID                -- ^ Capture name+--  , s_pos           :: !Int               -- ^ Capture position+    , s_wsLine        :: !Line              -- ^ Last whitespace position+    , s_wsColumn      :: !Column            -- ^ Last whitespace position+--  , s_blockPads     :: Map Scope Pad      -- ^ Hoisted pad for this block+    , s_knownVars     :: !(Map Var MPad)        -- ^ Map from variables to its associated scope+    , s_outerVars     :: !(Map MPad (Set Var))  -- ^ Map from scopes to vars that must not be declared in it+--  , s_freeVars      :: !(Set (Var, LexPads))  -- ^ Set of free vars and the mpadlist to check with+    , s_protoPad      :: !Pad                   -- ^ Pad that's part of all scopes; used in param init+    , s_closureTraits :: [TraitBlocks -> TraitBlocks]+                                       -- ^ Closure traits: head is this block, tail is all outer blocks+    }++data BracketLevel+    = ConditionalBracket    -- if ... {}+    | StatementBracket      -- ... ; ...+    | ParensBracket         -- (...)+    | QuoteAdverbBracket    -- q...+    deriving (Show, Eq)++{-|+A parser that operates on @Char@s, and maintains state in a 'RuleState'.+-}+type RuleParser = GenParser Char RuleState++data CharClass = WordClass | SpaceClass | SymClass+    deriving (Show, Eq)++data ParensOption = ParensMandatory | ParensOptional+    deriving (Show, Eq)++data FormalsOption = FormalsSimple | FormalsComplex+    deriving (Show, Eq)++instance MonadSTM RuleParser where+    liftSTM x = return $! unsafePerformSTM x++instance MonadReader Env RuleParser where+    ask = getRuleEnv+    local f action = do+        env     <- getRuleEnv+        putRuleEnv (f env)+        rv      <- action+        env'    <- getRuleEnv+        putRuleEnv env'+            { envPackage = envPackage env+            , envLexical = envLexical env+            }+        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++-----------------------------------------------------------+-- Assoc and OperatorTable+-----------------------------------------------------------+data Assoc                = AssocNone+                          | AssocLeft+                          | AssocRight+                          | AssocList+                          | AssocChain+                          deriving (Show)++data Operator t st a      = Infix { op_infix :: (GenParser t st (a -> a -> a)), op_assoc :: Assoc }+                          | Prefix (GenParser t st (a -> a))+                          | Postfix (GenParser t st (a -> a))+                          | InfixList { op_infixList :: (GenParser t st ([a] -> a)), op_assoc ::  Assoc }+                          | OptionalPrefix (GenParser t st (a -> a))+                          | DependentPostfix (a -> GenParser t st a)+                          | Term (GenParser t st a)++type OperatorTable t st a = [[Operator t st a]]++{-|+Retrieve the 'Pugs.AST.Internals.Env' from the current state of the parser.+-}+enterBracketLevel :: BracketLevel -> RuleParser a -> RuleParser a+enterBracketLevel bracket rule = do+    prev <- gets s_bracketLevel+    modify $ \state -> state{ s_bracketLevel = bracket }+    rv <- rule+    modify $ \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++{-|+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) }++{-|+Update the 's_blockPads' in the parser's state by applying a transformation function.+-}+addBlockPad :: Pad -> RuleParser ()+addBlockPad pad = do+    -- To add a Pad to the COMPILING block, we do two things:+    -- 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+    let myVars          = padKeys pad+        dupVars         = case Map.lookup compPad (s_outerVars state) of+            Just vars   -> myVars `Set.intersection` vars+            _           -> Set.empty+        Just compPad    = envCompPad (s_env state)++    -- traceM ("Checking: " ++ show (myVars, s_outerVars state))+    unless (Set.null dupVars) $ do+        fail $ "Redeclaration of "+            ++ unwords (map show (Set.elems dupVars))+            ++ " conflicts with earlier OUTER references in the same scope"++    -- Then we merge the Pad into COMPILING, and add those vars into s_knownVars.+    ()  <- stm $ appendMPad compPad pad++    let myKnownVars = Map.fromDistinctAscList [ (var, compPad) | var <- Set.toAscList myVars ]+    put state{ s_knownVars = s_knownVars state `Map.union` myKnownVars }++popClosureTrait :: RuleParser ()+popClosureTrait = do+    modify $ \state -> state+        { s_closureTraits = case s_closureTraits state of+            []      -> [id]+            [_]     -> [id]+            (_:fs)  -> fs+        }++addClosureTrait :: String -> VCode -> RuleParser ()+addClosureTrait name code = do+    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+        { s_closureTraits = case s_closureTraits state of+            []      -> [addTrait]+            (f:fs)  -> ((addTrait . f) : fs)+        }+    where+    trait = code{ subName = cast name }+    addTrait block = case name of +        "CONTROL"   -> block{ subControlBlocks = trait:subControlBlocks block }+        "CATCH"     -> block{ subCatchBlocks = trait:subCatchBlocks block }+        "KEEP"      -> block+            { subKeepBlocks     = trait:subKeepBlocks block+            , subLeaveBlocks    = trait:subLeaveBlocks block+            }+        "UNDO"      -> block+            { subUndoBlocks     = trait:subUndoBlocks block+            , subLeaveBlocks    = trait:subLeaveBlocks block+            }+        "ENTER"     -> block{ subEnterBlocks = subEnterBlocks block ++ [trait] }+        "LEAVE"     -> block{ subLeaveBlocks = trait:subLeaveBlocks block }+        "NEXT"      -> block{ subNextBlocks = trait:subNextBlocks block }+        "LAST"      -> block{ subLastBlocks = trait:subLastBlocks block }+        "PRE"       -> block{ subPreBlocks = subPreBlocks block ++ [trait] }+        "POST"      -> block{ subPostBlocks = trait:subPostBlocks block }+        "FIRST"     -> block{ subFirstBlocks = subFirstBlocks block ++ [trait] }+        _           -> trace ("Wrong closure trait name: "++name) block++{-|+Replace the 'Pugs.AST.Internals.Env' in the parser's state with a new one.+-}+putRuleEnv :: Env -> RuleParser ()+putRuleEnv = modifyRuleEnv . const++{-|+Clear the parser's cache of dynamically-generated parsers for user-defined+operators.++These will be re-generated by 'Pugs.Parser.parseOpWith' when needed.+-}+clearDynParsers :: RuleParser ()+clearDynParsers = modify $ \state -> state{ s_dynParsers = MkDynParsersEmpty }++parserWarn :: (Typeable a, Show a) => String -> a -> RuleParser ()+parserWarn str val = do+    currPos <- getPosition+    traceM (pretty (VError (VStr $ str ++ showVal) [mkPos currPos currPos]))+    where+    showVal = case show val of+        "()" -> ""+        txt  -> ":\n    " ++ txt+++{-|+Create a Pugs 'Pugs.AST.Pos' (for storing in the AST) from two Parsec+@SourcePos@ positions, being the start and end respectively of the current+region.+-}+mkPos :: SourcePos -- ^ Starting position of the region+      -> SourcePos -- ^ Ending position of the region+      -> Pos+mkPos pos1 pos2 = MkPos+    { posName         = __(sourceName pos1)+    , posBeginLine    = sourceLine pos1+    , posBeginColumn  = sourceColumn pos1+    , posEndLine      = sourceLine pos2+    , posEndColumn    = sourceColumn pos2+    }++{-|+Record the current parser position, invoke the given subrule, then record the+parser's new position and encapsulate the subrule's result in a+'Pugs.AST.Internals.Pos' indicating the source region matched by the rule.++Also applies 'unwrap' to the result of the given parser.+-}+expRule :: RuleParser Exp -- ^ Sub-rule to invoke+        -> RuleParser Exp+expRule rule = do+    pos1 <- getPosition+    exp  <- rule+    pos2 <- getPosition+    return $ Ann (Pos (mkPos pos1 pos2)) (unwrap exp)+++{-|+Modify the input stream by inserting a 'String' as the next thing to parse.+-}+insertIntoPosition :: String -> RuleParser ()+insertIntoPosition str = do+    currPos <- getPosition+    input   <- getInput +    setInput (str ++ input)+    setPosition (setSourceColumn currPos (sourceColumn currPos - length str))
+ src/Pugs/Parser/Unsafe.hs view
@@ -0,0 +1,108 @@+{-# OPTIONS_GHC -fglasgow-exts -fno-full-laziness -fno-cse #-}++-- possibly this needs to be beside the AST or Eval, not the Parser+module Pugs.Parser.Unsafe (+    unsafeEvalLexDiff,+    unsafeEvalEnv,+    unsafeEvalExp,+    possiblyApplyMacro,+) where+import Pugs.Internals+import Pugs.AST+import Pugs.Pretty+import Pugs.Parser.Types+import Pugs.Parser.Util+import Pugs.Eval.Var+import Pugs.Types+import Pugs.Rule+import DrIFT.YAML ()++unsafeEvalLexDiff :: Exp -> RuleParser Pad+unsafeEvalLexDiff exp = do+    env  <- getRuleEnv+    putRuleEnv env{ envLexical = mkPad [] }+    env' <- unsafeEvalEnv exp+    putRuleEnv env'{ envLexical = envLexical env' `unionPads` envLexical env }+    return $ envLexical env'++-- XXX: Should these fail instead of error?+unsafeEvalEnv :: Exp -> RuleParser Env+unsafeEvalEnv exp = do+    -- pos <- getPosition+    env <- getRuleEnv+    val <- unsafeEvalExp $ mergeStmts exp (Syn "continuation" [])+    case val of+        Val (VControl (ControlContinuation { ccEnv = env' })) ->+            return env'{ envDebug = envDebug env }+        _  -> error $ pretty val++{-# NOINLINE unsafeEvalExp #-}+unsafeEvalExp :: Exp -> RuleParser Exp+unsafeEvalExp exp = do+    -- clearDynParsers+    env <- getRuleEnv+    let val = unsafePerformIO $ do+        runEvalIO env $ do+            evl <- asks envEval+            evl exp+    case val of+        VError{} -> error $ pretty (val :: Val)+        _        -> return $ Val val++{-# NOINLINE possiblyApplyMacro #-}+{-| @possiblyApplyMacro@ takes an @Exp@ containg only an @App@. It then checks+    if the code to be executed is a reference to a macro. If it is, the macro+    is executed now, i.e. during compile-time. The return value of the macro is+    then processed accordingly (i.e. a return value of type @Str@ will be+    parsed, and a @Code@ will be executed during runtime).+-}+possiblyApplyMacro :: Exp            -- ^ The @Exp@ containg only an @App@ to+                                     --   check if it calls a macro+                   -> RuleParser Exp -- ^ The result expression (either the+                                     --   original one or the result of+                                     --   applying the macro)+possiblyApplyMacro app@(App (Var name) invs args) = do+    -- First, we've to resolve name to a vcode.+    env <- getRuleEnv+    -- Note that we don't have to clearDynParsers, as we just do a variable+    -- lookup here.+    subCode <- return $! unsafePerformIO $! runEvalIO env $! do+        res <- findVar name+        maybe (return undef) readRef res+    case subCode of+        -- If we found a Code var, possibly process it further.+        VCode vcode -> possiblyApplyMacro' vcode app+        -- Else, return the original expression.+        _ -> return app+    where+    {-# NOINLINE possiblyApplyMacro' #-}+    possiblyApplyMacro' :: VCode -> Exp -> RuleParser Exp+    possiblyApplyMacro' vcode app+        | SubMacro <- subType vcode+        = do+            -- The vcode is a macro! Apply it and substitute its return value.+            ret <- unsafeEvalExp $! App (Val $ VCode vcode{ subType = SubRoutine }) invs args+            -- local (maybe id const (subEnv vcode)) $ +            substMacroResult ret+        | otherwise+        = return app+    {-# NOINLINE substMacroResult #-}+    substMacroResult :: Exp -> RuleParser Exp+    -- An AST is spliced+    substMacroResult (Val (VObject o)) | objType o == mkType "Code::Exp" = do+        return $! fromObject o+    -- A Str should be (re)parsed.+    substMacroResult (Val (VStr code)) = fmap bi_body . localBlock $ do+        parseProgram <- gets s_parseProgram+        env          <- ask+        pos          <- getPosition+        case envBody (parseProgram env ("MACRO { " ++ show pos ++" }") code) of+            Val (err@VError{})  -> fail $ pretty err+            exp                 -> return exp+    -- A Code does not need to be parsed, so simply return the equivalent of+    --  $code().+    substMacroResult code@(Val (VCode _)) = do+        return $! App code Nothing []+    substMacroResult (Val (VUndef)) = return emptyExp+    substMacroResult _ = fail "Macro did not return an AST, a Str or a Code!"+possiblyApplyMacro x = return x
+ src/Pugs/Parser/Util.hs view
@@ -0,0 +1,306 @@+{-# OPTIONS_GHC -fglasgow-exts -fallow-overlapping-instances #-}+module Pugs.Parser.Util where++import Pugs.Internals+import Pugs.AST+import Pugs.Types+import Pugs.Lexer+import Pugs.Rule+import Pugs.Parser.Types+import qualified Data.Map as Map+import qualified Data.Set as Set++grammaticalCategories :: [String]+grammaticalCategories = ["prefix_circumfix_meta_operator:","infix_circumfix_meta_operator:","prefix_postfix_meta_operator:","postfix_prefix_meta_operator:","infix_postfix_meta_operator:","statement_modifier:","statement_control:","scope_declarator:","trait_auxiliary:","trait_verb:","regex_mod_external:","regex_mod_internal:","regex_assertion:","regex_backslash:","regex_metachar:","postcircumfix:","circumfix:","postfix:","infix:","prefix:","quote:","term:"]+++retBlockWith :: (Exp -> Exp) -> BlockInfo -> RuleParser BlockInfo+retBlockWith f bi = return bi{ bi_body = f (bi_body bi) }++-- around a block body we save the package and the current lexical pad+-- at the start, so that they can be restored after parsing the body+localBlock :: RuleParser Exp -> RuleParser BlockInfo+localBlock m = do+    state   <- get++    -- XXX - Perhaps clone the protopad right here, for $_ etc?+    compPad <- newMPad (s_protoPad state)++    -- traceM $ "Gen:" ++ show compPad+    let env     = s_env state+        lexPads = (PCompiling compPad:envLexPads env)+        protoVars = Map.map (const compPad) (padEntries $ s_protoPad state)++    put state+        { s_closureTraits   = (id : s_closureTraits state)+        , s_env             = env+            { envLexPads = lexPads  -- enter the scope+            , envCompPad = Just compPad+            }+        , s_protoPad        = emptyPad+        , s_knownVars       = s_knownVars state `Map.union` protoVars+        }++    body    <- m+    state'  <- get++    -- Remove from knownVars the bindings belonging to this scope.+    let outerKnownVars = Map.filter (/= compPad) (s_knownVars state')+        outerOuterVars = Map.delete compPad (s_outerVars state')+        (traits, outerTraits) = case s_closureTraits state' of+            (t:ts)  -> (t, ts)+            _       -> (id, [])++    put state+        { s_env = (s_env state')+            { envPackage = envPackage env+            , envLexical = envLexical env+            , envLexPads = envLexPads env+            , envCompPad = envCompPad env+            }+        , s_closureTraits = outerTraits+        , s_knownVars     = outerKnownVars+        , s_outerVars     = outerOuterVars+        , s_protoPad      = emptyPad+        }++    -- Re-read compile time refs into the new protos at end of scope.+    newPad <- return $! unsafePerformSTM $! do+        curPad  <- readMPad compPad+        entries <- forM (padToList curPad) $ \(var, entry) -> do+            proto   <- readPadEntry entry+            let newEntry = entry{ pe_proto = proto }+            return (newEntry `seq` (var, newEntry))+        let newPad = listToPad (length entries `seq` entries)+        writeMPad compPad newPad+        return newPad+    return $ MkBlockInfo{ bi_pad = newPad, bi_body = body, bi_traits = traits }++ruleParamList :: ParensOption -> RuleParser a -> RuleParser (Maybe [[a]])+ruleParamList wantParens parse = rule "parameter list" $ do+    (formal, hasParens) <- f $+        (((try parse) `sepEndBy` lexeme (oneOf ",;")) `sepEndBy` invColon)+    case formal of+        [[]]   -> return $ if hasParens then Just [[], []] else Nothing+        [args] -> return $ Just [[], args]+        [_,_]  -> return $ Just formal+        _      -> fail "Only one invocant list allowed"+    where+    f = case wantParens of+        ParensOptional  -> maybeParensBool+        ParensMandatory -> \x -> do rv <- parens x; return (rv, True)+    invColon = do+        ch <- oneOf ":;"+        -- Compare:+        --   sub foo (: $a)   # vs.+        --   sub foo (:$a)+        lookAhead $ (many1 space <|> string ")")+        whiteSpace+        return ch+        +maybeParensBool :: RuleParser a -> RuleParser (a, Bool)+maybeParensBool p = choice+    [ do rv <- parens p; return (rv, True)+    , do rv <- p; return (rv, False)+    ]+++{-| Wraps a call to @&Pugs::Internals::check_for_io_leak@ around the input+    expression. @&Pugs::Internals::check_for_io_leak@ should @die()@ if the+    expression returned an IO handle. -}+-- Please remember to edit Prelude.pm, too, if you rename the name of the+-- checker function.+checkForIOLeak :: VCode -> Exp+checkForIOLeak code =+    App (_Var "&Pugs::Internals::check_for_io_leak") Nothing [ Val $ VCode code ]+    +defaultParamFor :: SubType -> [Param]+defaultParamFor SubBlock    = [] -- defaultScalarParam]+defaultParamFor SubPointy   = []+defaultParamFor _           = [defaultArrayParam]++extractNamedPlaceholders :: SubType -> Maybe [Param] -> Exp -> (Exp, [Var], [Param])+extractNamedPlaceholders SubBlock formal body = (fun, names', params)+    where+    (fun, names) = extractPlaceholderVars body Set.empty+    names' | isJust formal+           = sortNames (Set.delete varTopic names)+           | otherwise+           = sortNames names+    params = map nameToParam names' ++ (maybe [] id formal)+extractNamedPlaceholders SubPointy formal body = (body, [], maybe [] id formal)+extractNamedPlaceholders SubMethod formal body = (body, [], maybe [] id formal)+extractNamedPlaceholders _ formal body = (body, names', params)+    where+    (_, names) = extractPlaceholderVars body Set.empty+    names' | isJust formal+           = sortNames (Set.delete varTopic names)+           | otherwise+           = sortNames (Set.filter (== varTopic) names)+    params = map nameToParam names' ++ (maybe [] id formal)++sortNames :: Set Var -> [Var]+sortNames = sortBy (\x y -> v_name x `compare` v_name y) . Set.toList++nameToParam :: Var -> Param+nameToParam name = MkOldParam+    { isInvocant    = False+    , isOptional    = False+    , isNamed       = False+    , isLValue      = True+    , isWritable    = (name == varTopic)+    , isLazy        = False+    , paramName     = name+    , paramContext  = CxtItem $ typeOfSigilVar name+    , paramDefault  = Noop+    }++_percentUnderscore :: Var+_percentUnderscore = cast "%_"++paramsFor :: SubType -> Maybe [Param] -> [Param] -> [Param]+paramsFor SubMethod formal params +    | isNothing (find ((_percentUnderscore ==) . paramName) params)+    = paramsFor SubRoutine formal params ++ [defaultHashParam]+paramsFor styp Nothing []       = defaultParamFor styp+paramsFor _ _ params            = params++processFormals :: Monad m => [[Exp]] -> m (Maybe Exp, [Exp])+processFormals formal = case formal of+    []      -> return (Nothing, [])+    [args]  -> return (Nothing, unwind args)+    [invs,args] | [inv] <- unwind invs -> return (Just inv, unwind args)+    _                   -> fail "Only one invocant allowed"+    where+    unwind :: [Exp] -> [Exp]+    unwind [] = []+    unwind ((Syn "," list):xs) = unwind list ++ unwind xs+    unwind x  = x++-- | A Param representing the default (unnamed) invocant of a method on the given type.+selfParam :: Type -> Param+selfParam typ = MkOldParam+    { isInvocant    = True+    , isOptional    = False+    , isNamed       = False+    , isLValue      = True+    , isWritable    = True+    , isLazy        = False+    , paramName     = cast "$__SELF__"+    , paramContext  = CxtItem typ+    , paramDefault  = Noop+    }++hashComposerCheck :: Exp -> RuleParser Bool+hashComposerCheck exp+    | Ann (Prag [MkPrag "eol-block" _]) _ <- exp = do+        when isHash $+            fail "Closing hash curly may not terminate a line;\nplease add a comma or a semicolon to disambiguate"+        return False+    | otherwise = return isHash+    where+    isHash = doCheck (possiblyUnwrap exp)++    possiblyUnwrap (Ann _ exp) = possiblyUnwrap exp+    possiblyUnwrap (Syn "block" [exp]) = unwrap exp+    possiblyUnwrap (App (Val (VCode (MkCode { subType = SubBlock, subBody = fun }))) Nothing []) = unwrap fun+    possiblyUnwrap x = x+    +    isHashOrPair (Ann _ exp)            = isHashOrPair exp+    isHashOrPair (App (Var var) _ _)    = (var == cast "&pair") || (var == cast "&infix:=>") +    isHashOrPair (Syn "%{}" _)          = True+    isHashOrPair (Var var)              = v_sigil var == SHash+    isHashOrPair _                      = False+    +    doCheck Noop                   = True+    doCheck (Syn "," (subexp:_))   = isHashOrPair subexp+    doCheck exp                    = isHashOrPair exp++tryLookAhead :: RuleParser a -> RuleParser b -> RuleParser a+tryLookAhead rule after = try $ do+    rv <- rule+    lookAhead after+    return rv++makeVar :: String -> Exp+makeVar (s:"<>") =+    makeVarWithSigil s $ _Var "$/"+makeVar (s:rest) | all (`elem` "1234567890") rest =+    makeVarWithSigil s $ Syn "[]" [_Var "$/", Val $ VInt (read rest)]+makeVar (s:'<':'<':name) =+    makeVarWithSigil s $ Syn "{}" [_Var "$/", doSplitStr shellWords (init (init name))]+makeVar (s:'\171':name) =+    makeVarWithSigil s $ Syn "{}" [_Var "$/", doSplitStr shellWords (init name)]+makeVar (s:'<':name) =+    makeVarWithSigil s $ Syn "{}" [_Var "$/", doSplitStr perl6Words (init name)]+makeVar var = _Var var++makeVarWithSigil :: Char -> Exp -> Exp+makeVarWithSigil '$' x = x+makeVarWithSigil s   x = Syn (s:"{}") [x]++-- | splits the string into expressions on whitespace.+-- Implements the <> operator at parse-time.+doSplitStr :: (String -> [String]) -> String -> Exp+doSplitStr f str = case f str of+    []  -> Syn "," []+    [x] -> Val (VStr x)+    xs  -> Syn "," $ map (Val . VStr) xs++perl6Words :: String -> [String]+perl6Words s+    | [] <- findSpace = []+    | otherwise       = w : words s''+    where+    (w, s'')  = break isBreakingSpace findSpace+    findSpace = dropWhile isBreakingSpace s++isBreakingSpace :: Char -> Bool+isBreakingSpace '\x09'  = True+isBreakingSpace '\x0a'  = True+isBreakingSpace '\x0d'  = True+isBreakingSpace '\x20'  = True+isBreakingSpace _       = False++followedBy, tryFollowedBy :: RuleParser a -> RuleParser b -> RuleParser a+followedBy rule after = do+    rv <- rule+    after+    return rv++tryFollowedBy = (try .) . followedBy++-- XXX - Naive implementation of << 1 '2' 3 >>, only used in $<< 'foo' >> so far++data ShellWordsState = MkShellWordsState+    { s_escape  :: Bool+    , s_quote   :: (Maybe Char)+    , s_cur     :: Maybe String+    , s_acc     :: [String]+    }++shellWords :: String -> [String]+shellWords = postProc . foldl doShellWords (MkShellWordsState False Nothing Nothing [])+    where+    doShellWords state ch+        | s_escape state+        = normalChar{ s_escape = False }+        | '\\' <- ch+        = state{ s_escape = True }+        | Just q <- s_quote state+        = if ch == q then closeQuote else normalChar+        | isBreakingSpace ch+        = nextWord+        | '"' <- ch     = beginQuote+        | '\'' <- ch    = beginQuote+        | otherwise     = normalChar+        where+        cur = s_cur state+        acc = s_acc state+        normalChar = state{ s_cur = Just (maybe [ch] (ch:) cur) }+        beginQuote = state{ s_quote = Just ch }+        closeQuote = state{ s_quote = Nothing, s_cur = Just (maybe "" id cur) }+        nextWord   = state{ s_acc = maybe acc (:acc) cur, s_cur = Nothing }+    postProc MkShellWordsState{ s_cur = cur, s_acc = acc } = reverse (map reverse acc')+        where+        acc' = maybe acc (:acc) cur
+ src/Pugs/Prelude.hs view
@@ -0,0 +1,824 @@+module Pugs.Prelude where++{-+    Prelude bootstap. ++>   The world was young, the mountains green,+>   No stain yet on the Moon was seen,+>   No words were laid on stream or stone,+>   When Durin woke and walked alone.++-}++----------------------------------------------------------------+-- Do not modify this file; it is generated automatically by  --+--                  util/gen_prelude.pl                       --+----------------------------------------------------------------++preludeStr :: String+preludeStr = "use v6-alpha;\n\+\\n\+\module Prelude-0.0.1;\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\class Process {\n\+\    multi sub exec($prog, @args) returns Bool is builtin is primitive is unsafe {\n\+\\n\+\        Pugs::Internals::exec($prog, Bool::False, @args);\n\+\    }\n\+\    multi sub exec(@args) returns Bool is builtin is primitive is unsafe {\n\+\\n\+\        Pugs::Internals::exec(@args[0], Bool::True, @args);\n\+\    }\n\+\    multi sub exec($string) returns Bool is builtin is primitive is unsafe {\n\+\\n\+\\n\+\\n\+\\n\+\        \n\+\        my @args = $string.split;\n\+\        exec(@args);\n\+\    }\n\+\}\n\+\\n\+\class Control::Basic {\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\    multi sub eval (Str $code, Str :$lang = 'Perl6') is primitive is safe is builtin {\n\+\        &::(\"Pugs::Internals::eval_\"~lc($lang))($code);\n\+\\n\+\    }\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\    multi sub evalfile (Str $filename; Str :$lang = 'Perl6')\n\+\            is primitive is unsafe {\n\+\        &eval(slurp $filename, $lang);\n\+\    }\n\+\}\n\+\\n\+\\n\+\class Control::Caller {\n\+\    has Str $.package;\n\+\    has Str $.file;\n\+\    has Int $.line;\n\+\    has Str $.subname;\n\+\    has Str $.subtype;\n\+\    has Code $.sub;\n\+\    has Str $.params;   # FIXME: needs attention; don't use yet.\n\+\}\n\+\\n\+\multi sub caller (Class $kind = Any, Int :$skip = 0, Str :$label)\n\+\        returns Control::Caller is primitive is builtin is safe {\n\+\    my @caller = Pugs::Internals::caller($kind, $skip, $label);\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\    @caller.elems ?? Control::Caller.new(\n\+\        package => @caller[0],\n\+\        file    => @caller[1],\n\+\        line    => @caller[2],\n\+\        subname => @caller[3],\n\+\        subtype => @caller[4],\n\+\        sub     => @caller[5],\n\+\    ) !! undef;\n\+\}\n\+\\n\+\class fatal {\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\    \n\+\\n\+\\n\+\\n\+\\n\+\    $fatal::DEFAULT_FATALITY = 1;\n\+\    \n\+\    sub import {\n\+\        Pugs::Internals::install_pragma_value($?CLASS, 1);\n\+\    }\n\+\\n\+\    sub unimport {\n\+\        Pugs::Internals::install_pragma_value($?CLASS, 0);\n\+\    }\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\    sub __fail($e = \"failed\") is primitive is builtin is safe {\n\+\        if Pugs::Internals::current_pragma_value($?CLASS) //\n\+\                $fatal::DEFAULT_FATALITY {\n\+\            die $e;\n\+\        } else {\n\+\            $! = $e;\n\+\            return undef; # this is probably the one place we can return\n\+\\n\+\\n\+\        }\n\+\    }\n\+\}\n\+\\n\+\class Carp {\n\+\\n\+\\n\+\    multi sub longmess (; $e = '') returns Str is primitive is safe {\n\+\        my($mess, $i);\n\+\        $mess = \"$e at $?CALLER::POSITION\";\n\+\\n\+\\n\+\\n\+\\n\+\        loop (;;) {\n\+\            my $caller = Control::Caller::caller(skip => $i++) orelse last;\n\+\            $mess ~= \"\\n\\t{$caller.package}::{$caller.subname}() at {$caller.file} line {$caller.line}\";\n\+\        };\n\+\\n\+\        $mess;\n\+\    }\n\+\}\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\class File {\n\+\    my $SEEK_START = 0;\n\+\    my $SEEK_CUR   = 1;\n\+\    my $SEEK_END   = 2;\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\    multi sub open (Str $filename, Str :$layer, Bool :$r, Bool :$w, Bool :$rw,\n\+\            Bool :$a) returns IO is primitive is unsafe is builtin {\n\+\        die \"fancy open modes not supported yet\" if $a and ($r or $w or $rw);\n\+\\n\+\        my $mode;\n\+\        $mode = \"a\" if $a;\n\+\        $mode = \"w\" if $w;\n\+\        $mode = \"rw\" if $rw or ($r and $w);\n\+\        $mode //= \"r\";\n\+\\n\+\\n\+\        my $fh = Pugs::Internals::openFile($filename, $mode);\n\+\\n\+\\n\+\        Pugs::Internals::hSetBinaryMode($fh, Bool::True) if\n\+\            $layer ~~ rx:P5/:raw\\b/;\n\+\\n\+\        $fh;\n\+\    }\n\+\\n\+\    multi method seek (Int $position, Int $whence = $File::SEEK_START)\n\+\            returns Bool is primitive is unsafe is builtin {\n\+\        Pugs::Internals::hSeek(self, $position, $whence);\n\+\    }\n\+\}\n\+\\n\+\\n\+\class Pipe {\n\+\\n\+\\n\+\    multi sub open (Str $command, Bool :$r is copy, Bool :$w) returns IO\n\+\            is primitive is unsafe {\n\+\        die \"Pipe::open is unidirectional\" if all($r, $w);\n\+\        $r = Bool::True if none($r, $w);\n\+\        my ($in, $out, $err) =\n\+\            Pugs::Internals::runInteractiveCommand($command);\n\+\        close $err;\n\+\        close  ($r ?? $in !! $out);\n\+\        ($r ?? $out !! $in);\n\+\    }\n\+\\n\+\\n\+\\n\+\    multi sub open2 (Str $command) returns List is primitive is unsafe {\n\+\        my ($in, $out, $err, $pid) =\n\+\            Pugs::Internals::runInteractiveCommand($command);\n\+\        close $err;\n\+\        ($in, $out, $pid);\n\+\    }\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\    multi sub open3 (Str $command) returns List is primitive is unsafe {\n\+\        my ($in, $out, $err, $pid) =\n\+\            Pugs::Internals::runInteractiveCommand($command);\n\+\        ($in, $out, $err, $pid);\n\+\    }\n\+\}\n\+\\n\+\\n\+\role Iter {\n\+\    multi sub prefix:<=> () is primitive { self.shift() }\n\+\    \n\+\    method shift   () { ... }\n\+\    method next    () { ... }\n\+\    method current () { ... }\n\+\}\n\+\\n\+\\n\+\class IO does Iter {\n\+\    method shift   () is primitive { self.readline() }\n\+\    method next    () is primitive { self.shift() }\n\+\}\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\class Str does Iter {\n\+\    method shift () is primitive { =open(self) }\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\    multi method comb () is primitive is safe {\n\+\        list self ~~ rx:P5:g/\\S+/;\n\+\    }\n\+\\n\+\    multi method comb ($rx) is primitive {\n\+\        given $rx {\n\+\            when Str { list self ~~ rx:P5:g/\\Q$rx\\E/; }\n\+\            when Regex {    # XXX kludge absence of /<$rx>/ above\n\+\                my $str = ~self;\n\+\                gather {\n\+\                    while $str ~~ $rx {\n\+\                        take ~$();\n\+\                        substr($str, 0, $/.to) = \"\";\n\+\                    }\n\+\\n\+\                };\n\+\            }\n\+\        }\n\+\    }\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\    method subst($rule, $replacement) is primitive is safe {\n\+\        my ($rgx,$adv,$dup = self);\n\+\\n\+\        if $rule.isa(Str) {\n\+\          $rgx =  \"<'$rule'>\";\n\+\        }\n\+\        else {\n\+\          $rgx = Pugs::Internals::rule_pattern($rule);\n\+\          $adv = Pugs::Internals::rule_adverbs($rule);\n\+\        }\n\+\\n\+\\n\+\        my $advstr = $adv.map: { \":$_[0]\"~\"($_[1])\"}.join if $adv;\n\+\        my $apply = '()' if $replacement ~~ Code;\n\+\        my $op=\"s$advstr/$rgx/\\$replacement$apply/\";\n\+\\n\+\        eval('$dup ~~ '~$op);\n\+\        $dup\n\+\    }\n\+\\n\+\    method match(Regex $rule) is primitive is safe{\n\+\        self ~~ $rule\n\+\    }\n\+\\n\+\    method trans (Pair *@intable) is primitive {\n\+\\n\+\        my sub expand (Str $string is copy) {\n\+\            my @rv;\n\+\\n\+\            my $idx;\n\+\\n\+\            $string ~~ s:P5:g/\\s+//;\n\+\            my $delim = '!';\n\+\            while index($string,$delim) != -1 {\n\+\                $delim = chr(ord($delim)+1);    # XXX still spoofable\n\+\            }\n\+\            $string = eval \"qb$delim$string$delim\";\n\+\            while (($idx = index($string,'..')) != -1) {\n\+\                my $pre = substr($string,0,$idx-1);\n\+\                my $start = substr($string,$idx-1,1);\n\+\                my $end = substr($string,$idx+2,1);\n\+\\n\+\                push @rv, $pre.split('');\n\+\                push @rv, (~ $start)..(~ $end);\n\+\\n\+\                $string = substr($string,$idx+3);\n\+\            }\n\+\\n\+\            push @rv, $string.split('');\n\+\\n\+\            @rv;\n\+\        }\n\+\\n\+\        my %transtable;\n\+\        for @intable -> Pair $pair {\n\+\            my ($k, $v) = $pair.kv;\n\+\\n\+\            my @ks = $k.isa(Str) ?? expand($k) !! $k.values;\n\+\            my @vs = $v.isa(Str) ?? expand($v) !! $v.values;\n\+\            %transtable{@ks} = @vs;\n\+\        }\n\+\\n\+\        [~] map { %transtable{$_} // $_ }, self.split('');\n\+\    }\n\+\\n\+\    method graphs(Str $s:) returns Int is primitive is safe {\n\+\\n\+\        my Int @combining = (0x0300, 0x0301, 0x0302, 0x0303,\n\+\            0x0304, 0x0305, 0x0306, 0x0307, 0x0308, 0x0309,\n\+\            0x030A, 0x030B, 0x030C, 0x030D, 0x030E, 0x030F,\n\+\            0x0310, 0x0311, 0x0312, 0x0313, 0x0314, 0x0315,\n\+\            0x0316, 0x0317, 0x0318, 0x0319, 0x031A, 0x031B,\n\+\            0x031C, 0x031D, 0x031E, 0x031F, 0x0320, 0x0321,\n\+\            0x0322, 0x0323, 0x0324, 0x0325, 0x0326, 0x0327,\n\+\            0x0328, 0x0329, 0x032A, 0x032B, 0x032C, 0x032D,\n\+\            0x032E, 0x032F, 0x0330, 0x0331, 0x0332, 0x0333,\n\+\            0x0334, 0x0335, 0x0336, 0x0337, 0x0338, 0x0339,\n\+\            0x033A, 0x033B, 0x033C, 0x033D, 0x033E, 0x033F,\n\+\            0x0340, 0x0341, 0x0342, 0x0343, 0x0344, 0x0345,\n\+\            0x0346, 0x0347, 0x0348, 0x0349, 0x034A, 0x034B,\n\+\            0x034C, 0x034D, 0x034E, 0x034F, 0x0350, 0x0351,\n\+\            0x0352, 0x0353, 0x0354, 0x0355, 0x0356, 0x0357,\n\+\            0x0358, 0x0359, 0x035A, 0x035B, 0x035C, 0x035D,\n\+\            0x035E, 0x035F, 0x0360, 0x0361, 0x0362, 0x0363,\n\+\            0x0364, 0x0365, 0x0366, 0x0367, 0x0368, 0x0369,\n\+\            0x036A, 0x036B, 0x036C, 0x036D, 0x036E, 0x036F,\n\+\            0x0483, 0x0484, 0x0485, 0x0486, 0x0488, 0x0489,\n\+\            0x135F, 0x1DC0, 0x1DC1, 0x1DC2, 0x1DC3, 0x20D0,\n\+\            0x20D1, 0x20D2, 0x20D3, 0x20D4, 0x20D5, 0x20D6,\n\+\            0x20D7, 0x20D8, 0x20D9, 0x20DA, 0x20DB, 0x20DC,\n\+\            0x20DD, 0x20DE, 0x20DF, 0x20E0, 0x20E1, 0x20E2,\n\+\            0x20E3, 0x20E4, 0x20E5, 0x20E6, 0x20E7, 0x20E8,\n\+\            0x20E9, 0x20EA, 0x20EB, 0x3099, 0x309A, 0xFE20,\n\+\            0xFE21, 0xFE22, 0xFE23, 0x1D165, 0x1D166, 0x1D167,\n\+\            0x1D168, 0x1D169, 0x1D16D, 0x1D16E, 0x1D16F, 0x1D170,\n\+\            0x1D171, 0x1D172, 0x1D17B, 0x1D17C, 0x1D17D, 0x1D17E,\n\+\            0x1D17F, 0x1D180, 0x1D181, 0x1D182, 0x1D185, 0x1D186,\n\+\            0x1D187, 0x1D188, 0x1D189, 0x1D18A, 0x1D18B, 0x1D1AA,\n\+\            0x1D1AB, 0x1D1AC, 0x1D1AD, 0x1D242, 0x1D243, 0x1D244);\n\+\        my Int $nc = $s.codes;\n\+\        my Int $ng = $nc;\n\+\        loop(my $i = 0; $i < $nc; $i++) {\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\            $ng-- if substr($s, $i, 1).ord == any(@combining)\n\+\                    or substr($s, $i, 2) eq \"\\r\\n\";\n\+\        }\n\+\        $ng;\n\+\    }\n\+\\n\+\    method chars(Str $s:) returns Int is primitive is safe {\n\+\        $s.graphs;\n\+\    }\n\+\\n\+\}\n\+\\n\+\\n\+\sub Pugs::Internals::but_block ($obj, Code $code) is primitive is safe {\n\+\    $code($obj);\n\+\    $obj;\n\+\}\n\+\\n\+\\n\+\class Time::Local {\n\+\    has Int  $.year;    # eg., 2005; \"pre-Gregorian dates are inaccurate\" - GHC\n\+\\n\+\    has Int  $.month;   # 1 to 12 - NOTE 1-based\n\+\    has Int  $.day;     # 1 to 31\n\+\    has Int  $.hour;    # 0 to 23\n\+\    has Int  $.min;     # 0 to 59\n\+\    has Int  $.sec;     # 0 to 61 (up to two leap seconds)\n\+\    has Int  $.picosec;\n\+\    has Int  $.wday;    # 1 to 7, Sunday == 1\n\+\    has Int  $.yday;    # 0 to 365 (up to one leap day)\n\+\    has Str  $.tzname;  # string, eg, JDT\n\+\    has Int  $.tz;      # variation from UTC in seconds\n\+\    has Bool $.is_dst;\n\+\}\n\+\\n\+\multi sub localtime(Num $when = time) returns Time::Local\n\+\        is primitive is builtin is safe {\n\+\    my $res;\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\        my @tm = Pugs::Internals::localtime($when); # Bool::False, $sec, $pico);\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\        $res = Time::Local.new(\n\+\            year    => @tm[0],\n\+\            month   => @tm[1],\n\+\            day     => @tm[2],\n\+\            hour    => @tm[3],\n\+\            min     => @tm[4],\n\+\            sec     => @tm[5],\n\+\            picosec => @tm[6],\n\+\            wday    => @tm[7],\n\+\            yday    => @tm[8],\n\+\            tzname  => @tm[9],\n\+\            tz      => @tm[10],\n\+\            is_dst  => @tm[11],\n\+\        );\n\+\\n\+\    $res;\n\+\}\n\+\\n\+\class Num {\n\+\\n\+\\n\+\\n\+\    multi sub round_gen(Int $n, Code $corner) returns Int is primitive is safe {\n\+\        $n\n\+\    }\n\+\    multi sub round_gen(Num $n, Code $corner) returns Int is primitive is safe {\n\+\        (int($n) == $n) ?? int($n) !! $corner($n);\n\+\    }\n\+\\n\+\    sub do_round($n) is primitive is safe {\n\+\        ($n < 0) ?? int( $n - 0.5) !! int($n + 0.5);\n\+\    }\n\+\    sub do_ceil($n) is primitive is safe {\n\+\        ($n < 0) ?? (-int(-$n)) !! int($n + 1)\n\+\    }\n\+\    sub do_floor($n) is primitive is safe {\n\+\        ($n < 0) ?? (-int(1-$n)) !! int($n)\n\+\    }\n\+\\n\+\\n\+\\n\+\    sub round($n) is primitive is safe is builtin {\n\+\        Num::round_gen($n, &Num::do_round)\n\+\    }\n\+\\n\+\    sub truncate($n) is primitive is safe is builtin { $n.int }\n\+\    sub trunc($n) is primitive is safe is builtin { $n.int }\n\+\\n\+\    sub ceiling($n) is primitive is safe is builtin { Num::round_gen($n, &Num::do_ceil) }\n\+\    sub ceil($n) is primitive is safe is builtin { Num::round_gen($n, &Num::do_ceil) }\n\+\\n\+\    sub floor($n) is primitive is safe is builtin {\n\+\        Num::round_gen($n, &Num::do_floor)\n\+\    }\n\+\}\n\+\\n\+\\n\+\\n\+\sub pi() is primitive is builtin is safe {Math::Basic::pi}\n\+\\n\+\\n\+\sub sprintf ($fmt, *@args) is primitive is builtin is safe {\n\+\    my $flen = $fmt.chars;\n\+\    my $fi = 0;\n\+\    my $ai = 0;\n\+\    my $str = \"\";\n\+\    while ($fi < $flen) {\n\+\\n\+\        my $idx = index($fmt,\"%\",$fi);\n\+\        if $idx < 0 {\n\+\            $str ~= substr($fmt,$fi);\n\+\            last;\n\+\        } else {\n\+\            my $len = $idx - $fi;\n\+\            $str ~= substr($fmt,$fi, $len) if $len > 0;\n\+\            $fi = $idx;\n\+\        }\n\+\\n\+\\n\+\        my $start = $fi;\n\+\        $fi++;\n\+\        while !(substr($fmt,$fi,1)\n\+\                ~~ any(<% c s d u o x e f g X E G b p n i D U O F>)) {\n\+\            $fi++;\n\+\        }\n\+\        my $specifier = substr($fmt,$fi,1); $fi++;\n\+\        my $conversion = substr($fmt,$start,$fi - $start);\n\+\\n\+\\n\+\        my $arg;\n\+\        if $specifier ne '%' {\n\+\            die \"Insufficient arguments to sprintf\" if $ai >= +@args;\n\+\            $arg = @args[$ai];\n\+\            $ai++;\n\+\        }\n\+\\n\+\        given $specifier {\n\+\            when any(<c d u o x i>) {\n\+\                $str ~= Pugs::Internals::sprintf($conversion,int($arg));\n\+\            }\n\+\\n\+\\n\+\\n\+\\n\+\\n\+\            when 'b' {\n\+\                my Bool @num;\n\+\                for (0..~int($arg).bytes*8-1) -> $bit {\n\+\                    push @num, int($arg) +& ( 1 ~ (0 x ($bit))) ?? 1 !! 0;\n\+\                }\n\+\\n\+\                my $converted = int(@num.reverse.join(\"\"));\n\+\\n\+\                $conversion ~~ m:P5/(\\d+)/;\n\+\                my $formatter = ~$0;\n\+\   \n\+\                my $length = int($formatter) - $converted.bytes;\n\+\   \n\+\                my $ret;\n\+\                if ($length < 0) {\n\+\                    $ret = int(@num.reverse.join(\"\"));\n\+\                }\n\+\                else {\n\+\                    given $formatter {\n\+\                        when rx:P5/^0/ {\n\+\                            $ret = (('0' x $length) ~ $converted);\n\+\                        }\n\+\                        default {\n\+\                            $ret = ((' ' x $length) ~ $converted);\n\+\                        }\n\+\                    }\n\+\                }\n\+\                $str ~= $ret;\n\+\\n\+\            }\n\+\            when 's' {\n\+\                $str ~= Pugs::Internals::sprintf($conversion,\"$arg\");\n\+\            }\n\+\            when any(<e f g>) {\n\+\                $str ~= Pugs::Internals::sprintf($conversion,1.0*$arg);\n\+\            }\n\+\            when any(<X D U O>) {\n\+\                $str ~= uc Pugs::Internals::sprintf(lc($conversion),int($arg));\n\+\            }\n\+\            when any(<E G F>) {\n\+\                $str ~= uc Pugs::Internals::sprintf(lc($conversion),1.0*$arg);\n\+\            }\n\+\            when '%' {\n\+\                $str ~= '%';\n\+\            }\n\+\            default {\n\+\                die \"sprintf does not yet implement %{$specifier}\";\n\+\            }\n\+\        }\n\+\    }\n\+\    $str;\n\+\}\n\+\\n\+\multi shift (@array) is builtin is primitive { List::shift(@array) };\n\+\multi shift ($array) is builtin is primitive { die \"Cannot 'shift' scalar\"; };\n\+\\n\+\multi pop (@array) is builtin is primitive { List::pop(@array) };\n\+\multi pop ($array) is builtin is primitive { die \"Cannot 'pop' scalar\"; };\n\+\\n\+\multi fmt ($_; $fmt) is builtin is primitive is safe {\n\+\    when Pair { sprintf($fmt, .kv) }\n\+\    default { sprintf($fmt, $_) }\n\+\}\n\+\\n\+\\n\+\\n\+\\n\+\multi fmt (@obj; $fmt, $comma = ' ') is builtin is primitive is safe {\n\+\    join($comma, map -> $v { sprintf($fmt, $v.isa(Pair) ?? $v.kv !! $v) }, @obj );\n\+\}\n\+\multi fmt (%obj; $fmt, $comma = \"\\n\") is builtin is primitive is safe {\n\+\    join($comma, map -> $k,$v { sprintf($fmt,$k,$v) }, %obj.kv );\n\+\}\n\+\\n\+\sub PIL2JS::Internals::use_jsan_module_imp (*@whatever) {\n\+\    die \"Can't load JSAN modules when not running under PIL2JS!\";\n\+\}\n\+\our &PIL2JS::Internals::use_jsan_module_noimp ::= &PIL2JS::Internals::use_jsan_module_imp;\n\+\\n\+\sub PIL2JS::Internals::use_perl5_module_imp (*@whatever) {\n\+\    die \"Can't load perl5 modules via js when not running under PIL2JS!\";\n\+\}\n\+\our &PIL2JS::Internals::use_perl5_module_noimp ::= &PIL2JS::Internals::use_perl5_module_imp;\n\+\\n\+\\n\+\\n\+\multi prefix_M ($file) is builtin is primitive is unsafe {\n\+\  if $file ~~ :!e {\n\+\    undef;\n\+\  }\n\+\  elsif $file ~~ rx:perl5/[^-_a-zA-Z0-9\\.\\/\\\\\\:]/ {\n\+\    warn \"-M bug: avoided $file\";\n\+\    undef;\n\+\  }\n\+\  else {\n\+\    my $cmd = %?CONFIG<perl5_path>~q{ -e 'print join(\"\\n\", map {-M}, @ARGV,\"\")' }~$file;\n\+\    my $p = Pipe::open($cmd);\n\+\    my $m = slurp($p);  $p.close;\n\+\\n\+\\n\+\    +$m;\n\+\  }\n\+\}\n\+\\n\+\\n\+\sub  *prelude_test_1(){'test 1'}\n\+\sub   prelude_test_2_helper(){'test 2'}\n\+\&*prelude_test_2 ::= &prelude_test_2_helper;\n\+\sub   prelude_test_3_helper(){'test 3'}\n\+\&*prelude_test_3 :=  &prelude_test_3_helper;\n\+\multi prelude_test_4(Str $x) is builtin {'test 4'}\n\+\multi *prelude_test_5(Str $x) {'test 5'}\n\+\\n\+\\n\+\{\n\+\use v6-alpha;\n\+\module Math::Basic;\n\+\\n\+\sub pi() is export(:constants) {3.141592653589793}\n\+\\n\+\};\n\+\BEGIN { %*INC<Math::Basic> = '<precompiled>' };\n\+\\n\+\"+
+ src/Pugs/Pretty.hs view
@@ -0,0 +1,262 @@+{-# OPTIONS_GHC -fglasgow-exts -fallow-overlapping-instances #-}++{-|+    Pretty printing for various data structures.++>   Galadriel! Galadriel!+>   Clear is the water of your well;+>   White is the stars in your white hand;+>   Unmarred, unstained is leaf and land+>   In Dwimordene, in Lorien+>   More fair than thoughts of Mortal Men.+-}++module Pugs.Pretty (+    Pretty(..), pretty, priggy,+) where+import Pugs.Internals+import Pugs.Types+import Pugs.AST+import qualified Pugs.Val as Val+import Pugs.Rule (SourcePos)+import Text.PrettyPrint+import qualified Data.Set as Set+import qualified Data.Map as Map++defaultIndent :: Int+defaultIndent = 2++class (Show a) => Pretty a where+    format, formatQuite :: a -> Doc+    format x = text $ show x+    formatQuite = format++instance Pretty VStr+instance Pretty Var++instance Pretty EntryFlags where+    format (MkEntryFlags True)  = text "(is context)"+    format _                    = empty++instance Pretty Exp where+    format (NonTerm pos) = text "Syntax error at" <+> format pos+    format (Val v) = format v+    format (Syn x vs) = text "Syn" <+> format x <+> (braces $ vcat (punctuate (text ";") (map format vs)))+    format (Stmts exp1 exp2) = (vcat $ punctuate (text ";") $ (map format) [exp1, exp2])+    format (App (Var name) invs args) = text "App" <+> text (cast name) <+> parens (nest defaultIndent $ cat (punctuate (text ": ") [ cat (punctuate (text ", ") (map format x)) | x <- [maybeToList invs, args] ]))+    format (App sub invs args) = text "App" <+> parens (format sub) <+> parens (nest defaultIndent $ vcat (punctuate (text ", ") (map format $ maybeToList invs ++ args)))+    format (Sym scope name flags init exp) = text "Sym" <+> text (show scope) <+> format name <+> format flags <+> format init $+$ format exp+    format (Ann _ exp) = format exp+    format x = text $ show x+    formatQuite (Syn "," xs) = parens (formatQuite xs)+    formatQuite (App (Var var) Nothing args)+        | C_infix <- v_categ var+        = parens (hsep (punctuate (text . (' ':) . cast $ v_name var) (map formatQuite args)))+        | otherwise+        = text (showsVar var "") <> parens (formatQuite args)+    formatQuite (App (Var var) (Just inv) args)+        = formatQuite inv <> char '.' <> text (cast $ v_name var) <> parens (formatQuite args)+    formatQuite (Ann _ exp) = formatQuite exp+    formatQuite x = format x++instance Pretty [Exp] where+    format xs = hsep (punctuate comma (map format xs))+    formatQuite xs = hsep (punctuate comma (map formatQuite xs))++instance Pretty (TVar Bool, TVar VRef) where+    format (_, tvar) = format tvar++instance Pretty Type where+    format = format . showType++instance Pretty PadEntry where+    format x = format (pe_type x) <+> format (pe_proto x)++instance Pretty Pad where+    format pad = vcat $ map formatAssoc $ padToList pad+        where+        formatAssoc (name, var) = format name <+> text ":=" <+> (nest defaultIndent $ format var)++instance Pretty Pos where+    format pos =+        let file = cast (posName pos)+            bln  = show $ posBeginLine pos+            bcl  = show $ posBeginColumn pos+            eln  = show $ posEndLine pos+            ecl  = show $ posEndColumn pos+            fmt ln cl = text "line" <+> text ln <> comma <+> text "column" <+> text cl+        in text file <+> case (bln == eln, bcl == ecl) of+            (True, True)  -> fmt bln bcl+            (True, False) -> fmt bln (bcl ++ "-" ++ ecl)+            (False, _)    -> fmt bln bcl <+> (text "-" <+> fmt eln ecl)++instance Pretty SubType where+    format = text . map toLower . drop 3 . show++instance Pretty Env where+    format x = doubleBraces $ nest defaultIndent (format $ envBody x) ++instance Pretty (Val, Val) where+    format (x, y) = hang (format x <+> text "=>") defaultIndent (format y)++instance Pretty (Exp, SourcePos) where+    format (x, _) = format x ++instance Pretty (TVar VRef) where+    format x = text ('#':show x)++instance Pretty VRef where+    format x = text ('#':show x)++instance Pretty VMatch where+    format m = joinList (text ", ")+        [ form ("ok",        matchOk)+        , form ("from",      matchFrom)+        , form ("to",        matchTo)+        , form ("str",       matchStr)+        , form ("sub_pos",   matchSubPos)+        , form ("sub_named", matchSubNamed)+        ]+        where+        form :: Pretty a => (String, VMatch -> a) -> Doc+        form (s, f) = hang (text s <+> text "=>") defaultIndent (format $ f m)++instance Pretty Bool where+    format x = text $ if x then "Bool::True" else "Bool::False"++instance Pretty Int where+    format i = int i++instance Pretty VList where+    format [x] = parens $ format x <> text ","+    format xs+        | not . null . (drop 100) $ xs = parens $ (format (head xs) <+> text ", ...")+        | otherwise = parens $ (joinList $ text ", ") (map format xs)++instance Pretty Params where+    format = text . show . paramsToSig++instance Pretty VHash where+    format x = cat+        [ text "{"+        , nest defaultIndent . joinList (text ", ") $+            [ format (VStr k, v) | (k, v) <- Map.toList x ]+        , text "}"+        ]++instance Pretty LexPads where+    format xs = hsep (punctuate comma (map format xs))++instance Pretty LexPad where+    format (PRuntime p) = format p+    format (PCompiling p) = format p++instance Pretty MPad where+    format = text . show++instance Pretty Val where+    format (VJunc j) = parens $ joinList mark items +        where+        dups = juncDup j+        vals = juncSet j+        items = map format $ values+        values = Set.elems vals ++ (concatMap (replicate 2)) (Set.elems dups)+        mark  = case juncType j of+            JAny  -> text " | "+            JAll  -> text " & "+            JOne  -> text " ^ "+            JNone -> text " ! "+    format (VBool x) = format x+    format (VNum x) = if x == 1/0+                         then text "Inf"+                         else if x == -1/0 +                                then text "-Inf"+                                else text $ show x+    format (VInt x) = integer x+    format (VStr x) = text $ "\"" ++ encodeUTF8 (concatMap quoted x) ++ "\""+    format (VRat x) = text $ showTrueRat x+    format (VComplex (r :+ i)) = format (VNum r) <+> text "+" <+> format (VNum i) <> text "i"+    format (VControl ControlContinuation{}) = text "<continuation>"+    format (VControl x) = text $ show x+    format (VProcess x) = text $ show x+    format (VOpaque (MkOpaque x)) = braces $ text $ "obj:" ++ show x+{-+    format (VRef (VList x))+        | not . null . (drop 100) $ x+        = brackets $ format (head x) <+> text ", ..."+        | otherwise = brackets $ cat $ (punctuate $ text ", ") (map format x)+-}+    format (VRef x) = format x+    format (VList x) = format x+    format (VCode x) = (<> braces (format $ subBody x)) .+        (<+> braces (format (subOuterPads x))) .+        (<+> format (subInnerPad x)) . (<> format (subParams x)) . text $ case subType x of+        SubMacro        -> "macro "+        SubRoutine      -> "sub "+        SubMethod       -> "method "+        SubCoroutine    -> "coro "+        SubPointy       -> "->"+        SubBlock        -> ""+        SubPrim         -> ""+    format (VBlock _) = text "{...}"+    format (VError x posList)+        -- Is this correct? Does this work on win32, too?+        | last s == '\n' = text . init $ s+        | otherwise      = text "***" <+>+            (vcat (map text $ split "\n" s) $+$ (text "at" <+> vcat (map format $ reverse posList)))+        where+        s = case x of+              VStr s' -> s'+              _       -> pretty x+--  format (VArray x) = format (VList $ Array.elems x)+--  format (VHash h) = braces $ (joinList $ text ", ") $+--      [ format (VStr k, v) | (k, v) <- Map.toList h ]+    format (VHandle x) = text $ show x+    format (VThread t) = text $ takeWhile isDigit $ dropWhile (not . isDigit) $ show t+    format (VSocket x) = text $ show x+    -- format (MVal v) = text $ inlinePerformSTM $ do+    --     val <- readTVar v+    --     return $ pretty val+    format (VRule _) = text $ "{regex}"+    format (VSubst _) = text $ "{subst}"+    format (VType t) = text $ "::" ++ showType t+    format (VObject o) = text $ "{obj:" ++ showType (objType o) ++ "}"+    format (VMatch m) = cat+        [ text "Match.new("+        , nest defaultIndent $ format m+        , text ")"+        ]+    format (PerlSV _) = text $ "{obj-perl5}"+    format VUndef = text $ "undef"+    format (VV x) = format x -- === formatVal x+    formatQuite (VV x) = text . cast $ Val.valShow x+    formatQuite x = format x++instance Pretty Val.Val where+    format = formatVal++quoted :: Char -> String+quoted '\'' = "\\'"+quoted '\\' = "\\\\"+quoted '"'  = "\\\""+quoted '{'  = "\\{"+quoted '\t' = "\\t"+quoted '\r' = "\\r"+quoted '\n' = "\\n"+quoted '$'  = "\\$"+quoted '@'  = "\\@"+quoted '%'  = "\\%"+quoted '&'  = "\\&"+quoted '^'  = "\\^"+quoted x | isPrint x = [x]+quoted x    = "\\x[" ++ showHex (ord x) "]"++doubleBraces :: Doc -> Doc+doubleBraces x = vcat [ (lbrace <> lbrace), nest defaultIndent x, rbrace <> rbrace]++joinList :: Doc -> [Doc] -> Doc+joinList x y = cat $ punctuate x y++pretty, priggy :: Pretty a => a -> String+pretty a = render $ format a+priggy a = render $ formatQuite a
+ src/Pugs/Prim.hs view
@@ -0,0 +1,2245 @@+{-# OPTIONS_GHC -fglasgow-exts -fno-warn-orphans -fno-full-laziness -fno-cse -fallow-overlapping-instances #-}++{-|+    Primitive operators.++>   There hammer on the anvil smote,+>   There chisel clove, and graver wrote;+>   There forged was blade, and bound was hilt;+>   The delver mined, the mason built...+-}++module Pugs.Prim (+    primOp,+    primDecl,+    initSyms,+    op2ChainedList,+    op1Exit,++    -- used by Pugs.Compile.Haskell+    op0, op1, op2,++    -- used Pugs.Eval+    op1Return, op1Yield,+    foldParam, op2Hyper, op1HyperPrefix, op1HyperPostfix, retSeq, atomicEval+) where+import Pugs.Internals+import Pugs.Junc+import Pugs.AST+import Pugs.Types+import Pugs.Monads+import Pugs.Pretty+import Text.Printf+import Pugs.External+import Pugs.Embed+import Pugs.Eval.Var+import Pugs.Meta ()+import qualified Data.Map as Map+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+import Pugs.Prim.Match+import Pugs.Prim.List+import Pugs.Prim.Numeric+import Pugs.Prim.Lifts+import Pugs.Prim.Eval+import Pugs.Prim.Code+import Pugs.Prim.Param+import qualified Data.IntSet as IntSet+import DrIFT.YAML+import GHC.Exts (unsafeCoerce#)+import GHC.Unicode+import qualified Data.HashTable as H+import Data.Time.LocalTime+import Data.Time.Calendar.OrdinalDate+import Data.Time.Calendar.MonthDay++constMacro :: Exp -> [Val] -> Eval Val+constMacro = const . expToEvalVal++-- |Implementation of 0-ary and variadic primitive operators and functions+-- (including list ops).+op0 :: String -> [Val] -> Eval Val+op0 "&"  = fmap opJuncAll . mapM fromVal+op0 "^"  = fmap opJuncOne . mapM fromVal+op0 "|"  = fmap opJuncAny . mapM fromVal+op0 "want"  = const $ fmap VStr (asks (maybe "Item" envWant . envCaller))+op0 "Bool::True"  = const . return $ VBool True+op0 "Bool::False" = const . return $ VBool False+op0 "True"  = constMacro . Val $ VBool True+op0 "False" = constMacro . Val $ VBool False+op0 "time"  = const $ do+    clkt <- guardIO getCurrentTime+    return $ VRat $ pugsTimeSpec clkt+op0 "times"  = const $ do+    ProcessTimes _ u s cu cs <- guardIO getProcessTimes+    return . VList $ map (castV . (% (clocksPerSecond :: VInt)) . toInteger . fromEnum)+        [u, s, cu, cs]+op0 "Z" = op0Zip+op0 "X" = op0Cross+    -- op0 "minmax" = op0Minmax+op0 "File::Spec::cwd" = const $ do+    cwd <- guardIO getCurrentDirectory+    return $ VStr cwd+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)+op0 "return"  = const $ op1Return (retControl (ControlLeave (<= SubRoutine) 0 undef))+op0 "yield"   = const $ op1Yield (retControl (ControlLeave (<= SubRoutine) 0 undef))+op0 "leave"   = const $ retControl (ControlLeave (>= SubBlock) 0 undef)+op0 "take"    = const $ assertFrame FrameGather retEmpty+op0 "nothing" = const . return $ VBool True+op0 "Pugs::Safe::safe_getc"     = const . op1Getc $ VHandle stdin+op0 "Pugs::Safe::safe_readline" = const . op1Readline $ VHandle stdin+op0 "reverse" = const $ return (VList [])+op0 "chomp"   = const $ return (VList [])+op0 "fork"    = const $ opPerl5 "fork" []+op0 "defer"   = const $ do+    env <- ask+    if envAtomic env then guardSTM retry else fail "Cannot call &defer outside a contend block."+op0 other = const $ fail ("Unimplemented listOp: " ++ other)++-- |Implementation of unary primitive operators and functions+op1 :: String -> Val -> Eval Val+op1 "!"    = op1Cast (VBool . not)+op1 "WHICH" = \x -> do+    val <- fromVal x+    return $ case val of+        VObject o   -> castV . unObjectId $ objId o+        _           -> val+op1 "chop" = \x -> do+    str <- fromVal x+    return $ if null str+        then VStr str+        else VStr $ init str+op1 "Scalar::chomp" = \x -> do+    str <- fromVal x+    return $ op1Chomp str+op1 "Str::split" = op1Cast (castV . words)+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)+  where+    mapEachWord _ [] = []+    mapEachWord f str@(c:cs)+        | isSpace c = c:(mapEachWord f cs)+        | otherwise = f word ++ mapEachWord f rest+          where (word,rest) = break isSpace str+    capitalizeWord []     = []+    capitalizeWord (c:cs) = toUpper c:(map toLower cs)+op1 "quotemeta" = op1Cast (VStr . concat . map toQuoteMeta)+op1 "undef" = const $ return undef+op1 "undefine" = \x -> do+    when (defined x) $ do+        ref <- fromVal x+        clearRef ref+    return undef+op1 "+"    = op1Numeric id+op1 "abs"  = op1Numeric abs+op1 "Pugs::Internals::truncate" = op1Round truncate+op1 "Pugs::Internals::round"    = op1Round round+op1 "Pugs::Internals::floor"    = op1Round floor+op1 "Pugs::Internals::ceiling"  = op1Round ceiling+op1 "cos"  = op1Floating cos+op1 "sin"  = op1Floating sin+op1 "tan"  = op1Floating tan+op1 "sqrt" = op1Floating sqrt+op1 "atan" = op1Floating atan+op1 "post:i" = \x -> do+    n <- fromVal x+    return $ VComplex (0 :+ n)+op1 "post:++" = \x -> atomicEval $ do+    ref <- fromVal x+    val <- fromVal x+    val' <- case val of+        (VStr str)  -> return (VStr $ strInc str)+        _           -> op1Numeric (+1) val+    writeRef ref val'+    case val of+        (VStr _)    -> return val+        _           -> op1 "+" val+op1 "++"   = \mv -> do+    op1 "post:++" mv+    fromVal mv+op1 "post:--"   = \x -> atomicEval $ do+    ref <- fromVal x+    val <- fromVal x+    writeRef ref =<< op1Numeric (\x -> x - 1) val+    return val+op1 "--"   = \mv -> do+    op1 "post:--" mv+    fromVal mv+op1 "-"    = op1Numeric negate+op1 "item" = \v -> return $ case v of+    VList vs    -> VRef . arrayRef $ vs+    _           -> v+op1 "sort" = \v -> do+    args    <- fromVal v+    (valList, sortByGiven) <- case args of+        (v:vs) -> do+            ifValTypeIsa v "Code"+                (return (vs, Just v))+                (ifValTypeIsa (last args) "Code"+                    (return (init args, Just $ last args))+                    (return (args, Nothing)))+        _  -> return (args, Nothing)+    sortBy <- case sortByGiven of+        Nothing -> readVar (cast "&*infix:cmp")+        Just subVal -> return subVal+    sub <- fromVal sortBy+    sorted <- (`sortByM` valList) $ \v1 v2 -> do+        rv  <- enterEvalContext (cxtItem "Int") $ App (Val sub) Nothing [Val v1, Val v2]+        int <- fromVal rv+        return (int <= (0 :: Int))+    retSeq sorted+op1 "Scalar::reverse" = \v -> do+    str     <- fromVal v+    return (VStr $ reverse str)+op1 "List::reverse" = \v -> do+    vlist <- fromVal v+    return (VList $ reverse vlist)+op1 "list" = op1Cast VList+op1 "pair" = op1Cast $ VList . (map $ \(k, v) -> castV ((VStr k, v) :: VPair))+op1 "~"    = op1Cast VStr+op1 "?"    = op1Cast VBool+op1 "int"  = op1Cast VInt+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 "^" = op2RangeExclRight (VNum 0)+op1 "post:..."  = op1Range+op1 "not"  = op1 "!"+op1 "true" = op1 "?"+op1 "any"  = op1Cast opJuncAny+op1 "all"  = op1Cast opJuncAll+op1 "one"  = op1Cast opJuncOne+op1 "none" = op1Cast opJuncNone+op1 "perl" = op1Pretty $ MkPrettyPrinter pretty+op1 "guts" = op1Pretty $ MkPrettyPrinter priggy+op1 "yaml" = dumpYaml+op1 "require_haskell" = \v -> do+    name    <- fromVal v+    externRequire "Haskell" name+    return $ VBool True+op1 "require_parrot" = \v -> do+    name    <- fromVal v+    io $ evalParrotFile name+    return $ VBool True+op1 "require_perl5" = \v -> do+    pkg     <- fromVal v+    let requireLine = "require " ++ pkg ++ "; '" ++ pkg ++ "'"+    val     <- evalPerl5WithCurrentEnv requireLine+    evalExp (_Sym SOur (':':'*':pkg) mempty (Val val) (newMetaType pkg))+    return val+op1 "require_java" = \v -> do+    pkg     <- fromVal v+    let requireLine = "package main; use Inline (qw( Java STUDY AUTOSTUDY 1 STUDY ), ['" ++ mod ++ "']); '" ++ pkg ++ "'"+        lastPart    = last (split "::" pkg)+        mod         = concat (intersperse "." (split "::" pkg))+    val     <- evalPerl5WithCurrentEnv requireLine+    evalExp (_Sym SOur (':':'*':pkg) mempty (Val val) (newMetaType pkg))+    when (lastPart /= pkg) $ do+        evalExp_ (_Sym SOur (':':'*':lastPart) mempty (Val val) (newMetaType lastPart))+    return val+op1 "Pugs::Internals::eval_parrot" = \v -> do+    code    <- fromVal v+    io . evalParrot $ case code of+        ('.':_) -> code+        _       -> unlines+            [ ".sub pugs_eval_parrot"+            -- , "trace 1"+            , code+            , ".end"+            ]+    return $ VBool True++-- XXX - revert these two to Prelude.pm's ::Disabled version once YAML+Closure is working+op1 "use" = opRequire True +op1 "require" = opRequire False++op1 "Pugs::Internals::use" = opRequire True+op1 "Pugs::Internals::require" = opRequire False+op1 "Pugs::Internals::eval_perl6" = \v -> do+    str <- fromVal v+    opEval quiet "<eval>" (encodeUTF8 str)+    where quiet = MkEvalStyle { evalResult = EvalResultLastValue+                              , evalError  = EvalErrorUndef }+op1 "evalfile" = \v -> do+    filename <- fromVal v+    opEvalFile filename+op1 "Pugs::Internals::eval_perl5" = \v -> do+    str     <- fromVal v+    env     <- ask+    lex     <- asks envLexical+    let vars = [ v | v@MkVar{ v_sigil = SScalar, v_twigil = TNil } <- Set.toList (padKeys lex), v /= varTopic ]+        code = "sub { " ++ codeSafe ++ codeVar ++ str ++ "\n}"+        codeSafe | safeMode  = "use ops (':default', 'binmode', 'entereval');"+                 | otherwise = ""+        codeVar | null vars = ""+                | otherwise = "my (" ++ (concat $ intersperse ", " (map cast vars)) ++ ") = @_;"+    vals    <- mapM readVar vars+    rv  <- tryIO (Perl5ErrorString "") $ do+        envSV   <- mkEnv env+        sub     <- evalPerl5 code envSV 0+        args    <- mapM newSVval vals+        invokePerl5 sub nullSV args envSV (enumCxt $ envContext env)+    case rv of+        Perl5ReturnValues [x]   -> io $ svToVal x+        Perl5ReturnValues xs    -> io $ fmap VList (mapM svToVal xs)+        Perl5ErrorString str    -> fail str+        Perl5ErrorObject err    -> throwError (PerlSV err)+op1 "Pugs::Internals::evalfile_p6y" = op1EvalFileP6Y+op1 "Pugs::Internals::eval_p6y"     = op1EvalP6Y+op1 "Pugs::Internals::eval_haskell" = op1EvalHaskell+op1 "Pugs::Internals::eval_yaml" = evalYaml+op1 "contend" = \v -> do+    env <- ask+    guardSTM . runEvalSTM env . evalExp $ App (Val v) Nothing []+op1 "try" = \v -> do+    sub <- fromVal v+    env <- ask+    val <- tryT $ case envAtomic env of+        True    -> guardSTM . runEvalSTM env . evalExp $ App (Val $ VCode sub) Nothing []+        False   -> guardIO . runEvalIO env . evalExp $ App (Val $ VCode sub) Nothing []+    retEvalResult style val+    where+    style = MkEvalStyle+        { evalResult = EvalResultLastValue+        , evalError  = EvalErrorUndef+        }+-- Tentative implementation of nothingsmuch's lazy proposal.+op1 "lazy" = \v -> do+    sub     <- fromVal v+    memo    <- io $ newTVarIO Nothing+    let exp = App (Val $ VCode sub) Nothing []+        thunk = do+            cur <- stm $ readTVar memo+            maybe eval return cur+        eval = do+            res <- evalExp exp+            stm $ writeTVar memo (Just res)+            return res+    typ <- inferExpType exp+    return . VRef . thunkRef $ MkThunk thunk typ++op1 "defined" = op1Cast (VBool . defined)+op1 "last" = const $ assertFrame FrameLoop $ op1ShiftOut (VControl (ControlLoop LoopLast))+op1 "next" = const $ assertFrame FrameLoop $ op1ShiftOut (VControl (ControlLoop LoopNext))+op1 "redo" = const $ assertFrame FrameLoop $ op1ShiftOut (VControl (ControlLoop LoopRedo))+op1 "continue" = const $ assertFrame FrameWhen $ op1ShiftOut (VControl (ControlWhen WhenContinue))+op1 "break" = const $ assertFrame FrameWhen $ op1ShiftOut (VControl (ControlWhen WhenBreak))+op1 "return" = op1Return . op1ShiftOut . VControl . ControlLeave (<= SubRoutine) 0+op1 "yield" = op1Yield . op1ShiftOut . VControl . ControlLeave (<= SubRoutine) 0+op1 "leave" = op1ShiftOut . VControl . ControlLeave (>= SubBlock) 0+op1 "take" = \v -> assertFrame FrameGather $ do+    glob    <- askGlobal+    arr     <- findSymRef (cast "$*TAKE") glob+    push    <- doArray (VRef arr) array_push+    push (listVal v)+    retEmpty+op1 "sign" = \v -> withDefined [v] $+    op1Cast (VInt . signum) v++op1 "srand" = \v -> do+    x <- fromVal v+    guardSTM . unsafeIOToSTM $ do+       seed <- if defined v+          then return x+          else randomRIO (0, 2^(31::Int))+       setStdGen $ mkStdGen seed+    return (castV True)+op1 "rand"  = \v -> do+    x    <- fromVal v+    rand <- guardSTM . unsafeIOToSTM+               $ getStdRandom (randomR (0, if x == 0 then 1 else x))+    return $ VNum rand+op1 "say" = op2 "IO::say" (VHandle stdout)+op1 "print" = op2 "IO::print" (VHandle stdout)+op1 "IO::say" = \v -> op2 "IO::say" v $ VList []+op1 "IO::print" = \v -> op2 "IO::print" v $ VList []+op1 "IO::next" = \v -> do+    fh  <- fromVal v+    guardIO $ fmap (VStr . (++ "\n") . decodeUTF8) (hGetLine fh)+op1 "Pugs::Safe::safe_print" = \v -> do+    str  <- fromVal v+    guardIO . putStr $ encodeUTF8 str+    return $ VBool True+op1 "die" = \v -> do+    v'      <- fromVal $! v+    poss    <- asks envPosStack+    retShift $! VError (errmsg $! v') poss+    where+    errmsg VUndef      = VStr "Died"+    errmsg VType{}     = VStr "Died"+    errmsg (VStr "")   = VStr "Died"+    errmsg (VList [])  = VStr "Died"+    errmsg (VList [x]) = x+    errmsg x           = x+op1 "warn" = \v -> do+    strs <- fromVal v+    errh <- readVar $ cast "$*ERR"+    poss    <- asks envPosStack+    op2 "IO::say" errh $ VList [ VStr $ pretty (VError (errmsg strs) poss) ]+    where+    errmsg "" = VStr "Warning: something's wrong"+    errmsg x  = VStr x+op1 "fail" = op1 "fail_" -- XXX - to be replaced by Prelude later+op1 "fail_" = \v -> do+    throw <- fromVal =<< readVar (cast "$*FAIL_SHOULD_DIE")+    if throw then op1 "die" (errmsg v) else do+    poss    <- asks envPosStack+    let die = retShift $ VError (errmsg v) poss+        dieThunk = VRef . thunkRef $ MkThunk die (mkType "Failure")+    op1Return (retControl (ControlLeave (<= SubRoutine) 0 dieThunk))+    where+    errmsg VUndef      = VStr "Failed"+    errmsg VType{}     = VStr "Failed"+    errmsg (VStr "")   = VStr "Failed"+    errmsg (VList [])  = VStr "Failed"+    errmsg (VList [x]) = x+    errmsg x           = x+op1 "exit" = op1Exit+op1 "readlink" = \v -> do+    str  <- fromVal v+    guardIO $ fmap VStr (readSymbolicLink str)+op1 "sleep" = \v -> do+    x <- fromVal v :: Eval VNum+    guardIO $ do+        start   <- getCurrentTime+        threadDelay (round $ x * clocksPerSecond)+        finish  <- getCurrentTime+        return $ VRat (toRational $ diffUTCTime start finish)+op1 "mkdir" = guardedIO createDirectory+op1 "rmdir" = guardedIO removeDirectory+op1 "chdir" = guardedIO setCurrentDirectory+op1 "graphs"= op1Cast (VInt . (genericLength :: String -> VInt)) -- XXX Wrong+op1 "codes" = op1Cast (VInt . (genericLength :: String -> VInt))+op1 "chars" = op1Cast (VInt . (genericLength :: String -> VInt))+op1 "bytes" = op1Cast (VInt . (genericLength :: String -> VInt) . encodeUTF8)++op1 "unlink" = \v -> do+    vals <- fromVals v+    rets <- mapM (doBoolIO removeFile) vals+    return $ VInt $ sum $ map bool2n rets+op1 "readdir" = \v -> do+    path  <- fromVal v+    files <- guardIO $ getDirectoryContents path+    retSeq (map VStr files)+op1 "slurp" = \v -> do+    ifValTypeIsa v "IO"+        (do h <- fromVal v+            ifListContext (strictify $! op1 "=" v) $ do+                content <- guardIO $ hGetContents h+                return . VStr $ decodeUTF8 content)+        (do+            fileName    <- fromVal v+            ifListContext+                (slurpList fileName)+                (slurpScalar fileName))+    where+    strictify action = do+        VList lines <- action+        return $ VList (length lines `seq` lines)+    slurpList file = strictify $! op1 "=" (VList [VStr file])+    slurpScalar file = do+        content <- guardIO $ readFile file+        return . VStr $ decodeUTF8 content+op1 "opendir" = \v -> do+    str <- fromVal v+    dir <- guardIO $ openDirStream str+    obj <- createObject (mkType "IO::Dir") []+    return . VObject $ obj{ objOpaque = Just $ toDyn dir }+op1 "IO::Dir::close" = op1 "IO::Dir::closedir"+op1 "IO::Dir::closedir" = guardedIO (closeDirStream . fromObject)+op1 "IO::Dir::rewind" = op1 "IO::Dir::rewinddir"+op1 "IO::Dir::rewinddir" = guardedIO (rewindDirStream . fromObject)+op1 "IO::Dir::read" = op1 "IO::Dir::readdir"+op1 "IO::Dir::readdir" = \v -> do+    dir <- fmap fromObject (fromVal v)+    ifListContext+        (retSeq =<< readDirStreamList dir)+        (guardIO $ fmap (\x -> if null x then undef else castV x) $ readDirStream dir)+    where+    readDirStreamList dir = do+        this <- tryIO "" $ readDirStream dir+        if null this then return [] else do+        rest <- readDirStreamList dir+        return (VStr this:rest)+op1 "Pugs::Internals::runShellCommand" = \v -> do+    str <- fromVal v+    cxt <- asks envContext+    (res, exitCode) <- tryIO ("", ExitFailure (-1)) $ do+        (inp,out,_,pid) <- runInteractiveCommand (encodeUTF8 str)+        hClose inp+        res             <- fmap (decodeUTF8 . deCRLF) $ hGetContents out+        exitCode        <- waitForProcess pid+        return (res, exitCode)+    handleExitCode exitCode +    return $ case cxt of+        CxtSlurpy{} -> VList (map VStr $ lines res)+        _           -> VStr res+    where+    -- XXX - crude CRLF treatment+    deCRLF []                   = []+    deCRLF ('\r':xs@('\n':_))   = xs+    deCRLF (x:xs)               = (x:deCRLF xs)+op1 "Pugs::Internals::runInteractiveCommand" = \v -> do+    str <- fromVal v+    guardIO $ do+        (inp,out,err,pid) <- runInteractiveCommand str+        return $ VList [ VHandle inp+                       , VHandle out+                       , VHandle err+                       , VProcess (MkProcess pid)+                       ]+op1 "Pugs::Internals::check_for_io_leak" = \v -> do+    rv      <- evalExp (App (Val v) Nothing [])+    leaked  <- fromVal =<< op2Match rv (VType $ mkType "IO")+    when leaked $ do+        fail $ "BEGIN and CHECK blocks may not return IO handles,\n" +++               "as they would be invalid at runtime."+    return rv+op1 "system" = \v -> do+    cmd         <- fromVal v+    exitCode    <- tryIO (ExitFailure (-1)) $ system (encodeUTF8 cmd)+    handleExitCode exitCode+op1 "accept" = \v -> do+    socket      <- fromVal v+    (h, _, _)   <- guardIO $ accept socket+    return $ VHandle h+op1 "detach" = \v -> do+    case v of+        VThread thr -> do+            stm $ tryPutTMVar (threadLock thr) undef+            return $ VBool True+        _           -> fail $ "Not a thread: " ++ show v+op1 "kill" = \v -> do+    case v of+        VThread thr -> do+            guardIO . killThread $ threadId thr+            return $ VBool True+        _           -> fail $ "Not a thread: " ++ show v+op1 "join" = \v -> do+    case v of+        VThread thr -> stm $ takeTMVar (threadLock thr)+        _           -> op2Join v (VList [])+op1 "async" = \v -> do+    env     <- ask+    code    <- fromVal v+    lock    <- stm $ newEmptyTMVar+    tid     <- guardIO . forkIO $ do -- (if rtsSupportsBoundThreads then forkOS else forkIO) $ do+        val <- runEvalIO env $ do+            enterEvalContext CxtVoid $ App (Val code) Nothing []+        stm $ tryPutTMVar lock val+        return ()+    return . VThread $ MkThread+        { threadId      = tid+        , threadLock    = lock+        }+--WV: async should return the thread id!    return undef+op1 "listen" = \v -> do+    port    <- fromVal v+    socket  <- guardIO $ listenOn (PortNumber $ fromInteger port)+    return $ VSocket socket+op1 "flush" = guardedIO hFlush+op1 "IO::close" = guardedIO hClose+op1 "Socket::close" = guardedIO sClose+op1 "Pair::key" = fmap fst . (fromVal :: Val -> Eval VPair)+op1 "Pair::value" = \v -> do+    ivar <- join $ doPair v pair_fetchElem+    return . VRef . MkRef $ ivar+op1 "pairs" = \v -> do+    pairs <- pairsFromVal v+    retSeq pairs+op1 "List::kv" = \v -> do+    pairs <- pairsFromVal v+    kvs   <- forM pairs $ \(VRef ref) -> do+        pair   <- readRef ref+        fromVal pair+    retSeq $ concat kvs+op1 "Pair::kv" = op1 "List::kv"+op1 "keys" = keysFromVal+op1 "values" = valuesFromVal+-- According to Damian+-- (http://www.nntp.perl.org/group/perl.perl6.language/21895),+-- =$obj should call $obj.next().+op1 "="        = \v -> case v of+    VObject _               -> evalExp $ App (_Var "&shift") (Just $ Val v) []+    VRef (MkRef IArray{})   -> do+        ifListContext+            (fmap VList (join $ doArray v array_fetch))+            (join $ doArray v array_shift)+    _           -> op1 "readline" v+op1 "readline" = op1Readline+op1 "getc"     = op1Getc+op1 "WHAT"     = fmap VType . evalValType+op1 "List::end"   = \x -> fmap (castV . pred) (join $ doArray x array_fetchSize) -- monadic join+op1 "List::elems" = \x -> fmap castV (join $ doArray x array_fetchSize) -- monadic join+op1 "List::pop"   = \x -> join $ doArray x array_pop -- monadic join+op1 "List::shift" = \x -> join $ doArray x array_shift -- monadic join+op1 "pick"  = op1Pick+op1 "sum"   = op1Sum+op1 "min"   = op1Min+op1 "max"   = op1Max+op1 "uniq"  = op1Uniq+op1 "chr"   = op1Cast (VStr . (:[]) . chr)+op1 "ord"   = op1Cast $ \str -> if null str then undef else (castV . ord . head) str+op1 "hex"   = fail "hex() is not part of Perl 6 - use :16() instead."+op1 "oct"   = fail "oct() is not part of Perl 6 - use :8() instead."+op1 "log"   = op1Floating log+op1 "log10" = op1Floating (logBase 10)+op1 "from"  = op1Cast (castV . matchFrom)+op1 "to"    = op1Cast (castV . matchTo)+op1 "matches" = op1Cast (VList . matchSubPos)+op1 "gather" = \v -> do+    evl <- asks envEval+    evl (Syn "gather" [Val v])+op1 "Thread::yield" = const $ do+    guardSTM . unsafeIOToSTM $ yield+    return $ VBool True+op1 "DESTROYALL" = \x -> cascadeMethod id "DESTROY" x VUndef+-- [,] is a noop -- It simply returns the input list+op1 "prefix:[,]" = return+op1 "prefix:$<<" = op1SigilHyper SScalar+op1 "prefix:@<<" = op1SigilHyper SArray+op1 "prefix:%<<" = op1SigilHyper SHash+op1 "prefix:&<<" = op1SigilHyper SCode+op1 "Code::assoc" = op1CodeAssoc+op1 "Code::name"  = op1CodeName+op1 "Code::arity" = op1CodeArity+op1 "Code::body"  = op1CodeBody+op1 "Code::pos"   = op1CodePos+op1 "Code::signature" = op1CodeSignature+op1 "IO::tell"    = \v -> do+    h <- fromVal v+    res <- guardIO $ hTell h+    return $ VInt res+op1 "Rat::numerator" = \(VRat t) -> return . VInt $ numerator t+op1 "Rat::denominator" = \(VRat t) -> return . VInt $ denominator t+op1 "TEMP" = \v -> do+    ref <- fromVal v+    val <- readRef ref+    return . VCode $ mkPrim+        { subBody = Prim . const $ do+            writeRef ref val+            retEmpty+        }+op1 "Pugs::Internals::hIsOpen" = op1IO hIsOpen+op1 "Pugs::Internals::hIsClosed" = op1IO hIsClosed+op1 "Pugs::Internals::hIsReadable" = op1IO hIsReadable+op1 "Pugs::Internals::hIsWritable" = op1IO hIsWritable+op1 "Pugs::Internals::hIsSeekable" = op1IO hIsSeekable+op1 "Pugs::Internals::reduceVar" = \v -> do+    str <- fromVal v+    evalExp (_Var str)+op1 "Pugs::Internals::rule_pattern" = \v -> do+    case v of+        VRule MkRulePGE{rxRule=re} -> return $ VStr re+        VRule MkRulePCRE{rxRuleStr=re} -> return $ VStr re+        _ -> fail $ "Not a rule: " ++ show v+op1 "Pugs::Internals::rule_adverbs" = \v -> do+    case v of+        VRule MkRulePGE{rxAdverbs=hash} -> return hash+        VRule MkRulePCRE{rxAdverbs=hash} -> return hash+        _ -> fail $ "Not a rule: " ++ show v+op1 "Pugs::Internals::current_pragma_value" = \v -> do+    name <- fromVal v+    prags <- asks envPragmas+    return $ findPrag name prags+    where+        findPrag :: String -> [Pragma] -> Val+        findPrag _ [] = VUndef+        findPrag n (this:rest)+            | n == pragName this = VInt $ toInteger $ pragDat this+            | otherwise          = findPrag n rest+op1 "Pugs::Internals::caller_pragma_value" = \v -> do+    caller <- asks envCaller+    case caller of+        Just env -> local (const env) (op1 "Pugs::Internals::current_pragma_value" v)+        _        -> return $ VUndef+op1 "eager" = \v -> do+    vlist <- fromVal v+    return $! length (map valType vlist) `seq` VList vlist+op1 "Pugs::Internals::emit_yaml" = \v -> do+    glob <- filterPrim =<< asks envGlobal+    yml  <- io $ showYaml (filterUserDefinedPad glob, v)+    return $ VStr yml+op1 "Object::HOW" = \v -> do+    typ     <- evalValType v+    evalExp $ _Var (':':'*':showType typ)+op1 "Class::name" = \v -> do+    cls     <- fromVal v+    meta    <- readRef =<< fromVal cls+    fetch   <- doHash meta hash_fetchVal+    str     <- fromVal =<< fetch "name"+    return str+op1 "Class::traits" = \v -> do+    cls     <- fromVal v+    meta    <- readRef =<< fromVal cls+    fetch   <- doHash meta hash_fetchVal+    str     <- fromVal =<< fetch "is"+    return str+op1 "vv" = op1Cast VV+op1 "stat" = \x -> opPerl5 "require File::stat; File::stat::stat" [x]+op1 "lstat" = \x -> opPerl5 "require File::stat; File::stat::lstat" [x]+op1 "Pugs::Internals::localtime"  = \x -> do+    tz  <- io getCurrentTimeZone+    tm  <- fromVal x    -- seconds since Perl's epoch+    let utc   = posixSecondsToUTCTime (fromInteger tm + offset)+        local = utcToLocalTime tz utc+        day   = localDay local+        tod   = localTimeOfDay local+        (year, month, dayOfMonth)   = toGregorian day +        (sec, pico)                 = properFraction $ todSec tod+        (_, dayOfWeek)              = sundayStartWeek day+    -- if wantString then return . VStr $ formatTime "%c" (ZonedTime local tz) else+    retSeq [ vI    $ year+           , vI    $ month+           , vI    $ dayOfMonth+           , vI    $ todHour tod+           , vI    $ todMin tod+           , VInt  $ sec+           , vI    $ fromEnum (pico * 1000000000000)+           , vI    $ dayOfWeek + 1+           , vI    $ (monthAndDayToDayOfYear (isLeapYear year) month dayOfMonth) - 1+           , VStr  $ timeZoneName tz+           , vI    $ timeZoneMinutes tz * 60+           , VBool $ timeZoneSummerOnly tz+           ]+    where+    offset :: NominalDiffTime+    offset = 946684800 -- diff between Haskell and Perl epochs (seconds)+    vI :: Integral a => a -> Val+    vI = VInt . toInteger++op1 other   = \_ -> fail ("Unimplemented unaryOp: " ++ other)++op1IO :: Value a => (Handle -> IO a) -> Val -> Eval Val+op1IO = \fun v -> do+    val <- fromVal v+    fmap castV (guardIO $ fun val)++op1SigilHyper :: VarSigil -> Val -> Eval Val+op1SigilHyper sig val = do+    vs <- fromVal val+    evalExp $ Syn "," (map (\x -> Syn (shows sig "{}") [Val x]) vs)++retSeq :: VList -> Eval Val+retSeq xs = length xs `seq` return (VList xs)++handleExitCode :: ExitCode -> Eval Val+handleExitCode exitCode = do+    glob    <- askGlobal+    errSV   <- findSymRef (cast "$!") glob+    writeRef errSV $ case exitCode of+        ExitFailure x   -> VInt $ toInteger x+        ExitSuccess     -> VUndef+    return (VBool $ exitCode == ExitSuccess)++cascadeMethod :: ([VStr] -> [VStr]) -> VStr -> Val -> Val -> Eval Val+cascadeMethod f meth v args = do+    typ     <- evalValType v+    pkgs    <- fmap f (pkgParents $ showType typ)+    named   <- case args of+        VUndef -> return Map.empty+        VType{}-> return Map.empty+        _      -> join $ doHash args hash_fetch++    -- Here syms is a list of (sym, tvar) tuples where tvar is the physical coderef+    -- The monad in the "do" below is List.+    syms <- forM pkgs $ \pkg -> do+        let sym = cast $ ('&':pkg) ++ "::" ++ meth+        maybeM (fmap (lookupPad sym) askGlobal) $ \ref -> do+            return (sym, ref)++    forM_ (nubBy (\(_, x) (_, y) -> x == y) (catMaybes syms)) $ \(sym, _) -> do+        enterEvalContext CxtVoid $+            App (Var sym) (Just $ Val v)+                [ Syn "named" [Val (VStr key), Val val]+                | (key, val) <- Map.assocs named+                ]+    return undef++op1Return :: Eval Val -> Eval Val+op1Return action = assertFrame FrameRoutine $ do+    sub   <- fromVal =<< readVar (cast "&?ROUTINE")+    -- If this is a coroutine, reset the entry point+    case subCont sub of+        Nothing -> action+        Just tvar -> do+            let thunk = (`MkThunk` anyType) . fix $ \redo -> do+                evalExp $ subBody sub+                stm $ writeTVar tvar thunk+                redo+            stm $ writeTVar tvar thunk+            action++op1Yield :: Eval Val -> Eval Val+op1Yield action = assertFrame FrameRoutine $ do+    sub   <- fromVal =<< readVar (cast "&?ROUTINE")+    case subCont sub of+        Nothing -> fail $ "cannot yield() from a " ++ pretty (subType sub)+        Just tvar -> callCC $ \esc -> do+            stm $ writeTVar tvar (MkThunk (esc undef) anyType)+            action++op1ShiftOut :: Val -> Eval Val+op1ShiftOut v = retShift =<< do+    evl <- asks envEval+    evl $ case v of+        VList [x]   -> Val x+        _           -> Val v++op1Exit :: Val -> Eval a+op1Exit v = do+    rv <- fromVal v+    retControl . ControlExit $ if rv /= 0+        then ExitFailure rv else ExitSuccess++op1StrFirst :: (Char -> Char) -> Val -> Eval Val+op1StrFirst f = op1Cast $ VStr .+    \str -> case str of+        []      -> []+        (c:cs)  -> (f c:cs)++-- op1Readline and op1Getc are precisely the implementation of op1 "readline"+-- and op1 "getc", but those may be hidden in safe mode. We still want to use+-- the functionality with the safe variants, hence these functions.+op1Readline :: Val -> Eval Val+op1Readline = \v -> op1Read v (io . getLines) getLine+    where+    getLines :: VHandle -> IO Val+    getLines fh = unsafeInterleaveIO $ do+        line <- doGetLine fh+        case line of+            Just str -> do+                ~(VList rest) <- getLines fh+                return $ VList (VStr str:rest)+            _ -> return (VList [])+    getLine :: VHandle -> Eval Val+    getLine fh = do+        line <- io $! doGetLine fh+        case line of+            Just str    -> return $! VStr $! (length str `seq` str)+            _           -> return undef+    doGetLine :: VHandle -> IO (Maybe VStr)+    doGetLine fh = guardIOexcept [(isIOError 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+        char <- hGetChar fh+        str  <- getChar' fh char+        return $ VStr $ decodeUTF8 str+    -- We may have to read more than one byte, as one utf-8 char can span+    -- multiple bytes.+    getChar' :: VHandle -> Char -> IO String+    getChar' fh char+        | ord char < 0x80 = return [char]+        | ord char < 0xE0 = readNmore 1+        | ord char < 0xEE = readNmore 2+        | ord char < 0xF5 = readNmore 3+        | otherwise       = fail "Invalid utf-8 read by getc()"+        where+        readNmore :: Int -> IO String+        readNmore n = do+            new <- sequence $ replicate n (hGetChar fh)+            return $ char:new++{-|+Read a char or a line from a handle.+-}+op1Read :: Val                   -- ^ The handle to read from (packed in a 'Val')+        -> (VHandle -> Eval Val) -- ^ The function to call in list context+        -> (VHandle -> Eval Val) -- ^ The function to call in item context+        -> Eval Val              -- ^ The return value (a list of strings or a+                                 --   string, packed in a 'Val')+op1Read v fList fScalar = do+    fh  <- handleOf v+    ifListContext+        (fList fh)+        (fScalar fh)+    where+    handleOf x | safeMode, (VHandle h) <- x, h /= stdin = fail "Evil handle detected"+    handleOf _ | safeMode = return stdin+    handleOf VUndef = handleOf (VList [])+    handleOf (VList []) = do+        argsGV  <- readVar (cast "$*ARGS")+        gv      <- fromVal argsGV+        if defined gv+            then handleOf gv+            else do+                args    <- readVar (cast "@*ARGS")+                files   <- fromVal args+                if null files+                    then return stdin+                    else do+                        hdl <- handleOf (VStr (head files)) -- XXX wrong+                        writeVar (cast "$*ARGS") (VHandle hdl)+                        return hdl+    handleOf (VStr x) = do+        return =<< guardIO $ openFile x ReadMode+    handleOf (VList [x]) = handleOf x+    handleOf v = fromVal v++bool2n :: Bool -> VInt+bool2n v = if v+  then 1+  else 0++doBoolIO :: Value a => (a -> IO b) -> Val -> Eval Bool+doBoolIO f v = do+    x <- fromVal v+    tryIO False $ do+        f x+        return True++guardedIO :: Value a => (a -> IO b) -> Val -> Eval Val+guardedIO f v = do+    x <- fromVal v+    guardIO $ f x+    return $ VBool True++guardedIO2 :: (Value a, Value b)+    => (a -> b -> IO c) -> Val -> Val -> Eval Val+guardedIO2 f u v = do+    x <- fromVal u+    y <- fromVal v+    guardIO $ f x y+    return $ VBool True++mapStr :: (Word8 -> Word8) -> [Word8] -> String+mapStr f = map (chr . fromEnum . f)++mapStr2 :: (Word8 -> Word8 -> Word8) -> [Word8] -> [Word8] -> String+mapStr2 f x y = map (chr . fromEnum . uncurry f) $ x `zip` y++mapStr2Fill :: (Word8 -> Word8 -> Word8) -> [Word8] -> [Word8] -> String+mapStr2Fill f x y = map (chr . fromEnum . uncurry f) $ x `zipFill` y+    where+    zipFill [] [] = []+    zipFill as [] = zip as (repeat 0)+    zipFill [] bs = zip (repeat 0) bs+    zipFill (a:as) (b:bs) = (a,b) : zipFill as bs++op1Chomp :: VStr -> Val+op1Chomp "" = VStr ""+op1Chomp str+    | last str == '\n'  = VStr (init str)+    | otherwise         = VStr str++perlReplicate :: VInt -> a -> [a]+perlReplicate = genericReplicate . max 0++-- XXX only used at    op2 "?^"   because my Haskell is too poor - ferreira +neBool :: VBool -> VBool -> VBool+neBool = (==) . not++-- |Implementation of 2-arity primitive operators and functions+op2 :: String -> Val -> Val -> Eval Val+op2 "rename" = guardedIO2 rename+op2 "symlink" = guardedIO2 createSymbolicLink+op2 "link" = guardedIO2 createLink+op2 "*"  = op2Numeric (*)+op2 "/"  = op2Divide+op2 "%"  = op2Modulus+op2 "x"  = op2Cast (\x y -> VStr . concat $ (y :: VInt) `perlReplicate` x)+op2 "xx" = op2Cast (\x y -> VList . concat $ (y :: VInt) `perlReplicate` x)+op2 "+&" = op2Int (.&.)+op2 "+<" = op2Int shiftL+op2 "+>" = op2Int shiftR+op2 "~&" = op2Str $ mapStr2 (.&.)+op2 "~<" = op2Cast (\x y -> VStr $ mapStr (`shiftL` y) x)+op2 "~>" = op2Cast (\x y -> VStr $ mapStr (`shiftR` y) x)+op2 "**" = op2Exp+op2 "+"  = op2Numeric (+)+op2 "-"  = op2Numeric (-)+op2 "atan" = op2Num atan2+op2 "~"  = op2Str (++)+op2 "+|" = op2Int (.|.)+op2 "+^" = op2Int xor+op2 "~|" = op2Str $ mapStr2Fill (.|.)+op2 "?|" = op2Bool (||)+op2 "?&" = op2Bool (&&)+op2 "~^" = op2Str $ mapStr2Fill xor+op2 "?^" = op2Bool neBool -- for bools, 'xor' is the same as '!=='+op2 "=>" = \x y -> return $ castV (x, y)+op2 "="  = \x y -> evalExp (Syn "=" [Val x, Val y])+op2 "cmp"= op2OrdNumStr+op2 "leg"= op2Ord vCastStr+op2 "<=>"= op2OrdNumeric compare+op2 ".." = op2Range+op2 "..^" = op2RangeExclRight+op2 "^.." = op2RangeExclLeft+op2 "^..^" = op2RangeExclBoth+op2 "!=" = op2OrdNumeric (/=)+op2 "==" = op2OrdNumeric (==)+op2 "<"  = op2OrdNumeric (<)+op2 "<=" = op2OrdNumeric (<=)+op2 ">"  = op2OrdNumeric (>)+op2 ">=" = op2OrdNumeric (>=)+op2 "ne" = op2Cmp vCastStr (/=)+op2 "eq" = op2Cmp vCastStr (==)+op2 "lt" = op2Cmp vCastStr (<)+op2 "le" = op2Cmp vCastStr (<=)+op2 "gt" = op2Cmp vCastStr (>)+op2 "ge" = op2Cmp vCastStr (>=)+op2 "~~" = op2Match+op2 "=:=" = \x y -> do+    return $ castV $ case x of+        VRef xr | VRef yr <- y ->+            -- Take advantage of the pointer address built-in with (Show VRef)+            show xr == show yr+        _   ->+            W# (unsafeCoerce# x :: Word#) == W# (unsafeCoerce# y :: Word#)+op2 "===" = \x y -> do+    return $ castV (x == y)+op2 "eqv" = op2Identity -- XXX wrong, needs to compare full objects+op2 "&&" = op2Logical (fmap not . fromVal)+op2 "||" = op2Logical (fmap id . fromVal)+op2 "^^" = \x y -> do+    let xor True True   = VBool False+        xor True False  = x+        xor False True  = y+        xor False False = VBool False+    op2Cast xor x y+op2 "//" = op2Logical (return . defined)+op2 ".[]" = \x y -> do+    evl <- asks envEval+    evl $ Syn "[]" [Val x, Val y]+op2 ".{}" = \x y -> do+    evl <- asks envEval+    evl $ Syn "{}" [Val x, Val y]+-- XXX pipe forward XXX+op2 "and"= op2 "&&"+op2 "or" = op2 "||"+op2 "xor"= op2 "^^"+op2 "orelse"= op2 "//"	-- XXX wrong+op2 "andthen"= op2 "&&"	-- XXX even wronger+op2 "pick" = op2Pick+op2 "grep" = op2Grep+op2 "first" = op2First+op2 "map"  = op2Map+op2 "join" = op2Join+op2 "reduce" = op2ReduceL False+op2 "produce" = op2ReduceL True+op2 "reverse" = op2MaybeListop (VList . reverse) (VStr . reverse)+op2 "chomp" = op2MaybeListop (VList . map op1Chomp) op1Chomp+op2 "kill" = \s v -> do+    sig  <- fromVal s+    pids <- fromVals v+    sig' <- fromVal sig+    pids'<- mapM fromVal pids+    let doKill pid = do+        signalProcess (toEnum sig') (toEnum pid)+        return 1+    rets <- mapM (tryIO 0 . doKill) pids'+    return . VInt $ sum rets+op2 "isa"    = \x y -> do+    typY <- case y of+        VStr str -> return $ mkType str+        _        -> fromVal y+    typX <- fromVal x -- XXX consider line 224 of Pugs.Prim.Match case too+    typs <- pkgParentClasses (showType typX)+    return . VBool $ showType typY `elem` (showType typX:typs)+op2 "does"   = \x y -> do+    typY <- case y of+        VStr str -> return $ mkType str+        _        -> fromVal y+    op2Match x (VType typY)+op2 "delete" = \x y -> do+    ref <- fromVal x+    rv  <- deleteFromRef ref y+    -- S29: delete always returns the full list regardless of context.+    return $ case rv of+        VList [x]   -> x+        _           -> rv+op2 "exists" = \x y -> do+    ref <- fromVal x+    fmap VBool (existsFromRef ref y)+op2 "unshift" = op2Array array_unshift+op2 "push" = op2Array array_push+op2 "split" = op2Split+op2 "Str::split" = flip op2Split+op2 "connect" = \x y -> do+    host <- fromVal x+    port <- fromVal y+    hdl  <- guardIO $ connectTo host (PortNumber $ fromInteger port)+    return $ VHandle hdl+op2 "Pugs::Internals::hSetBinaryMode" = \x y -> do+    fh    <- fromVal x+    mode  <- fromVal y+    guardIO $ hSetBinaryMode fh mode+    return $ VBool True+op2 "Pugs::Internals::openFile" = \x y -> do+    filename <- fromVal x+    mode     <- fromVal y+    hdl      <- guardIO $ do+        h <- openFile filename (modeOf mode)+        hSetBuffering h NoBuffering+        return h+    return $ VHandle hdl+    where+    modeOf "r"  = ReadMode+    modeOf "w"  = WriteMode+    modeOf "a"  = AppendMode+    modeOf "rw" = ReadWriteMode+    modeOf m    = error $ "unknown mode: " ++ m+op2 "exp" = \x y -> if defined y+    then op2Num (**) x y+    else op1Floating exp x+op2 "Pugs::Internals::sprintf" = \x y -> do+    -- a single argument is all Haskell can really handle.+    -- XXX printf should be wrapped in a catch so a mis-typed argument+    -- doesnt kill pugs with a runtime exception.+    -- XXX fail... doesnt?!+    str <- fromVal x+    arg <- fromVal y+    return $ VStr $ case arg of+       VNum n -> printf str n+       VRat r -> printf str ((fromRational r)::Double)+       VInt i -> printf str i+       VStr s -> printf str s+       _      -> fail "should never be reached given the type declared below"+op2 "system" = \x y -> do+    prog        <- fromVal x+    args        <- fromVals y+    exitCode    <- tryIO (ExitFailure (-1)) $+        rawSystem (encodeUTF8 prog) (map encodeUTF8 args)+    handleExitCode exitCode+op2 "crypt" = \x y -> opPerl5 "crypt" [x, y]+op2 "chmod" = \x y -> do+    mode  <- fromVal x+    files <- fromVals y+    rets  <- mapM (doBoolIO . flip setFileMode $ toEnum mode) files+    return . VInt . sum $ map bool2n rets+op2 "splice" = \x y -> do+    fetchSize   <- doArray x array_fetchSize+    len'        <- fromVal y+    sz          <- fetchSize+    let len = if len' < 0 then if sz > 0 then (len' `mod` sz) else 0 else len'+    op4 "splice" x y (castV (sz - len)) (VList [])+op2 "sort" = \x y -> do+    xs <- fromVals x+    ys <- fromVals y+    op1 "sort" . VList $ xs ++ ys+op2 "IO::say" = op2Print True+op2 "IO::print" = op2Print False+op2 "printf" = op3 "IO::printf" (VHandle stdout)+op2 "BUILDALL" = cascadeMethod reverse "BUILD"+op2 "Pugs::Internals::install_pragma_value" = \x y -> do+    name <- fromVal x+    val  <- fromVal y+    idat <- asks envInitDat+    idatval <- stm $ readTVar idat+    --trace ("installing " ++ name ++ "/" ++ (show val)) $ return ()+    let prag = initPragmas idatval+    stm $ writeTVar idat idatval{initPragmas = +        MkPrag{ pragName=name, pragDat=val } : prag }+    return (VBool True)+op2 "Pugs::Internals::base" = \x y -> do+    base <- fromVal x+    case y of+        VRef{}  -> op2BasedDigits base =<< fromVal y+        VList{} -> op2BasedDigits base =<< fromVal y+        _       -> do+            str <- fromVal y+            op2BasedDigits base [ s | Just s <- map baseDigit str ]+op2 "HOW::does" = \t p -> do+    meta    <- readRef =<< fromVal t+    fetch   <- doHash meta hash_fetchVal+    name    <- fromVal =<< fetch "name"+    roles   <- fromVals p+    mixinRoles name roles+    return undef++op2 ('!':name) = \x y -> op1Cast (VBool . not) =<< op2 name x y+op2 other = \_ _ -> fail ("Unimplemented binaryOp: " ++ other)++baseDigit :: Char -> Maybe Val+baseDigit '.'       = return (VStr ".")+baseDigit ch | ch >= '0' && ch <= '9' = return (castV (ord ch - ord '0'))+baseDigit ch | ch >= 'a' && ch <= 'z' = return (castV (ord ch - ord 'a' + 10))+baseDigit ch | ch >= 'A' && ch <= 'Z' = return (castV (ord ch - ord 'A' + 10))+baseDigit _         = Nothing++op2BasedDigits :: VInt -> [Val] -> Eval Val+op2BasedDigits base vs+    | null post = do+        pre' <- mapM fromVal pre+        return $ VInt (asIntegral pre')+    | otherwise = do+        pre'  <- mapM fromVal pre+        post' <- mapM fromVal $ tail post+        return $ VRat (asFractional (0:post') + (asIntegral pre' % 1))+    where+    (pre, post) = break (== VStr ".") $ filter (/= VStr "_") vs+    asIntegral = foldl (\x d -> base * x + d) 0+    asFractional :: [VInt] -> VRat+    asFractional = foldr (\d x -> (x / (base % 1)) + (d % 1)) (0 % 1)++op2Print :: Bool -> Val -> Val -> Eval Val+op2Print wantNewline h v = do+    handle <- fromVal h+    strs   <- mapM fromVal =<< case v of+        VList vs  -> return vs+        _         -> return [v]+    guardIO $ do+        forM_ strs (hPutStr handle . encodeUTF8)+        when wantNewline (hPutStr handle "\n")+        return $ VBool True++op2Split :: Val -> Val -> Eval Val+op2Split x y = do+    val <- fromVal x+    str <- fromVal y+    case val of+        VRule rx -> do+            chunks <- rxSplit rx str+            return $ VList chunks+        _ -> do+            delim <- fromVal val+            return $ split' delim str+    where+    split' :: VStr -> VStr -> Val+    split' [] xs = VList $ map (VStr . (:[])) xs+    split' glue xs = VList $ map VStr $ split glue xs++op2MaybeListop :: forall tlist titem. (Value tlist, Value [tlist], Value titem) =>+    ([tlist] -> Val) -> (titem -> Val) -> Val -> Val -> Eval Val+op2MaybeListop flist fitem lead rest = case lead of+    VList{} -> do+        lead' <- fromVal lead+        rest' <- fromVal rest+        return (flist $ lead' ++ rest')+    VRef ref -> do+        vs      <- fromVal =<< readRef ref+        vlist   <- fromVal rest+        return (flist $ vs ++ vlist)+    _ | VList [] <- rest -> do+        -- Probably a single item.+        item    <- fromVal lead +        return (fitem item)+    _ -> do+        lead'   <- fromVal lead+        rest'   <- fromVal rest+        return (flist (lead':rest'))++-- |Implementation of 3-arity primitive operators and functions+op3 :: String -> Val -> Val -> Val -> Eval Val+op3 "Pugs::Internals::exec" = \x y z -> do+    prog        <- fromVal x+    shell       <- fromVal y+    args        <- fromVals z+    exitCode    <- guardIO $ executeFile' prog shell args Nothing+    rv          <- handleExitCode exitCode+    when (rv == VBool True) $ do+        guardIO $ exitWith ExitSuccess+    return rv+op3 "Pugs::Internals::caller" = \x y z -> do+    --kind <- fromVal =<< op1 "WHAT" x+    kind <- case x of+        VStr str -> return $ mkType str+        _        -> fromVal x+    skip <- fromVal y+    when (skip < 0) $ do+        fail "Pugs::Internals::caller called with negative skip"+    label <- fromVal z+    op3Caller kind skip label+op3 "index" = \x y z -> do+    str <- fromVal x+    sub <- fromVal y+    pos <- fromVal z+    return . VInt $ doIndex 0 str sub pos+    where+    doIndex :: VInt -> VStr -> VStr -> VInt -> VInt+    doIndex n a b p+        | p > 0, null a     = doIndex n a b 0+        | p > 0             = doIndex (n+1) (tail a) b (p-1)+        | b `isPrefixOf` a  = n+        | null a            = -1+        | otherwise         = doIndex (n+1) (tail a) b 0+op3 "rindex" = \x y z -> do+    str <- fromVal x+    sub <- fromVal y+    pos <- fromVal z+    let skip | defined z = length str - pos - length sub+             | otherwise = 0+    return . VInt $ doRindex str sub skip+    where+    doRindex :: VStr -> VStr -> Int -> VInt+    doRindex a b skip+        | skip > 0         = doRindex (init a) b (skip-1)+        | b `isSuffixOf` a = toInteger $ length a - length b+        | null a           = -1+        | otherwise        = doRindex (init a) b 0++op3 "splice" = \x y z -> do+    op4 "splice" x y z (VList [])+op3 "split" = op3Split+op3 "Str::split" = \x y z -> do+    op3 "split" y x z+op3 "HOW::new" = \t n p -> do+    cls     <- op3 "Object::new" t n p+    meta    <- readRef =<< fromVal cls+    fetch   <- doHash meta hash_fetchVal++    attrs   <- fetch "attrs"++    name    <- fromVal =<< fetch "name" :: Eval String+    roles   <- fromVals =<< fetch "does" :: Eval [String]+    supers  <- fromVals =<< fetch "is" :: Eval [String]++    -- Role flattening -- copy over things there and put it to symbol table+    -- XXX - also do renaming of concrete types mentioned in roles+    -- XXX - also, rewrite subEnv mentioned in the subs+    -- XXX - also, copy over the inheritance chain from role's metaobject+    mixinRoles name roles++    -- Merge in slot definitions in "attrs"+    defs        <- join $ doHash attrs hash_fetch+    parentAttrs <- forM (roles ++ supers) $ fetchMetaInfo "attrs"+    store       <- doHash attrs hash_store+    store $ Map.unions (defs:parentAttrs)+    +    return cls++op3 "Object::new" = \t n p -> do+    positionals <- fromVal p+    typ     <- fromVal t+    named   <- fromVal n++    defs    <- fetchMetaInfo "attrs" (showType typ)+    attrs   <- io $ H.new (==) H.hashString+    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.")+    let obj = VObject $ MkObject+            { objType   = typ+            , objAttrs  = attrs+            , objId     = uniq+            , objOpaque = Nothing+            }+    -- Now start calling BUILD for each of parent classes (if defined)+    op2 "BUILDALL" obj $ (VRef . hashRef) named+    -- Register finalizers by keeping weakrefs somehow+    setFinalization obj++op3 "Object::clone" = \t n _ -> do+    named <- fromVal n+    (VObject o) <- fromVal t+    attrs   <- readIVar (IHash $ objAttrs o)+    attrs'  <- io $ H.new (==) H.hashString+    uniq    <- newObjectId+    writeIVar (IHash attrs') (named `Map.union` attrs)+    return $ VObject o{ objAttrs = attrs', objId = uniq }++op3 "Pugs::Internals::hSeek" = \x y z -> do+    handle <- fromVal x+    pos <- fromVal y+    mode <- fromVal z+    guardIO $ hSeek handle (modeOf mode) pos+    retEmpty+    where+        modeOf :: Int -> SeekMode+        modeOf 0 = AbsoluteSeek+        modeOf 1 = RelativeSeek+        modeOf 2 = SeekFromEnd+        modeOf m = error ("Unknown seek mode: " ++ (show m))+op3 "IO::printf" = \x y z -> do+    rv      <- evalExp $ App (_Var "&sprintf") Nothing [Val y, Val z]+    op2Print False x rv+op3 other = \_ _ _ -> fail ("Unimplemented 3-ary op: " ++ other)++mixinRoles :: String -> [String] -> Eval ()+mixinRoles name roles = do+    glob    <- asks envGlobal+    let rolePkgs = map cast roles+        thisPkg  = cast name++    stm . modifyMPad glob $ \(MkPad entries) ->+        MkPad . Map.unionWith mergePadEntry entries . Map.fromList $+            [ (k{ v_package = thisPkg }, v)+            | (k, v) <- Map.assocs entries+            , v_package k `elem` rolePkgs+            ]++op3Split :: Val -> Val -> Val -> Eval Val+op3Split x y z = do+    val <- fromVal x+    str <- fromVal y+    limit <- fromVal z+    case val of+        VRule rx -> do+            chunks <- rxSplit_n rx str limit+            return $ VList chunks+        _ -> do+            delim <- fromVal val+            return $ split' delim str limit+    where+    split' :: VStr -> VStr -> Int -> Val+    split' [] xs n = VList $ (map (VStr . (:[])) (take (n-1) xs)) ++ [ VStr $ drop (n-1) xs ]+    split' glue xs n = VList $ map VStr $ split_n glue xs n++-- XXX - The "String" below wants to be Type.+fetchMetaInfo :: Value a => String -> [Char] -> Eval a+fetchMetaInfo key typ = do+    meta    <- readRef =<< fromVal =<< evalExp (_Var (':':'*':typ))+    fetch   <- doHash meta hash_fetchVal+    fromVal =<< fetch key++-- |Implementation of 4-arity primitive operators and functions.+-- Only substr and splice+op4 :: String -> Val -> Val -> Val -> Val -> Eval Val+op4 "substr" = \x y z w -> do+    str  <- fromVal x+    pos  <- fromVal y+    lenP <- fromVal z+    let len | defined z = lenP+            | otherwise = length str+        (pre, result, post) = doSubstr str pos len+    let change = \new -> do+        var <- fromVal x+        rep <- fromVal new+        writeRef var (VStr $ concat [pre, rep, post])+    -- If the replacement is given in w, change the str.+    when (defined w && not (defined result)) $ change w+    -- Return a proxy which will modify the str if assigned to.+    return $ VRef . MkRef $ proxyScalar (return result) change+    where+    doSubstr :: VStr -> Int -> Int -> (VStr, Val, VStr)+    doSubstr str pos len+        | abs pos > length str = ("", VUndef, "")+        | pos < 0   = doSubstr str (length str + pos) len+        | len < 0   = doSubstr str pos (length str - pos + len)+        | otherwise = ((take pos str), VStr (take len $ drop pos str), (drop (pos + len) str))++-- op4 "splice" = \x y z w-> do+op4 "splice" = \x y z w -> do+    splice  <- doArray x array_splice+    start   <- fromVal y+    count   <- fromVal z+    vals    <- fromVals w+    vals'   <- splice start count vals+    return $ VList vals'++op4 other = \_ _ _ _ -> fail ("Unimplemented 4-ary op: " ++ other)++op1Range :: Val -> Eval Val+op1Range (VStr s)    = return . VList $ map VStr $ strRangeInf s+op1Range (VRat n)    = return . VList $ map VRat [n ..]+op1Range (VNum n)    = return . VList $ map VNum [n ..]+op1Range (VInt n)    = return . VList $ map VInt [n ..]+op1Range x           = do+    int <- fromVal x+    op1Range (VInt int)++{- In the four op2Range* functions below, rationals+have to be handled separately because Haskell ranges +are different from Perl 6 ranges.  For example, +in Haskell, [1.1 .. 2] will return [1.1,2.1].  So, we+run the elements through a filter to ensure that the +upper bound is satisfied +-}+op2Range :: Val -> Val -> Eval Val+op2Range (VStr s) y  = do+    y'  <- fromVal y+    return . VList $ map VStr $ strRange s y'+op2Range (VNum n) y  = do+    y'  <- fromVal y+    return . VList $ map VNum [n .. y']+op2Range x (VNum n)  = do+    x'  <- fromVal x+    return . VList $ map VNum [x' .. n]+op2Range (VRat n) y  = do+    y'  <- fromVal y+    return . VList $ map VRat (filter (<= y') [n .. y'])+op2Range x (VRat n)  = do+    x'  <- fromVal x+    return . VList $ map VRat (filter (<= n) [x' .. n])+op2Range x y         = do+    x'  <- fromVal x+    y'  <- fromVal y+    return . VList $ map VInt [x' .. y']++-- because the right-exclusivity of a range can leave it+-- with no remaining elements, we need to check before+-- removing an element when enforcing left-exclusivity+removeRangeFirst :: [Val] -> [Val]+removeRangeFirst vals = if null vals then vals else init vals++op2RangeExclRight :: Val -> Val -> Eval Val+op2RangeExclRight (VRat n) y  = do+    y' <- fromVal y+    return . VList $ map VRat (filter (< y') [n .. y'])+op2RangeExclRight x (VRat n)  = do+    x'  <- fromVal x+    return . VList $ map VRat (filter (< n) [x' .. n])+op2RangeExclRight x y = do+    VList vals <- op2Range x y+    return . VList $ removeRangeFirst vals++op2RangeExclLeft :: Val -> Val -> Eval Val+op2RangeExclLeft (VRat n) y  = do+    y'  <- fromVal y+    return . VList $ map VRat (filter (\v -> n < v && v <= y') [n .. y'])+op2RangeExclLeft x (VRat n)  = do+    x'  <- fromVal x+    return . VList $ map VRat (filter (\v -> x' < v && v <= n) [x' .. n])+op2RangeExclLeft x y = do+    VList vals <- op2Range x y+    return . VList $ tail vals++op2RangeExclBoth :: Val -> Val -> Eval Val+op2RangeExclBoth (VRat n) y  = do+    y'  <- fromVal y+    return . VList $ map VRat (filter (\v -> n < v && v < y') [n .. y'])+op2RangeExclBoth x (VRat n)  = do+    x'  <- fromVal x+    return . VList $ map VRat (filter (\v -> x' < v && v < n) [x' .. n])+op2RangeExclBoth x y = do+    VList vals <- op2Range x y+    return . VList $ removeRangeFirst (tail vals)++op2ChainedList :: Val -> Val -> Val+op2ChainedList x y+    | VList xs <- x, VList ys <- y  = VList $ xs ++ ys+    | VList xs <- x                 = VList $ xs ++ [y]+    | VList ys <- y                 = VList (x:ys)+    | otherwise                     = VList [x, y]++op2Logical :: (Val -> Eval Bool) -> Val -> Val -> Eval Val+op2Logical f x y = do+    ok <- f x+    if ok then return x else do+    ref <- fromVal y+    forceRef ref++op2Identity :: Val -> Val -> Eval Val+op2Identity (VObject x) (VObject y) = return $ VBool (objId x == objId y)+op2Identity (VRef ref) y = do+    x <- readRef ref+    op2Identity x y+op2Identity x (VRef ref) = do+    y <- readRef ref+    op2Identity x y+op2Identity x y = do+    return $ VBool (x == y)++op2Cmp :: (a -> Eval b) -> (b -> b -> VBool) -> a -> a -> Eval Val+op2Cmp f cmp x y = do+    x' <- f x+    y' <- f y+    return $ VBool $ x' `cmp` y'++op2Ord :: (Ord ord) => (Val -> Eval ord) -> Val -> Val -> Eval Val+op2Ord f x y = withDefined [x, y] $ do+    x' <- f x+    y' <- f y+    return $ VInt $ case x' `compare` y' of+        LT -> -1+        EQ -> 0+        GT -> 1++isNumeric :: Val -> Bool+isNumeric (VNum {}) = True+isNumeric (VRat {}) = True+isNumeric (VInt {}) = True+isNumeric _ = False++op2OrdNumStr :: Val -> Val -> Eval Val+op2OrdNumStr x y+    | isNumeric x && isNumeric y = op2Ord vCastRat x y+    | otherwise                  = op2Ord vCastStr x y++op3Caller :: Type -> Int -> Val -> Eval Val+--op3Caller kind skip label = do+op3Caller kind skip _ = do                                 -- figure out label+    chain <- callChain =<< ask+    formatFrame $ filter labelFilter $ drop skip $ filter kindFilter chain+    where+    formatFrame :: [(Env, Maybe VCode)] -> Eval Val+    formatFrame [] = retEmpty+    formatFrame ((env, Just sub):_) = retSeq+        [ VStr $ cast (envPackage env)                 -- .package+        , VStr $ cast (posName $ envPos env)           -- .file+        , VInt $ toInteger $ posBeginLine $ envPos env -- .line+        , VStr $ cast (subName sub)                    -- .subname+        , VStr $ show $ subType sub                    -- .subtype+        , VCode $ sub                                  -- .sub+        -- TODO: add more things as they are specced.+        ]+    formatFrame ((env, _):_) = retSeq+        [ VStr $ cast (envPackage env)                 -- .package+        , VStr $ cast (posName $ envPos env)           -- .file+        , VInt $ toInteger $ posBeginLine $ envPos env -- .line+        ]+    kindFilter :: (Env, Maybe VCode) -> Bool+    kindFilter (_, Just sub) =+        case (showType kind, subType sub) of+            ("Any",      _)          -> True  -- I hope this is optimized+            ("Method",   SubMethod)  -> True+            ("Sub",      SubRoutine) -> True+            ("Block",    SubBlock)   -> True+            ("Block",    SubPointy)  -> True+            (_,          _)          -> False+    kindFilter _ = kind == anyType+    labelFilter _ = True                             -- TODO: figure out how+    callChain :: Env -> Eval [(Env, Maybe VCode)]+    callChain cur = +        case envCaller cur of+            Just caller -> do+                val <- local (const caller) (readVar $ cast "&?ROUTINE")+                if (val == undef) then return [(caller, Nothing)] else do+                sub <- fromVal val+                rest <- callChain caller+                return ((caller, Just sub) : rest)+            _           -> return []+++opPerl5 :: String -> [Val] -> Eval Val+opPerl5 sub args = do+    env     <- ask+    envSV   <- io $ mkEnv env+    let prms = map (\i -> "$_[" ++ show i ++ "]") [0 .. (length args - 1)]+    subSV   <- io $ evalPerl5 ("sub { " ++ sub ++ "(" ++ (concat $ intersperse ", " prms) ++ ") }") envSV (enumCxt cxtItemAny)+    argsSV  <- mapM fromVal args+    runInvokePerl5 subSV nullSV argsSV++evalPerl5WithCurrentEnv :: String -> Eval Val+evalPerl5WithCurrentEnv code = do+    env     <- ask+    guardIO $ do+        envSV   <- mkEnv env+        sv      <- evalPerl5 code envSV $ enumCxt cxtItemAny+        return (PerlSV sv)++atomicEval :: Eval Val -> Eval Val+atomicEval action = do+    env <- ask+    if envAtomic env then action else do+        rv <- guardSTM (runEvalSTM env action)+        case rv of+            VError{}    -> retShift rv+            VControl{}  -> retShift rv+            _           -> return rv++{-| Assert that a list of Vals is all defined.+This should 'fail' (in the Perl sense).++TOTHINK: report which element in the input list was the one+triggering the failure. Just zipping with [1 ..] may not be+enough because our caller may not be passing through its own+input args in the same order and position to us.++-}+withDefined :: (Monad m) => [Val] -> m a -> m a+withDefined [] c = c+withDefined (VUndef:_) _  = fail "use of uninitialized value"+withDefined (VType{}:_) _ = fail "use of uninitialized value"+withDefined (_:xs) c = withDefined xs c++-- |Returns a transaction to install a primitive operator using+-- 'Pugs.AST.genMultiSym'.+-- The associativity determines the arity and fixity of ops.+-- The primitive\'s subBody is defined in 'op0', 'op1', etc depending on arity,+-- the default is 'op0'.+-- The Pad symbol name is prefixed with \"&*\" for functions and+-- \"&*\" ~ fixity ~ \":\" for operators.+primOp :: String -> String -> Params -> String -> Bool -> Bool -> Bool -> STM PadMutator+primOp sym assoc prms ret isSafe isMacro isExport = fullEval $ do+    prim <- genMultiSym var (sub (isSafe || not safeMode)) mempty+    case assoc of+        -- Manufacture &infix:<!===> from &infix:<===>.+        "chain" | head sym /= '!' -> do+            prim' <- primOp ('!':sym) assoc prms ret isSafe isMacro isExport+            return (prim . prim')+        _       | isExport -> do+            -- Here we rewrite a multi form that redispatches into the method form.+            prim' <- genMultiSym (var{ v_package = emptyPkg }) (sub (isSafe || not safeMode)) mempty+            return (prim . prim')+        _       -> return prim+    where+    -- It is vital that we generate the ID for the Var for all the primitives at once,+    -- otherwise they'll be generated unpredictably during runtime with an as-needed basis,+    -- which may introduce race conditions under e.g. anotmer atomic block.+    fullEval x = idKey (v_name var) `seq` x++    -- In safemode, we filter all prims marked as "unsafe".+    var | isAlpha (head sym)+        , fixity == "prefix"+        = cast ("&*" ++ sym)+        | otherwise+        = cast ("&*" ++ fixity ++ (':':sym))++    pkg = do+        (_, pre) <- breakOnGlue "::" (reverse sym)+        return $ dropWhile (not . isAlphaNum) (reverse pre)++    sub safe = codeRef $! mkPrim+        { subName     = cast sym+        , subType     = case pkg of+            Nothing | isMacro       -> SubMacro+                    | otherwise     -> SubPrim+            Just "Pugs::Internals"  -> SubPrim+            _                       -> SubMethod+        , subAssoc    = case assoc of+            "left"  -> A_left+            "right" -> A_right+            "non"   -> A_non+            "chain" -> A_chain+            "list"  -> A_list+            "spre"  -> AIrrelevantToParsing -- XXX HACK+            _       -> ANil+        , subParams   = prms+        , subReturns  = mkType ret+        , subBody     = Prim $! if safe then f else unsafe+        }+    unsafe :: [Val] -> Eval Val+    unsafe _ = fail $ "Unsafe function '" ++ sym ++ "' called under safe mode"+    f :: [Val] -> Eval Val+    f    = case arity of+        Arity0 -> op0 sym+        Arity1 -> \x -> case x of+            [a]       -> op1 symName a+            [a,b]     -> op2 sym a b+            [a,b,c]   -> op3 sym a b c+            [a,b,c,d] -> op4 sym a b c d+            a         -> op0 sym a+        Arity2 -> \[x,y] -> op2 sym x y+    symName = if modify then assoc ++ ":" ++ sym else sym+    -- prefix symName with post, circum or other (not yet used)+    -- to disambiguate, for example, &*prefix:++ and &*postfix:++ in 'op0'+    (arity, fixity, modify) = case assoc of+        "pre"       -> (Arity1, "prefix", False)+        "spre"      -> (Arity1, "prefix", False)+        "post"      -> (Arity1, "postfix", True)+        "circum"    -> (Arity1, "circumfix", True)+        "left"      -> (Arity2, "infix", False)+        "right"     -> (Arity2, "infix", False)+        "non"       -> (Arity2, "infix", False)+        "chain"     -> (Arity2, "infix", False)+        "list"      -> (Arity0, "infix", False)+        other       -> (Arity0, other, True)++data Arity = Arity0 | Arity1 | Arity2+    deriving (Show, Eq, Ord, Typeable)++-- |Produce a Pad update transaction with 'primOp' from a string description+primDecl :: String -> STM PadMutator+primDecl str = length str `seq` rv `seq` rv+    where+    rv = primOp sym assoc params ret+        ("safe" `isPrefixOf` traits)+        ("macro" `isSuffixOf` traits)+        ("export" `isSuffixOf` traits)+    (ret:assoc:sym:traits:prms) = words str+    takeWord = takeWord' . dropWhile (not . isWord)+    takeWord' "" = ""+    takeWord' (':':':':xs) = (':':':':takeWord' xs)+    takeWord' (x:xs) | isWord x = (x:takeWord' xs)+    takeWord' _ = ""+    isWord = not . (`elem` "(),:")+    prms'  = map takeWord prms+    prms'' = foldr foldParam [] prms'+    params = map (\p -> p{ isWritable = isLValue p }) prms''++setFinalization :: Val -> Eval Val+setFinalization obj = do+    env <- ask+    -- XXX - Not sure if this can break guarantees in STM or not; disable for now+    if envAtomic env+        then return obj -- stm $ unsafeIOToSTM (obj `setFinalization` env)+        else io $ obj `setFinalizationIn` env+    where+    setFinalizationIn obj env = do+        objRef <- mkWeakPtr obj . Just $ do+            runEvalIO env $ do+                evalExp $ App (_Var "&DESTROYALL") (Just $ Val obj) []+            return ()+        modifyIORef _GlobalFinalizer (>> finalize objRef)+        return obj++-- A "box" to put our polymorphic printer in+newtype PrettyPrinter = MkPrettyPrinter { runPrinter :: forall a. Pretty a => a -> String }++-- op1 "perl"+op1Pretty :: PrettyPrinter -> Val -> Eval Val+op1Pretty printer v = do+    recur   <- io (newTVarIO False)+    let ?seen    = IntSet.empty+        ?recur   = recur+        ?printer = printer+    rv      <- prettyVal v+    isRecur <- stm (readTVar recur)+    return $ VStr $ decodeUTF8 $ if isRecur then "$_ := " ++ rv else rv++prettyVal :: (?seen :: IntSet.IntSet, ?recur :: TVar Bool, ?printer :: PrettyPrinter) => Val -> Eval VStr+prettyVal v@(VRef r) = do+    ptr <- io (stableAddressOf r)+    if IntSet.member ptr ?seen+        then do+            stm $ writeTVar ?recur True+            return "\\$_"+        else let ?seen = IntSet.insert ptr ?seen in doPrettyVal v+prettyVal v = doPrettyVal v++doPrettyVal :: (?seen :: IntSet.IntSet, ?recur :: TVar Bool, ?printer :: PrettyPrinter) => Val -> Eval VStr+doPrettyVal v@(VRef r) = do+    v'  <- readRef r+    ifValTypeIsa v "Pair"+        (case v' of+            VList [ks, vs] -> do+                kStr <- prettyVal ks+                vStr <- prettyVal vs+                return $ "(" ++ kStr ++ " => " ++ vStr ++ ")"+            _ -> prettyVal v'+        )+        (do str <- prettyVal v'+            ifValTypeIsa v "Array"+                (return $ ('[':(init (tail str))) ++ "]")+                (ifValTypeIsa v "Hash"+                    (return $ ('{':(init (tail str))) ++ "}")+                    (return ('\\':str)))+        )+doPrettyVal (VList vs) = do+    vs' <- mapM prettyVal vs+    -- (3,) should dump as (3,), not a (3), which would be the same as 3.+    return $ case vs' of+        []  -> "()"+        [x] -> "(" ++ x ++ ",)"+        _   -> "(" ++ concat (intersperse ", " vs') ++ ")"+doPrettyVal v@(VObject obj) = do+    -- ... dump the objAttrs+    -- XXX this needs fixing WRT demagicalized pairs:+    -- currently, this'll return Foo.new((attr => "value)), with the inner+    -- parens, which is, of course, wrong.+    hash    <- fromVal v :: Eval VHash+    str     <- prettyVal (VRef (hashRef hash))+    return $ showType (objType obj)+        ++ ".new(" ++ init (tail str) ++ ")"+doPrettyVal v = return (runPrinter ?printer v)++-- XXX -- Junctive Types -- XXX --++-- spre is "symbolic pre", that is, operators for which a precedence has+-- already been assigned in Parser.hs++-- |Initial set global symbols to populate the evaluation environment+--  in the form of Pad mutating transactions built with 'primDecl'.+--+--  The source string format is:+--+-- >  ret_val   assoc   op_name [safe|unsafe] args+initSyms :: STM [PadMutator]+initSyms = seq (length syms) $ do+    rv <- mapM primDecl syms+    length rv `seq` return (length rv `seq` rv)+    where+    syms = filter (not . null) . lines $ "\+\\n   Bool      spre    !       safe   (Bool)\+\\n   Num       spre    +       safe   (Num)\+\\n   Num       pre     abs     safe   (Num)\+\\n   Int       pre     Pugs::Internals::truncate safe   (Num)\+\\n   Int       pre     Pugs::Internals::round    safe   (Num)\+\\n   Int       pre     Pugs::Internals::floor    safe   (Num)\+\\n   Int       pre     Pugs::Internals::ceiling  safe   (Num)\+\\n   Num       pre     atan    safe   (Num)\+\\n   Num       pre     atan    safe   (Num, Num)\+\\n   Num       pre     cos     safe   (Num)\+\\n   Num       pre     sin     safe   (Num)\+\\n   Num       pre     tan     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)\+\\n   Num       pre     sqrt    safe   (Num)\+\\n   Num       spre    -       safe   (Num)\+\\n   Str       spre    ~       safe   (Str)\+\\n   Bool      spre    ?       safe   (Bool)\+\\n   Str       spre    =       unsafe (?IO)\+\\n   List      spre    =       unsafe (?IO)\+\\n   Str       pre     readline unsafe (?IO)\+\\n   List      pre     readline unsafe (?IO)\+\\n   Str       pre     getc     unsafe (?IO)\+\\n   Str       pre     Pugs::Safe::safe_getc      safe ()\+\\n   Str       pre     Pugs::Safe::safe_readline  safe ()\+\\n   Int       pre     int     safe   (Int)\+\\n   List      pre     list    safe   (List)\+\\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   Any       pre     List::reverse safe   (Array)\+\\n   Any       pre     reverse safe   (Scalar, List)\+\\n   Any       pre     reverse safe   ()\+\\n   List      pre     eager   safe   (List)\+\\n   Int       spre    +^      safe   (Int)\+\\n   Int       spre    ~^      safe   (Str)\+\\n   Bool      spre    ?^      safe   (Bool)\+\\n   Ref       spre    \\      safe   (rw!Any)\+\\n   List      spre    ^       safe   (Scalar)\+\\n   List      post    ...     safe   (Str)\+\\n   List      post    ...     safe   (Scalar)\+\\n   Any       pre     undef     safe   ()\+\\n   Any       pre     undefine  safe   (?rw!Any)\+\\n   Str       pre     chop    safe   (Str)\+\\n   Str       pre     Scalar::chomp   safe   (Scalar)\+\\n   Any       pre     chomp   safe   (Scalar, List)\+\\n   Any       pre     chomp   safe   ()\+\\n   Any       right   =       safe   (rw!Any, Any)\+\\n   Int       pre     index   safe   (Str, Str, ?Int=0)\+\\n   Int       pre     rindex  safe   (Str, Str, ?Int)\+\\n   Int       pre     substr  safe   (rw!Str, Int, ?Int, ?Str)\+\\n   Str       pre     lc      safe   (Str)\+\\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     crypt   safe   (Str, Str)\+\\n   Str       post    ++      safe   (rw!Str)\+\\n   Str       post    --      safe   (rw!Str)\+\\n   Num       post    ++      safe   (rw!Num)\+\\n   Num       post    --      safe   (rw!Num)\+\\n   Complex   post    i       safe   (Num)\+\\n   Str       spre    ++      safe   (rw!Str)\+\\n   Str       spre    --      safe   (rw!Str)\+\\n   Num       spre    ++      safe   (rw!Num)\+\\n   Num       spre    --      safe   (rw!Num)\+\\n   Bool      pre     not     safe   (Bool)\+\\n   Bool      pre     true    safe   (Bool)\+\\n   List      spre    gather  safe   (Code)\+\\n   List      pre     map     safe   (Code, List)\+\\n   List      pre     grep    safe   (Code, List)\+\\n   Scalar    pre     first   safe   (Code, List)\+\\n   List      pre     sort    safe   (Code, List)\+\\n   List      pre     reduce  safe   (Code, List)\+\\n   List      pre     produce safe   (Code, List)\+\\n   List      pre     sort    safe   (Array)\+\\n   List      pre     map     safe   (Array: Code)\+\\n   List      pre     grep    safe   (Array: Code)\+\\n   Scalar    pre     first   safe   (Array: Code)\+\\n   List      pre     sort    safe   (Array: Code)\+\\n   List      pre     reduce  safe   (Array: Code)\+\\n   List      pre     produce safe   (Array: Code)\+\\n   Any       pre     splice  safe   (rw!Array, ?Int=0)\+\\n   Any       pre     splice  safe   (rw!Array, Int, Int)\+\\n   Any       pre     splice  safe   (rw!Array, Int, Int, List)\+\\n   Int       pre     push    safe   (rw!Array, List)\+\\n   Int       pre     unshift safe   (rw!Array, List)\+\\n   Scalar    pre     List::pop     safe   (rw!Array)\+\\n   Scalar    pre     List::shift   safe   (rw!Array)\+\\n   Scalar    pre     sum     safe   (List)\+\\n   Scalar    pre     min     safe   (List)\+\\n   Scalar    pre     max     safe   (List)\+\\n   List      pre     uniq    safe   (List)\+\\n   Str       pre     join    safe   (Array: Str)\+\\n   Str       pre     join    safe   (Str, List)\+\\n   Any       pre     join    safe   (Thread)\+\\n   Bool      pre     detach  safe   (Thread)\+\\n   List      pre     cat     safe   (List)\+\\n   List      pre     zip     safe   (List)\+\\n   List      pre     each    safe   (List)\+\\n   List      pre     roundrobin    safe   (List)\+\\n   List      pre     keys    safe   (rw!Hash)\+\\n   List      pre     values  safe   (rw!Hash)\+\\n   List      pre     List::kv      safe,export   (rw!Hash)\+\\n   List      pre     pairs   safe   (rw!Hash)\+\\n   List      pre     keys    safe   (rw!Array)\+\\n   List      pre     values  safe   (rw!Array)\+\\n   List      pre     List::kv      safe,export   (rw!Array)\+\\n   List      pre     pairs   safe   (rw!Array)\+\\n   Scalar    pre     delete  safe   (rw!Hash: List)\+\\n   Scalar    pre     delete  safe   (rw!Array: List)\+\\n   Bool      pre     exists  safe   (rw!Hash: Str)\+\\n   Bool      pre     exists  safe   (rw!Array: Int)\+\\n   Str       pre     perl    safe   (rw!Any|Junction)\+\\n   Str       pre     guts    safe   (rw!Any|Junction)\+\\n   Any       pre     try     safe   (Code)\+\\n   Any       pre     lazy    safe   (Code)\+\\n   Any       pre     contend safe   (Code)\+\\n   Void      pre     defer   safe   ()\+\\n   Any       pre     Pugs::Internals::eval_perl6    safe   (Str)\+\\n   Any       pre     evalfile     unsafe (Str)\+\\n   Any       pre     Pugs::Internals::eval_parrot  unsafe (Str)\+\\n   Any       pre     Pugs::Internals::eval_perl5   safe (Str)\+\\n   Any       pre     Pugs::Internals::eval_haskell unsafe (Str)\+\\n   Any       pre     Pugs::Internals::eval_p6y unsafe (Str)\+\\n   Any       pre     Pugs::Internals::evalfile_p6y unsafe (Str)\+\\n   Any       pre     Pugs::Internals::eval_yaml    safe   (Str)\+\\n   Any       pre     Pugs::Internals::emit_yaml    unsafe   (rw!Any)\+\\n   Str       pre     yaml    safe   (rw!Any|Junction)\+\\n   Any       pre     Pugs::Internals::require unsafe (Str)\+\\n   Any       pre     Pugs::Internals::use     unsafe (Str)\+\\n   Any       pre     require unsafe (Str)\+\\n   Any       pre     use     unsafe (Str)\+\\n   Any       pre     require_haskell unsafe (Str)\+\\n   Any       pre     require_parrot  unsafe (Str)\+\\n   Any       pre     require_perl5   unsafe (Str)\+\\n   Any       pre     require_java    unsafe (Str)\+\\n   Any       pre     last    safe   (?Int=1)\+\\n   Any       pre     next    safe   (?Int=1)\+\\n   Any       pre     redo    safe   (?Int=1)\+\\n   Any       pre     continue    safe   (?Int=1)\+\\n   Any       pre     break    safe   (?Int=1)\+\\n   Any       pre     exit    unsafe (?Int=0)\+\\n   Any       pre     srand   safe   (?Num)\+\\n   Num       pre     rand    safe   (?Num=1)\+\\n   Bool      pre     defined safe   (Any)\+\\n   Str       pre     WHAT     safe   (rw!Any|Junction)\+\\n   Str       pre     isa     safe   (rw!Any|Junction, Str)\+\\n   Str       pre     does    safe   (rw!Any|Junction, Str)\+\\n   Num       pre     time    safe   ()\+\\n   List      pre     times   safe   ()\+\\n   List      pre     Pugs::Internals::localtime   safe   (Num)\+\\n   Str       pre     want    safe   ()\+\\n   Str       pre     File::Spec::cwd     unsafe ()\+\\n   Str       pre     File::Spec::tmpdir  unsafe ()\+\\n   Str       pre     IO::next   unsafe (IO)\+\\n   Bool      pre     IO::print   unsafe (IO)\+\\n   Bool      pre     IO::print   unsafe (IO: List)\+\\n   Bool      pre     print   safe ()\+\\n   Bool      pre     print   safe (List)\+\\n   Bool      pre     IO::printf   unsafe (IO: Str, List)\+\\n   Bool      pre     printf   safe (Str, List)\+\\n   Str       pre     Pugs::Internals::sprintf safe   (Str, Num|Rat|Int|Str)\+\\n   Bool      pre     IO::say unsafe (IO)\+\\n   Bool      pre     IO::say unsafe (IO: List)\+\\n   Bool      pre     say     safe ()\+\\n   Bool      pre     say     safe (List)\+\\n   Bool      pre     Pugs::Safe::safe_print     safe     (Str)\+\\n   Bool      pre     flush   unsafe (IO)\+\\n   Bool      pre     IO::close   unsafe,export (IO:)\+\\n   Bool      pre     Socket::close   unsafe,export (Socket:)\+\\n   Bool      pre     die     safe   (?Object)\+\\n   Bool      pre     warn    safe   (List)\+\\n   Bool      pre     fail_   safe   (?Object)\+\\n   Bool      pre     fail    safe   (?Object)\+\\n   Socket    pre     listen  unsafe (Int)\+\\n   Socket    pre     connect unsafe (Str, Int)\+\\n   Any       pre     accept  unsafe (Any)\+\\n   List      pre     slurp   unsafe (Str)\+\\n   List      pre     slurp   unsafe (Handle)\+\\n   List      pre     readdir unsafe (Str)\+\\n   Bool      pre     Pugs::Internals::exec    unsafe (Str, Bool, List)\+\\n   Int       pre     system  unsafe (Str)\+\\n   Int       pre     system  unsafe (Str: List)\+\\n   Bool      pre     binmode unsafe (IO: ?Int=1)\+\\n   Void      pre     return  safe   ()\+\\n   Void      pre     return  safe   (rw!Any)\+\\n   Void      pre     return  safe   (List)\+\\n   Void      pre     leave   safe   ()\+\\n   Void      pre     leave   safe   (rw!Any)\+\\n   Void      pre     leave   safe   (List)\+\\n   Void      pre     yield   safe   ()\+\\n   Void      pre     yield   safe   (rw!Any)\+\\n   Void      pre     yield   safe   (List)\+\\n   Void      pre     take    safe   ()\+\\n   Void      pre     take    safe   (rw!Any)\+\\n   Void      pre     take    safe   (List)\+\\n   Junction  pre     any     safe   (List)\+\\n   Junction  pre     all     safe   (List)\+\\n   Junction  pre     one     safe   (List)\+\\n   Junction  pre     none    safe   (List)\+\\n   Bool      pre     sleep   unsafe (Int)\+\\n   Bool      pre     rmdir   unsafe (Str)\+\\n   Bool      pre     mkdir   unsafe (Str)\+\\n   Bool      pre     chdir   unsafe (Str)\+\\n   Int       pre     List::elems   safe,export   (rw!Array)\+\\n   Int       pre     List::end     safe,export   (Array)\+\\n   Int       pre     graphs  safe   (Str)\+\\n   Int       pre     codes   safe   (Str)\+\\n   Int       pre     chars   safe   (Str)\+\\n   Int       pre     bytes   safe   (Str)\+\\n   Int       pre     chmod   unsafe (Int, List)\+\\n   Scalar    pre     Pair::key     safe (rw!Pair)\+\\n   Scalar    pre     Pair::value   safe (rw!Pair)\+\\n   List      pre     keys    safe   (rw!Pair)\+\\n   List      pre     values  safe   (Pair|Junction)\+\\n   List      pre     Pair::kv      safe,export   (rw!Pair)\+\\n   List      pre     pairs   safe   (rw!Pair)\+\\n   Any       pre     pick    safe   (Any|Junction)\+\\n   List      pre     pick    safe   (Any|Junction: Int)\+\\n   Bool      pre     rename  unsafe (Str, Str)\+\\n   Bool      pre     symlink unsafe (Str, Str)\+\\n   Bool      pre     link    unsafe (Str, Str)\+\\n   Int       pre     unlink  unsafe (List)\+\\n   Str       pre     readlink unsafe (Str)\+\\n   List      pre     Str::split   safe   (Str)\+\\n   List      pre     Str::split   safe   (Str: Str)\+\\n   List      pre     Str::split   safe   (Str: Regex)\+\\n   List      pre     Str::split   safe   (Str: Str, Int)\+\\n   List      pre     Str::split   safe   (Str: Regex, Int)\+\\n   List      pre     split   safe   (Str, Str)\+\\n   List      pre     split   safe   (Str, Str, Int)\+\\n   List      pre     split   safe   (Regex, Str)\+\\n   List      pre     split   safe   (Regex, Str, Int)\+\\n   Str       spre    =       safe   (Any)\+\\n   List      spre    =       safe   (Any)\+\\n   Junction  list    |       safe   (Any|Junction)\+\\n   Junction  list    &       safe   (Any|Junction)\+\\n   Junction  list    ^       safe   (Any|Junction)\+\\n   Num       left    *       safe   (Num, Num)\+\\n   Num       left    /       safe   (Num, Num)\+\\n   Num       left    %       safe   (Num, Num)\+\\n   Str       left    x       safe   (Str, Int)\+\\n   List      left    xx      safe   (Any, Int)\+\\n   Int       left    +&      safe   (Int, Int)\+\\n   Int       left    +<      safe   (Int, Int)\+\\n   Int       left    +>      safe   (Int, Int)\+\\n   Str       left    ~&      safe   (Str, Str)\+\\n   Str       left    ~<      safe   (Str, Str)\+\\n   Str       left    ~>      safe   (Str, Str)\+\\n   Num       right   **      safe   (Num, Num)\+\\n   Num       left    +       safe   (Num, Num)\+\\n   Num       left    -       safe   (Num, Num)\+\\n   Str       left    ~       safe   (Str, Str)\+\\n   Int       left    +|      safe   (Int, Int)\+\\n   Int       left    +^      safe   (Int, Int)\+\\n   Str       left    ~|      safe   (Str, Str)\+\\n   Str       left    ~^      safe   (Str, Str)\+\\n   Bool      left    ?|      safe   (Bool, Bool)\+\\n   Bool      left    ?^      safe   (Bool, Bool)\+\\n   Bool      left    ?&      safe   (Bool, Bool)\+\\n   Pair      right   =>      safe   (Any, Any)\+\\n   Int       non     cmp     safe   (Any, Any)\+\\n   Int       non     leg     safe   (Str, Str)\+\\n   Int       non     <=>     safe   (Num, Num)\+\\n   List      non     ..      safe   (Scalar, Scalar)\+\\n   List      non     ..^     safe   (Scalar, Scalar)\+\\n   List      non     ^..     safe   (Scalar, Scalar)\+\\n   List      non     ^..^    safe   (Scalar, Scalar)\+\\n   Bool      chain   !=      safe   (Num, Num)\+\\n   Bool      chain   ==      safe   (Num, Num)\+\\n   Bool      chain   =:=     safe   (rw!Any, rw!Any)\+\\n   Bool      chain   ===     safe   (Any, Any)\+\\n   Bool      chain   eqv     safe   (Any, Any)\+\\n   Bool      chain   ~~      safe   (rw!Any, Any)\+\\n   Bool      chain   <       safe   (Num, Num)\+\\n   Bool      chain   <=      safe   (Num, Num)\+\\n   Bool      chain   >       safe   (Num, Num)\+\\n   Bool      chain   >=      safe   (Num, Num)\+\\n   Bool      chain   ne      safe   (Str, Str)\+\\n   Bool      chain   eq      safe   (Str, Str)\+\\n   Bool      chain   lt      safe   (Str, Str)\+\\n   Bool      chain   le      safe   (Str, Str)\+\\n   Bool      chain   gt      safe   (Str, Str)\+\\n   Bool      chain   ge      safe   (Str, Str)\+\\n   Scalar    left    &&      safe   (Bool, ~Bool)\+\\n   Scalar    left    ||      safe   (Bool, ~Bool)\+\\n   Scalar    left    ^^      safe   (Bool, Bool)\+\\n   Scalar    left    //      safe   (Bool, ~Bool)\+\\n   Scalar    left    .[]     safe   (Array, Int)\+\\n   Scalar    left    .{}     safe   (Hash, Str)\+\\n   List      list    Z       safe   (Array)\+\\n   List      list    X       safe   (Array)\+\\n   List      spre    <==     safe   (List)\+\\n   List      left    ==>     safe   (List, Code)\+\\n   Scalar    left    and     safe   (Bool, ~Bool)\+\\n   Scalar    left    or      safe   (Bool, ~Bool)\+\\n   Scalar    left    xor     safe   (Bool, Bool)\+\\n   Scalar    left    orelse  safe   (Bool, ~Bool)\+\\n   Scalar    left    andthen safe   (Bool, ~Bool)\+\\n   Str       pre     chr     safe   (Int)\+\\n   Int       pre     ord     safe   (Str)\+\\n   Str       pre     oct     safe   (Str)\+\\n   Object    pre     stat    unsafe  (Str)\+\\n   Object    pre     lstat   unsafe  (Str)\+\\n   Int       pre     from    safe   (Match)\+\\n   Int       pre     to      safe   (Match)\+\\n   List      pre     matches safe   (Match)\+\\n   Str       pre     oct     safe   (Int)\+\\n   Num       pre     log     safe   (Int)\+\\n   Num       pre     log     safe   (Num)\+\\n   Num       pre     log10   safe   (Num)\+\\n   Thread    pre     async   safe   (Code)\+\\n   Thread    pre     fork    unsafe ()\+\\n   Int       pre     sign    safe   (Num)\+\\n   Bool      pre     kill    safe   (Thread)\+\\n   Int       pre     kill    unsafe (Int, List)\+\\n   Object    pre     Object::new     safe,export   (Object: Named)\+\\n   Object    pre     BUILDALL   safe   (Object)\+\\n   Object    pre     DESTROYALL safe   (Object)\+\\n   Code      pre     TEMP    safe   (rw!Any)\+\\n   Object    pre     Object::clone   safe   (Object: Named)\+\\n   Class     pre     Object::HOW    safe,export   (Object)\+\\n   Object    pre     HOW::new     safe   (Object: Named)\+\\n   Object    pre     HOW::does     safe   (Object: List)\+\\n   Str       pre     Class::name    safe   (Class)\+\\n   Hash      pre     Class::traits  safe   (Class)\+\\n   Object    pre     WHICH      safe   (Any)\+\\n   Int       pre     Rat::numerator   safe   (Rat:)\+\\n   Int       pre     Rat::denominator safe   (Rat:)\+\\n   Bool      pre     Thread::yield   safe   (Thread)\+\\n   List      pre     Pugs::Internals::runShellCommand        unsafe (Str)\+\\n   List      pre     Pugs::Internals::runInteractiveCommand  unsafe (Str)\+\\n   Bool      pre     Pugs::Internals::hSetBinaryMode         unsafe (IO, Str)\+\\n   Void      pre     Pugs::Internals::hSeek                  unsafe (IO, Int, Int)\+\\n   Int       pre     IO::tell                                unsafe,export (IO)\+\\n   Bool      pre     Pugs::Internals::hIsOpen                unsafe (IO)\+\\n   Bool      pre     Pugs::Internals::hIsClosed              unsafe (IO)\+\\n   Bool      pre     Pugs::Internals::hIsReadable            unsafe (IO)\+\\n   Bool      pre     Pugs::Internals::hIsWritable            unsafe (IO)\+\\n   Bool      pre     Pugs::Internals::hIsSeekable            unsafe (IO)\+\\n   IO        pre     Pugs::Internals::openFile               unsafe (Str, Str)\+\\n   List      pre     Pugs::Internals::caller                 safe (Any, Int, Str)\+\\n   Any       pre     Pugs::Internals::check_for_io_leak      safe (Code)\+\\n   Bool      pre     Bool::True  safe   ()\+\\n   Bool      pre     Bool::False safe   ()\+\\n   Bool      pre     True  safe,macro   ()\+\\n   Bool      pre     False safe,macro   ()\+\\n   List      spre    prefix:[,]  safe   (List)\+\\n   List      spre    prefix:@<<    safe   (List)\+\\n   List      spre    prefix:$<<    safe   (List)\+\\n   List      spre    prefix:&<<    safe   (List)\+\\n   List      spre    prefix:%<<    safe   (List)\+\\n   Str       pre     Code::name    safe   (Code:)\+\\n   Int       pre     Code::arity   safe   (Code:)\+\\n   Str       pre     Code::assoc   safe   (Code:)\+\\n   Code::Exp pre     Code::body    safe   (Code:)\+\\n   Str       pre     Code::pos     safe   (Code:)\+\\n   Any       pre     Code::signature     safe   (Code:)\+\\n   IO::Dir   pre     opendir    unsafe (Str)\+\\n   Str       pre     IO::Dir::read       unsafe,export (IO::Dir:)\+\\n   List      pre     IO::Dir::read       unsafe,export (IO::Dir:)\+\\n   Str       pre     IO::Dir::readdir    unsafe,export (IO::Dir:)\+\\n   List      pre     IO::Dir::readdir    unsafe,export (IO::Dir:)\+\\n   Bool      pre     IO::Dir::close      unsafe,export (IO::Dir:)\+\\n   Bool      pre     IO::Dir::closedir   unsafe,export (IO::Dir:)\+\\n   Bool      pre     IO::Dir::rewind     unsafe,export (IO::Dir:)\+\\n   Bool      pre     IO::Dir::rewinddir  unsafe,export (IO::Dir:)\+\\n   Any       pre     Pugs::Internals::reduceVar  unsafe (Str)\+\\n   Str       pre     Pugs::Internals::rule_pattern safe (Regex)\+\\n   Hash      pre     Pugs::Internals::rule_adverbs safe (Regex)\+\\n   Int       pre     Pugs::Internals::install_pragma_value safe (Str, Int)\+\\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   Any       pre     vv      safe (Any)\+\\n"
+ src/Pugs/Prim/Code.hs view
@@ -0,0 +1,59 @@+{-# OPTIONS_GHC -fglasgow-exts -fallow-overlapping-instances #-}+module Pugs.Prim.Code (+    op1CodeAssoc, op1CodeName, op1CodeArity, op1CodeBody, op1CodePos, op1CodeSignature+) where+import Pugs.AST+import Pugs.Internals+-- import Pugs.Pretty++{- On Code -}++op1CodeAssoc :: Val -> Eval Val+op1CodeAssoc v = do+    code <- fromVal v+    return $ case subAssoc code of+        ANil                    -> undef+        AIrrelevantToParsing    -> undef+        A_left                  -> castV "left"+        A_right                 -> castV "right"+        A_non                   -> castV "non"+        A_chain                 -> castV "chain"+        A_list                  -> castV "list"++op1CodeName :: Val -> Eval Val+op1CodeName v = do+    code <- fromVal v+    return . VStr $ case cast $ subName code of+        "<anon>"  -> cast $ subName code+        _         -> "&" ++ cast (subPackage code) +++                     "::" ++ tail (cast (subName code))++op1CodeArity :: Val -> Eval Val+op1CodeArity v = do+    code <- fromVal v+    return . castV . length $ subParams code++op1CodeBody :: Val -> Eval Val+op1CodeBody v = do+    (code :: VCode) <- fromVal v+    expToEvalVal $ subBody code++op1CodePos :: Val -> Eval Val+op1CodePos v = do -- die "XXX - code.pos not implemented" v+    return $ castV (show v)+{-+do+    code <- fromVal v+    let env = subEnv code+    case env of+        Nothing  -> return VUndef+        Just env -> return $ castV $ pretty $ envPos env+-}++op1CodeSignature :: Val -> Eval Val+op1CodeSignature v = do+    code <- fromVal v+    return . VV . mkVal . paramsToSig . subParams $ code++{- On Code::Exp -}+
+ src/Pugs/Prim/Eval.hs view
@@ -0,0 +1,194 @@+{-# OPTIONS_GHC -fglasgow-exts -fallow-overlapping-instances #-}+module Pugs.Prim.Eval (+    -- used by Pugs.Prim+    op1EvalHaskell, op1EvalP6Y, op1EvalFileP6Y,+    opEval, opEvalFile,+    opRequire, requireInc,+    EvalError(..), EvalResult(..), EvalStyle(..),+    -- used by Pugs.Eval -- needs factored somewhere bettwen+    retEvalResult,+) where+import Pugs.AST+import Pugs.Parser.Program+import Pugs.Embed+import Pugs.Monads+import Pugs.Internals+import Pugs.Pretty+import Pugs.Config+import Pugs.Prim.Keyed+import Pugs.Types+import DrIFT.YAML+import Data.Yaml.Syck+import qualified Data.ByteString.Char8 as Bytes++type Bytes        = Bytes.ByteString++data EvalError = EvalErrorFatal+               | EvalErrorUndef+               deriving Eq+data EvalResult = EvalResultLastValue+                | EvalResultModule+                | EvalResultEnv+                deriving Eq+data EvalStyle = MkEvalStyle+               { evalError  :: EvalError+               , evalResult :: EvalResult+               }+++specialPackageNames :: [String]+specialPackageNames = ["MY", "OUR", "GLOBAL", "OUTER", "CALLER", "ENV", "SUPER", "COMPILING"]++opRequire :: Bool -> Val -> Eval Val+opRequire dumpEnv v = do+    mod         <- fromVal v+    if elem mod specialPackageNames then return (VBool True) else do+    incs        <- fromVal =<< readVar (cast "@*INC")+    glob        <- askGlobal+    seen        <- findSymRef (cast "%*INC") glob+    loaded      <- existsFromRef seen v+    let file | '.' `elem` mod = mod+             | otherwise      = (concat $ intersperse (getConfig "file_sep") $ split "::" mod) ++ ".pm"+    pathName    <- requireInc incs file (errMsg file incs)+    if loaded then opEval style pathName "" else do+        -- %*INC{mod} = { relname => file, pathname => pathName }+        evalExp $ Syn "="+            [ Syn "{}"             -- subscript+                [ _Var "%*INC", Val . VStr $ decodeUTF8 mod ]+                , Syn "\\{}"       -- hashref+                    [ Syn "," [ mkStrPair "fullpath" (decodeUTF8 pathName)+                              , mkStrPair "relpath"  (decodeUTF8 file) ]+                    ]+            ]+        -- merge @*END here+        endAV   <- findSymRef (cast "@*END") glob+        ends    <- fromVal =<< readRef endAV+        clearRef endAV+        rv <- tryFastEval pathName (pathName ++ ".yml")+        endAV'  <- findSymRef (cast "@*END") glob+        doArray (VRef endAV') (`array_unshift` ends)+        return rv+    where+    tryFastEval pathName pathNameYml = do+        ok <- io $ doesFileExist pathNameYml+        if not ok then slowEval pathName else do+        isYamlStale <- tryIO False $ do+            timePm  <- getModificationTime pathName+            timeYml <- getModificationTime pathNameYml+            return (timeYml < timePm)+        if isYamlStale then slowEval pathName else do+        rv <- tryT $ fastEval pathNameYml+        case rv of+            VError _ [MkPos{posBeginLine=0}]-> slowEval pathName+            _                               -> opEval style pathName ""+        +        +    fastEval = op1EvalFileP6Y . VStr+    slowEval pathName = do +        str      <- io $ readFile pathName+        opEval style pathName str+    style = MkEvalStyle+        { evalError  = EvalErrorFatal+        , evalResult = (if dumpEnv == True then EvalResultEnv+                                           else EvalResultLastValue)}+    errMsg file incs = "Can't locate " ++ file ++ " in @*INC (@*INC contains: " ++ unwords incs ++ ")."+    mkStrPair :: String -> String -> Exp+    mkStrPair key val = App (_Var "&infix:=>") Nothing (map (Val . VStr) [key, val])++requireInc :: (MonadIO m) => [FilePath] -> FilePath -> String -> m String+requireInc [] _ msg = fail msg+requireInc (p:ps) file msg = do+    let pathName  = p ++ (getConfig "file_sep") ++ file+    ok <- io $ doesFileExist pathName+    if (not ok)+        then requireInc ps file msg+        else return pathName++opEvalFile :: String -> Eval Val+opEvalFile filename = do+    ok <- io $ doesFileExist filename+    if (not ok)+        then fail $ "Can't locate " ++ filename ++ "."+        else do+            contents <- io $ readFile filename+            opEval style filename contents+    where+    style = MkEvalStyle{ evalError=EvalErrorUndef+                       , evalResult=EvalResultLastValue}++op1EvalHaskell :: Val -> Eval Val+op1EvalHaskell cv = do+    str     <- fromVal cv+    val     <- tryT $ evalHaskell str+    retEvalResult style val+    where+    style = MkEvalStyle{ evalError=EvalErrorUndef+                       , evalResult=EvalResultLastValue}+++op1EvalP6Y, op1EvalFileP6Y :: Val -> Eval Val++op1EvalFileP6Y fileName = do+    fileName' <- fromVal fileName+    file      <- io $ Bytes.readFile fileName'+    op1EvalP6Y' file++op1EvalP6Y bytecode = do+    bytecode' <- fromVal bytecode+    op1EvalP6Y' $ Bytes.pack bytecode' -- XXX: is this the right pack function?++op1EvalP6Y' :: Bytes -> Eval Val+op1EvalP6Y' bytecode = do+    yml  <- io $ (`catchIO` (return . Left . show)) $+        fmap Right (parseYamlBytes bytecode)+    case yml of+        Right MkNode{ n_elem=ESeq (v:_) }+            | MkNode{ n_elem=EStr vnum } <- v+            , vnum /= (packBuf $ show compUnitVersion) -> do+                err $ "incompatible version number for compilation unit: found " +++                    unpackBuf vnum ++ ", expecting " ++ (show compUnitVersion)+        Right yml' -> do+            globTVar    <- asks envGlobal+            MkCompUnit _ _ glob ast <- io $ fromYAML yml'+            tryT $ do+                -- Inject the global bindings+                stm $ do+                    glob' <- readMPad globTVar+                    writeMPad globTVar (glob `unionPads` glob')+                evl <- asks envEval+                evl ast+        x -> err x+    where+    err x = local (\e -> e{ envPos = (envPos e){ posBeginLine=0 } }) $+        fail $ "failed loading Yaml: " ++ show x++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)) [] }+    env'    <- io $ evaluateIO (parseProgram env path str) `catchIO` errHandler+    val     <- tryT $ local (const env') $ do+        evl <- asks envEval+        initAV   <- evalExp (_Var "@*INIT")+        initSubs <- fromVals initAV+        mapM_ evalExp [ Ann (Cxt CxtVoid) (App (Val sub) Nothing []) | sub@VCode{} <- initSubs ]+        evalExp (Syn "=" [_Var "@*INIT", Syn "," []])+        evl $ case evalResult style of+            EvalResultEnv   -> envBody env' `mergeStmts` Syn "continuation" []+            _               -> envBody env'+    retEvalResult style val++retEvalResult :: EvalStyle -> Val -> Eval Val+retEvalResult style val = do+    glob <- askGlobal+    errSV <- findSymRef (cast "$!") glob+    case val of+        err@(VError e _) -> do+            writeRef errSV e+            when (evalError style == EvalErrorFatal) $ do+                io $ fail $ pretty err+            retEmpty+        _ -> do+            writeRef errSV VUndef+            return val+
+ src/Pugs/Prim/FileTest.hs view
@@ -0,0 +1,110 @@+{-# OPTIONS_GHC -fglasgow-exts -fallow-overlapping-instances -fallow-undecidable-instances #-}+module Pugs.Prim.FileTest (+    isReadable, isWritable, isExecutable,+    exists, isFile, isDirectory,+    fileSize, sizeIsZero,+    fileMTime, fileCTime, fileATime,+    fileTestViaPerl5+) where+import Pugs.Internals+import Pugs.Embed+import Pugs.Types+import Pugs.AST hiding (isWritable)++-- filetest operators --++-- Officially, these should return a stat object, which sometimes pretends+-- to be a boolean, and may(?) return the filename in string context.+-- DARCS was working on stat, and we should perhaps grab their work:+--  http://www.abridgegame.org/pipermail/darcs-users/2005-February/005499.html+-- They currently (2004-04-05) seem to be using:+--  http://abridgegame.org/cgi-bin/darcs.cgi/darcs/win32/System/Posix.hs+-- For the moment, these return filename and false or undef.+-- Known Bugs: multiple stat()s are done, and filename isnt a boolean.++isReadable   :: Val -> Eval Val+isReadable   = fileTestIO fileTestIsReadable+isWritable   :: Val -> Eval Val+isWritable   = fileTestIO fileTestIsWritable+isExecutable :: Val -> Eval Val+isExecutable = fileTestIO fileTestIsExecutable+exists       :: Val -> Eval Val+exists       = fileTestIO fileTestExists+isFile       :: Val -> Eval Val+isFile       = fileTestIO fileTestIsFile+isDirectory  :: Val -> Eval Val+isDirectory  = fileTestIO fileTestIsDirectory+fileSize     :: Val -> Eval Val+fileSize     = fileTestIO fileTestFileSize+sizeIsZero   :: Val -> Eval Val+sizeIsZero   = fileTestIO fileTestSizeIsZero+fileMTime    :: Val -> Eval Val+fileMTime    = fileTime statFileMTime+fileCTime    :: Val -> Eval Val+fileCTime    = fileTime statFileCTime+fileATime    :: Val -> Eval Val+fileATime    = fileTime statFileATime++fileTestViaPerl5 :: String -> Val -> Eval Val+fileTestViaPerl5 testOp v = do+    env     <- ask+    envSV   <- io $ mkEnv env+    argSV   <- fromVal v+    subSV   <- io $ evalPerl5 ("sub { -" ++ testOp ++ " $_[0] }") envSV (enumCxt cxtItemAny)+    rv      <- runInvokePerl5 subSV nullSV [argSV]+    return $ case rv of+        VStr "" -> VBool False+        VNum 1  -> VBool True+        VInt 1  -> VBool True+        _       -> rv++fileTime :: (FilePath -> IO Integer) -> Val -> Eval Val+fileTime test f = do+    t   <- fileTestIO (fileTestDo test) f+    if (t == undef) then return VUndef else do+    t'  <- fromVal t :: Eval Integer+    b   <- fromVal =<< readVar (cast "$*BASETIME")+    return $ VRat $ (b - (pugsTimeSpec . posixSecondsToUTCTime $ fromIntegral t')) / 86400++fileTestIO :: (Value n) => (n -> IO Val) -> Val -> Eval Val+fileTestIO f v = do+    str <- fromVal =<< fromVal' v+    tryIO undef $ f str++valFromBool :: Value a => a -> Bool -> Val+valFromBool v b = if b then castV v else VBool False++testPerms :: (Permissions -> Bool) -> FilePath -> IO Val+testPerms t f = do+    p <- getPermissions f+    let b = t p+    return $ valFromBool f b++fileTestIsReadable :: FilePath -> IO Val+fileTestIsReadable = testPerms readable++fileTestIsWritable :: FilePath -> IO Val+fileTestIsWritable = testPerms writable++fileTestIsExecutable :: FilePath -> IO Val+fileTestIsExecutable = testPerms $ liftM2 (||) executable searchable++fileTestExists :: FilePath -> IO Val+fileTestExists f = doesExist f >>= return . (valFromBool f)++fileTestIsFile :: FilePath -> IO Val+fileTestIsFile f = doesFileExist f >>= return . (valFromBool f)++fileTestIsDirectory :: FilePath -> IO Val+fileTestIsDirectory f = doesDirectoryExist f >>= return . (valFromBool f)++fileTestFileSize :: FilePath -> IO Val+fileTestFileSize f = statFileSize f >>= return . VInt++fileTestSizeIsZero :: FilePath -> IO Val+fileTestSizeIsZero f = do+    n <- statFileSize f+    return $ if n == 0 then VBool True else VBool False++fileTestDo :: (FilePath -> IO Integer) -> FilePath -> IO Val+fileTestDo test f = test f >>= return . VInt
+ src/Pugs/Prim/Keyed.hs view
@@ -0,0 +1,144 @@+{-# OPTIONS_GHC -fglasgow-exts -fno-warn-orphans #-}++module Pugs.Prim.Keyed (+  -- keyed values (Val)+  pairsFromVal, keysFromVal, valuesFromVal,++  -- keyed references (VRef)+  pairsFromRef, keysFromRef, valuesFromRef,+  existsFromRef, deleteFromRef,+) where+import Pugs.Internals+import Pugs.AST+import Pugs.Types+import qualified Data.Map as Map+import qualified Data.Set as Set++pairsFromVal :: Val -> Eval [Val]+pairsFromVal VUndef = return []+pairsFromVal (PerlSV sv) = do+    keys    <- hash_fetchKeys sv+    return $ VList (map castV keys)+    elems   <- mapM (hash_fetchElem sv) keys+    return $ map (VRef . MkRef . IPair) (keys `zip` elems)+pairsFromVal (VRef ref) = pairsFromRef ref+pairsFromVal v = fallback pairsFromVal v++fallback :: (Val -> Eval b) -> Val -> Eval b+fallback f v@(VV vv) = do+    val <- vvToVal vv+    case val of+        VV{} -> die "Not a keyed object" v+        _    -> f val+fallback _ v = die "Not a keyed value" v++keysFromVal :: Val -> Eval Val+keysFromVal VUndef = return $ VList []+keysFromVal (PerlSV sv) = do+    keys    <- hash_fetchKeys sv+    return $ VList (map castV keys)+keysFromVal (VList vs) = return . VList $ map VInt [0 .. (genericLength vs) - 1]+keysFromVal (VRef ref) = do+    vals <- keysFromRef ref+    return $ VList vals+keysFromVal v = fallback keysFromVal v++valuesFromVal :: Val -> Eval Val+valuesFromVal VUndef = return $ VList []+valuesFromVal (VJunc j) = return . VList . Set.elems $ juncSet j+valuesFromVal v@(VList _) = return v+valuesFromVal (VRef ref) = do+    vals <- valuesFromRef ref+    return $ VList vals+valuesFromVal (PerlSV sv) = do+    pairs <- hash_fetch sv+    return . VList $ Map.elems pairs+valuesFromVal v = fallback valuesFromVal v++-- XXX These bulks of code below screams for refactoring++pairsFromRef :: VRef -> Eval [Val]+pairsFromRef r@(MkRef (IPair _)) = do+    return [VRef r]+pairsFromRef (MkRef (IHash hv)) = do+    keys    <- hash_fetchKeys hv+    elems   <- mapM (hash_fetchElem hv) keys+    return $ map (VRef . MkRef . IPair) (keys `zip` elems)+pairsFromRef (MkRef (IArray av)) = do+    vals    <- array_fetch av+    return $ map castV ((map VInt [0..]) `zip` vals)+pairsFromRef (MkRef (IScalar sv)) = do+    refVal  <- scalar_fetch' sv+    pairsFromVal refVal+pairsFromRef ref = die "Not a keyed reference" ref++keysFromRef :: VRef -> Eval [Val]+keysFromRef (MkRef (IPair pv)) = do+    key     <- pair_fetchKey pv+    return [key]+keysFromRef (MkRef (IHash hv)) = do+    keys    <- hash_fetchKeys hv+    return $ map castV keys+keysFromRef (MkRef (IArray av)) = do+    keys    <- array_fetchKeys av+    return $ map castV keys+keysFromRef (MkRef (IScalar sv)) = do+    refVal  <- scalar_fetch' sv+    if defined refVal+        then fromVal =<< keysFromVal refVal+        else return []+keysFromRef ref = die "Not a keyed reference" ref++valuesFromRef :: VRef -> Eval [Val]+valuesFromRef (MkRef (IPair pv)) = do+    val   <- pair_fetchVal pv+    return [val]+valuesFromRef (MkRef (IHash hv)) = do+    pairs <- hash_fetch hv+    return $ Map.elems pairs+valuesFromRef (MkRef (IArray av)) = array_fetch av+valuesFromRef (MkRef (IScalar sv)) = do+    refVal  <- scalar_fetch' sv+    if defined refVal+        then fromVal =<< valuesFromVal refVal+        else return []+valuesFromRef ref = die "Not a keyed reference" ref++existsFromRef :: VRef -> Val -> Eval VBool+existsFromRef (MkRef (IHash hv)) val = do+    idx     <- fromVal val+    hash_existsElem hv idx+existsFromRef (MkRef (IArray av)) val = do+    idx     <- fromVal val+    array_existsElem av idx+existsFromRef (MkRef (IScalar sv)) val = do+    refVal  <- scalar_fetch' sv+    case refVal of+        VRef ref    -> existsFromRef ref val+        VList _     -> (`existsFromRef` val) =<< fromVal refVal+        _           -> return False+existsFromRef ref _ = die "Not a keyed reference" ref++deleteFromRef :: VRef -> Val -> Eval Val+deleteFromRef (MkRef (IHash hv)) val = do+    idxs    <- fromVals val+    rv      <- forM idxs $ \idx -> do+        val <- hash_fetchVal hv idx+        hash_deleteElem hv idx+        return val+    return $ VList rv+deleteFromRef (MkRef (IArray av)) val = do+    idxs    <- fromVals val+    rv      <- forM idxs $ \idx -> do+        val <- array_fetchVal av idx+        array_deleteElem av idx+        return val+    return $ VList rv+deleteFromRef (MkRef (IScalar sv)) val = do+    refVal  <- scalar_fetch' sv+    case refVal of+        VRef ref    -> deleteFromRef ref val+        VList _     -> (`deleteFromRef` val) =<< fromVal refVal+        v           -> die "Argument is not a Hash or Array element or slice in delete" v+deleteFromRef ref _ = die "Argument is not a Hash or Array element or slice in delete" ref+
+ src/Pugs/Prim/Lifts.hs view
@@ -0,0 +1,52 @@+{-# OPTIONS_GHC -fglasgow-exts -fno-warn-orphans #-}++module Pugs.Prim.Lifts (+  op1Cast, op2Cast,+  op2Array,+  vCastStr, vCastRat,+  op2Str, op2Num, op2Bool, op2Int, op2Rat,+) where+import Pugs.AST+import Pugs.Types++op1Cast :: (Value n) => (n -> Val) -> Val -> Eval Val+op1Cast f val = fmap f (fromVal val)++op2Cast :: (Value n, Value m) => (n -> m -> Val) -> Val -> Val -> Eval Val+op2Cast f x y = do+    x' <- fromVal =<< fromVal' x+    y' <- fromVal =<< fromVal' y+    return (f x' y')++op2Array :: (forall a. ArrayClass a => a -> [Val] -> Eval ()) -> Val -> Val -> Eval Val+op2Array f x y = do+    f    <- doArray x f+    vals <- fromVal y+    f vals+    size <- doArray x array_fetchSize+    idx  <- size+    return $ castV idx++vCastStr :: Val -> Eval VStr+vCastStr = fromVal+vCastRat :: Val -> Eval VRat+vCastRat = fromVal++op2Str :: (Value v1, Value v2) => (v1 -> v2 -> VStr) -> Val -> Val -> Eval Val+op2Str f x y = do+    x' <- fromVal x+    y' <- fromVal y+    return $ VStr $ f x' y'++op2Num    :: (Value v1, Value v2) => (v1 -> v2 -> VNum) -> Val -> Val -> Eval Val+op2Num  f = op2Cast $ (VNum .) . f++op2Bool   :: (Value v1, Value v2) => (v1 -> v2 -> VBool) -> Val -> Val -> Eval Val+op2Bool f = op2Cast $ (VBool .) . f++op2Int    :: (Value v1, Value v2) => (v1 -> v2 -> VInt) -> Val -> Val -> Eval Val+op2Int  f = op2Cast $ (VInt .) . f++op2Rat    :: (Value v1, Value v2) => (v1 -> v2 -> VRat) -> Val -> Val -> Eval Val+op2Rat  f = op2Cast $ (VRat .) . f+
+ src/Pugs/Prim/List.hs view
@@ -0,0 +1,491 @@+{-# OPTIONS_GHC -fglasgow-exts -fallow-overlapping-instances #-}++module Pugs.Prim.List (+    op0Zip, op0Cross, op0Cat, op0Each, op0RoundRobin, op1Pick, op1Sum,+    op1Min, op1Max, op1Uniq,+    op2Pick,+    op2ReduceL, op2Reduce, op2Grep, op2First, op2Map, op2Join,+    sortByM,+    op1HyperPrefix, op1HyperPostfix, op2Hyper,+) where+import Pugs.Internals+import Pugs.AST+import Pugs.Types+import Pugs.Monads+import qualified Data.Set as Set++import Pugs.Prim.Numeric+import Pugs.Prim.Lifts++op0Cat :: [Val] -> Eval Val+op0Cat = fmap (VList . concat) . mapM fromVal++op0Zip :: [Val] -> Eval Val+op0Zip = fmap (VList . fmap VList . op0Zip') . mapM fromVal++op0Each :: [Val] -> Eval Val+op0Each = fmap (VList . concat . op0Zip') . mapM fromVal++op0RoundRobin :: [Val] -> Eval Val+op0RoundRobin = fmap (VList . fst . partition defined . concat . op0Zip') . mapM fromVal++op0Zip' :: [[Val]] -> [[Val]]+op0Zip' lists | any null lists = []+op0Zip' []    = []+op0Zip' lists = (map zipFirst lists):(op0Zip' (map zipRest lists))+    where+    zipFirst []     = undef+    zipFirst (x:_)  = x+    zipRest  []     = []+    zipRest  (_:xs) = xs++op0Cross :: [Val] -> Eval Val+op0Cross = fmap (VList . fmap VList . op0Cross') . mapM fromVal++op0Cross' :: [[Val]] -> [[Val]]+op0Cross' [] = [[]]+op0Cross' (xs:yss) = do+    x <- xs+    ys <- op0Cross' yss+    return (x:ys)++op1Pick :: Val -> Eval Val+op1Pick (VRef r) = op1Pick =<< readRef r+op1Pick (VList []) = return undef+op1Pick (VList vs) = do+    rand <- io $ randomRIO (0, length vs - 1)+    return $ vs !! rand+op1Pick (VJunc (MkJunc _ _ set)) | Set.null set = return undef+op1Pick (VJunc (MkJunc JAny _ set)) = do -- pick mainly works on 'any'+    rand <- io $ randomRIO (0 :: Int, (Set.size set) - 1)+    return $ (Set.elems set) !! rand+op1Pick (VJunc (MkJunc JNone _ _)) = return undef+op1Pick (VJunc (MkJunc JAll _ set)) =+    if (Set.size $ set) == 1 then return $ head $ Set.elems set+    else return undef+op1Pick (VJunc (MkJunc JOne dups set)) =+    if (Set.size $ set) == 1 && (Set.size $ dups) == 0+    then return $ head $ Set.elems set+    else return undef+op1Pick v = die "pick not defined" v++shuffleN :: Int -> [a] -> Eval [a]+shuffleN _ [] = return []+shuffleN 0 _  = return []+shuffleN n xs = do+    -- pick the first element+    first <- io $ randomRIO (0 :: Int, length xs - 1)+    rest <- shuffleN (n-1) $ take first xs ++ drop (first+1) xs+    return $ head (drop first xs) : rest++op2Pick :: Val -> Val -> Eval Val+op2Pick (VRef r) num = do+    ref <- readRef r+    op2Pick ref num+op2Pick l@(VList xs) (VNum n)+    | n == 1/0  = op2Pick l (VInt . toInteger $ length xs)+    | otherwise = op2Pick l (VInt $ floor n)+op2Pick (VList xs) (VInt num) = do+    shuffled <- shuffleN (fromInteger num) xs+    return $ VList shuffled+op2Pick r _ = die "pick not defined" r++op1Sum :: Val -> Eval Val+op1Sum list = do+    vals <- fromVal list+    foldM (op2Numeric (+)) undef vals++op1Min :: Val -> Eval Val+op1Min v = op1MinMax not v++op1Max :: Val -> Eval Val+op1Max v = op1MinMax id v++-- min_or_max is a function which negates truth/falsehood.+-- This is necessary as op1MinMax should cope with min() as well as max().+op1MinMax :: (Bool -> Bool) -> Val -> Eval Val+op1MinMax min_or_max v = do+    -- We want to have a real Haskell list+    args    <- fromVal v+    -- Extract our comparator sub, or Nothing if none was specified+    (valList, cmp) <- case args of+        (v:vs) -> do+            ifValTypeIsa v "Code"+                (return (vs, Just v))+                (ifValTypeIsa (last args) "Code"+                    (return (init args, Just $ last args))+                    (return (args, Nothing)))+        _  -> return (args, Nothing)+    -- Now let our helper function do the rest+    op1MinMax' min_or_max cmp valList+    where+    op1MinMax' :: (Bool -> Bool) -> (Maybe Val) -> [Val] -> Eval Val+    -- The min or max of an empty list is undef.+    op1MinMax' _ _ [] = return undef+    -- We have to supply our own comparator...+    op1MinMax' _ Nothing valList = foldM default_compare (head valList) (tail valList)+    -- or use the one of the user+    op1MinMax' min_or_max (Just subVal) valList = do+          sub <- fromVal subVal+          evl <- asks envEval+          -- Here we execute the user's sub+          foldM (\a b -> do+              rv  <- local (\e -> e{ envContext = cxtItem "Int" }) $ do+                  evl (App (Val sub) Nothing [Val a, Val b])+              int <- fromVal rv+              -- If the return value from the sub was+              --   -1 ==> a < b+              --    0 ==> a == b+              --   +1 ==> a > b+              -- We call min_or_max so we can work for both min() and max().+              return $ if min_or_max (int > (0::VInt)) then a else b) (head valList) (tail valList)+    -- This is the default comparision function, which will be used if the user+    -- hasn't specified a own comparision function.+    default_compare a b = do+        a' <- vCastRat a+        b' <- vCastRat b+        let cmp = if a' < b' then (-1) else if a' == b' then 0 else 1+        return $ if min_or_max (cmp > (0::VInt)) then a else b++op1Uniq :: Val -> Eval Val+op1Uniq v = do+    -- We want to have a real Haskell list+    args    <- fromVal v+    -- Extract our comparator sub, or Nothing if none was specified+    (valList, cmp) <- case args of+        (v:vs) -> do+            ifValTypeIsa v "Code"+                (return (vs, Just v))+                (ifValTypeIsa (last args) "Code"+                    (return (init args, Just $ last args))+                    (return (args, Nothing)))+        _  -> return (args, Nothing)+    -- After this parameter unpacking, we begin doing the real work.+    op1Uniq' cmp valList+    where+    op1Uniq' :: (Maybe Val) -> [Val] -> Eval Val+    -- If the user didn't specify an own comparasion sub, we can simply use+    -- Haskell's nub.+    op1Uniq' Nothing valList = return . VList $ nub valList+    -- Else, we have to write our own nubByM and use that.+    op1Uniq' (Just subVal) valList = do+        sub <- fromVal subVal+        evl <- asks envEval+        -- Here we execute the user's sub+        result <- nubByM (\a b -> do+            rv  <- local (\e -> e{ envContext = cxtItem "Bool" }) $ do+                evl (App (Val sub) Nothing [Val a, Val b])+            -- The sub returns either true or false.+            bool <- fromVal rv+            return . VBool $ bool) valList+        return . VList $ result+    -- This is the same as nubBy, only lifted into the Eval monad+    nubByM :: (Val -> Val -> Eval Val) -> [Val] -> Eval [Val]+    nubByM eq l = nubByM' l []+      where+        nubByM' [] _      = return []+        nubByM' (y:ys) xs = do+            -- elemByM returns a Val, but we need a VBool, so we have to use fromVal.+            cond <- fromVal =<< elemByM eq y xs+            if cond then nubByM' ys xs else do+                result <- nubByM' ys (y:xs)+                return (y:result)+        elemByM :: (Val -> Val -> Eval Val) -> Val -> [Val] -> Eval Val+        elemByM _  _ []     = return . VBool $ False+        elemByM eq y (x:xs) = do+            cond <- fromVal =<< eq x y+            -- Same here (we need a VBool, not a Var).+            if cond then return . VBool $ cond else elemByM eq y xs++op2ReduceL :: Bool -> Val -> Val -> Eval Val+op2ReduceL keep sub@(VCode _) list = op2ReduceL keep list sub+op2ReduceL keep list sub = do+    code <- fromVal sub+    op2Reduce keep list $ VCode code{ subAssoc = A_left }++op2Reduce :: Bool -> Val -> Val -> Eval Val+op2Reduce keep sub@VCode{} list = op2Reduce keep list sub+op2Reduce keep list sub = do+    code <- fromVal sub+    args <- fromVal list+    if null args then identityVal (subName code) else do+    -- cxt  <- asks envContext+    let arity = length $ subParams code+        (reduceM, reduceMn) = if keep then (scanM, scanMn) else (foldM, foldMn)+    if subAssoc code == A_list+        then asks envEval >>= \evl -> evl $ App (Val $ VCode code{ subParams = length args `replicate` head (subParams code)}) Nothing (map Val args)+        else do+            when (arity < 2) $ fail "Cannot reduce() using a unary or nullary function."+            -- n is the number of *additional* arguments to be passed to the sub.+            -- Ex.: reduce { $^a + $^b       }, ...   # n = 1+            -- Ex.: reduce { $^a + $^b + $^c }, ...   # n = 2+            let n = arity - 1+            -- Break on empty list.+            let doFold xs = do+                evl <- asks envEval+                local (\e -> e{ envContext = cxtItemAny }) $ do+                    evl (App (Val sub) Nothing (map Val xs))+            case subAssoc code of+                A_right -> do+                    let args' = reverse args+                    reduceMn args' n (doFold . reverse)+                A_chain -> if arity /= 2            -- FIXME: incorrect for scans+                    then fail+                        "When reducing using a chain-associative sub,\nthe sub must take exactly two arguments."+                    else catchT $ \esc -> do+                        let doFold' x y = do+                            val <- doFold [x, y]+                            case val of+                                VBool False -> esc val+                                _           -> return y+                        reduceM doFold' (head args) (tail args)+                        return $ VBool True+                A_non   -> fail $ "Cannot reduce over non-associativity"+                _       -> reduceMn args n doFold -- "left", "pre"+    where+    -- This is a generalized foldM.+    -- It takes an input list (from which the first elem will be used as start+    -- value), the number of additional arguments, and a reducing function.+    foldMn :: [Val] -> Int -> ([Val] -> Eval Val) -> Eval Val+    foldMn list n f = foldM (\a b -> f (a:b)) (head list) $ list2LoL n $ drop 1 list+    -- Scan version of foldMn.+    scanMn :: [Val] -> Int -> ([Val] -> Eval Val) -> Eval Val+    scanMn list n f = scanM (\a b -> f (a:b)) (head list) $ list2LoL n $ drop 1 list+    -- The Prelude defines foldM but not scanM.+    scanM :: (Val -> b -> Eval Val) -> Val -> [b] -> Eval Val+    scanM f q ls = case ls of+        []   -> return $ VList [q]+        x:xs -> do+            fqx  <- f q x+            rest <- fromVal =<< scanM f fqx xs+            return $ VList (q:rest)+    identityVal name = case nameStr of+        "**"    -> _1+        "*"     -> _1+        "/"     -> _fail+        "%"     -> _fail+        "x"     -> _fail+        "xx"    -> _fail+        "+&"    -> _neg1+        "+<"    -> _fail+        "+>"    -> _fail+        "~&"    -> _fail+        "~<"    -> _fail+        "~>"    -> _fail+        "+"     -> _0+        "-"     -> _0+        "~"     -> _''+        "+|"    -> _0+        "+^"    -> _0+        "~|"    -> _''+        "~^"    -> _''+        "&"     -> _junc JAll+        "|"     -> _junc JAny+        "^"     -> _junc JOne+        "!="    -> _false+        "=="    -> _true+        "<"     -> _true+        "<="    -> _true+        ">"     -> _true+        ">="    -> _true+        "~~"    -> _true+        "eq"    -> _true+        "ne"    -> _false+        "lt"    -> _true+        "le"    -> _true+        "gt"    -> _true+        "ge"    -> _true+        "=:="   -> _true+        "==="   -> _true+        "eqv"   -> _true+        "&&"    -> _true+        "||"    -> _false+        "^^"    -> _false+        ","     -> _list+        "Z"     -> _list+        "X"     -> _list+        ('!':_) -> _false+        _           -> _undef+        where+        nameStr = cast name+        _0      = return (VInt 0)+        _1      = return (VInt 1)+        _undef  = return undef+        _false  = return (VBool False)+        _true   = return (VBool True)+        _list   = return (VList [])+        _neg1   = return (VInt $ -1)+        _junc   = \jtyp -> return . VJunc $ MkJunc jtyp Set.empty Set.empty+        _''     = return (VStr "")+        _fail   = fail $ "reduce is nonsensical for " ++ cast name++op2Grep :: Val -> Val -> Eval Val+op2Grep sub@(VCode _) list = op2Grep list sub+op2Grep list sub = do+    args <- fromVal list+    vals <- (`filterM` args) $ \x -> do+        evl <- asks envEval+        rv  <- local (\e -> e{ envContext = cxtItem "Bool" }) $ do+            evl (App (Val sub) Nothing [Val x])+        fromVal rv+    return $ VList vals++op2First :: Val -> Val -> Eval Val+op2First sub@(VCode _) list = op2First list sub+op2First list sub = do+  (VList vals) <- (op2Grep list sub)+  if not (null vals)+    then return $ (vals !! 0)+    else return $ undef++op2Map :: Val -> Val -> Eval Val+op2Map sub@(VCode _) list = op2Map list sub+op2Map list sub = do+    args  <- fromVal list+    arity <- fmap (length . subParams) (fromVal sub)+    evl   <- asks envEval+    vals  <- mapMn args arity $ \x -> do+        rv  <- local (\e -> e{ envContext = cxtSlurpyAny }) $ do+            evl (App (Val sub) Nothing (map Val x))+        fromVal rv+    return $ VList vals+    where+    -- Takes a list, an arity, and a function.+    mapMn           :: [Val] -> Int -> ([Val] -> Eval [Val]) -> Eval [Val]+    mapMn list 0 f   = fmap concat (mapM (const $ f []) list)+    mapMn list n f   = mapMn' (list2LoL n list) f+    -- Takes a LoL and a function and applies the function to the inputlist.+    mapMn'          :: [[Val]] -> ([Val] -> Eval [Val]) -> Eval [Val]+    mapMn' (x:xs) f  = liftM2 (++) (f x) (mapMn' xs f)+    mapMn' []     _  = return []++{-|+Takes an int and a list and returns a LoL.+Ex.:++> list2LoL 3 [1,2,3,4,5] = [[1,2,3],[4,5,undef]]+-}+list2LoL :: Int -> [Val] -> [[Val]]+list2LoL n list+    | n == 0           = fail "Cannot map() using a nullary function."+    -- If the list has exactly n elements, we've finished our work.+    | length list == n = [list]+    -- If the list is empty, we're done, too.+    | length list == 0 = []+    -- But if the list contains more elems than we need, we process the+    -- first n ones and the rest separately.+    | length list  > n = (list2LoL n $ take n list) ++ (list2LoL n $ drop n list)+    -- And if the list contains less elems than we need, we pad with undefs.+    | length list  < n = list2LoL n $ list ++ [undef :: Val]+    | otherwise        = fail "Invalid arguments to internal function list2LoL passed."++op2Join :: Val -> Val -> Eval Val+-- op2Join (VList [x@(VRef _)]) y = op2Join x y+op2Join x y = do+    (strVal, valList) <- ifValTypeIsa x "Scalar"+        (return (x, (VRef (arrayRef (listVal y)))))+        (return (y, x))+    str     <- fromVal strVal+    ref     <- fromVal valList+    list    <- readRef ref+    strList <- fromVals list+    return . VStr . concat . intersperse str $ strList++sortByM :: (Val -> Val -> Eval Bool) -> [Val] -> Eval [Val]+sortByM _ []  = return []+sortByM _ [x] = return [x]+sortByM f xs  = do+    let (as, bs) = splitAt (length xs `quot` 2) xs+    aSorted <- sortByM f as+    bSorted <- sortByM f bs+    doMerge f aSorted bSorted+    where+    doMerge :: (Val -> Val -> Eval Bool) -> [Val] -> [Val] -> Eval [Val]+    doMerge _ [] ys = return ys+    doMerge _ xs [] = return xs+    doMerge f (x:xs) (y:ys) = do+        isLessOrEqual <- f x y+        if isLessOrEqual+            then do+                rest <- doMerge f xs (y:ys)+                return (x:rest)+            else do+                rest <- doMerge f (x:xs) ys+                return (y:rest)++op1HyperPrefix :: VCode -> Val -> Eval Val+op1HyperPrefix sub (VRef ref) = do+    x <- readRef ref+    op1HyperPrefix sub x+op1HyperPrefix sub x+    | VList x' <- x+    = fmap VList $ hyperList x'+    | otherwise+    = fail "Hyper OP only works on lists"+    where+    doHyper x+        | VRef x' <- x+        = doHyper =<< readRef x'+        | VList{} <- x+        = op1HyperPrefix sub x+        | otherwise+        = enterEvalContext cxtItemAny $ App (Val $ VCode sub) Nothing [Val x]+    hyperList xs = do+        env <- ask+        io $ do+            mvs <- forM xs $ \x -> do+                mv  <- newEmptyMVar+                forkIO $ do+                    val <- runEvalIO env (doHyper x)+                    putMVar mv val+                return mv+            mapM takeMVar mvs++op1HyperPostfix :: VCode -> Val -> Eval Val+op1HyperPostfix = op1HyperPrefix++op2Hyper :: VCode -> Val -> Val -> Eval Val+op2Hyper sub (VRef ref) y = do+    x <- readRef ref+    op2Hyper sub x y+op2Hyper sub x (VRef ref) = do+    y <- readRef ref+    op2Hyper sub x y+op2Hyper sub x y+    | VList x' <- x, VList y' <- y+    = fmap VList $ hyperLists x' y'+    | VList x' <- x+    = fmap VList $ mapM ((flip doHyper) y) x'+    | VList y' <- y+    = fmap VList $ mapM (doHyper x) y'+    | otherwise+    = fail "Hyper OP only works on lists"+    where+    doHyper x y +        | VRef x' <- x, VRef y' <- y+        = join $ liftM2 doHyper (readRef x') (readRef y')+        | VRef x' <- x+        = (flip doHyper $ y) =<< readRef x'+        | VRef y' <- y+        = doHyper x =<< readRef y'+        | VList{} <- x+        = op2Hyper sub x y+        | VList{} <- y+        = op2Hyper sub x y+        | otherwise+        = enterEvalContext cxtItemAny $ App (Val $ VCode sub) Nothing [Val x, Val y]+    hyperLists xs ys = do+        env <- ask+        io $ do+            mvs <- doHyperLists env xs ys+            mapM takeMVar mvs+    doHyperLists _ [] [] = return []+    doHyperLists _ xs [] = mapM newMVar xs+    doHyperLists _ [] ys = mapM newMVar ys+    doHyperLists env (x:xs) (y:ys) = do+        mv  <- newEmptyMVar+        forkIO $ do+            val <- runEvalIO env $ doHyper x y+            putMVar mv val+        mvs <- doHyperLists env xs ys+        return (mv:mvs)
+ src/Pugs/Prim/Match.hs view
@@ -0,0 +1,340 @@+{-# OPTIONS_GHC -fglasgow-exts -fno-warn-orphans -fallow-overlapping-instances #-}++module Pugs.Prim.Match (+    op2Match, rxSplit, rxSplit_n, pkgParents, pkgParentClasses+) where+import Pugs.Internals+import Pugs.Embed+import Pugs.AST+import Pugs.Types+import Pugs.Config+import Pugs.Prim.Code+import qualified Data.Map as Map+import qualified Data.Array as Array+import qualified Pugs.Prim.FileTest as FileTest++-- XXX - kluge: before we figure out the parrot calling convention,+--       we'll simply inline the adverbs into the regex.+ruleWithAdverbs :: VRule -> Eval VStr+ruleWithAdverbs MkRulePGE{ rxRule = re, rxAdverbs = advs } = do+    when (null re) $+        fail "Null patterns are invalid; use <?null> or an empty string instead"+    hv      <- join $ doHash advs hash_fetch+    advs    <- forM (Map.assocs hv) $ \(k, v) -> do+        str <- case v of+            VBool True  -> return "1"+            VBool False -> return "0"+            _           -> fromVal v+        return $ \x -> ":" ++ k ++ "(" ++ str ++ ")[" ++ x ++ "]"+    return $ combine advs re+ruleWithAdverbs _ = fail "PCRE regexes can't be compiled to PGE regexes"++doMatch :: String -> VRule -> Eval VMatch+doMatch cs rule@MkRulePGE{ rxRule = ruleStr } = do+    let pwd1 = getConfig "installsitelib" ++ "/auto/pugs/perl5/lib"+        pwd2 = getConfig "sourcedir" ++ "/perl5/Pugs-Compiler-Rule/lib"+    hasSrc <- io $ doesDirectoryExist pwd2+    let pwd = if hasSrc then pwd2 else pwd1+    glob    <- askGlobal+    let syms = [ (cast $ v_name var, entry)+               | (var, entry) <- padToList glob+               , SRegex == v_sigil var+               , isGlobalVar var+               ]+    subrules <- forM syms $ \(name, entry) -> do+        ref         <- readPadEntry entry+        VRule rule  <- fromVal =<< readRef ref+        text        <- ruleWithAdverbs rule+        return (name, text)+    text <- ruleWithAdverbs rule+    rv   <- io $ fmap (fmap (fmap toUpper)) (getEnv "PUGS_REGEX_ENGINE")+    let ruleEngine | Just "PGE" <- rv   = evalPGE+                   | otherwise          = evalPCR+    pge  <- io $ ruleEngine pwd cs text subrules+            `catchIO` (\e -> return $ show e)+    rv  <- tryIO Nothing $ fmap Just (readIO $ decodeUTF8 pge)+    let matchToVal PGE_Fail = VMatch mkMatchFail+        matchToVal (PGE_String str) = VStr str+        matchToVal (PGE_Array ms) = VList (map matchToVal ms)+        matchToVal (PGE_Match from to pos named) = VMatch $+            mkMatchOk from to substr pos' named'+            where+            substr  = genericTake (to - from) (genericDrop from cs)+            pos'    = map matchToVal pos+            named'  = Map.map matchToVal $ Map.fromList named+    case rv of+        Just m  -> fromVal (matchToVal m)+        Nothing -> do+            io $ putStrLn ("*** Cannot parse regex: " ++ ruleStr ++ "\n*** Error: " ++ pge)+            return mkMatchFail++doMatch csChars MkRulePCRE{ rxRegex = re } = do+    result <- io $ executePCRE re csBytes+    case result of+        Left{} -> return mkMatchFail+        Right Nothing -> return mkMatchFail+        Right (Just rv) -> do+            let ((fromBytes, lenBytes):subs) = Array.elems rv+                substr str from len = take len (drop from str)+                subsMatch = [+                    VMatch $ if fBytes == -1 then mkMatchFail else mkMatchOk+                        fChars (fChars + lChars)+                        (substr csChars fChars lChars)+                        [] Map.empty+                    | (fBytes, lBytes) <- subs+                    , let fChars = chars $ take fBytes csBytes+                    , let lChars = chars $ substr csBytes fBytes lBytes+                    ]+                fromChars = chars $ take fromBytes csBytes+                lenChars  = chars $ substr csBytes fromBytes lenBytes+                chars = genericLength . decodeUTF8+            return $ mkMatchOk fromChars (fromChars + lenChars)+                (substr csChars fromChars lenChars) subsMatch Map.empty+    where+    csBytes = encodeUTF8 csChars++-- Used in op2Match+not_VRule :: Val -> Bool+not_VRule _y@(VRule _) = False+not_VRule _            = True++classType :: Type+classType = mkType "Class"++-- XXX - need to generalise this+op2Match :: Val -> Val -> Eval Val++op2Match x y@(VCode _) = do+    (arity :: Int) <- fromVal =<< op1CodeArity y+    res <- fromVal =<< case arity of+        0 -> do+            writeVar (cast "$*_") x+            evalExp $ App (Val y) Nothing []+        1 -> do+            evalExp $ App (Val y) Nothing [Val x]+        _ -> fail ("Unexpected arity in smart match: " ++ (show arity))+    return $ VBool $ res++op2Match x (VRef (MkRef (IScalar sv))) | scalar_iType sv == mkType "Scalar::Const" = do+    y' <- scalar_fetch' sv+    op2Match x y'++op2Match x (VRef (MkRef (IPair pv))) = do +    -- Pair match: ~~ :e executes the -e filetest.+    (k, v)  <- pair_fetch pv+    isTrue  <- fromVal v :: Eval Bool+    testOp  <- fromVal k+    file    <- fromVal x+    rv      <- ($ file) $ case testOp of+        "r" -> FileTest.isReadable+        "w" -> FileTest.isWritable+        "x" -> FileTest.isExecutable+        "e" -> FileTest.exists+        "z" -> FileTest.sizeIsZero+        "s" -> FileTest.fileSize+        "M" -> FileTest.fileMTime+        "A" -> FileTest.fileATime+        "C" -> FileTest.fileCTime+        "f" -> FileTest.isFile+        "d" -> FileTest.isDirectory+        [op] | op `elem` "oRWXOlpSbctugkTB" -> FileTest.fileTestViaPerl5 testOp+        _   -> const $ die "Unknown file test operator" testOp+    if isTrue+        then return rv+        else fmap (castV . not) (fromVal rv)++op2Match x (VRef y) = do+    y' <- readRef y+    op2Match x y'++op2Match x@(VObject MkObject{ objType = cls }) y | cls == classType = do+    fetch   <- doHash x hash_fetchVal+    name    <- fromVal =<< fetch "name"+    op2Match (VType (mkType name)) y++op2Match x y@(VObject MkObject{ objType = cls }) | cls == classType = do+    fetch   <- doHash y hash_fetchVal+    name    <- fromVal =<< fetch "name"+    op2Match x (VType (mkType name))++-- '$x ~~ tr/x/y/' ==> $x = ~$x.trans('x' => 'y')+op2Match x (VSubst (MkTrans from to)) = do+    str <- fromVal x+    evalExp $ Syn "="+        [ Val x+        , App (_Var "&trans") (Just (Val (VStr str)))+            [ App (_Var "&infix:=>") Nothing+                [ Val (VStr from)+                , Val (VStr to)+                ]+            ]+        ]++op2Match x (VSubst (MkSubst rx subst)) | rxGlobal rx = do+    str         <- fromVal x+    (str', cnt) <- doReplace str 0+    if cnt == 0 then return (VBool False) else do+    ref     <- fromVal x+    writeRef ref $ VStr str'+    return $ castV cnt+    where+    doReplace :: String -> Int -> Eval (String, Int)+    doReplace str ok = do+        match <- str `doMatch` rx+        if not (matchOk match) then return (str, ok) else do+        glob    <- askGlobal+        matchSV <- findSymRef (cast "$/") glob+        writeRef matchSV (VMatch match)+        str'    <- fromVal =<< evalExp subst+        -- XXX - on zero-width match, advance the cursor and, if can't,+        --       don't even bother with the recursive call.+        case (matchTo match, matchFrom match) of+            (0, 0) -> if null str then return (str' ++ str, ok) else do+                (after', ok') <- doReplace (tail str) (ok + 1)+                return (concat [str' ++ (head str:after')], ok')+            (to, from) -> do+                (after', ok') <- doReplace (genericDrop to str) (ok + 1)+                return (concat [genericTake from str, str', after'], ok')++op2Match x (VSubst (MkSubst rx subst)) = do+    str     <- fromVal x+    ref     <- fromVal x+    match   <- str `doMatch` rx+    if not (matchOk match) then return (VBool False) else do+    glob    <- askGlobal+    matchSV <- findSymRef (cast "$/") glob+    writeRef matchSV (VMatch match)+    str'    <- fromVal =<< evalExp subst+    writeRef ref . VStr $ concat+        [ genericTake (matchFrom match) str+        , str'+        , genericDrop (matchTo match) str+        ]+    return $ VBool True++op2Match x (VRule rx) | rxGlobal rx = do+    str     <- fromVal x+    rv      <- matchOnce str+    cxt     <- asks envContext+    case rxStringify rx of+        True -> do+            strs <- mapM fromVal rv+            return $ case strs of+                [str]   -> VStr str+                _       -> VList $ map VStr strs+        _ | isSlurpyCxt cxt -> do+            return (VList rv)+        _ -> do+            return (VInt $ genericLength rv)+    where+    hasSubpatterns = case rx of+        MkRulePGE{}             -> True -- XXX bogus - use <p6rule> to parse itself+        MkRulePCRE{rxNumSubs=n} -> not (n == 0)+    matchOnce :: String -> Eval [Val]+    matchOnce str = do+        match <- str `doMatch` rx+        if not (matchOk match) then return [] else do+        let ret x = return $ if hasSubpatterns+                        then [ m | m@(VMatch MkMatch{ matchOk = True }) <- matchSubPos match ] ++ x+                        else (VMatch match):x+        case (matchTo match, matchFrom match) of+            (0, 0) -> if null str then ret [] else do+                rest <- matchOnce (tail str)+                ret rest+            (to, _) -> do+                rest <- matchOnce (genericDrop to str)+                ret rest++op2Match x (VRule rx) = do+    str     <- fromVal x+    match   <- str `doMatch` rx+    glob    <- askGlobal+    matchSV <- findSymRef (cast "$/") glob+    writeRef matchSV (VMatch match)+    ifListContext+        (return $ VList (matchSubPos match))+        (return $ VMatch match)++op2Match x@(VRule _) y | not_VRule y = do+    op2Match y x++op2Match (VType typ) (VType t) = do+    typs <- pkgParents (showType typ)+    return . VBool $ showType t `elem` (showType typ:typs)++op2Match x y@(VType _) = do+    typ <- fromVal x+    case x of+        VRef x | typ == mkType "Class" -> do+            x' <- readRef x+            op2Match x' y+        _ -> op2Match (VType typ) y++op2Match (VRef x) y = do+    x' <- readRef x+    op2Match x' y++op2Match x y = do+    op2Cmp (fromVal :: Val -> Eval VStr) (==) x y++op2Cmp :: (a -> Eval b) -> (b -> b -> VBool) -> a -> a -> Eval Val+op2Cmp f cmp x y = do+    x' <- f x+    y' <- f y+    return $ VBool $ x' `cmp` y'++rxSplit :: VRule -> String -> Eval [Val]+rxSplit _  [] = return []+rxSplit rx str = do+    match <- str `doMatch` rx+    if not (matchOk match) then return [VStr str] else do+    if matchFrom match == matchTo match+        then do+            let (c:cs) = str+            rest <- rxSplit rx cs+            return (VStr [c]:rest)+        else do+            let before = genericTake (matchFrom match) str+                after  = genericDrop (matchTo match) str+            rest <- rxSplit rx after+            return $ (VStr before:matchSubPos match) ++ rest++-- duplicated for now, pending über-Haskell-fu++rxSplit_n :: VRule -> String -> Int -> Eval [Val]+rxSplit_n _ [] _ = return []+rxSplit_n rx str n = do+    match <- str `doMatch` rx+    if or [ ( n == 1 ), ( not (matchOk match) ) ] then return [VStr str] else do+    if matchFrom match == matchTo match+        then do+            let (c:cs) = str+            rest <- rxSplit_n rx (cs) (n-1)+            return (VStr [c]:rest)+        else do+            let before = genericTake (matchFrom match) str+                after  = genericDrop (matchTo match) str+            rest <- rxSplit_n rx after (n-1)+            return $ (VStr before:matchSubPos match) ++ rest++pkgParents :: VStr -> Eval [VStr]+pkgParents pkg = do+    ref     <- readVar $ cast (':':'*':pkg)+    if ref == undef then return [] else do+    meta    <- readRef =<< fromVal ref+    fetch   <- doHash meta hash_fetchVal+    attrs   <- fromVal =<< fetch "is"+    attrs'  <- fromVal =<< fetch "does" -- XXX wrong+    pkgs    <- mapM pkgParents (attrs ++ attrs')+    return $ nub (pkg:concat pkgs)++-- XXX - copy and paste code; merge with above!+pkgParentClasses :: VStr -> Eval [VStr]+pkgParentClasses pkg = do+    ref     <- readVar $ cast (':':'*':pkg)+    if ref == undef then return [] else do+    meta    <- readRef =<< fromVal ref+    fetch   <- doHash meta hash_fetchVal+    attrs   <- fromVal =<< fetch "is"+    pkgs    <- mapM pkgParentClasses attrs+    return $ nub (pkg:concat pkgs)
+ src/Pugs/Prim/Numeric.hs view
@@ -0,0 +1,174 @@+{-# OPTIONS_GHC -fglasgow-exts -fno-warn-orphans #-}++module Pugs.Prim.Numeric (+    op2Numeric, op1Floating, op1Round, op1Numeric,+    op2Exp, op2Divide, op2Modulus, op2OrdNumeric+) where+import Pugs.Internals+import Pugs.AST+import Pugs.Types++import Pugs.Prim.Lifts++op2OrdNumeric :: Value b => (forall a. (Ord a) => a -> a -> b) -> Val -> Val -> Eval Val+op2OrdNumeric f x y+    | VInt x' <- x, VInt y' <- y  = return $ castV $ f x' y'+    | VRat x' <- x, VRat y' <- y  = return $ castV $ f x' y'+    | VRat x' <- x, VInt y' <- y  = return $ castV $ f x' (y' % 1)+    | VInt x' <- x, VRat y' <- y  = return $ castV $ f (x' % 1) y'+    | VUndef <- x = op2OrdNumeric f (VInt 0) y+    | VUndef <- y = op2OrdNumeric f x (VInt 0)+    | VType{} <- x = op2OrdNumeric f (VInt 0) y+    | VType{} <- y = op2OrdNumeric f x (VInt 0)+    | VRef r <- x = do+        x' <- readRef r+        op2OrdNumeric f x' y+    | VRef r <- y = do+        y' <- readRef r+        op2OrdNumeric f x y'+    | VComplex x' <- x = do+        y'  <- fromVal y+        return . castV $ f x' y'+    | VComplex y' <- y = do+        x'  <- fromVal x+        return . castV $ f x' y'+    | otherwise = do+        x' <- fromVal x :: Eval VNum+        y' <- fromVal y+        return . castV $ f x' y'++op2Floating :: (forall a. (Floating a) => a -> a -> a) -> Val -> Val -> Eval Val+op2Floating f x y+    | VUndef <- x = op2Floating f (VInt 0) y+    | VUndef <- y = op2Floating f x (VInt 0)+    | VType{} <- x = op2Floating f (VInt 0) y+    | VType{} <- y = op2Floating f x (VInt 0)+    | VRef r <- x = do+        x' <- readRef r+        op2Floating f x' y+    | VRef r <- y = do+        y' <- readRef r+        op2Floating f x y'+    | VComplex x' <- x = do+        y'  <- fromVal y+        return . VComplex $ f x' y'+    | VComplex y' <- y = do+        x'  <- fromVal x+        return . VComplex $ f x' y'+    | otherwise = do+        x' <- fromVal x+        y' <- fromVal y+        return . VNum $ f x' y'++op2Numeric :: (forall a. (Num a) => a -> a -> a) -> Val -> Val -> Eval Val+op2Numeric f x y+    | VInt x' <- x, VInt y' <- y  = return $ VInt $ f x' y'+    | VRat x' <- x, VRat y' <- y  = return $ VRat $ f x' y'+    | VRat x' <- x, VInt y' <- y  = return $ VRat $ f x' (y' % 1)+    | VInt x' <- x, VRat y' <- y  = return $ VRat $ f (x' % 1) y'+    | VUndef <- x = op2Numeric f (VInt 0) y+    | VUndef <- y = op2Numeric f x (VInt 0)+    | VType{} <- x = op2Numeric f (VInt 0) y+    | VType{} <- y = op2Numeric f x (VInt 0)+    | VRef r <- x = do+        x' <- readRef r+        op2Numeric f x' y+    | VRef r <- y = do+        y' <- readRef r+        op2Numeric f x y'+    | VComplex x' <- x = do+        y'  <- fromVal y+        return . VComplex $ f x' y'+    | VComplex y' <- y = do+        x'  <- fromVal x+        return . VComplex $ f x' y'+    | otherwise = do+        x' <- fromVal x+        y' <- fromVal y+        return . VNum $ f x' y'++op1Floating :: (forall a. (Floating a) => a -> a) -> Val -> Eval Val+op1Floating f VUndef        = return . VNum $ f 0+op1Floating f VType{}       = return . VNum $ f 0+op1Floating f (VComplex x)  = return . VComplex $ f x+op1Floating f (VRef x)      = op1Floating f =<< readRef x+op1Floating f x             = fmap (VNum . f) (fromVal x)++op1Round :: (Double -> Integer) -> Val -> Eval Val+op1Round f v = do+    case v of+       VInt i -> return $ VInt $ i+       VRat r -> return $ VInt $ f ((fromRational r)::Double)+       VNum n -> return $ VInt $ f n+       _      -> fail "Can't round non-numeric value(?)"++op1Numeric :: (forall a. (Num a) => a -> a) -> Val -> Eval Val+op1Numeric f VUndef     = return . VInt $ f 0+op1Numeric f VType{}    = return . VInt $ f 0+op1Numeric f (VInt x)   = return . VInt $ f x+op1Numeric f l@(VList _)= fmap (VInt . f) (fromVal l)+op1Numeric f (VRat x)   = return . VRat $ f x+op1Numeric f (VComplex x) = return . VComplex $ f x+op1Numeric f (VRef x)   = op1Numeric f =<< readRef x+op1Numeric f x          = fmap (VNum . f) (fromVal x)++op2Exp :: Val -> Val -> Eval Val+op2Exp x y = do+    num1 <- fromVal =<< fromVal' x+    if isNaN num1 then return (VNum (0/0)) else do+    if num1 == (1 :: VNum) then return (VInt 1) else do+    num2 <- fromVal =<< fromVal' y+    if isNaN num2 then return (VNum (0/0)) else do+    if num2 == (0 :: VNum) then return (VInt 1) else do+    case reverse $ show (num2 :: VNum) of+        ('0':'.':_) -> do+            num1 <- fromVal =<< fromVal' x+            if isDigit . head $ show (num1 :: VNum)+                then op2Rat ((^^) :: VRat -> VInt -> VRat) x y+                else op2Floating (**) x y+        _ -> op2Floating (**) x y++op2Divide :: Val -> Val -> Eval Val+op2Divide x y+    | VInt x' <- x, VInt y' <- y+    = if y' == 0 then err else return . VRat $ x' % y'+    | VInt x' <- x, VRat y' <- y+    = if y' == 0 then err else return . VRat $ (x' % 1) / y'+    | VRat x' <- x, VInt y' <- y+    = if y' == 0 then err else return . VRat $ x' / (y' % 1)+    | VRat x' <- x, VRat y' <- y+    = if y' == 0 then err else return . VRat $ x' / y'+    | VComplex x' <- x = do+        y' <- fromVal y+        if y' == 0 then err else return . VComplex $ x' / y'+    | VComplex y' <- y = do+        x' <- fromVal x+        if y' == 0 then err else return . VComplex $ x' / y'+    | otherwise+    = op2Num (/) x y+    where+    err = fail "Illegal division by zero"++op2Modulus :: Val -> Val -> Eval Val+op2Modulus x y+    | VInt x' <- x, VInt y' <- y+    = if y' == 0 then err else return . VInt $ x' `mod` y'+    | VInt x' <- x, VRat y' <- y+    = if y' == 0 then err else return . VRat $ (x' % 1) `fmod` y'+    | VRat x' <- x, VInt y' <- y+    = if y' == 0 then err else return . VRat $ x' `fmod` (y' % 1)+    | VRat x' <- x, VRat y' <- y+    = if y' == 0 then err else return . VRat $ x' `fmod` y'+--  | VComplex x' <- x = do+--      y' <- fromVal y+--      if y' == 0 then err else return . VComplex $ x' `fmod` y'+--  | VComplex y' <- y = do+--      x' <- fromVal x+--      if y' == 0 then err else return . VComplex $ x' `fmod` y'+    | otherwise      -- pray for the best+    = op2Num fmod x y+    where+    err = fail "Illegal modulus zero"+    fmod :: RealFrac a => a -> a -> a+    fmod x y = let mod = x - (fromIntegral (truncate (x/y) :: Integer) * y) in+        if signum y * signum mod < 0 then mod + y else mod
+ src/Pugs/Prim/Param.hs view
@@ -0,0 +1,38 @@+{-# OPTIONS_GHC -fglasgow-exts -fallow-overlapping-instances #-}++module Pugs.Prim.Param (+    foldParam+) where+import Pugs.AST+import Pugs.Internals++doFoldParam :: String -> String -> [Param] -> [Param]+doFoldParam cxt [] []       = [(buildParam cxt "" "$?1" (Val VUndef)) { isLValue = False }]+doFoldParam cxt [] (p:ps)   = ((buildParam cxt "" (strInc . cast $ paramName p) (Val VUndef)) { isLValue = False }:p:ps)+doFoldParam cxt (s:name) ps = ((buildParam cxt [s] name (Val VUndef)) { isLValue = False } : ps)++foldParam :: String -> Params -> Params+foldParam "Named" = \ps -> (+    (buildParam "Any" "*" "@?0" (Val VUndef)):+    (buildParam "Any" "*" "%?0" (Val VUndef)):ps)+foldParam "List"    = doFoldParam "Any" "*@?1"+foldParam ('r':'w':'!':"List") = \ps -> ((buildParam "List" "" "@?0" (Val VUndef)) { isLValue = True }:ps)+foldParam ('r':'w':'!':str) = \ps -> ((buildParam str "" "$?1" (Val VUndef)) { isLValue = True }:ps)+foldParam ""        = id+foldParam ('?':str)+    | ('r':'w':'!':typ) <- str+    = \ps -> ((buildParam typ "?" "$?1" (Val VUndef)) { isLValue = True }:ps)+    | (('r':'w':'!':typ), "=$_") <- break (== '=') str+    = \ps -> ((buildParam typ "?" "$?1" (_Var "$_")) { isLValue = True }:ps)+    | (typ, "=$_") <- break (== '=') str+    = \ps -> ((buildParam typ "?" "$?1" (_Var "$_")) { isLValue = False }:ps)+    | (typ, ('=':def)) <- break (== '=') str+    = let readVal "Num" = Val . VNum . read+          readVal "Int" = Val . VInt . read+          readVal "Str" = Val . VStr . read+          readVal x     = error $ "Unknown type: " ++ x+      in \ps -> ((buildParam typ "?" "$?1" (readVal typ def)) { isLValue = False }:ps)+    | otherwise+    = \ps -> (buildParam str "?" "$?1" (Val VUndef):ps)+foldParam ('~':str) = \ps -> (((buildParam str "" "$?1" (Val VUndef)) { isLValue = False }) { isLazy = True }:ps)+foldParam x         = doFoldParam x []
+ src/Pugs/Prim/Yaml.hs view
@@ -0,0 +1,128 @@+{-# OPTIONS_GHC -fglasgow-exts -fno-warn-orphans #-}++module Pugs.Prim.Yaml ( evalYaml, dumpYaml, stableAddressOf ) where+import Pugs.Internals+import Pugs.AST+import Pugs.Pretty+import Pugs.Types+import Data.Yaml.Syck+import Foreign.StablePtr+import Foreign.Ptr+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 DrIFT.YAML++evalYaml :: Val -> Eval Val+evalYaml cv = do+    str     <- fromVal cv+    node    <- guardIO (parseYaml $ encodeUTF8 str)+    fromYaml node++fromYaml :: YamlNode -> Eval Val+fromYaml MkNode{n_elem=ENil}       = return VUndef+fromYaml MkNode{n_elem=EStr str}   = return $ VStr $ decodeUTF8 $ unpackBuf str+fromYaml MkNode{n_elem=ESeq nodes} = do+    av  <- mapM fromYaml nodes+    val <- newArray av+    return (VRef $ MkRef val)+fromYaml MkNode{n_elem=EMap nodes, n_tag=tag} = do+    case tag of+        Nothing  -> do+            vals    <- forM nodes $ \(keyNode, valNode) -> do+                key <- fromVal =<< fromYaml keyNode+                val <- newScalar =<< fromYaml valNode+                return (key, val)+            hv      <- io $ (H.fromList H.hashString vals :: IO IHash)+            return $ VRef (hashRef hv)+        Just s | (pre, post) <- Str.splitAt 16 s   -- 16 == length "tag:pugs:Object:"+               , pre == packBuf "tag:pugs:Object:" -> do+            let typ = unpackBuf post+            vals    <- forM nodes $ \(keyNode, valNode) -> do+                key <- fromVal =<< fromYaml keyNode+                val <- fromYaml valNode+                return (key, val)+            return . VObject =<< createObject (mkType typ) vals+        Just s | s == packBuf "tag:pugs:Rule" -> do+            vals    <- forM nodes $ \(keyNode, valNode) -> do+                key <- fromVal =<< fromYaml keyNode+                val <- fromYaml valNode+                return (key, val)+            --let spec    = Map.fromList (vals :: [(String, Val)])+            --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+            return $ VRule MkRulePGE{rxRule=rule, rxGlobal=global, rxStringify=stringify, rxAdverbs=adverbs}+        Just x   -> error ("can't deserialize: " ++ unpackBuf x)++dumpYaml :: Val -> Eval Val+dumpYaml v = do+    let ?seen = IntSet.empty+    obj     <- toYaml v+    rv      <- guardIO . emitYaml $ obj+    (return . VStr . decodeUTF8) rv++strNode :: String -> YamlNode+strNode = mkNode . EStr . packBuf++stableAddressOf :: a -> IO Int+stableAddressOf x = do+    ptr <- newStablePtr x+    return (castStablePtrToPtr ptr `minusPtr` (nullPtr :: Ptr ()))++toYaml :: (?seen :: IntSet.IntSet) => Val -> Eval YamlNode+toYaml VUndef       = return $ mkNode ENil+toYaml (VBool x)    = return $ boolToYaml x+toYaml (VStr str)   = return $ strNode (encodeUTF8 str)+toYaml v@(VRef r)   = do+    ptr <- io $ stableAddressOf r+    if IntSet.member ptr ?seen then return nilNode{ n_anchor = AReference ptr } else do+        let ?seen = IntSet.insert ptr ?seen+        node <- ifValTypeIsa v "Hash" (hashToYaml r) $ do+            v'      <- readRef r+            nodes   <- toYaml v'+            ifValTypeIsa v "Array" (return nodes) $ case v' of+                VObject _   -> return nodes+                _           -> io $ toYamlNode r+        return node{ n_anchor = AAnchor ptr }+toYaml (VList nodes) = do+    n <- mapM toYaml nodes+    return $ mkNode (ESeq n)+    -- fmap ESeq$ mapM toYaml nodes+toYaml v@(VObject obj) = do+    -- ... dump the objAttrs+    -- XXX this needs fixing WRT demagicalized pairs:+    -- currently, this'll return Foo.new((attr => "value)), with the inner+    -- parens, which is, of course, wrong.+    hash    <- fromVal v :: Eval VHash+    attrs   <- toYaml $ VRef (hashRef hash)+    return $ tagNode (Just $ packBuf $ "tag:pugs:Object:" ++ showType (objType obj)) attrs+toYaml (VRule MkRulePGE{rxRule=rule, rxGlobal=global, rxStringify=stringify, rxAdverbs=adverbs}) = do+    adverbs' <- toYaml adverbs+    return . mkTagNode "tag:pugs:Rule" $ EMap+        [ (strNode "rule", strNode rule)+        , (strNode "global", boolToYaml global)+        , (strNode "stringify", boolToYaml stringify)+        , (strNode "adverbs", adverbs')+        ]+toYaml v = return $ strNode $ (encodeUTF8 . pretty) v++hashToYaml :: (?seen :: IntSet.IntSet) => VRef -> Eval YamlNode+hashToYaml (MkRef (IHash hv)) = do+    h <- hash_fetch hv+    let assocs = Map.toList h+    yamlmap <- forM assocs $ \(ka, va) -> do+        ka' <- toYaml $ VStr ka+        va' <- toYaml va+        return (ka', va')+    return $ mkNode (EMap yamlmap)+hashToYaml r = error ("unexpected node: " ++ show r)++boolToYaml :: VBool -> YamlNode+boolToYaml True  = strNode "true"+boolToYaml False = strNode "false"
+ src/Pugs/Rule.hs view
@@ -0,0 +1,31 @@+{-# OPTIONS_GHC -fglasgow-exts #-}++{-|+    Rule-based grammar engine.++>   From the ashes a fire shall be woken+>   A light from the shadows shall spring+>   Renewed shall be blade that was broken+>   The crownless again shall be king.++-}+++module Pugs.Rule (+    module Text.ParserCombinators.Parsec+) where++import Text.ParserCombinators.Parsec hiding (+    token       ,+    char        ,+    octDigit    ,+    satisfy     ,+    oneOf       ,+    string      ,+    anyChar     ,+    upper       ,+    hexDigit    ,+    digit       ,+    noneOf      ,+    eof         ,+    )
+ src/Pugs/Run.hs view
@@ -0,0 +1,285 @@+{-# OPTIONS_GHC -fglasgow-exts -fno-full-laziness -fno-cse -cpp -fallow-overlapping-instances #-}+++{-|+    Runtime engine.++>   The mountain throne once more is freed!+>   O! Wandering folk, the summons heed!+>   Come haste! Come haste! Across the waste!+>   The king of friend and kin has need...+-}++module Pugs.Run (+    runWithArgs,+    prepareEnv, runEnv,+    runAST, runComp,+    getLibs,+    -- mutable global storage+    _GlobalFinalizer,+) where+import Pugs.Run.Args+import Pugs.Run.Perl5 ()+import Pugs.Internals+import Pugs.Config+import Pugs.AST+import Pugs.Types+import Pugs.Eval+import Pugs.Prim.Eval+import Pugs.Embed+import Pugs.Prelude +import qualified Data.Map as Map+import qualified Data.ByteString as Str+import DrIFT.YAML+import Data.Yaml.Syck+--import Data.Generics.Schemes+import System.IO+import qualified System.FilePath as FilePath (combine)+++{-|+Run 'Main.run' with command line args. ++See 'Main.main' and 'Pugs.Run.Args.canonicalArgs'+-}+runWithArgs :: ([String] -> IO t) -> IO t+runWithArgs f = do+    args <- getArgs+    f $ canonicalArgs args++runEvalMain :: Env -> Eval Val -> IO Val+runEvalMain env eval = withSocketsDo $ do+    val     <- runEvalIO env eval+    -- freePerl5 my_perl+    io performGC+    return val++runEnv :: Env -> IO Val+runEnv env = runEvalMain env $ evaluateMain (envBody env)++-- | Run for 'Pugs.Compile.Pugs' backend+runAST :: Pad -> Exp -> IO Val+runAST glob ast = do+    hSetBuffering stdout NoBuffering+    name    <- getProgName+    args    <- getArgs+    env     <- prepareEnv name args+    globRef <- stm $ do+        glob' <- readMPad $ envGlobal env+        newMPad (glob `unionPads` glob')+    runEnv env{ envBody = ast, envGlobal = globRef, envDebug = Nothing }++-- | Run for 'Pugs.Compile.Haskell' backend+runComp :: Eval Val -> IO Val+runComp comp = do+    hSetBuffering stdout NoBuffering+    name <- getProgName+    args <- getArgs+    env  <- prepareEnv name args+    runEvalMain env{ envDebug = Nothing } comp++-- | Initialize globals and install primitives in an 'Env'+prepareEnv :: VStr -> [VStr] -> IO Env+prepareEnv name args = do+    let confHV = Map.map VStr config+    exec    <- getArg0+    libs    <- getLibs+    pid     <- getProcessID+    pidSV   <- newScalar (VInt $ toInteger pid)+    uid     <- getRealUserID+    uidSV   <- newScalar (VInt $ toInteger uid)+    euid    <- getEffectiveUserID+    euidSV  <- newScalar (VInt $ toInteger euid)+    gid     <- getRealGroupID+    gidSV   <- newScalar (VInt $ toInteger gid)+    egid    <- getEffectiveGroupID+    failSV  <- newScalar (VBool False)+    egidSV  <- newScalar (VInt $ toInteger egid)+    execSV  <- newScalar (VStr exec)+    progSV  <- newScalar (VStr name)+    checkAV <- newArray []+    initAV  <- newArray []+    endAV   <- newArray []+    takeAV  <- newArray []+    matchAV <- newScalar (VMatch mkMatchFail)+    incAV   <- newArray (map VStr libs)+    incHV   <- newHash Map.empty+    argsAV  <- newArray (map VStr args)+    inGV    <- newHandle stdin+    outGV   <- newHandle stdout+    errGV   <- newHandle stderr+    argsGV  <- newScalar undef+    errSV   <- newScalar (VStr "")+    defSV   <- newScalar undef+    autoSV  <- newScalar undef+    classes <- initClassObjects (MkObjectId $ -1) [] initTree+    strictSV<- newScalar $ VBool (name /= "-e")+    baset   <- getCurrentTime+#if defined(PUGS_HAVE_HSPLUGINS)+    hspluginsSV <- newScalar (VInt 1)+#else+    hspluginsSV <- newScalar (VInt 0)+#endif+    let gen = genSym . cast+    env <- emptyEnv name $+        [ gen "@*ARGS"       $ hideInSafemode $ MkRef argsAV+        , gen "@*INC"        $ hideInSafemode $ MkRef incAV+        , gen "%*INC"        $ hideInSafemode $ MkRef incHV+        , gen "$*PUGS_HAS_HSPLUGINS" $ hideInSafemode $ MkRef hspluginsSV+        , gen "$*EXECUTABLE_NAME"    $ hideInSafemode $ MkRef execSV+        , gen "$*PROGRAM_NAME"       $ hideInSafemode $ MkRef progSV+        , gen "$*PID"        $ hideInSafemode $ MkRef pidSV+        -- XXX these four need a proper `set' magic+        , gen "$*UID"        $ hideInSafemode $ MkRef uidSV+        , gen "$*EUID"       $ hideInSafemode $ MkRef euidSV+        , gen "$*GID"        $ hideInSafemode $ MkRef gidSV+        , gen "$*EGID"       $ hideInSafemode $ MkRef egidSV+        , gen "$*FAIL_SHOULD_DIE"$ hideInSafemode $ MkRef failSV+        , gen "@*CHECK"      $ MkRef checkAV+        , gen "@*INIT"       $ MkRef initAV+        , gen "@*END"        $ MkRef endAV+        , gen "$*TAKE"       $ MkRef takeAV+        , gen "$*IN"         $ hideInSafemode $ MkRef inGV+        , gen "$*OUT"        $ hideInSafemode $ MkRef outGV+        , gen "$*ERR"        $ hideInSafemode $ MkRef errGV+        , gen "$*ARGS"       $ hideInSafemode $ MkRef argsGV+        , gen "$!"           $ MkRef errSV+        , gen "$/"           $ MkRef matchAV+        , gen "%*ENV"        $ hideInSafemode $ hashRef MkHashEnv+        , gen "$*CWD"        $ hideInSafemode $ scalarRef MkScalarCwd+        -- XXX What would this even do?+        -- , gen "%=POD"        (Val . VHash $ emptyHV)+        , gen "@=POD"        $ MkRef $ constArray []+        , gen "$=POD"        $ MkRef $ constScalar (VStr "")+        -- To answer the question "what revision does evalbot run on?"+        , gen "$?PUGS_VERSION" $ MkRef $ constScalar (VStr $ getConfig "pugs_version")+        , gen "$*PUGS_VERSION" $ MkRef $ constScalar (VStr $ getConfig "pugs_version")+        -- If you change the name or contents of $?PUGS_BACKEND, be sure+        -- to update all t/ and perl5/{PIL2JS,PIL-Run} as well.+        , gen "$?PUGS_BACKEND" $ MkRef $ constScalar (VStr "BACKEND_PUGS")+        , gen "$?COMPILER"   $ MkRef $ constScalar (VStr "Pugs")+        , gen "$?VERSION"    $ MkRef $ constScalar (VStr $ getConfig "pugs_versnum")+        , gen "$*OS"         $ hideInSafemode $ MkRef $ constScalar (VStr $ getConfig "osname")+        , gen "%?CONFIG" $ hideInSafemode $ hashRef confHV+        , gen "$*_" $ MkRef defSV+        , gen "$*AUTOLOAD" $ MkRef autoSV+        , gen "$*STRICT" $ MkRef strictSV+        -- XXX do we want hideInSafemode?+        , gen "$*BASETIME" $ MkRef $ constScalar (VRat $ pugsTimeSpec baset)+        ] ++ classes+    -- defSVcell <- (gen "$_" . MkRef) =<< newScalar undef+    let env' = env+    {-+            { envLexical  = defSVcell (envLexical env)+            , envImplicit = Map.singleton "$_" ()+            }+    -}+    initPerl5 "" (Just env')+    initPreludePC env'             -- null in first pass+    where+    hideInSafemode x = if safeMode then MkRef $ constScalar undef else x++initClassObjects :: ObjectId -> [Type] -> ClassTree -> IO [STM PadMutator]+initClassObjects uniq parent (MkClassTree (Node typ children)) = do+    obj     <- createObjectRaw uniq Nothing (mkType "Class")+        [ ("name",  castV $ showType typ)+        , ("is",    castV $ map showType parent)+        ]+    objSV   <- newScalar (VObject obj)+    rest    <- forM children $+        initClassObjects (MkObjectId . pred $ unObjectId uniq) [typ] . MkClassTree+    let metaSym  = genSym (cast (":*"++name)) (MkRef objSV)+        codeSym  = genMultiSym (cast ("&*term:"++name)) (codeRef typeCode) mempty+        name     = showType typ+        typeBody = Val . VType . mkType $ name+        Syn "sub" [Val (VCode typeCode)] = typeMacro name typeBody+    return (metaSym:codeSym:concat rest)++{-|+Combine @%*ENV\<PERL6LIB\>@, -I, 'Pugs.Config.config' values and \".\" into the+@\@*INC@ list for 'Main.printConfigInfo'. If @%*ENV\<PERL6LIB\>@ is not set,+@%*ENV\<PERLLIB\>@ is used instead.+-}+getLibs :: IO [String]+getLibs = do+    args    <- getArgs+    p6lib   <- (getEnv "PERL6LIB") >>= (return . (fromMaybe ""))+    plib    <- (getEnv "PERLLIB")  >>= (return . (fromMaybe ""))+    let lib = if (p6lib == "") then plib else p6lib+    return $ filter (not . null) (libs lib $ canonicalArgs args)+    where+    -- broken, need real parser+    inclibs ("-I":dir:rest) = (dir:inclibs rest)+    inclibs (_:rest)        = inclibs rest+    inclibs ([])            = []+    libs p6lib args = (inclibs args)+              ++ (split (getConfig "path_sep") p6lib)+              ++ [ getConfig "archlib"+                 , getConfig "privlib"+                 , getConfig "sitearch"+                 , getConfig "sitelib"+                 , foldl1 FilePath.combine [getConfig "privlib", "auto", "pugs", "perl6", "lib"]+                 , foldl1 FilePath.combine [getConfig "sitelib", "auto", "pugs", "perl6", "lib"]+                 ]+              ++ [ "." ]++bypassPreludePC :: IO Bool+bypassPreludePC = do+    compPrelude <- getEnv "PUGS_COMPILE_PRELUDE"+    return $! case compPrelude of+        Just "0"    -> True+        _           -> False++initPreludePC :: Env -> IO Env+initPreludePC env = do+    bypass <- bypassPreludePC+    if bypass then return env else do+        let dispProgress = (posName . envPos $ env) == (__"<interactive>")+        when dispProgress $ putStr "Loading Prelude... "+        catchIO loadPreludePC $ \e -> do+            case e of+                IOException ioe+                    | isUserError ioe, not . null $ ioeGetErrorString ioe+                    -> hPrint stderr ioe+                _ -> return ()+            -- when dispProgress $ do+            --    hPutStr stderr "Reloading Prelude from source..."+            evalPrelude+        when dispProgress $ putStrLn "done."+        return env+    where+    style = MkEvalStyle+        { evalResult = EvalResultModule+        , evalError  = EvalErrorFatal+        }+    evalPrelude = runEvalIO env{ envDebug = Nothing } $ opEval style "<prelude>" preludeStr+    loadPreludePC = do  -- XXX: this so wants to reuse stuff from op1EvalP6Y+        -- print "Parsing yaml..."+        incs     <- io $ fmap ("blib6/lib":) getLibs+        pathName <- io $ requireInc incs "Prelude.pm.yml" ""+        yml      <- io $ parseYamlBytes =<< Str.readFile pathName+        when (n_elem yml == ENil) $ fail ""+        -- FIXME: this detects an error if a bad version number was found,+        -- but not if no number was found at all. Then again, if that+        -- happens surely the fromYAML below will fail?+        case yml of+            MkNode{ n_elem=ESeq (v:_) }+                | MkNode{ n_elem=EStr vnum } <- v+                , vnum /= (packBuf $ show compUnitVersion) -> do+                    fail $ unlines+                        [ "Incompatible version number for compilation unit"+                        , "Consider removing " ++ pathName ++ " and make it again"+                        ]+            _ -> return ()+        -- print "Parsing done!"+        -- print "Loading yaml..."+        --(glob, ast) <- fromYAML yml+        -- cleanSeen+        MkCompUnit _ _ glob ast <- io $ fromYAML yml+        -- print "Loading done!"+        -- z   <- stm $ join (findSym (cast "&*__fail") glob)+        -- j   <- showYaml z+        -- print j+        appendMPad (envGlobal env) glob+        runEnv env{ envBody = ast, envDebug = Nothing }+        --     Right Nothing -> fail ""
+ src/Pugs/Run/Args.hs view
@@ -0,0 +1,194 @@+{-# 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" "while (defined($_ = =<>)) { " : args) ++ [Opt "-e" "; .say; }"]+desugarDashE ((Switch 'n'):args) = desugarDashE $+    (Opt "-e" "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)
+ src/Pugs/Run/Perl5.hs view
@@ -0,0 +1,148 @@+{-# OPTIONS_GHC -fglasgow-exts -cpp -fno-warn-unused-binds -fno-warn-unused-imports -fallow-overlapping-instances #-}++module Pugs.Run.Perl5 () where++#ifdef PUGS_HAVE_PERL5++import Pugs.Internals+import Pugs.AST+import Pugs.Prim.Eval+import Pugs.Embed.Perl5+import Pugs.Types+import Foreign+import Foreign.C.Types+import Foreign.C.String+import Foreign.Marshal.Array++foreign export ccall "pugs_Eval"+    pugs_eval :: CString -> IO PugsVal++foreign export ccall "pugs_Apply"+    pugs_apply :: PugsVal -> PugsVal -> Ptr PugsVal -> CInt -> IO PerlSV++foreign export ccall "pugs_ValToSv"+    valToSv :: PugsVal -> IO PerlSV++foreign export ccall "pugs_ValToIv"+    valToIv :: PugsVal -> IO CInt++foreign export ccall "pugs_ValToNv"+    valToNv :: PugsVal -> IO CDouble++foreign export ccall "pugs_ValToPv"+    valToPv :: PugsVal -> IO CString++foreign export ccall "pugs_MkSvRef"+    mkSvRef :: PerlSV -> IO PugsVal++foreign export ccall "pugs_IvToVal"+    ivToVal :: CInt -> IO PugsVal++foreign export ccall "pugs_NvToVal"+    nvToVal :: CDouble -> IO PugsVal++foreign export ccall "pugs_PvnToVal"+    pvnToVal :: CString -> CInt -> IO PugsVal++foreign export ccall "pugs_PvnToValUTF8"+    pvnToValUTF8 :: CString -> CInt -> IO PugsVal++foreign export ccall "pugs_UndefVal"+    undefVal :: IO PugsVal++askPerl5Env :: IO Env+askPerl5Env = deEnv =<< pugs_getenv++pugs_eval :: CString -> IO PugsVal+pugs_eval cstr = do+    str <- peekCString cstr+    env <- askPerl5Env+    val <- runEvalIO env $ opEval quiet "<eval>" str+    mkValPtr val+    where+    quiet = MkEvalStyle+        { evalResult    = EvalResultLastValue+        , evalError     = EvalErrorUndef+        }++pugs_apply :: PugsVal -> PugsVal -> Ptr PugsVal -> CInt -> IO PerlSV+pugs_apply subPtr invPtr argsPtr cxt = do+    env     <- askPerl5Env+    sub     <- deVal subPtr+    inv     <- deValMaybe invPtr+    args    <- mapM deVal =<< peekArray0 nullVal argsPtr+    let subExp = case sub of+            VStr name@('&':_)   -> _Var name+            VStr name           -> _Var ('&':name)+            _                   -> Val sub+    -- warn "Applying:" (subExp, inv, args, envLexical env)+    val <- runEvalIO env $+        evalExp (Ann (Cxt (cxtEnum cxt)) $+            App subExp (fmap Val inv) (map Val args))+    newSVval val++deVal :: PugsVal -> IO Val+deVal ptr = deRefStablePtr ptr++deEnv :: PugsEnv -> IO Env+deEnv ptr = do+    env <- deRefStablePtr ptr+    return env{ envDebug = Nothing }++nullVal :: PugsVal+nullVal = castPtrToStablePtr nullPtr++deValMaybe :: PugsVal -> IO (Maybe Val)+deValMaybe ptr | castStablePtrToPtr ptr == nullPtr = return Nothing+deValMaybe ptr = fmap Just (deVal ptr)++valToSv :: PugsVal -> IO PerlSV+valToSv ptr = do+    val <- deVal ptr+    newSVval val++valToIv :: PugsVal -> IO CInt+valToIv ptr = do+    val     <- deVal ptr+    env     <- askPerl5Env+    VInt x  <- runEvalIO env $ fmap VInt (fromVal val)+    return $ fromInteger x++valToNv :: PugsVal -> IO CDouble+valToNv ptr = do+    val     <- deVal ptr+    env     <- askPerl5Env+    VRat x  <- runEvalIO env $ fmap VInt (fromVal val)+    return $ fromRational x++valToPv :: PugsVal -> IO CString+valToPv ptr = do+    val     <- deVal ptr+    env     <- askPerl5Env+    VStr x  <- runEvalIO env $ fmap VInt (fromVal val)+    newCString x++mkSvRef :: PerlSV -> IO PugsVal+mkSvRef = mkValPtr . VV . mkVal  -- NewVal/MO+-- mkSvRef = mkValPtr . PerlSV            -- OldVal++ivToVal :: CInt -> IO PugsVal+ivToVal = mkValPtr . VInt . fromIntegral++nvToVal :: CDouble -> IO PugsVal+nvToVal = mkValPtr . VNum . realToFrac++pvnToValUTF8 :: CString -> CInt -> IO PugsVal+pvnToValUTF8 cstr len = do+    str <- peekCStringLen (cstr, fromEnum len)+    mkValPtr $ VStr (decodeUTF8 str)++pvnToVal :: CString -> CInt -> IO PugsVal+pvnToVal cstr len = do+    str <- peekCStringLen (cstr, fromEnum len)+    mkValPtr $ VStr str -- XXX - wrong - make Buf object!++undefVal :: IO PugsVal+undefVal = mkValPtr VUndef++#endif
+ src/Pugs/Shell.hs view
@@ -0,0 +1,98 @@+{-# OPTIONS_GHC -fglasgow-exts -cpp #-}++{-|+    Interactive shell.++>   There is an inn, a merry old inn,+>   beneath an old grey hill,+>   And there they brew a beer so brown+>   That the Man in the Moon himself came down+>   one night to drink his fill...+-}++module Pugs.Shell (+    Command(..),+    RunOptions(..),+    initializeShell,+    getCommand,+    readline,+) where+import Pugs.Internals+import Data.Char (isSpace)++#define PUGS_HAVE_READLINE+#ifdef PUGS_HAVE_READLINE+{-# INCLUDE "readline/readline.h" #-}+import qualified System.Console.Readline as Readline+#endif++data Command+   = CmdLoad FilePath+   | CmdQuit+   | CmdParse String+   | CmdParseRaw String+   | CmdRun { runOpt :: RunOptions, runProg :: String }+   | CmdHelp+   | CmdReset++data RunOptions = RunOpts { runOptDebug :: Bool+                          , runOptSeparately :: Bool+                          , runOptShowPretty :: Bool}++-- | read some input from the user+-- parse the input and return the corresponding command+getCommand :: IO Command+getCommand = do+    input <- readline "pugs> " +    doCommand input++doCommand :: Maybe String -> IO Command+doCommand Nothing = return CmdQuit+doCommand (Just line)+    | all isSpace line  = getCommand+    | (s, _) <- break (== '#') line+    , all isSpace s     = getCommand+    | otherwise         = do+        addHistory line+        return $ parseCommandLine line++parseCommandLine :: String -> Command +parseCommandLine (':':'e':'r':str)  = CmdRun (RunOpts False True False) str+parseCommandLine (':':'e':str)  = CmdRun (RunOpts False False False) str+parseCommandLine (':':'E':'R':str)  = CmdRun (RunOpts True True False) str+parseCommandLine (':':'E':str)  = CmdRun (RunOpts True False False) str+parseCommandLine (':':'d':str)  = CmdParse str+parseCommandLine (':':'D':str)  = CmdParseRaw str+parseCommandLine (':':'q':_)    = CmdQuit+parseCommandLine (':':'h':_)    = CmdHelp+parseCommandLine (':':'r':_)    = CmdReset+parseCommandLine (':':'l':str)  = CmdLoad $ unwords (words str)+parseCommandLine str            = CmdRun (RunOpts False False True) str++initializeShell :: IO ()+initializeShell = do+#ifdef PUGS_HAVE_READLINE+#ifdef RL_READLINE_VERSION+    Readline.setCatchSignals False+#endif+    Readline.initialize+#endif+    return ()++readline :: String -> IO (Maybe String)+readline prompt = do+#ifdef PUGS_HAVE_READLINE+    Readline.readline prompt+#else+    putStr prompt+    input <- getLine+    return $ Just input+#endif++addHistory :: String -> IO ()+#ifdef PUGS_HAVE_READLINE+addHistory str = Readline.addHistory str+#else+addHistory _ = return ()+#endif+
+ src/Pugs/Types.hs view
@@ -0,0 +1,935 @@+{-# OPTIONS_GHC -fglasgow-exts -fno-warn-deprecations -fno-warn-orphans -funbox-strict-fields -fallow-overlapping-instances -fparr #-}+{-|+    Implementation Types.++>   Three Rings for the Elven-kings under the sky,+>   Seven for the Dwarf-lords in their halls of stone,+>   Nine for Mortal Men doomed to die,+>   One for the Dark Lord on his dark throne+>   In the Land of Mordor where the Shadows lie.+-}++module Pugs.Types+{-+(+    Type(..), mkType, anyType, showType, isaType, isaType', deltaType,+    ClassTree, initTree,++    Cxt(..),+    cxtItem, cxtSlurpy, cxtVoid, cxtItemAny, cxtSlurpyAny,+    typeOfCxt, isSlurpyCxt, isItemCxt, isVoidCxt,+    enumCxt, cxtEnum,++    VStr, VBool, VInt, VRat, VNum, VComplex, VHandle, VSocket,+    VThread(..),++    MatchPGE(..)+)+-}+where+import Pugs.Internals+import Data.Bits (shiftL)+import qualified Data.Map as Map+import qualified Data.HashTable as H+import qualified Data.IntMap as IntMap+import qualified Data.IntSet as IntSet+import qualified Data.ByteString.Char8 as Buf -- Intentionally not UTF8!+import qualified Data.ByteString as B (findSubstring)++data Type+    = MkType !ID            -- ^ A regular type+    | TypeOr  !Type !Type   -- ^ The disjunction (|) of two types+    | TypeAnd !Type !Type   -- ^ The conjunction (&) of two types+    deriving (Eq, Ord, Typeable, Data)++instance ((:>:) ByteString) Type where+    cast (MkType x) = cast x+    cast (TypeOr t1 t2)  = cast t1 +++ __"|" +++ cast t2+    cast (TypeAnd t1 t2) = cast t1 +++ __"&" +++ cast t2++instance ((:>:) Type) ByteString where+    cast = MkType . cast++instance ((:>:) Type) Pkg where+    cast = cast . (cast :: Pkg -> ByteString)++instance ((:>:) Pkg) Type where+    cast = cast . (cast :: Type -> ByteString)++instance Show Type where+    show t = "(mkType \"" ++ showType t ++ "\")"++showType :: Type -> String+showType (MkType typ)    = cast typ+showType (TypeOr t1 t2)  = showType t1 ++ "|" ++ showType t2+showType (TypeAnd t1 t2) = showType t1 ++ "&" ++ showType t2++newtype ClassTree = MkClassTree (Tree Type)+    deriving (Eq, Ord, Typeable)++instance Show ClassTree where+    show t = "{ClassTree:" ++ show (countTree t) ++ "}"++data Cxt = CxtVoid         -- ^ Context that isn't expecting any values+         | CxtItem !Type   -- ^ Context expecting a value of the specified type+         | CxtSlurpy !Type -- ^ Context expecting multiple values of the+                           --     specified type+    deriving (Eq, Show, Ord, Typeable)++anyType :: Type+anyType = mkType "Any"++cxtItem   :: String -> Cxt+cxtItem   = CxtItem . mkType+cxtSlurpy :: String -> Cxt+cxtSlurpy = CxtSlurpy . mkType+cxtVoid   :: Cxt+cxtVoid   = CxtVoid++typeOfCxt :: Cxt -> Type+typeOfCxt CxtVoid           = anyType+typeOfCxt (CxtItem typ)     = typ+typeOfCxt (CxtSlurpy typ)   = typ++-- | Return a 'Cxt' indicating a context expecting a scalar of any type+cxtItemAny :: Cxt+cxtItemAny   = CxtItem anyType+-- | Return a 'Cxt' indicating a context expecting a list of any type+cxtSlurpyAny :: Cxt+cxtSlurpyAny = CxtSlurpy anyType++{-|+Return true if the given 'Cxt' (context) is 'CxtSlurpy', rather than+'CxtItem' or 'CxtVoid'.+-}+isSlurpyCxt :: Cxt -> Bool+isSlurpyCxt (CxtSlurpy _) = True+isSlurpyCxt _             = False+{-|+Return true if the given 'Cxt' (context) is 'CxtItem', rather than+'CxtSlurpy' or 'CxtVoid'.+-}+isItemCxt :: Cxt -> Bool+isItemCxt   (CxtItem _)   = True+isItemCxt   _             = False+{-|+Return true if the given 'Cxt' (context) is 'CxtVoid', rather than+'CxtSlurpy' or 'CxtItem'.+-}+isVoidCxt :: Cxt -> Bool+isVoidCxt   CxtVoid       = True+isVoidCxt   _             = False++-- | Return the Perl 5 calling convention bit value for the context.+enumCxt :: (Num a) => Cxt -> a+enumCxt CxtVoid       = 128+enumCxt (CxtItem _)   = 0+enumCxt (CxtSlurpy _) = 1++-- | Return the 'Cxt' corresponding to the given P5 calling convention bits.+cxtEnum :: (Show a, Num a) => a -> Cxt+cxtEnum 128 = CxtVoid+cxtEnum 0   = cxtItemAny+cxtEnum 1   = cxtSlurpyAny+cxtEnum n   = error ("Invalid cxt: " ++ show n)++{-|+Make a type value representing the type with the specified name.++Recognises conjunctive (&) and disjunctive (|) types.+-}+mkType :: String -- ^ Name of the type, e.g. \"Hash\" or \"Str|Int\"+       -> Type+mkType str+    | (t1, (_:t2)) <- span (/= '|') str+    = TypeOr (mkType t1) (mkType t2)+    | (t1, (_:t2)) <- span (/= '&') str+    = TypeAnd (mkType t1) (mkType t2)+    | otherwise+    = MkType (cast str)++data Var = MkVar+    { v_name    :: !ID+    , v_sigil   :: !VarSigil+    , v_twigil  :: !VarTwigil+    , v_categ   :: !VarCateg+    , v_package :: !Pkg+    , v_meta    :: !VarMeta+    , v_longname:: !ID+    }+    deriving (Eq, Ord, Typeable, Data)++-- | a dummy scalar, used for example as the invocant+-- in the signature :( $ : $x, $y ).+varNullScalar :: Var+varNullScalar = MkVar+    { v_name    = nullID+    , v_longname= nullID+    , v_sigil   = SScalar+    , v_twigil  = TNil+    , v_categ   = CNil+    , v_package = MkPkg []+    , v_meta    = MNil+    }++-- | the topical variable $_+varTopic :: Var+varTopic = cast "$_"++data VarMeta+    = MNil+    | MFold             -- [+]+    | MScan             -- [\+]+--  | MFoldPost         -- [+]<<+--  | MScanPost         -- [\+]<<+    | MPre              -- >>++    | MPost             -- +<<+    | MHyper            -- >>+<<+    | MHyperFold        -- [>>+<<]+--  | MHyperFoldPost    -- [>>+<<]<<+    | MHyperScan        -- [\>>+<<]+--  | MHyperScanPost    -- [\>>+<<]<<+    deriving (Show, Enum, Eq, Ord, Typeable, Data, Read)++isLexicalVar :: Var -> Bool+isLexicalVar MkVar{ v_package = MkPkg [], v_twigil = twi } = case twi of+    TGlobal -> False+    TDoc    -> False    -- XXX noncanonical+    _       -> True+isLexicalVar _ = False++isQualifiedVar :: Var -> Bool+isQualifiedVar MkVar{ v_package = MkPkg [] } = False+isQualifiedVar _ = True++dropVarPkg :: ByteString -> Var -> Maybe Var+dropVarPkg buf var@MkVar{ v_package = MkPkg ps }+    | (p:_) <- ps, p == buf = Just var{ v_package = MkPkg (tail ps) }+    | otherwise             = Nothing++-- | Package name, composed of multiple parts.+newtype Pkg = MkPkg [ByteString]+    deriving (Eq, Ord, Typeable, Data)++instance Show Pkg where+    show pkg = cast (cast pkg :: ByteString)++instance ((:>:) ByteString) Pkg where+    cast (MkPkg ns) = Buf.intercalate (__"::") ns++instance Show Var where+    show var = show (cast var :: ByteString)++varToBuf :: Var -> ByteString+varToBuf MkVar+    { v_sigil   = sig+    , v_twigil  = twi+    , v_package = (MkPkg ns)+    , v_categ   = cat+    , v_name    = name+    , v_longname= longname+    , v_meta    = meta+    } = Buf.concat . (cast sig:) . (cast twi:) . doPkg ns . doCat $ doMeta+    where+    n = cast name+    l = cast longname+    doPkg []     = id+    doPkg (x:xs) = (x:) . (__"::":) . doPkg xs+    doCat = case cat of+        CNil    -> id+        _       -> (cast cat:) . (__":":)+    doMeta = case meta of+        MNil        -> [n, l]+        MFold       -> [__"[", n, l, __"]"]+        MScan       -> [__"[\\", n, l, __"]"]+        MPre        -> [__">>", n, l]+        MPost       -> [n, l, __"<<"]+        MHyper      -> [__">>", n, l, __"<<"]+        MHyperFold  -> [__"[>>", n, l, __"<<]"]+        MHyperScan  -> [__"[\\>>", n, l, __"<<]"]++showsVar :: Var -> String -> String+showsVar var = (show var ++)++showsMeta :: VarMeta -> (String -> String) -> String -> String+showsMeta MNil              f x = f x+showsMeta MFold             f x = ('[':f (']':x))+showsMeta MScan             f x = ('[':'\\':f (']':x))+--showsMeta MFoldPost         f x = ('[':f (']':'<':'<':x))+--showsMeta MScanPost         f x = ('[':'\\':f (']':'<':'<':x))+showsMeta MPre              f x = ('>':'>':f x)+showsMeta MPost             f x = f ('<':'<':x)+showsMeta MHyper            f x = ('>':'>':f ('<':'<':x))+showsMeta MHyperFold        f x = ('[':'>':'>':f ('<':'<':']':x))+--showsMeta MHyperFoldPost    f x = ('[':'>':'>':f ('<':'<':']':'<':'<':x))+showsMeta MHyperScan        f x = ('[':'\\':'>':'>':f ('<':'<':']':x))+--showsMeta MHyperScanPost    f x = ('[':'\\':'>':'>':f ('<':'<':']':'<':'<':x))++instance ((:>:) ByteString) Var where+    cast var = varToBuf var++instance ((:>:) String) Var where+    cast var = cast (varToBuf var)++instance ((:>:) String) Pkg where+    cast = cast . (cast :: Pkg -> ByteString)++data VarCateg+    = CNil+    | C_prefix_circumfix_meta_operator+    | C_infix_circumfix_meta_operator+    | C_prefix_postfix_meta_operator+    | C_postfix_prefix_meta_operator+    | C_infix_postfix_meta_operator+    | C_statement_modifier+    | C_statement_control+    | C_scope_declarator+    | C_trait_auxiliary+    | C_trait_verb+    | C_regex_mod_external+    | C_regex_mod_internal+    | C_regex_assertion+    | C_regex_backslash+    | C_regex_metachar+    | C_postcircumfix+    | C_circumfix+    | C_postfix+    | C_infix+    | C_prefix+    | C_quote+    | C_term+    deriving (Show, Enum, Eq, Ord, Bounded, Typeable, Data, Read)++data VarSigil = SScalar | SArray | SHash | SType | SCode | SRegex | SArrayMulti+    deriving (Enum, Eq, Ord, Typeable, Data)++data VarTwigil = TNil | TAttribute | TPrivate | TImplicit | TMagical | TDoc+    | TGlobal -- XXX WRONG!+    deriving (Enum, Eq, Ord, Typeable, Data)++isSigilChar :: Char -> Bool+isSigilChar '$' = True+isSigilChar '@' = True+isSigilChar '%' = True+isSigilChar '&' = True+isSigilChar '<' = True -- XXX wrong+isSigilChar ':' = True+isSigilChar _   = False++instance ((:>:) ByteString) VarSigil where+    cast x = case x of+        SScalar     -> __"$"+        SArray      -> __"@"+        SHash       -> __"%"+        SCode       -> __"&"+        SRegex      -> __"<"+        SType       -> __"::"+        SArrayMulti -> __"@@"++instance ((:>:) ByteString) VarTwigil where+    cast x = case x of+        TNil        -> Buf.empty+        TAttribute  -> __"."+        TPrivate    -> __"!"+        TImplicit   -> __"^"+        TMagical    -> __"?"+        TDoc        -> __"="+        TGlobal     -> __"*"++instance Show VarSigil where+    showsPrec _ sig = case sig of+        SScalar     -> ('$':)+        SArray      -> ('@':)+        SHash       -> ('%':)+        SCode       -> ('&':)+        SRegex      -> ('<':)+        SType       -> \x -> (':':':':x)+        SArrayMulti -> \x -> ('@':'@':x)++instance Show VarTwigil where+    showsPrec _ twi = case twi of+        TNil        -> id+        TAttribute  -> ('.':)+        TPrivate    -> ('!':)+        TImplicit   -> ('^':)+        TMagical    -> ('?':)+        TDoc        -> ('=':)+        TGlobal     -> ('*':)++-- Cached Categ->ByteString mappings.+catBufMap :: [:ByteString:]+catBufMap = mapP (_cast . drop 2 . show) [:minBound..(maxBound :: VarCateg):]++-- Cached ByteString->Categ mappings.+bufCatMap :: Map ByteString VarCateg+bufCatMap = Map.fromList (fromP catBufMap `zip` [minBound..(maxBound :: VarCateg)])++instance ((:>:) ByteString) VarCateg where+    cast categ = catBufMap !: fromEnum categ++instance ((:>:) (Maybe VarCateg)) ByteString where+    cast buf = Map.lookup buf bufCatMap++instance ((:>:) VarCateg) ByteString where+    cast buf = case Map.lookup buf bufCatMap of+        Just x  -> x+        _       -> internalError $ "Invalid grammatical category: " ++ show buf++instance ((:>:) VarSigil) Char where+    cast '$'    = SScalar+    cast '@'    = SArray+    cast '%'    = SHash+    cast '&'    = SCode+    cast '<'    = SRegex+    cast ':'    = SType+    cast x      = internalError $ "Invalid sigil " ++ show x++instance ((:>:) VarSigil) ByteString where+    cast name+        | name == __"$"     = SScalar+        | name == __"@"     = SArray+        | name == __"%"     = SHash+        | name == __"&"     = SCode+        | name == __"<"     = SRegex+        | name == __":"     = SType+        | name == __"::"    = SType+        | name == __"&&"    = SCode -- XXX+        | name == __"@@"    = SArrayMulti+        | otherwise         = internalError $ "Invalid sigil " ++ show name++{-|+Transform an operator name, for example @&infix:\<+\>@ or @&prefix:«[+]»@,+into its internal name (@&infix:+@ and @&prefix:[+]@ respectively).+-}+instance ((:>:) Var) String where+    cast = cast . (cast :: String -> ByteString)++emptyPkg :: Pkg+emptyPkg = MkPkg []++-- globalPkg :: Pkg+-- globalPkg = MkPkg [__"GLOBAL"]++mainPkg :: Pkg+mainPkg = MkPkg [__"Main"]++callerPkg :: Pkg+callerPkg = MkPkg [__"CALLER"]++outerPkg :: Pkg+outerPkg = MkPkg [__"OUTER"]++contextPkg :: Pkg+contextPkg = MkPkg [__"ENV"] -- XXX wrong++nextPkg :: Pkg+nextPkg = MkPkg [__"NEXT"] -- XXX noncanonical++toGlobalVar :: Var -> Var+toGlobalVar var = var{ v_twigil = TGlobal }++isGlobalVar :: Var -> Bool+isGlobalVar MkVar{ v_twigil = TGlobal } = True+isGlobalVar MkVar{ v_twigil = TDoc }    = True -- XXX noncanonical+isGlobalVar _                           = False++instance ((:>:) Var) ByteString where+    cast x = unsafePerformIO (bufToVar x)++{-# NOINLINE _BufToVar #-}+_BufToVar :: H.HashTable ByteString Var+_BufToVar = unsafePerformIO hashNew++bufToVar :: ByteString -> IO Var+bufToVar buf = do+    a' <- H.lookup _BufToVar buf+    maybe (do+        let a = doBufToVar buf+        H.insert _BufToVar buf a+        return a) return a'++doBufToVar :: ByteString -> Var+doBufToVar buf = MkVar+    { v_sigil   = sig'+    , v_twigil  = twi+    , v_package = pkg+    , v_categ   = cat+    , v_meta    = meta+    , v_name    = name+    , v_longname= longname+    }+    where+    (sig, afterSig) = Buf.span isSigilChar buf+    sig' = if Buf.null sig then internalError $ "Sigilless var: " ++ show buf else cast sig+    len = Buf.length afterSig+    (twi, (pkg, (cat, afterCat)))+        | len == 0 = (TNil, (emptyPkg, (CNil, afterSig)))+--      | len <= 1 = (TNil, (emptyPkg, (CNil, afterSig)))+        | len == 1 = case Buf.head afterSig of+            '!' -> (TGlobal, (emptyPkg, (CNil, afterSig)))  -- XXX $! always global - WRONG+            '/' -> (TGlobal, (emptyPkg, (CNil, afterSig)))  -- XXX $/ always global - WRONG+            _   -> (TNil, (emptyPkg, (CNil, afterSig)))+        | otherwise = case Buf.head afterSig of+            '.' -> (TAttribute, toPkg afterTwi)+            '^' -> (TImplicit, toPkg afterTwi)+            '?' -> (TMagical, toPkg afterTwi)+            '!' -> (TPrivate, toPkg afterTwi)+            '=' -> (TDoc, toPkg afterTwi)+--          '*' -> (TNil, (globalPkg, Buf.tail afterSig))+            '*' -> (TGlobal, toPkg afterTwi)+            '+' -> (TNil, (contextPkg, snd afterTwi))+            _   -> (TNil, toPkg (tokenPkg afterSig))+    afterTwi = tokenPkg (Buf.tail afterSig)+    toPkg (pg, rest) = (MkPkg pg, rest)+    tokenPkg :: ByteString -> ([ByteString], (VarCateg, ByteString))+    tokenPkg str = case Buf.elemIndex ':' str of+        Just idx1 -> case B.findSubstring (__":(") str of+            Just idxSig | idx1 == idxSig -> ([], (CNil, str))+            _ -> case B.findSubstring (__"::") str of+                Nothing  -> ([], (cast (Buf.take idx1 str), Buf.drop (succ idx1) str))+                Just 0   -> tokenPkg (Buf.drop 2 str) -- '$::x' is the same as $x+                Just idx+                    | idx == idx1 -> case cast (Buf.take idx1 str) of+                        -- &infix::= should parse as infix:<:=>, not infix::<=>+                        Just ct -> ([], (ct, Buf.drop (succ idx1) str))+                        -- &Infix::= should parse as Infix::<=>, not Infix:<:=>+                        _        -> let (rest, final) = tokenPkg (Buf.drop (idx + 2) str) in+                            ((Buf.take idx str:rest), final)+                    | otherwise -> ([], (cast (Buf.take idx1 str), Buf.drop (succ idx1) str))+        _ -> ([], (CNil, str))+    (name, longname) = case B.findSubstring (__":(") fullname of+        Just idx -> (cast (Buf.take idx fullname), cast (Buf.drop idx fullname))+        _        -> (cast fullname, nullID)+    (fullname, meta)+        | C_postfix <- cat, __"\187" `Buf.isPrefixOf` afterCat+        = (Buf.drop 2 afterCat, MPre)+        | C_postfix <- cat, __">>" `Buf.isPrefixOf` afterCat+        = (Buf.drop 2 afterCat, MPre)+        | C_infix <- cat+        , __"\187" `Buf.isPrefixOf` afterCat+        , __"\171" `Buf.isSuffixOf` afterCat+        = (Buf.drop 2 (dropEnd 2 afterCat), MHyper)+        | C_infix <- cat+        , __">>" `Buf.isPrefixOf` afterCat+        , __"<<" `Buf.isSuffixOf` afterCat+        = (Buf.drop 2 (dropEnd 2 afterCat), MHyper)+        | C_prefix <- cat+        , __"[\\" `Buf.isPrefixOf` afterCat+        , ']' <- Buf.last afterCat+        = case Buf.drop 2 (Buf.init afterCat) of+            maybeHyper | __">>" `Buf.isPrefixOf` maybeHyper+                       , __"<<" `Buf.isSuffixOf` maybeHyper+                -> (Buf.drop 2 (dropEnd 2 maybeHyper), MHyperScan)+            maybeHyper | __"\187" `Buf.isPrefixOf` maybeHyper+                       , __"\171" `Buf.isSuffixOf` maybeHyper+                -> (Buf.drop 2 (dropEnd 2 maybeHyper), MHyperScan)+            other -> (other, MScan)+        | C_prefix <- cat+        , '[' <- Buf.head afterCat+        , ']' <- Buf.last afterCat+        = case Buf.tail (Buf.init afterCat) of+            maybeHyper | __">>" `Buf.isPrefixOf` maybeHyper+                       , __"<<" `Buf.isSuffixOf` maybeHyper+                -> (Buf.drop 2 (dropEnd 2 maybeHyper), MHyperFold)+            maybeHyper | __"\187" `Buf.isPrefixOf` maybeHyper+                       , __"\171" `Buf.isSuffixOf` maybeHyper+                -> (Buf.drop 2 (dropEnd 2 maybeHyper), MHyperFold)+            other -> (other, MFold)+        -- XXX - massive cut-n-paste!+        {-+        | C_prefix <- cat+        , __"[\\" `Buf.isPrefixOf` afterCat+        , __"]\171" `Buf.isSuffixOf` afterCat || __"]<<" `Buf.isSuffixOf` afterCat+        = case Buf.drop 2 (dropEnd 3 afterCat) of+            maybeHyper | __">>" `Buf.isPrefixOf` maybeHyper+                       , __"<<" `Buf.isSuffixOf` maybeHyper+                -> (Buf.drop 2 (dropEnd 2 maybeHyper), MHyperScanPost)+            maybeHyper | __"\187" `Buf.isPrefixOf` maybeHyper+                       , __"\171" `Buf.isSuffixOf` maybeHyper+                -> (Buf.drop 2 (dropEnd 2 maybeHyper), MHyperScanPost)+            other -> (other, MScanPost)+        | C_prefix <- cat+        , '[' <- Buf.head afterCat+        , __"]\171" `Buf.isSuffixOf` afterCat || __"]<<" `Buf.isSuffixOf` afterCat+        = case Buf.tail (dropEnd 3 afterCat) of+            maybeHyper | __">>" `Buf.isPrefixOf` maybeHyper+                       , __"<<" `Buf.isSuffixOf` maybeHyper+                -> (Buf.drop 2 (dropEnd 2 maybeHyper), MHyperFoldPost)+            maybeHyper | __"\187" `Buf.isPrefixOf` maybeHyper+                       , __"\171" `Buf.isSuffixOf` maybeHyper+                -> (Buf.drop 2 (dropEnd 2 maybeHyper), MHyperFoldPost)+            other -> (other, MFoldPost)+        -}+        | C_prefix <- cat, __"\171" `Buf.isSuffixOf` afterCat+        = (dropEnd 2 afterCat, MPost)+        | C_prefix <- cat, __"<<" `Buf.isSuffixOf` afterCat+        = (dropEnd 2 afterCat, MPost)+        | otherwise+        = (afterCat, MNil)++instance ((:>:) Pkg) ByteString where+    cast = MkPkg . filter (not . Buf.null) . Buf.splitWith (== ':')++instance ((:>:) Pkg) String where+    cast = cast . (cast :: String -> ByteString)++instance ((:>:) ID) Pkg where+    cast = cast . (cast :: Pkg -> ByteString)++instance ((:>:) Type) ID where+    cast = cast . (cast :: ID -> ByteString)++possiblyFixOperatorName :: Var -> Var+possiblyFixOperatorName var@MkVar{ v_categ = CNil } = var+possiblyFixOperatorName var@MkVar{ v_sigil = SCode, v_name = name }+    | __"\171" `Buf.isPrefixOf` buf, __"\187" `Buf.isSuffixOf` buf+    = var{ v_name = cast (dropEnd 2 (Buf.drop 2 buf)) }+    | __"<<" `Buf.isPrefixOf` buf, __">>" `Buf.isSuffixOf` buf+    = var{ v_name = cast (dropEnd 2 (Buf.drop 2 buf)) }+    | Buf.head buf == '<', Buf.last buf == '>', buf /= __"<=>"+    = var{ v_name = cast (Buf.init (Buf.tail buf)) }+    | otherwise+    = var+    where+    buf = cast name+possiblyFixOperatorName var = var++dropEnd :: Int -> ByteString -> ByteString+dropEnd i buf = Buf.take (Buf.length buf - i) buf++-- | Uses Haskell's underlying representation for strings.+type VStr  = String+-- | Uses Haskell's underlying representation for booleans.+type VBool = Bool+-- | Uses Haskell's underlying representation for integers.+type VInt  = Integer+-- | Uses Haskell's underlying representation for rational numbers.+type VRat  = Rational+-- | Uses Haskell's 'Double' type to represent arbitrary numbers.+type VNum  = Double+-- | Uses Haskell's underlying representation for complex numbers.+type VComplex = Complex VNum+-- | Uses Haskell's underlying representation for filehandles.+type VHandle = Handle+-- | Uses Haskell's underlying representation for sockets.+type VSocket = Socket++-- | Rule Match object from PGE+data MatchPGE+    = PGE_Match !Int !Int ![MatchPGE] ![(VStr, MatchPGE)]+    | PGE_Array ![MatchPGE]+    | PGE_String !String+    | PGE_Fail+    deriving (Show, Eq, Ord, Read, Typeable)++instance Ord VHandle where+    compare _ _ = EQ+instance Ord VSocket where+    compare x y = compare (show x) (show y)+instance (Ord a) => Ord (Tree a) where+    compare _ _ = EQ+instance Ord (TMVar a) where+    compare x y = compare (addressOf x) (addressOf y)+instance Eq (TMVar a) where+    x == y = addressOf x == addressOf y+instance Show (TMVar a) where+    show = showAddressOf "tmvar"++{-|+Count the total number of types in a class tree, including both internal and+leaf nodes.++This is used by 'deltaType' to ensure that incompatible types are always+further apart than compatible types.+-}+countTree :: ClassTree -> Int+countTree (MkClassTree (Node _ [])) = 1+countTree (MkClassTree (Node _ cs)) = 1 + sum (map (countTree . MkClassTree) cs)++{-|+Find the \'difference\' between two types in the given class tree (for MMD+purposes and such).++Identical types (that exist in the class tree) produce 0. Compatible types+will produce a small positive number representing their distance.+Incompatible will produce a distance larger+than any two compatible types. If one (or both) of the types doesn't exist in+the tree, the result is a very large number.++> <scook0> is deltaType supposed to be returning large positive numbers for+>            types that are actually incompatible?+> <autrijus> that is a open design question.+> <autrijus> it is that way because we want+> <autrijus> '1'+'2'+> <autrijus> to work+> <scook0> I see+> <autrijus> without having to define <+> as Scalar Scalar+> <autrijus> I think I did think of leaving a compatibleTypes as remedy+> <autrijus> to specify things that are fundamentally uncastable+> <scook0> I think I'll just document the current behaviour for now+> <autrijus> nod. it is a mess. it really wants a rewrite.+-}+deltaType :: Type      -- ^ Base type+          -> Type      -- ^ Possibly-derived type+          -> Int+deltaType = junctivate min max $ \base target ->+    let distance = distanceType base target in+    if distance < 0+        then initTreeCount - distance+        else distance++{-|+Autothreading of comparisons between junctive types.++Just as autothreading over value junctions will perform an operation on all+junction elements and combine the results back into a junction, this function+autothreads some type comparison over all the possible type permutations,+then combines the results using two user-specified /functions/.++E.g. if we want to check whether the type @(Int|Str)@ is a @Num@, we first+check whether @Int@ is a @Num@ (@True@), then check whether @Str@ is a num+(@False@), then combine the results using the specified disjunctive combiner+(in this case Haskell's @(||)@). The result is thus @True@.+-}+junctivate :: (t -> t -> t) -- ^ Function to combine results over disjunctive+                            --     (@|@) types+           -> (t -> t -> t) -- ^ Function to combine results over conjunctive+                            --     (@\&@) types+           -> (Type -> Type -> t)+                            -- ^ Function that will actually perform the+                            --     comparison (on non-junctive types)+           -> Type          -- ^ First type to compare+           -> Type          -- ^ Second type to compare+           -> t+junctivate ors ands f base target+    | TypeOr t1 t2 <- target+    = redo base t1 `ors` redo base t2+    | TypeOr b1 b2 <- base+    = redo b1 target `ors` redo b2 target+    | TypeAnd t1 t2 <- target+    = redo base t1 `ands` redo base t2+    | TypeAnd b1 b2 <- base+    = redo b1 target `ands` redo b2 target+    | otherwise+    = f base target+    where+      redo = junctivate ors ands f++-- When saying Int.isa(Scalar), Scalar is the base, Int is the target+{-|+A more convenient version of 'isaType\'' that automatically converts the base+type string into an actual 'Type' value.+-}+isaType :: String    -- ^ Base type+        -> Type      -- ^ Possibly-derived type+        -> Bool+isaType base target = isaType' (mkType base) target++{-|+Return true if the second type (the \'target\') is derived-from or equal-to the+first type (the \'base\'), in the context of the given class tree.++This function will autothread over junctive types.+-}+isaType' :: Type      -- ^ Base type+         -> Type      -- ^ Possibly-derived type+         -> Bool+isaType' = junctivate (||) (&&) $ \base target ->+    distanceType base target >= 0++{-|+Compute the \'distance\' between two types by applying 'findList' to each of+/bin/bash: line 1: :1: command not found+See 'compareList' for further details.+-}+distanceType :: Type -> Type -> Int+distanceType base@(MkType b) target@(MkType t) =+    IntMap.findWithDefault (distanceType base' target') (bk `shiftL` 16 + tk) initCache+--  | not (castOk base target)  = 0+--  | otherwise = compareList l1 l2+    where+    bk      = idKey b+    tk      = idKey t+    base'   = if IntSet.member bk initKeySet then base else anonType1+    target' = if IntSet.member tk initKeySet then target else anonType2+distanceType _ _ = error "distanceType: MkType not 'simple'"++anonType1, anonType2 :: Type+anonType1 = mkType "\1"+anonType2 = mkType "\2"++initKeySet :: IntSet.IntSet+initKeySet = IntSet.fromList (map idKey initLeaves)++initCache :: IntMap.IntMap Int+initCache = IntMap.fromList leaves+    where+    leaves = [ (idKey x `shiftL` 16 + idKey y, cachedLookup x y)+             | x <- initLeaves, y <- initLeaves+             ]+    cachedLookup base target = compareList l1 l2+        where+        l1 = findList base rawTree+        l2 = findList target rawTree++initLeaves :: [ID]+initLeaves = flatten rawTree++{-+-- | (This is currently unused...)+castOk :: a -> b -> Bool+castOk _ _ = True+-}++{-|+Take two inheritance chains produced by 'findList', and determine how+\'compatible\' the first one is with the second.++Compatible types will produce a number indicating how distant they are.+Incompatible types produce a negative number indicating how much the base type+would need to be relaxed. If one (or both) types doesn't exist in the tree, a+large negative number is produced++E.g.:++* comparing @Int@ and @Int@ will produce 0++* comparing @Scalar@ and @String@ will produce 1++* comparing @Num@ and @Scalar@ will produce -2++* comparing @Blorple@ and @Method@ will produce -999 (or similar)+-}+compareList :: Eq a+            => [a] -- ^ Base type's chain+            -> [a] -- ^ Possibly-derived type's chain+            -> Int+compareList [] _ = -999 -- XXX hack (nonexistent base type?)+compareList _ [] = -999 -- XXX hack (incompatible types)+compareList l1 l2+    | last l1 `elem` l2 =   length(l2 \\ l1) -- compatible types+    | last l2 `elem` l1 = - length(l1 \\ l2) -- anti-compatible types+    | otherwise = compareList l1 (init l2)+{-# SPECIALIZE compareList :: [ID] -> [ID] -> Int #-}+{-# SPECIALIZE compareList :: [Type] -> [Type] -> Int #-}++{-|+Produce the type \'inheritance\' chain leading from the base type (@Any@) to+the given type.++e.g.++@+'findList' ('MkType' \"Num\") 'initTree'+@++will produce the list of types++@+Any, Void, Object, Scalar, Complex, Num+@++This function does /not/ expect to be given junctive types.+-}+findList :: Eq a+         => a      -- ^ 'Type' to find the inheritance chain of+         -> Tree a -- ^ Class tree to look in+         -> [a]+findList base (Node l cs)+    | base == l                             = [l]+    | Just ls <- find (not . null) found    = l:ls+    | otherwise                             = []+    where+    found = map (findList base) cs+{-# SPECIALIZE findList :: ID -> Tree ID -> [ID] #-}+{-# SPECIALIZE findList :: Type -> Tree Type -> [Type] #-}++{-+{-|+Pretty-print the initial class tree, using @Tree@'s @drawTree@.++(This seems to be a debugging aid, since it's not actually used anywhere.)+-}+prettyTypes :: String+prettyTypes = drawTree $ fmap show initTree+-}++{-|+Default class tree, containing all built-in types.+-}+initTree :: ClassTree+initTree = MkClassTree (fmap MkType rawTree)++initTreeCount :: Int+initTreeCount = countTree initTree++rawTree :: Tree ID+rawTree = fmap cast $! Node "Object"+    [ Node "Any"+        [ Node "Item"+            [ Node "List"+                [ Node "Lazy"+                    [ Node "Array"+                        [ Node "Array::Const" []+                        , Node "Array::Slice" []+                        ]+                    , Node "Hash"+                        [ Node "Hash::Const" []+                        , Node "Hash::Env" []+                        ]+                    ]+                , Node "Eager" []+                ]+            , Node "Scalar"+                [ Node "Complex"+                    [ Node "Num"+                        [ Node "Rat"+                            [ Node "Int"+                                [ Node "Bit" [] ] ] ] ]+                , Node "Bool" []+                , Node "Str" []+                , Node "Ref" []+                , Node "IO" []+                , Node "IO::Dir" []+                , Node "Socket" []+                , Node "Thread" []+                , Node "Code"+                    [ Node "Routine"+                        [ Node "Sub"+                            [ Node "Method" []+                            , Node "Submethod" []  -- why isn't this a node off Method? - mugwump+                            ]+                        , Node "Macro" [] ]+                    , Node "Block"+                        [ Node "Loop" [] ]+                    ]+                , Node "Regex" []+                , Node "Signature" []+                , Node "Capture"+                    [ Node "Match" []+                    ]+                , Node "Scalar::Const" []+                , Node "Scalar::Proxy" []+                , Node "Scalar::Lazy" []+                , Node "Scalar::Perl5" []+                , Node "Proxy" []+                , Node "Control::Caller" []+                , Node "Time::Local" []+                , Node "Type"+                    [ Node "Package"+                        [ Node "Module"+                            [ Node "Class"+                                [ Node "Role" []+                                , Node "Grammar" []+                                ] ] ] ]+                ]+            ]+        , Node "Pair"+            [ Node "Pair::HashSlice" []+            ]+        ]+    , Node "Junction" []+    , Node "\1" []+    , Node "\2" []+    ]+
+ src/Pugs/Types/Array.hs view
@@ -0,0 +1,305 @@+type ArrayIndex = Int++class (Typeable a) => ArrayClass a where+    array_iType :: a -> Type+    array_iType = const $ mkType "Array"+    array_fetch       :: a -> Eval VArray+    array_fetch av = do+        size <- array_fetchSize av+        mapM (array_fetchVal av) [0..size-1]+    array_store       :: a -> VArray -> Eval ()+    array_store av list = do+        forM_ ([0..] `zip` list) $ \(idx, val) -> do+            sv <- array_fetchElem av idx+            writeIVar sv val+        array_storeSize av (length list)+    array_fetchKeys   :: a -> Eval [ArrayIndex]+    array_fetchKeys av = do+        svList <- array_fetch av+        return $ zipWith const [0..] svList+    array_fetchElemAll :: a -> Eval [IVar VScalar]+    array_fetchElemAll av = do+        size <- array_fetchSize av+        mapM (array_fetchElem av) [0..size-1]+    array_fetchElem   :: a -> ArrayIndex -> Eval (IVar VScalar) -- autovivify+    array_fetchElem av idx = do+        return $ proxyScalar (array_fetchVal av idx) (array_storeVal av idx)+    array_storeElem   :: a -> ArrayIndex -> IVar VScalar -> Eval () -- binding+    array_storeElem av idx sv = do+        val <- readIVar sv+        array_storeVal av idx val+    array_fetchVal    :: a -> ArrayIndex -> Eval Val+    array_fetchVal av idx = do+        rv <- array_existsElem av idx+        if rv then readIVar =<< array_fetchElem av idx+              else return undef+    array_storeVal    :: a -> ArrayIndex -> Val -> Eval ()+    array_storeVal av idx val = do+        sv <- array_fetchElem av idx+        writeIVar sv val+    array_fetchSize   :: a -> Eval ArrayIndex+    array_fetchSize av = do+        vals <- array_fetch av+        return $ length vals+    array_storeSize   :: a -> ArrayIndex -> Eval ()+    array_storeSize av sz = do+        size <- array_fetchSize av+        case size `compare` sz of+            GT -> mapM_ (const $ array_pop av) [size .. sz-1]+            EQ -> return () -- no need to do anything+            LT -> mapM_ (\idx -> array_storeElem av idx lazyUndef) [size .. sz-1]+    array_extendSize  :: a -> ArrayIndex -> Eval ()+    array_extendSize _ 0 = return ()+    array_extendSize av sz = do+        size <- array_fetchSize av+        when (size < sz) $ do+            mapM_ (\idx -> array_storeElem av idx lazyUndef) [size .. sz-1]+    array_deleteElem  :: a -> ArrayIndex -> Eval ()+    array_deleteElem av idx = do+        size <- array_fetchSize av+        let idx' = if idx < 0 then idx `mod` size else idx+        case (size - 1) `compare` idx' of+            GT -> return ()                             -- no such index+            EQ -> array_storeSize av (size - 1)               -- truncate+            LT -> array_storeElem av idx' lazyUndef            -- set to undef+    array_existsElem  :: a -> ArrayIndex -> Eval VBool+    array_existsElem av idx = do+        size <- array_fetchSize av+        return $ size > (if idx < 0 then idx `mod` size else idx)+    array_clear       :: a -> Eval ()+    array_clear av = array_storeSize av 0+    array_push        :: a -> [Val] -> Eval ()+    array_push av vals = do+        size <- array_fetchSize av+        forM_ ([size..] `zip` vals) $ \(idx, val) -> do+            array_storeElem av idx (lazyScalar val)+    array_pop         :: a -> Eval Val+    array_pop av = do+        size <- array_fetchSize av+        if size == 0+            then return undef+            else do+                sv <- array_fetchElem av $ size - 1+                array_storeSize av $ size - 1+                readIVar sv+    array_shift       :: a -> Eval Val+    array_shift av = do+        vals <- array_splice av 0 1 []+        return $ last (undef:vals)+    array_unshift     :: a -> [Val] -> Eval ()+    array_unshift av vals = do+        array_splice av 0 0 vals+        return ()+    array_splice      :: a -> ArrayIndex -> ArrayIndex -> [Val] -> Eval [Val]+    array_splice av off len vals = do+        size <- array_fetchSize av+        let off' = if off < 0 then off + size else off+            len' = if len < 0 then len + size - off' else len+        result <- mapM (array_fetchElem av) [off' .. off' + len' - 1]+        let off = if off' > size then size else off'+            len = if off + len' > size then size - off else len'+            cnt = length vals+        case cnt `compare` len of+            GT -> do+                -- Move items up to make room+                let delta = cnt - len+                array_extendSize av (size + delta)+                (`mapM_` reverse [off + len .. size - 1]) $ \idx -> do+                    val <- array_fetchElem av idx+                    array_storeElem av (idx + delta) val+            LT -> do+                let delta = len - cnt+                (`mapM_` [off + len .. size - 1]) $ \idx -> do+                    val <- array_fetchElem av idx+                    array_storeElem av (idx - delta) val+                array_storeSize av (size - delta)+            _ -> return ()+        forM_ ([0..] `zip` vals) $ \(idx, val) -> do+            array_storeElem av (off + idx) (lazyScalar val)+        mapM readIVar result+    array_clone :: a -> STM a+    array_clone = return++instance ArrayClass IArraySlice where+    array_iType = const $ mkType "Array::Slice"+    array_store av vals = mapM_ (uncurry writeIVar) (zip av (vals ++ repeat undef))+    array_fetchSize = return . length+    array_fetchElem av idx = getIndex idx Nothing (return av) Nothing+    array_storeSize _ _ = return () -- XXX error?+    array_storeElem _ _ _ = retConstError undef++a_size :: [:IVar VScalar:] -> Int+a_size = lengthP++a_update :: Int -> IVar VScalar -> [:IVar VScalar:] -> [:IVar VScalar:]+a_update i x xs = takeP i xs +:+ [:x:] +:+ sliceP (i + 1) (lengthP xs - 1) xs++instance ArrayClass IArray where+    array_clone (MkIArray iv) = do+        a   <- readTVar iv+        tvs <- mapM cloneIVar (fromP a)+        fmap MkIArray (newTVar (toP tvs))+    array_store (MkIArray iv) vals = stm $ do+        tvs <- mapM newScalar vals+        writeTVar iv (toP tvs)+    array_fetchSize (MkIArray iv) = stm $ do+        a   <- readTVar iv+        return $ a_size a+    array_storeSize (MkIArray iv) sz = stm $ do+        a       <- readTVar iv+        case a_size a `compare` sz of+            GT -> writeTVar iv (takeP sz a) -- shrink+            EQ -> return ()+            LT -> do+                tvs <- replicateM (sz - a_size a) (newScalar undef)+                writeTVar iv (a +:+ toP tvs) -- extend+    array_shift (MkIArray iv) = join . stm $ do+        a   <- readTVar iv+        case a_size a of+            0   -> return (return undef)+            l   -> do+                writeTVar iv (sliceP 1 (l - 1) a)+                return (readIVar (a !: 0))+    array_unshift _ [] = return ()+    array_unshift (MkIArray iv) vals = stm $ do+        a   <- readTVar iv+        tvs <- mapM newScalar vals+        writeTVar iv (toP tvs +:+ a)+    array_pop (MkIArray iv) = join . stm $ do+        a   <- readTVar iv+        case a_size a of+            0   -> return (return undef)+            sz  -> do+                writeTVar iv (takeP (sz - 1) a)+                return (readIVar (a !: (sz - 1)))+    array_push _ [] = return ()+    array_push (MkIArray iv) vals = stm $ do+        a   <- readTVar iv+        tvs <- mapM newScalar vals+        writeTVar iv (a +:+ toP tvs)+    array_extendSize (MkIArray iv) sz = stm $ do+        a       <- readTVar iv+        case a_size a `compare` sz of+            LT  -> do+                tvs <- replicateM (sz - a_size a) (newScalar undef)+                writeTVar iv (a +:+ toP tvs)+            _   -> return ()+    array_fetchVal arr idx = do+        rv  <- getArrayIndex idx (Just $ constScalar undef)+                (return arr)+                Nothing -- don't bother extending+        readIVar rv+    array_fetchKeys (MkIArray iv) = stm $ do+        a   <- readTVar iv+        return [0 .. (a_size a - 1)]+    array_fetchElem arr idx = do+        getArrayIndex idx Nothing+            (return arr)+            (Just (array_extendSize arr $ idx+1))+    array_existsElem arr idx | idx < 0 = array_existsElem arr (abs idx - 1)    -- FIXME: missing mod?+    array_existsElem (MkIArray iv) idx = stm $ do+        a   <- readTVar iv+        return (idx < a_size a)+    array_storeElem arr@(MkIArray iv) idx sv = do+        a   <- stm $ readTVar iv+        let size = a_size a+        when (size <= idx) $ do+            array_extendSize arr (idx + 1)+        stm $ modifyTVar iv (a_update idx sv)+    array_deleteElem (MkIArray iv) idx = stm $ do+        a   <- readTVar iv+        let idx' | idx < 0   = idx `mod` size        --- XXX wrong; wraparound => what do you mean?+                 | otherwise = idx+            size = a_size a+        case (size-1) `compare` idx' of+            LT -> return ()+            EQ -> writeTVar iv (takeP (size-1) a)+            GT -> do+                tvar <- newScalar undef+                writeTVar iv (a_update idx' tvar a)+    array_splice (MkIArray iv) off len vals = join . stm $ do+        a    <- readTVar iv++        let off' = if off < 0 then off + size else off+            len' = if len < 0 then len + size - off' else len+            size = a_size a++        let result = mapM readIVar (fromP (sliceP off' (off' + len' - 1) a))++        let off = if off' > size then size else off'+            len = if off + len' > size then size - off else len'++        tvars  <- mapM newScalar vals+        writeTVar iv (takeP off a +:+ toP tvars +:+ sliceP (off+len) (size-1) a)+        return result++instance ArrayClass VArray where+    array_iType = const $ mkType "Array::Const"+    array_store [] _ = return ()+    array_store (VUndef:as) (_:vs) = array_store as vs+    array_store as [] = forM_ as $ \a -> do+        -- clear out everything+        ref <- fromVal a+        if isaType "List" (refType ref)+            then writeRef ref (VList [])+            else writeRef ref VUndef+    array_store (a:as) vals@(v:vs) = do+        ref <- fromVal a+        if isaType "List" (refType ref)+            then do+                writeRef ref (VList vals)+                array_store as []+            else do+                writeRef ref v+                array_store as vs+    array_fetch = return+    array_fetchSize = return . length+    array_fetchVal av idx = getIndex idx (Just undef) (return av) Nothing+    array_fetchElemAll av = return $ map constScalar av+    array_fetchElem av idx = do+        val <- array_fetchVal av idx+        return $ constScalar val+    array_storeVal _ _ _ = retConstError undef+    array_storeElem _ _ _ = retConstError undef+    array_existsElem av idx = return . not . null $ drop idx av++instance ArrayClass (IVar VPair) where+    array_iType = const $ mkType "Pair"+    array_fetch pv = do+        (k, v)  <- readIVar pv+        return [k, v]+    array_existsElem _ idx = return (idx >= -2 || idx <= 1)+    array_fetchSize        = const $ return 2+    array_fetchVal pv (-2) = return . fst =<< readIVar pv+    array_fetchVal pv (-1) = return . snd =<< readIVar pv+    array_fetchVal pv 0    = return . fst =<< readIVar pv+    array_fetchVal pv 1    = return . snd =<< readIVar pv+    array_fetchVal _  _    = return undef+    array_storeVal a _ _   = retConstError $ VStr $ show a+    array_storeElem a _ _  = retConstError $ VStr $ show a+    array_deleteElem a _   = retConstError $ VStr $ show a++perl5EvalApply :: String -> [PerlSV] -> Eval Val+perl5EvalApply code args = do+    env     <- ask+    envSV   <- io $ mkEnv env+    subSV   <- io $ evalPerl5 code envSV (enumCxt cxtItemAny)+    runInvokePerl5 subSV nullSV args++instance ArrayClass PerlSV where+    array_iType = const $ mkType "Array::Perl"+    array_fetchVal sv idx = do+        idxSV   <- fromVal $ castV idx+        perl5EvalApply "sub { $_[0]->[$_[1]] }" [sv, idxSV]+    array_clear sv = do+        perl5EvalApply "sub { undef @{$_[0]} }" [sv]+        return ()+    array_storeVal sv idx val = do+        idxSV   <- fromVal $ castV idx+        valSV   <- fromVal val+        perl5EvalApply "sub { $_[0]->[$_[1]] = $_[2] }" [sv, idxSV, valSV]+        return ()+    array_deleteElem sv idx = do+        idxSV   <- fromVal $ castV idx+        perl5EvalApply "sub { delete $_[0]->[$_[1]] }" [sv, idxSV]+        return ()
+ src/Pugs/Types/Code.hs view
@@ -0,0 +1,45 @@++class (Typeable a) => CodeClass a where+    code_iType    :: a -> Type+    code_iType = const $ mkType "Code"+    code_fetch    :: a -> Eval VCode+    code_fetch a = code_assuming a [] []+    code_store    :: a -> VCode -> Eval ()+    code_assuming :: a -> [Exp] -> [Exp] -> Eval VCode+    code_apply    :: a -> Eval Val+    code_assoc    :: a -> SubAssoc+    code_params   :: a -> Params+    code_type     :: a -> SubType+    code_clone    :: a -> STM a++instance CodeClass VMultiCode where+    code_iType      = mc_type+    code_fetch c    = do+        -- warn "XXX - Multi dispatch -- Not yet!" ()+        fromVal =<< readVar (Set.findMax (mc_variants c))+    code_store c _  = retConstError . VStr $ show c+    code_params     = mc_signature+    code_assuming c [] [] = code_fetch c+    code_assuming _ _ _   = error "assuming"+    code_assoc      = mc_assoc+    code_apply      = error "apply"+    code_type       = mc_subtype+    code_clone      = return++instance CodeClass VCode where+    -- XXX - subType should really just be a mkType itself+    code_iType c  = case subType c of+        SubBlock    -> mkType "Block"+        SubPointy   -> mkType "Block"+        SubMethod   -> mkType "Method"+        _           -> mkType "Sub"+    code_fetch    = return+    code_store c _= retConstError . VStr $ show c+    code_assuming c [] [] = return c+    code_assuming _ _ _   = error "assuming"+    code_apply    = error "apply"+    code_assoc    = subAssoc+    code_params   = subParams+    code_type     = subType+    code_clone c  = return c+
+ src/Pugs/Types/Handle.hs view
@@ -0,0 +1,47 @@++type Layer = VStr+type FileDescriptor = VInt++class (Typeable a) => HandleClass a where+    handle_iType :: a -> Type+    handle_iType = const $ mkType "IO"+    handle_fetch       :: a -> Eval VHandle+    handle_store       :: a -> VHandle -> Eval ()+    handle_write       :: a -> VStr -> Eval VInt+    handle_write = error ""+    handle_print       :: a -> [Val] -> Eval VBool+    handle_print gv vals = do+        hdl  <- handle_fetch gv+        strs <- mapM valToStr vals+        tryIO False $ do+            hPutStr hdl $ concatMap encodeUTF8 strs+            return True+    handle_printf      :: a -> VStr -> [Val] -> Eval VBool+    handle_printf = error ""+    handle_read        :: a -> VInt -> Eval (VInt, VStr)+    handle_read = error ""+    handle_readLine    :: a -> Eval VStr+    handle_readLine = error ""+    handle_getC        :: a -> Eval VStr+    handle_getC = error ""+    handle_close       :: a -> Eval ()+    handle_close gv = do+        hdl <- handle_fetch gv+        liftIO $ hClose hdl+    handle_binmode     :: a -> Layer -> Eval ()+    handle_binmode _ _ = return ()+    handle_open        :: a -> Layer -> FilePath -> Eval VBool+    handle_open = error ""+    handle_eof         :: a -> Eval VBool+    handle_eof = error ""+    handle_fileNo      :: a -> Eval FileDescriptor+    handle_fileNo = error ""+    handle_seek        :: a -> VInt -> SeekMode -> Eval VBool+    handle_seek = error ""+    handle_tell        :: a -> Eval VInt+    handle_tell = error ""++instance HandleClass IHandle where+    handle_fetch = return+    handle_store = error "store"+
+ src/Pugs/Types/Hash.hs view
@@ -0,0 +1,158 @@+type HashIndex = VStr++class (Typeable a) => HashClass a where+    hash_iType :: a -> Type+    hash_iType = const $ mkType "Hash"+    hash_fetch       :: a -> Eval VHash+    hash_fetch hv = do+        keys <- hash_fetchKeys hv+        vals <- mapM (hash_fetchVal hv) keys+        let ps = keys `zip` vals+        return (length ps `seq` Map.fromList ps)+    hash_store       :: a -> VHash -> Eval ()+    hash_store hv vals = do+        hash_clear hv+        forM_ (Map.assocs vals) $ \(key, val) -> do+            hash_storeVal hv key val+    hash_fetchElem   :: a -> HashIndex -> Eval (IVar VScalar) -- autovivify+    hash_fetchElem hv key = do+        return $ proxyScalar (hash_fetchVal hv key) (hash_storeVal hv key)+    hash_storeElem   :: a -> HashIndex -> IVar VScalar -> Eval () -- binding+    hash_storeElem hv idx sv = do+        val <- readIVar sv+        hash_storeVal hv idx val+    hash_fetchVal    :: a -> HashIndex -> Eval Val+    hash_fetchVal hv key = do+        rv <- hash_existsElem hv key+        if rv then readIVar =<< hash_fetchElem hv key+              else return undef+    hash_storeVal    :: a -> HashIndex -> Val -> Eval ()+    hash_storeVal hv key val = do+        sv <- hash_fetchElem hv key+        writeIVar sv val+    hash_fetchKeys   :: a -> Eval [HashIndex]+    hash_fetchKeys hv = do+        vals <- hash_fetch hv+        return $ Map.keys vals+    hash_fetchSize   :: a -> Eval Int+    hash_fetchSize hv = do+        vals <- hash_fetch hv+        return $ Map.size vals+    hash_deleteElem  :: a -> HashIndex -> Eval ()+    hash_existsElem  :: a -> HashIndex -> Eval VBool+    hash_existsElem hv idx = do+        keys <- hash_fetchKeys hv+        return $ idx `elem` keys+    hash_clear       :: a -> Eval ()+    hash_clear hv = do+        keys <- hash_fetchKeys hv+        mapM_ (hash_deleteElem hv) keys+    hash_isEmpty     :: a -> Eval VBool+    hash_isEmpty hv = do+        keys <- hash_fetchKeys hv+        return $ null keys +    hash_clone :: a -> STM a+    hash_clone = return++instance HashClass (IVar VPair) where+    hash_iType = const $ mkType "Pair"+    hash_fetch pv = do+        (k, v)  <- readIVar pv+        str     <- fromVal k+        return $ Map.singleton str v+    hash_fetchVal pv idx = do+        (k, v)  <- readIVar pv+        str     <- fromVal k+        if str == idx+            then return v+            else return undef+    hash_storeVal _ _ _ = retConstError undef+    hash_deleteElem _ _ = retConstError undef++instance HashClass VHash where+    hash_iType = const $ mkType "Hash::Const"+    hash_fetch = return+    hash_fetchKeys = return . Map.keys+    hash_fetchVal hv idx = return $ Map.findWithDefault undef idx hv+    hash_clear _ = retConstError undef+    hash_store _ _ = retConstError undef+    hash_storeVal _ _ _ = retConstError undef+    hash_storeElem _ _ _ = retConstError undef+    hash_deleteElem _ _ = retConstError undef++instance HashClass IHashEnv where+    hash_iType = const $ mkType "Hash::Env"+    hash_fetch _ = do+        envs <- io getEnvironment+        return . Map.map (VStr . decodeUTF8) $ Map.fromList envs+    hash_fetchVal _ key = tryIO undef $ do+        str <- getEnv key+        return $ fromMaybe VUndef (fmap (VStr . decodeUTF8) str)+    hash_storeVal _ key val = do+        str <- fromVal val+        io $ setEnv key (encodeUTF8 str) True+    hash_existsElem _ key = tryIO False $ do+        str <- getEnv key+        return (isJust str)+    hash_deleteElem _ key = do+        io $ unsetEnv key++encodeKey, decodeKey :: HashIndex -> HashIndex+encodeKey x = x+decodeKey x = x++instance HashClass IHash where+    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'+    hash_fetch hv = do+        ps  <- io $ H.toList hv+        ps' <- forM ps $ \(k, sv) -> do+            val <- readIVar sv+            return (decodeKey k, val)+        return (length ps' `seq` Map.fromList ps')+    hash_fetchKeys hv = do+        fmap (map (decodeKey . fst)) (io $ H.toList hv)+    hash_fetchElem hv idx = do+        let idx' = encodeKey idx+        r <- io $ H.lookup hv idx'+        case r of+             Just sv -> return sv+             Nothing -> do+                sv <- newScalar undef+                io $ H.insert hv idx' sv+                return sv+    hash_storeElem hv idx sv = do+        io $ H.insert hv (encodeKey idx) sv+    hash_deleteElem hv idx = do+        io $ H.delete hv (encodeKey idx)+        return ()+    hash_existsElem hv idx = do+        io $ fmap isJust (H.lookup hv (encodeKey idx))++instance HashClass PerlSV where+    hash_iType = const $ mkType "Hash::Perl"+    hash_fetchVal sv key = do+        keySV   <- fromVal $ castV key+        perl5EvalApply "sub { $_[0]->{$_[1]} }" [sv, keySV]+    hash_clear sv = do+        perl5EvalApply "sub { undef %{$_[0]} }" [sv]+        return ()+    hash_storeVal sv key val = do+        keySV   <- fromVal $ castV key+        valSV   <- fromVal val+        perl5EvalApply "sub { $_[0]->{$_[1]} = $_[2] }" [sv, keySV, valSV]+        return ()+    hash_fetchKeys sv = do+        keysSV  <- perl5EvalApply "sub { join $/, keys %{$_[0]} }" [sv]+        keysStr <- fromVal keysSV+        return $ lines keysStr+    hash_deleteElem sv key = do+        keySV   <- fromVal $ castV key+        perl5EvalApply "sub { delete $_[0]->{$_[1]} }" [sv, keySV]+        return ()+    hash_isEmpty sv = do+        fromVal =<< perl5EvalApply "sub { !!%{$_[0]} }" [sv]
+ src/Pugs/Types/Object.hs view
@@ -0,0 +1,14 @@++class (Typeable a) => ObjectClass a where+    object_iType :: a -> Type++instance (Typeable a) => ObjectClass (IVar a) where+    object_iType (IScalar x) = scalar_iType x+    object_iType (IArray x)  = array_iType x+    object_iType (IHash x)   = hash_iType x+    object_iType (ICode x)   = code_iType x+    object_iType (IHandle x) = handle_iType x+    object_iType (IRule x)   = rule_iType x+    object_iType (IThunk x)  = thunk_iType x+    object_iType (IPair x)   = pair_iType x+    object_iType (IVal x)    = valType x
+ src/Pugs/Types/Pair.hs view
@@ -0,0 +1,38 @@++class (Typeable a) => PairClass a where+    pair_iType :: a -> Type+    pair_iType = const $ mkType "Pair"+    pair_fetch :: a -> Eval VPair+    pair_fetch pv = do+        key <- pair_fetchKey pv+        val <- pair_fetchVal pv+        return (key, val)+    pair_fetchKey  :: a -> Eval VScalar+    pair_fetchVal  :: a -> Eval VScalar+    pair_fetchVal pv = do+        readIVar =<< pair_fetchElem pv+    pair_storeVal  :: a -> Val -> Eval ()+    pair_storeVal pv val = do+        sv <- pair_fetchElem pv+        writeIVar sv val+    pair_fetchElem :: a -> Eval (IVar VScalar)+    pair_fetchElem pv = do+        return $ proxyScalar (pair_fetchVal pv) (pair_storeVal pv)++instance PairClass VPair where+    pair_fetchKey = return . fst+    pair_fetchVal = return . snd+    pair_storeVal pv val = do+        ref <- fromVal (snd pv)+        writeRef ref val+    pair_fetch pv = do+        key <- pair_fetchKey pv+        val <- pair_fetchVal pv+        return (key, val)+    pair_fetchElem pv = do+        return $ proxyScalar (pair_fetchVal pv) (pair_storeVal pv)++instance PairClass IPairHashSlice where+    pair_iType = const $ mkType "Pair::HashSlice"+    pair_fetchKey  = return . VStr . fst+    pair_fetchElem = return . snd
+ src/Pugs/Types/Rule.hs view
@@ -0,0 +1,7 @@++class (Typeable a) => RuleClass a where+    rule_iType :: a -> Type+    rule_iType = const $ mkType "Regex"+    rule_fetch :: a -> Eval VRule+    rule_store :: a -> VRule -> Eval ()+    rule_match :: a -> VStr -> Eval (MatchResult Val)
+ src/Pugs/Types/Scalar.hs view
@@ -0,0 +1,55 @@++class (Typeable a) => ScalarClass a where+    scalar_iType :: a -> Type+    scalar_iType = const $ mkType "Scalar"+    scalar_fetch :: a -> Eval VScalar+    scalar_store :: a -> VScalar -> Eval ()+    scalar_const :: a -> Maybe VScalar+    scalar_clone :: a -> STM a+    scalar_clone = return+    scalar_fetch' :: a -> Eval VScalar+    scalar_fetch' x = scalar_fetch x+    scalar_type  :: a -> Eval Type+    scalar_type x = do+        v <- scalar_fetch x+        evalValType v++instance ScalarClass IScalarProxy where+    scalar_iType = const $ mkType "Scalar::Proxy"+    scalar_fetch = fst+    scalar_store = snd+    scalar_const = const Nothing++instance ScalarClass IScalar where+    scalar_fetch = stm . readTVar+    scalar_store = (stm .) . writeTVar+    scalar_const = const Nothing+    scalar_clone sv = newTVar =<< readTVar sv++instance ScalarClass IScalarLazy where+    scalar_iType = const $ mkType "Scalar::Lazy"+    scalar_fetch = return . maybe undef id+    scalar_store d _ = retConstError $ VStr $ show d+    scalar_const = const Nothing++instance ScalarClass IScalarCwd where+    scalar_iType = const $ mkType "Scalar::Cwd"+    scalar_fetch _ = do+        str <- io getCurrentDirectory+        return $ VStr str+    scalar_store _ val = do+        str <- fromVal val+        tryIO () $ setCurrentDirectory str+    scalar_const = const Nothing++instance ScalarClass VScalar where+    scalar_iType = const $ mkType "Scalar::Const"+    -- scalar_fetch v@(VRef (MkRef IPair{})) = return v+    scalar_fetch (VRef (MkRef (IScalar sv))) = scalar_fetch sv+    scalar_fetch v = return v+    scalar_store d _ = retConstError d+    scalar_const = Just+    scalar_type (VRef (MkRef (IScalar sv))) = scalar_type sv+    scalar_type v = return $ valType v+    scalar_fetch' v = return v+
+ src/Pugs/Types/Thunk.hs view
@@ -0,0 +1,10 @@++class (Typeable a) => ThunkClass a where+    thunk_iType :: a -> Type+    thunk_iType = const $ mkType "Thunk"+    thunk_force :: a -> Eval Val++instance ThunkClass VThunk where+    thunk_iType (MkThunk _ t) = t+    thunk_force (MkThunk c _) = c+
+ src/Pugs/Val.hs view
@@ -0,0 +1,603 @@+{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances -fallow-overlapping-instances -fno-warn-missing-methods -cpp #-}+{-|+    Perl 6 Values.++>   There beryl, pearl, and opal pale,+>   And metal wrought like fishes' mail,+>   Buckler and corslet, axe and sword,+>   And shining spears were laid in hoard...+-}++module Pugs.Val (+    module Pugs.Val,+    module Pugs.Val.Code,+    module Pugs.Val.Capture,+    Val, Call,+) where+import Pugs.Class+import Pugs.Val.Base ()+import Pugs.Val.Code+import Pugs.Val.Capture+import Pugs.Internals+import Text.PrettyPrint++asStr :: Val -> Eval PureStr+asStr (MkInvocant x _) = return (cast (show x))+asBit :: Val -> Eval PureBit+asBit _ = return (cast True)+asInt :: Val -> Eval PureInt+asInt _ = return (cast (0 :: Int))+asNum :: Val -> Eval PureNum+asNum _ = return (cast (0 :: Double))+listVal :: Val -> Eval PureList+listVal = return . (:[])+itemVal :: Val -> Eval Val+itemVal = return++valMeta :: Val -> PureStr+valMeta _ = cast "Object"++valShow :: Val -> PureStr+valShow _ = cast "<opaque>"++formatVal :: Val -> Doc+formatVal (MkInvocant x _) = text (show x)++castVal :: forall a m . (Monad m, Typeable a) => Val -> m a+castVal (MkInvocant v _)  = fromTypeable v++instance ((:>:) PureNum) Rational where cast = NRational+instance ((:<:) PureNum) Rational where+    castBack (NDouble   x) = toRational x+    castBack (NRational x) = x+instance ((:>:) PureNum) Double where cast = NDouble+instance ((:<:) PureNum) Double where+    castBack (NDouble   x) = x+    castBack (NRational x) = fromRational x++instance ((:>:) PureInt) Integer where cast = IFinite+instance ((:<:) PureInt) Integer where+    castBack (IFinite i) = i+    castBack INotANumber = error "NaN"+    castBack (IInfinite SPositive) = error "+Infinity"+    castBack (IInfinite SNegative) = error "-Infinity"++instance ((:>:) PureInt) Int where cast = IFinite . toInteger +instance ((:<:) PureInt) Int where+    castBack (IFinite i) = fromInteger i+    castBack INotANumber = error "NaN"+    castBack (IInfinite SPositive) = error "+Infinity"+    castBack (IInfinite SNegative) = error "-Infinity"+type PureList = [Val] -- Seq (Either PureSeq PureRange) -- XXX - *very bogus*++newtype PureBit = MkBit Bool+    deriving (Typeable, Show, Eq, Ord, Data, (:>:) Bool, (:<:) Bool)++type PureStr = ByteString++data PureInt+    = IFinite      !Integer+    | IInfinite    !Sign+    | INotANumber+    deriving (Typeable, Show, Eq, Ord, Data)++data PureNum+    = NDouble   !Double              -- change to "!NativeDouble"+    | NRational !Rational+    deriving (Typeable, Show, Eq, Ord, Data)++data Sign+    = SPositive+    | SNegative+    deriving (Show, Eq, Ord, Data, Typeable)++-- | L<S02/"Undefined types">+data ValUndef+    = UUndef                      -- ^ "my $x"+    | UWhatever                   -- ^ "my $x = *"+    | UFailure  { f_err  :: !ID } -- ^ "my $x = fail 'oops'"+    | UProto    { p_meta :: !ID } -- ^ "my $x = Dog"+    deriving (Show, Eq, Ord, Data, Typeable)++instance Boxable ValUndef+instance Boxable PureInt+instance Boxable PureNum+instance Boxable PureSig+instance Boxable PureBit+instance Boxable ValCapt++instance Boxable Int+{-+module Pugs.Val (+    IValue(..), Val(..), ValUndef(..), ValNative, P,+    ICoercible(..), WHICH, castVal, formatVal,+    PureBit, PureBool, PureInt, PureNum, PureStr, PureList, itemVal, listVal,++    Table, Var(..),++    -- From Code+    Sig(..), SigParam(..), ParamAccess(..), ParamDefault(..),+    Capt(..), Feed(..), emptyFeed, Code(..),+    ValCapt, ValFeed,+) where+import Pugs.Internals+import Pugs.Class+import GHC.Exts+import Data.Generics.Basics hiding (cast)+import qualified Data.Typeable as Typeable+import qualified Data.ByteString as Buf+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Monoid++import Pugs.AST.SIO+import Pugs.Val.Base+--import Pugs.Val.Sig+--import Pugs.Val.Code+--import Pugs.Exp+import {-# SOURCE #-} Pugs.Exp+import qualified Pugs.Types as Types+import Pugs.Types (Var(..))++import Text.PrettyPrint -- move to Pugs.Val.Pretty?++-- XXX - Once GHC 6.6 is released with bindists, change #include to .hs-boot!+#include "Val/Code.hs"++{-|++This module contains the definition of the five variants for a Perl 6 value.+However, the actual constructors for each variant are abstract, and this module+does not provide concrete data type definitions beyond those five.++-}++-- | 'Val' represents what an unconstrained scalar container can hold.+data Val+    = VUndef  !ValUndef   -- ^ Values that are false on .defined      (WHICH = undef)+    | VNative !ValNative  -- ^ Values that can fit into an UArray     (WHICH = impl.dep.)+    | forall a. Pure a => VPure !a  -- ^ Values that are immutable    (WHICH = pureId)+    | forall a. Mut a  => VMut  !a  -- ^ In-memory mutable structures (WHICH = memory addr)+    | forall a. Ext a  => VExt  !a  -- ^ Input/Ouput handles          (WHICH = memory addr)+    deriving (Typeable)++castVal :: forall a m . (Monad m, Typeable a) => Val -> m a+--castVal = gmapQi 0 fromTypeable -- when we have 6.6, and can make all Val in Data.+castVal (VUndef v)  = fromTypeable v+castVal (VNative v) = fromTypeable v+castVal (VPure v)   = fromTypeable v+castVal (VMut v)    = fromTypeable v+castVal (VExt v)    = fromTypeable v++-- | Value view. Contains methods for inspecting values: getting+-- their metaclass, ids, stringification and so on.+class ICoercible m a => IValue m a where+    -- | lift an ASTish leaf type to a value. Using this convenience method+    -- you can say "val (NInt 42)" instead of "Val (VNative (NInt 42))".+    val         :: a -> Val+    -- | retrieve metaclass instance of a value.+    valMeta     :: a -> Class+    valMeta     = cast . takeTypeName "" . reverse . show . typeOf+        where+        -- Here we intuit "Str" from "Pugs.Val.Str.PureStr".+        takeTypeName acc [] = acc+        takeTypeName acc (x:xs)+            | isLower x = takeTypeName (x:acc) xs+            | otherwise = x:acc+    -- | Stringification of arbitrary values.+    valShow     :: a -> PureStr+    valShow _ = cast "<opaque>"+    -- | Identity.+    valId       :: a -> WHICH+    valId x = cast (NUint (W# (unsafeCoerce# x)))+    -- | Comparison.+    valCompare  :: a -> a -> Ordering+    valCompare x y = valId x `compare` valId y++instance ICoercible SIO Val where+    -- XXX - have to invent a generic map somehow -- DrIFT anyone?+    asBit VUndef{}      = cast False+    asBit (VNative x)   = cast $ asBit x+    asBit (VPure x)     = cast $ asBit x+    asBit (VMut x)      = cast $ asBit x+    asInt (VPure x)     = cast $ asInt x+    asNum (VPure x)     = cast $ asNum x+    asStr (VPure x)     = cast $ asStr x+    asItem = Just . itemVal+    asList = Just . listVal+    asNative (VPure x)  = cast $ asNative x++-- evaluate a Val in Item context, a.k.a. rvalue, a.k.a. "is readonly"+itemVal :: Val -> SIO Val+itemVal v@(VPure x) = f v x asItem+itemVal v@(VMut x)  = f v x asItem+itemVal v@(VExt x)  = f v x asItem+itemVal v           = return v++-- evaluate a Val in List context, a.k.a. flattening, a.k.a. "is slurpy"+listVal :: Val -> SIO PureList+listVal v@(VPure x) = f v x asList+listVal v@(VMut x)  = f v x asList+listVal v@(VExt x)  = f v x asList+listVal v           = cast v++f v x g = maybe (cast v) cast (g x)++instance ((:>:) PureList) Val where+    cast = singleton -- . Left . singleton++instance IValue SIO Val where+    val = id+    valId VUndef{}      = cast (NBit False)+    valId (VNative x)   = Just x+    valId (VPure x)     = valId x+    valId (VMut x)      = valId x+    valId (VExt x)      = valId x+    valCompare          = compare+    valMeta (VUndef x)  = cast . show . typeOf $ x+    valMeta (VNative x) = valMeta x+    valMeta (VPure x)   = valMeta x+    valMeta (VMut x)    = valMeta x+    valMeta (VExt x)    = valMeta x+    valShow             = cast . show++-- instance Pure PureStr where+--  pureId x = cast (cast x :: ByteString)++instance ((:>:) WHICH) NativeBuf where+    cast = cast . NBuf++instance ICoercible P ValNative where+    asNative = return . id++instance IValue P ValNative where+    val                 = VNative+    valMeta NBit{}      = cast "bit"+    valMeta NInt{}      = cast "int"+    valMeta NUint{}     = cast "uint"+    valMeta NBuf{}      = cast "buf"+    valMeta NNum{}      = cast "num"+    valMeta NComplex{}  = cast "complex"+    valCompare          = compare+    valShow             = cast . show+    valId x             = cast x++-- | 'WHICH' is an unique ID that distinguishes two @Val@s of the same type from each other.+type WHICH = Maybe ValNative++instance ((:>:) WHICH) ValNative where+    cast = Just++--------------------------------------------------------------------------------------++-- | L<S02/"Undefined types">+data ValUndef+    = UUndef                        -- ^ "my $x"+    | UWhatever                     -- ^ "my $x = *"+    | UFailure  { f_err  :: !WHICH } -- ^ "my $x = fail 'oops'"+    | UProto    { p_meta :: !WHICH } -- ^ "my $x = Dog"+    deriving (Show, Eq, Ord, Data, Typeable)++--------------------------------------------------------------------------------------+-- | Unboxed values.+data ValNative+    = NBit      !NativeBit      -- ^ 0+    | NInt      !NativeInt      -- ^ -3+    | NUint     !NativeUint     -- ^ 7+    | NBuf      !NativeBuf      -- ^ (a raw chunk of ints or uints)+    | NNum      !NativeNum      -- ^ 4.2+    | NComplex  !NativeComplex  -- ^ (45 - 9i)+    deriving (Show, Eq, Ord, Data, Typeable)++type NativeBit      = Bool+type NativeInt      = Int+type NativeUint     = Word+type NativeBuf      = ByteString+type NativeNum      = Float++-- Haskell's Complex type does not instantiate Ord and Data.+newtype NativeComplex = MkNComplex { unComplex :: Complex NativeNum }+    deriving (Show, Eq, Typeable)+instance Ord NativeComplex where+    compare = error "NativeComplex numbers cannot be ordered"+instance Data NativeComplex where+--  gunfold    = error "gunfold NativeComplex"+    toConstr   = error "toConstr NativeComplex"+    dataTypeOf = error "dataTypeOf NativeComplex"++--------------------------------------------------------------------------------------++-- | L<S02/"Immutable types">++-- | Pure values need not be in a monad, but we put them in the trivial+-- Identity so that they are at the same monadic depth as Mut and Ext.+type P = Identity+instance Typeable1 P++class (ICoercible P a, Ord a, Show a) => Pure a where+    purePretty :: a -> Doc+    purePretty = text . show++instance (ICoercible P a, Ord a, Show a) => Pure a where {}++liftP :: Monad m => P a -> m a+liftP = return . runIdentity++instance Pure a => IValue P a where+    val         = VPure+    valId       = liftP . asNative+    valShow     = cast . show+    valCompare  = compare++instance Mut a => IValue STM a where+    val         = VMut++instance Ext a => IValue SIO a where+    val         = VExt++class ICoercible STM a => Mut a where {}+instance ICoercible STM a => Mut a where {}++class ICoercible SIO a => Ext a where {}+instance ICoercible SIO a => Ext a where {}++-- type Class = PureStr -- XXX - Wrong++dynEq :: (Typeable a, Typeable b, Eq a) => a -> b -> Bool+dynEq x y = case Typeable.cast y of+    Just y' -> x == y'+    Nothing -> False++dynCompare :: forall a b ma mb. (IValue ma a, IValue mb b) => a -> b -> Ordering+dynCompare x y = case Typeable.cast y of+    Just y' -> valCompare x y'+    Nothing -> compare (show $ typeOf x) (show $ typeOf y)++{-+    = PBit       !PureBit+    | PInt       !PureInt+    | PStr       !PureStr+    | PNum       !PureNum+    | PComplex   !PureComplex+    | PBool      !PureBool+    | PException !PureException -- XXX+    | PCode      !PureCode+    | PBlock     !PureCode -- XXX: or more primitive type?+    | PList      !PureList+    | PSeq       !PureSeq+    | PRange     !PureRange+    | PSet       !PureSet+    | PJunc      !PureJunc+    | PPair      !PurePair+    | PMap       !PureMap+    | PSig       !PureSig+    | PCap       !PureCap +    deriving (Show, Eq, Ord, Data, Typeable) {-!derive: YAML_Pos, Perl6Class, MooseClass!-}++-}+type PureBool       = Bool+type PureException  = ()            -- XXX *very* bogus+type PureCode       = ()            -- XXX *very* bogus+type PureCap        = ()+type PureSet        = Set Val+type PureSeq        = Seq Val+type PureComplex    = ()+type PureRange      = ()+type PureJunc       = ()+type PurePair       = ()+type PureMap        = ()++{-+--------------------------------------------------------------------------------------+-- | L<S02/"Mutable types"> minus IO types+--   Computations on these types take place in the STM monad.+data ValMut+    = MScalar    !MutScalar+    | MArray     !MutArray+    | MHash      !MutHash+    | MBuf       !MutBuf+    | MRoutine   !MutRoutine+    | MSub       !MutRoutine -- ?+    | MMethod    !MutRoutine -- ?+    | MSubmethod !MutRoutine -- ?+    | MMacro     -- ???+    | MRegex     !MutVRule -- XXX: maybe move to pure+    | MMatch     !MutVMatch+    | MPackage   !MutPackage+    | MModule    !MutModule+    | MClass     !MutClass+    | MRole      !MutRole+    | MGrammar   !MutGrammar+    | MObject    !MutObject  -- ? or ObjectId?+    | MForeign   !MutDynamic -- ...?+    deriving (Show, Eq, Ord, Data, Typeable) {-!derive: YAML_Pos, Perl6Class, MooseClass!-}+-}++--------------------------------------------------------------------------------------+{-+-- | Obviously side-effectual types such as file handles.+--   Computations on these types must take place in the IO monad.+data ValExt+    = IFile     !ExtFile     -- ^ File handle+    | ISocket   !ExtSocket   -- ^ Socket handle+    | IThread   !ExtThread   -- ^ Thread handle+    | IProcess  !ExtProcess  -- ^ Process handle+    deriving (Show, Eq, Ord, Data, Typeable) {-!derive: YAML_Pos, Perl6Class, MooseClass!-}+-}++type ExtFile         = ()+type ExtSocket       = ()+type ExtThread       = ()+type ExtProcess      = ()++--------------------------------------------------------------------------------------++-- | General purpose mapping from identifiers to values.+type Table = Map.Map ID Val+++{- Pad -}+{-|+A 'Pad' keeps track of the names of all currently-bound symbols, and+associates them with the things they actually represent.++It is represented as a mapping from names to /lists/ of bound items.+This is to allow for multi subs, because we will need to keep+/multiple/ subs associated with one symbol. In other cases, the list+should just contain a single value. See 'Pugs.AST.genSym' and 'Pugs.AST.genMultiSym' for+more details.++@TVar@ indicates that the mapped-to items are STM transactional variables.++Pads are stored in the current 'Code', and lexical lookups proceed through+progressively outer scopes until an item is found. For dynamic variables+(e.g., "our"), the pad holding the items is located in the package.+-}++newtype Pad = MkPad { padEntries :: Map.Map Var PadEntry }+    deriving (Show, Eq, Ord, Data, Typeable) {-!derive: YAML_Pos, Perl6Class, MooseClass!-}++newtype EntryStorage = MkStorage { s_cell :: TVar Val }+    deriving (Data, Typeable) {-!derive: YAML_Pos, Perl6Class, MooseClass!-}+instance Show EntryStorage where+    show _ = error "can't show EntryStorage"+instance Ord EntryStorage where+    compare _ = error "can't compare EntryStorage"+instance Eq EntryStorage where+    (==) = error "can't equate EntryStorage"++data EntryDeclarator+    = DeclMy+    | DeclOur+    | DeclHas+    | DeclState+    | DeclConstant+    deriving (Show, Eq, Ord, Data, Typeable) {-!derive: YAML_Pos, Perl6Class, MooseClass!-}++data PadEntry = MkEntry+    { e_declarator :: EntryDeclarator   -- ^ my etc.+    , e_storage    :: EntryStorage      -- ^ stored value+    }+    deriving (Show, Eq, Ord, Data, Typeable) {-!derive: YAML_Pos, Perl6Class, MooseClass!-}++--------------------------------------------------------------------------------------++-- type Var = Types.Var+{- Variable specification. This belongs in an AST .hs file, not here but until+ - it finds its home we will give it boarding.+ - XXX - Augment Pugs.Types.Var to reason about caller/outer, not here! -}++ {-+data Var+    = VarLexical+        { v_name        :: ID+        , v_callerCount :: Int+        , v_outerCount  :: Int+        }+    | VarDynamic+        { v_name        :: ID+        , v_packageName :: [ID]+        }+    | VarMagic+        { v_magic       :: Magic+        }+    deriving (Show, Eq, Ord, Data, Typeable) {-!derive: YAML_Pos, Perl6Class, MooseClass!-}+    -}++data Magic+    = MOS               -- ^ $?OS        Which os am I compiled for?+    | MOSVer            -- ^ $?OSVER     Which os version am I compiled for?+    | MPerlVer          -- ^ $?PERLVER   Which Perl version am I compiled for?+    | MFile             -- ^ $?FILE      Which file am I in?+    | MLine             -- ^ $?LINE      Which line am I at?+    | MScalarPackage    -- ^ $?PACKAGE   Which package am I in?+    | MArrayPackages    -- ^ @?PACKAGE   Which packages am I in?+    | MScalarModule     -- ^ $?MODULE    Which module am I in?+    | MArrayModules     -- ^ @?MODULE    Which modules am I in?+    | MScalarClass      -- ^ $?CLASS     Which class am I in? (as variable)+    | MArrayClasses     -- ^ @?CLASS     Which classes am I in?+    | MScalarRole       -- ^ $?ROLE      Which role am I in? (as variable)+    | MArrayRoles       -- ^ @?ROLE      Which roles am I in?+    | MScalarGrammar    -- ^ $?GRAMMAR   Which grammar am I in?+    | MArrayGrammars    -- ^ @?GRAMMAR   Which grammars am I in?+    | MParser           -- ^ $?PARSER    Which Perl grammar was used to+                        -- ^                   parse this statement?+    | MScalarRoutine    -- ^ &?ROUTINE   Which routine am I in?+    | MArrayRoutines    -- ^ @?ROUTINE   Which routines am I in?+    | MScalarBlock      -- ^ &?BLOCK     Which block am I in?+    | MArrayBlocks      -- ^ @?BLOCK     Which blocks am I in?+    deriving (Show, Eq, Ord, Data, Typeable) {-!derive: YAML_Pos, Perl6Class, MooseClass!-}++--------------------------------------------------------------------------------------+formatVal :: Val -> Doc+formatVal (VUndef v) = text $ case v of+    (UUndef)     -> "undef"+    (UWhatever)  -> "{whatever}"+    (UFailure x) -> "{failure:" ++ (show x) ++ "}" -- what we really want is to port Pretty to fps+    (UProto x)   -> "{proto:" ++ (show x) ++ "}"+formatVal (VNative v) = text $ case v of+    (NBit x)     -> if x then "True" else "False"+    (NInt x)     -> show x+    (NUint x)     -> show x+    (NBuf _)     -> "{Buf}"+    (NNum x)     -> show x+    (NComplex (MkNComplex x)) -> (show "(") ++ (show $ realPart x) ++ " " +++        (if (0 >) (imagPart x) then "- " ++ (show $ 0 - imagPart x) else "+ " ++ (show $ imagPart x)) ++ "*Math::i)"+formatVal (VPure v) = purePretty v+formatVal x = text $ show x++--    (NComplex r i(s@i')) -> "(" ++ (show r) ++ " " +++--        (if s == '-' then ("- " ++ show i') else ("+ " ++ show i)) ++ "*i)"+--formatVal (VPure v) = runIdentity+--------------------------------------------------------------------------------------++{-* Generated by DrIFT : Look, but Don't Touch. *-}+instance Show Val where+    showsPrec d (VUndef aa) = showParen (d >= 10)+              (showString "VUndef" . showChar ' ' . showsPrec 10 aa)+    showsPrec d (VNative aa) = showParen (d >= 10)+              (showString "VNative" . showChar ' ' . showsPrec 10 aa)+    showsPrec d (VPure aa) = showParen (d >= 10)+              (showString "VPure (" . showsPrec 10 aa . showChar ')')+    showsPrec d (VMut aa) = showParen (d >= 10)+              (showString "VMut (" . (cast(valShow aa) ++) . showChar ')')+    showsPrec d (VExt aa) = showParen (d >= 10)+              (showString "VExt (" . (cast(valShow aa) ++) . showChar ')')++instance Eq Val where+    (VUndef aa)  == (VUndef aa')    = aa == aa'+    (VNative aa) == (VNative aa')   = aa == aa'+    (VPure aa)   == (VPure aa')     = dynEq aa aa'+    (VMut aa)    == (VMut aa')      = valId aa == valId aa'+    (VExt aa)    == (VExt aa')      = valId aa == valId aa'+    _            == _               = False++instance Ord Val where+    compare (VUndef aa) (VUndef aa') = compare aa aa'+    compare (VUndef _) (VNative _) = LT+    compare (VUndef _) (VPure _) = LT+    compare (VUndef _) (VMut _) = LT+    compare (VUndef _) (VExt _) = LT+    compare (VNative _) (VUndef _) = GT+    compare (VNative aa) (VNative aa') = compare aa aa'+    compare (VNative _) (VPure _) = LT+    compare (VNative _) (VMut _) = LT+    compare (VNative _) (VExt _) = LT+    compare (VPure _) (VUndef _) = GT+    compare (VPure _) (VNative _) = GT+    compare (VPure aa) (VPure aa') = dynCompare aa aa'+    compare (VPure _) (VMut _) = LT+    compare (VPure _) (VExt _) = LT+    compare (VMut _) (VUndef _) = GT+    compare (VMut _) (VNative _) = GT+    compare (VMut _) (VPure _) = GT+    compare (VMut aa) (VMut aa') = dynCompare aa aa'+    compare (VMut _) (VExt _) = LT+    compare (VExt _) (VUndef _) = GT+    compare (VExt _) (VNative _) = GT+    compare (VExt _) (VPure _) = GT+    compare (VExt _) (VMut _) = GT+    compare (VExt aa) (VExt aa') = dynCompare aa aa'+++-}
+ src/Pugs/Val/Base.hs view
@@ -0,0 +1,144 @@+{-# OPTIONS_GHC -fglasgow-exts -fallow-overlapping-instances -funbox-strict-fields -fallow-undecidable-instances #-}++module Pugs.Val.Base where++_ValBaseStub :: ()+_ValBaseStub = ()++{-+import qualified UTF8 as UTF8++import Pugs.Internals+import Pugs.Class+import {-# SOURCE #-} Pugs.Val++++-- Goal: associate each builtin type with prim methods (that handles native monotypes)+--       its metaclass then get those as the initial method slots+--       still have to maintain a list of builtin bootstrap classes somewhere+--       but everything else can be reflected via Coercible+--+-- Plan: Each prim type has a static fixed meta class++class (Monad m, Functor m, Typeable a) => ICoercible m a | a -> m where+    asBit    :: a -> m PureBit+    asBit _ = return $ cast True+    asInt    :: a -> m PureInt+    asInt x = fail $ "coerce fail: " ++ (show $ typeOf x) ++ " to PureInt"+    asNum    :: a -> m PureNum+    asNum x = fail $ "coerce fail: " ++ (show $ typeOf x) ++ " to PureNum"+    asStr    :: a -> m PureStr+    asStr _ = return (cast "<opaque>") -- XXX wrong+    -- "$item = VAL"+    asItem   :: a -> Maybe (m Val)+    asItem _ = Nothing -- default = do nothing (for Scalar this would return its content)+    -- "@list = VAL"+    asList   :: a -> Maybe (m PureList)+    asList _ = Nothing -- default = do nothing (for Scalar this would return its content wrapped in a 1-seq)+    asNative :: a -> m ValNative+    asNative = fmap (NBuf . cast) . asStr+    classOf :: a -> MI m+    fromObj :: Invocant m -> m a++type PureList       = Seq Val -- Seq (Either PureSeq PureRange) -- XXX - *very bogus*++-- PureBit++instance ((:>:) PureBit) Bool where cast = MkBit+instance ((:<:) PureBit) Bool where castBack (MkBit i) = i++newtype PureBit = MkBit Bool+    deriving (Typeable, Show, Eq, Ord, Data, (:>:) Bool, (:<:) Bool)++instance ICoercible P PureBit where asBit = return . cast++-- PureInt++instance ((:>:) PureInt) Integer where cast = IFinite+instance ((:<:) PureInt) Integer where+    castBack (IFinite i) = i+    castBack INotANumber = error "NaN"+    castBack (IInfinite SPositive) = error "+Infinity"+    castBack (IInfinite SNegative) = error "-Infinity"++instance ((:>:) PureInt) Int where cast = IFinite . toInteger +instance ((:<:) PureInt) Int where+    castBack (IFinite i) = fromInteger i+    castBack INotANumber = error "NaN"+    castBack (IInfinite SPositive) = error "+Infinity"+    castBack (IInfinite SNegative) = error "-Infinity"++data Sign+    = SPositive+    | SNegative+    deriving (Show, Eq, Ord, Data, Typeable)++data PureInt+    = IFinite      !Integer+    | IInfinite    !Sign+    | INotANumber+    deriving (Typeable, Show, Eq, Ord, Data)++instance ICoercible P PureInt where+    asInt = return . cast+    asStr INotANumber           = cast "NaN"+    asStr (IInfinite SPositive) = cast "Inf"+    asStr (IInfinite SNegative) = cast "-Inf"+    asStr (IFinite n)           = cast (show n)+    asNum INotANumber           = return $ cast ( (0/0) :: Double)+    asNum (IInfinite SPositive) = return $ cast ( (1/0) :: Double)+    asNum (IInfinite SNegative) = return $ cast ((-1/0) :: Double)+    asNum (IFinite   n)         = return $ cast ((fromIntegral n) :: Double)++-- PureNum++instance ((:>:) PureNum) Double where cast = NDouble+instance ((:<:) PureNum) Double where+    castBack (NDouble   x) = x+    castBack (NRational x) = fromRational x++instance ((:>:) PureNum) Rational where cast = NRational+instance ((:<:) PureNum) Rational where+    castBack (NDouble   x) = toRational x+    castBack (NRational x) = x++instance ((:>:) PureNum) Int where cast = NRational . fromIntegral++data PureNum+    = NDouble   !Double              -- change to "!NativeDouble"+    | NRational !Rational+    deriving (Typeable, Show, Eq, Ord, Data)++instance ICoercible P PureNum where asNum = return . cast++-- PureStr++newtype PureStr = MkStr { unStr :: ByteString } deriving+    ( Typeable, Show, Eq, Ord, Data+    , (:>:) ID, (:<:) ID+    , (:>:) String, (:<:) String+    , (:>:) ByteString, (:<:) ByteString+    )++parseInt :: PureStr -> Int+parseInt (MkStr s) = maybe 0 fst (UTF8.readInt s)++instance (Typeable1 m, Ord a, ICoercible m a) => Boxable m a where+    fromObjBox = fromObj+    classOfBox = classOf++instance ICoercible P PureStr where+    asBit (MkStr s)+        | UTF8.null s = return $ cast False+        | otherwise  = return $ cast (UTF8.head s /= '0') -- 0x30+    asStr = cast+    asNum = cast . parseInt -- XXX - wrong+    asInt = cast . parseInt+    fromObj (MkInvocant x _) = fromTypeable x+    classOf _ = mkBoxClass "Str"+        [ "reverse"    ... (MkStr . UTF8.reverse . unStr)+        ]+++-}
+ src/Pugs/Val/Capture.hs view
@@ -0,0 +1,2 @@+module Pugs.Val.Capture (module MO.Capture) where+import MO.Capture
+ src/Pugs/Val/Code.hs view
@@ -0,0 +1,253 @@+{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances -fallow-overlapping-instances -fno-warn-missing-methods #-}+module Pugs.Val.Code where+import Pugs.Internals+import Pugs.Types+-- import Pugs.Val.Base+-- import Pugs.Val.Capture+import Pugs.Class+import Text.PrettyPrint+import Data.Monoid+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Pugs.Types as Types++import {-# SOURCE #-} Pugs.Exp+++type Code = ()+type Table = Map ID Val++{-+-- | AST for a primitive Code object+data Code+    = CodePerl+        { c_signature         :: Sig+        , c_precedence        :: Rational+        , c_assoc             :: CodeAssoc+        , c_isRW              :: Bool+        , c_isSafe            :: Bool+        , c_isCached          :: Bool+        , c_body              :: CodeBody  -- ^ AST of "do" block+        , c_pad               :: Pad       -- ^ Storage for lexical vars+        , c_traits            :: Table     -- ^ Any additional trait not+                                           --   explicitly mentioned below+        , c_preBlocks         :: [Code]    -- ^ DBC hooks: pre(\$args --> Bool) +        , c_postBlocks        :: [Code]+        , c_enterBlocks       :: [Code]    -- ^ AOPish hooks+        , c_leaveBlocks       :: [CodeLeave]+        , c_firstBlocks       :: [Code]+        , c_lastBlocks        :: [Code]+        , c_nextBlocks        :: [Code]+        , c_catchBlock        :: Maybe Code+        , c_controlBlock      :: Maybe Code+        }+    | CodePrim+        { c_signature         :: Sig+        , c_precedence        :: Rational+        , c_assoc             :: CodeAssoc+        , c_isRW              :: Bool+        , c_isSafe            :: Bool+        }+    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos, Perl6Class, MooseClass!-}++-- | Block exit traits may be interleaved, so tag them by type+data CodeLeave+    = LeaveNormal Code        -- ^ LEAVE block+    | LeaveKeep   Code        -- ^ KEEP block+    | LeaveUndo   Code        -- ^ UNDO block+    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos, Perl6Class, MooseClass!-}++-- | Function associtivity+data CodeAssoc+    = AssLeft+    | AssRight+    | AssNon+    | AssChain+    | AssList+    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos, Perl6Class, MooseClass!-}++--------------------------------------------------------------------------------------+-}++-- | AST for function signature. Separated to method and function variants+--   for ease of pattern matching.+data Sig = MkSig+    { s_invocant                  :: Maybe Param+    , s_requiredPositionalCount   :: Int+    , s_requiredNames             :: Set ID+    , s_positionalList            :: [Param]+    , s_namedSet                  :: Map.Map ID Param+    , s_slurpyScalarList          :: [Param]+    , s_slurpyArray               :: Maybe Param+    , s_slurpyHash                :: Maybe Param+    , s_slurpyCode                :: Maybe Param+    , s_slurpyCapture             :: Maybe Param+    }+    deriving (Eq, Ord, Typeable) {-!derive: YAML_Pos, Perl6Class, MooseClass!-}++type PureSig = Sig++-- | Single parameter for a function or method, e.g.:+--   Elk $m where { $m.antlers ~~ Velvet }+{-|+A formal parameter of a sub (or other callable).++These represent declared parameters; don't confuse them with actual argument+values.+-}+data SigParam = MkParam+    { p_variable    :: Var           -- ^ E.g. $m above+    , p_types       :: [Types.Type]  -- ^ Static pieces of inferencer-food+                                     --   E.g. Elk above+    , p_constraints :: [Code]        -- ^ Dynamic pieces of runtime-mood+                                     --   E.g. where {...} above+    , p_unpacking   :: Maybe PureSig -- ^ E.g. BinTree $t (Left $l, Right $r)+    , p_default     :: ParamDefault  -- ^ E.g. $answer? = 42+    , p_label       :: ID            -- ^ The external name for the param ('m' above)+    , p_slots       :: Table         -- ^ Any additional attrib not+                                     --   explicitly mentioned below+    , p_hasAccess   :: ParamAccess   -- ^ is ro, is rw, is copy+    , p_isRef       :: Bool          -- ^ must be true if hasAccess = AccessRW+    , p_isContext   :: Bool          -- ^ "is context"+    , p_isLazy      :: Bool+    }+    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos, Perl6Class, MooseClass!-}++type Param = SigParam -- to get around name clashes in Pugs.AST :(++paramWhatever :: Param+paramWhatever = MkParam+    { p_variable    = varNullScalar+    , p_types       = []+    , p_constraints = []+    , p_unpacking   = Nothing+    , p_default     = MkParamDefault Nothing+    , p_label       = nullID+    , p_slots       = Map.empty+    , p_hasAccess   = AccessRO+    , p_isRef       = False+    , p_isContext   = False+    , p_isLazy      = False+    }++instance Monoid Sig where+    mempty  = sigEmpty+    mappend = sigAppend++sigEmpty, sigWhatever :: Sig+sigEmpty = MkSig+    { s_invocant                  = Nothing+    , s_requiredPositionalCount   = 0+    , s_requiredNames             = Set.empty+    , s_positionalList            = []+    , s_namedSet                  = Map.empty+    , s_slurpyScalarList          = []+    , s_slurpyArray               = Nothing+    , s_slurpyHash                = Nothing+    , s_slurpyCode                = Nothing+    , s_slurpyCapture             = Nothing+    }++sigWhatever = sigEmpty{ s_slurpyCapture = Just paramWhatever }++sigAppend :: Sig -> Sig -> Sig+sigAppend x y+    | x == y = x+    | sigIsMethod x `xor` sigIsMethod y+    = orz             -- "incompatible Signature: method and nonmenthod"+    | s_requiredPositionalCount x /= s_requiredPositionalCount y+    = orz             -- "incompatible Signature: arity mismatch: positionals" -- XXX WRONG: ?-floating+    | (Set.size . s_requiredNames) x /= (Set.size . s_requiredNames) y+    = orz             -- "incompatible Signature: arity mismatch: nameds"+    where+    orz = sigWhatever+    xor True False = True+    xor False True = True+    xor _     _    = False++sigIsMethod :: Sig -> Bool+sigIsMethod MkSig{ s_invocant = Nothing } = False+sigIsMethod _                             = True++newtype CodeBody = MkCodeBody [Stmt]+    deriving (Typeable)++newtype ParamDefault = MkParamDefault { unDefault :: Maybe Exp }+    deriving (Typeable)++instance Eq ParamDefault where _ == _ = True+instance Ord ParamDefault where compare _ _ = EQ+instance Show ParamDefault where+    show MkParamDefault{ unDefault = Nothing } = "<ParamDefault:Nothing>"+    show _    = "<ParamDefault:Just<Exp>>"++instance Eq CodeBody where _ == _ = True+instance Ord CodeBody where compare _ _ = EQ+instance Show CodeBody where show _ = "<Code.Body>"++data ParamAccess+    = AccessRO+    | AccessRW+    | AccessCopy+    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos, Perl6Class, MooseClass!-}++{-+instance ICoercible P Sig where+    asStr = return . cast . render . purePretty++instance Pure Sig where+-}++instance Show Sig where+   show = render . (colon <>) . parens . prettySig++prettySig :: Sig -> Doc+prettySig s@MkSig{s_invocant = Just i} = invocant <> colon `invSpace` (prettySubSig s)+    where+    invocant = if (v_name $ p_variable $ i) == nullID then text "$ " else prettyParam i True True+    invSpace :: Doc -> Doc -> Doc+    invSpace = if (isEmpty $ prettySubSig s) then (<>) else (<+>)+prettySig s = prettySubSig s++prettySubSig :: Sig -> Doc+prettySubSig s = sep $ punctuate comma $ concat [posParams, namedParams]+    where+    posParams = [prettyParam p r True | p <- (s_positionalList s) | r <- (replicate (s_requiredPositionalCount s) True) ++ repeat False]+    namedParams = [prettyParam p (isReqNamed n) False | (n, p) <- Map.toList $ s_namedSet s]+    isReqNamed n = Set.member n $ s_requiredNames s++prettyParam :: Param -> Bool -> Bool -> Doc+prettyParam p isReq isPos = sep [ staticTypes, varDecl, defaultVal, traits, unpacking, constraints, debugDump ]+    where+    varDecl = varName <> defaultHint+    varName+        | isPos = text (cast $ p_variable p)+        | v_name (p_variable p) == p_label p = text $ ":" ++ (cast $ p_variable p)+        | otherwise = text ":" <> text (cast $ p_label p) <> (parens $ text (cast $ p_variable p))+    staticTypes = hsep $ map (text . Types.showType) $ p_types p+    defaultHint = if not isReq && not haveDefault then text "?" else empty+    defaultExp  = fromJust .  unDefault $ p_default p+    haveDefault = isJust . unDefault $ p_default p+    defaultVal  = if haveDefault then equals <+> prettyExp defaultExp else empty+    traits      = sep [acc, ref, lazy, slots]+    unpacking   = case p_unpacking p of+        (Just s)   -> prettySig s+        _          -> empty+    acc         = case p_hasAccess p of+        AccessRO   -> empty+        AccessRW   -> text "is rw"+        AccessCopy -> text "is copy"+    ref         = if p_isRef  p then text "is ref"  else empty+    lazy        = if p_isLazy p then text "is lazy" else empty+    -- slots = hsep [text ("is " ++ (cast aux)) <+> text "..." | (aux, val) <- Map.toList $ p_slots p] XXX: for when traits have args+    slots       = hsep [text ("is " ++ (cast $ fst trait)) | trait <- Map.toList $ p_slots p]+    constraints = hsep $ replicate (length $ p_constraints p) (text "where {...}")+    debugDump   = if True then empty else braces $ text $ show p -- XXX delme+--------------------------------------------------------------------------------------++-- | Runtime Capture with dynamic Exp for leaves+--type ExpCapt = Capt Exp+-- | Static Capture with Val for leaves+type ValCapt = Capt Val+type ValFeed = Feed Val+
+ src/Pugs/Version.hs view
@@ -0,0 +1,43 @@+{-# OPTIONS_GHC -fglasgow-exts -cpp #-}++{-|+    Version information.++>   Tree and flower and leaf and grass,+>   Let them pass! Let them pass!+>   Hill and water under sky,+>   Pass them by! Pass them by!++-}++-- #include "pugs_config.h"+-- #include "pugs_version.h"++#ifndef PUGS_VERSION+#define PUGS_VERSION "6.2.13.1"+#endif+#ifndef PUGS_DATE+#define PUGS_DATE "June 22, 2008"+#endif+#ifndef PUGS_SVN_REVISION+#define PUGS_SVN_REVISION 0+#endif++module Pugs.Version (+    name, versnum, date, version, copyright, revnum, revision,+) where++name, versnum, date, version, copyright, revnum, revision :: String++name       = "Perl6 User's Golfing System"+versnum    = PUGS_VERSION+date       = PUGS_DATE+version    = name ++ ", version " ++ versnum ++ ", " ++ date ++ revision+copyright  = "Copyright 2005-2007, The Pugs Contributors"+revnum     = show (PUGS_SVN_REVISION :: Integer)+revision+    | rev <- revnum+    , rev /= "0"+    = " (r" ++ rev ++ ")"+    | otherwise+    = ""