packages feed

berp (empty) → 0.0.1

raw patch · 69 files changed

+5033/−0 lines, 69 filesdep +arraydep +basedep +containerssetup-changed

Dependencies added: array, base, containers, directory, extensible-exceptions, filepath, ghc, ghc-paths, ghc-prim, haskeline, haskell-src-exts, integer, language-python, monads-tf, parseargs, process, template-haskell, transformers

Files

+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2009-2010 Bernard James Pope (also known as Bernie Pope).++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT OWNER OR+CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ berp.cabal view
@@ -0,0 +1,113 @@+name:                berp+version:             0.0.1+cabal-version:       >= 1.6+synopsis:            An implementation of Python 3. +description:         Berp is an implementation of Python 3, written in Haskell.+                     It provides a compiler and an interpreter. In both cases+                     the input Python program is translated into Haskell code.+                     The compiler turns the Haskell code into machine code.+                     The interpreter runs the Haskell code immediately via+                     the GHCi interpreter. The user interface of the interpreter+                     imitates the one provided by CPython.+category:            Language+license:             BSD3+license-file:        LICENSE+copyright:           (c) 2010 Bernard James Pope+author:              Bernard James Pope (Bernie Pope)+maintainer:          florbitous@gmail.com +homepage:            http://wiki.github.com/bjpop/berp/  +build-type:          Simple+stability:           experimental+tested-with:         GHC==6.10.4 +extra-source-files:  src/include/BerpDebug.h++Executable berp+  ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-orphans+  main-is:+      Main.hs+  hs-source-dirs:+      src, +      src/Berp/+  build-depends:   +      base == 4.*,+      monads-tf == 0.1.*,+      transformers == 0.2.*,+      containers == 0.2.*,+      language-python == 0.3.*,+      haskell-src-exts == 1.9.*,+      parseargs == 0.1.*,+      process == 1.0.*,+      filepath == 1.1.*,+      directory == 1.0.*,+      ghc >= 6.10.4,+      haskeline == 0.6.*,+      ghc-paths == 0.1.*,+      extensible-exceptions == 0.1.*+  other-modules:+      Berp.Compile.Compile+      Berp.Compile.IdentString+      Berp.Compile.Monad+      Berp.Compile.HsSyntaxUtils+      Berp.Compile.PySyntaxUtils+      Berp.Compile.PrimName+      Berp.Compile.Utils+      Berp.Compile.VarSet+      Berp.Interpreter.Input+      Berp.Interpreter.Monad+      Berp.Interpreter.Repl++Library+   ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-orphans+   include-dirs:+       src/include +   hs-source-dirs:+       src+   build-depends:+       base,+       monads-tf,+       transformers,+       containers,+       ghc-prim,+       integer,+       template-haskell,+       array+   exposed-modules:+      Berp.Base+      Berp.Base.Hash+      Berp.Base.Mangle+      Berp.Version+   other-modules:+      Berp.Base.Attributes+      Berp.Base.Builtins+      Berp.Base.Builtins.Constants+      Berp.Base.Builtins.Exceptions+      Berp.Base.Builtins.Functions+      Berp.Base.Builtins.Utils+      Berp.Base.Class+      Berp.Base.ControlStack+      Berp.Base.Exception+      Berp.Base.ExitCodes+      Berp.Base.HashTable+      Berp.Base.Ident +      Berp.Base.Identity+      Berp.Base.LiftedIO+      Berp.Base.Monad+      Berp.Base.Object+      Berp.Base.Operators+      Berp.Base.Prims+      Berp.Base.SemanticTypes+      Berp.Base.StdNames+      Berp.Base.StdTypes.Bool+      Berp.Base.StdTypes.Dictionary+      Berp.Base.StdTypes.Function+      Berp.Base.StdTypes.Generator+      Berp.Base.StdTypes.Integer+      Berp.Base.StdTypes.List+      Berp.Base.StdTypes.None+      Berp.Base.StdTypes.Object+      Berp.Base.StdTypes.ObjectBase+      Berp.Base.StdTypes.String+      Berp.Base.StdTypes.Tuple+      Berp.Base.StdTypes.Type+      Berp.Base.Truth+      Berp.Base.Unique
+ src/Berp/Base.hs view
@@ -0,0 +1,37 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Base+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com +-- Stability   : experimental+-- Portability : ghc+--+-- This module exports all the primitive functions which are needed by+-- the compiled programs. Avoid putting extraneous exports in this file+-- because it is imported by all compiled programs.+--+-----------------------------------------------------------------------------++module Berp.Base+   ( module Builtins, int, none, string, true, false, def, lambda, (=:), stmt, ifThenElse, ret, pass, break+   , continue, while, whileElse, for, forElse, ifThen, (@@), tailCall, tuple, read, var+   , (%), (+), (-), (*), (.), (/), (==), (<), (>), (<=), (>=), and, or, klass, setattr, list, dictionary+   , subs, try, tryElse, tryFinally, tryElseFinally, except, exceptDefault, raise, reRaise, raiseFrom+   , pure, pureObject, yield, mkGenerator, unaryMinus, unaryPlus, invert, runStmt, runExpr, interpretStmt+   , topVar)+   where++import Berp.Base.Builtins as Builtins+import Prelude hiding (break, (+), (-), (*), (.), (/), (==), (<), (>), (<=), (>=), and, or, read)+import Berp.Base.Prims ((=:), stmt, ifThenElse, ret, pass, break, continue, while, whileElse, for, forElse, ifThen, (@@), tailCall, read, var, setattr, subs, try, tryElse, tryFinally, tryElseFinally, except, exceptDefault, raise, reRaise, raiseFrom, yield, def, lambda, mkGenerator, topVar, pure, pureObject)+import Berp.Base.Operators ((%), (+), (-), (*), (.), (/), (==), (<), (>), (<=), (>=), and, or, unaryMinus, unaryPlus, invert)+import Berp.Base.Monad (runExpr, runStmt, interpretStmt)+import Berp.Base.Class (klass)+import Berp.Base.StdTypes.Integer (int)+import Berp.Base.StdTypes.Tuple (tuple)+import Berp.Base.StdTypes.Bool (true, false)+import Berp.Base.StdTypes.String (string)+import Berp.Base.StdTypes.None (none)+import Berp.Base.StdTypes.List (list)+import Berp.Base.StdTypes.Dictionary (dictionary)
+ src/Berp/Base/Attributes.hs view
@@ -0,0 +1,32 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Base.Attributes+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- Build a dictionary of the attributes of an object from a list of +-- pairs containing the hashed name of the attribute and the corresponding +-- value.+--+-----------------------------------------------------------------------------++module Berp.Base.Attributes (mkAttributes) where++import Berp.Base.SemanticTypes (Object (..))+import Berp.Base.HashTable (stringTableFromList)+import Berp.Base.Hash (Hashed)+import Berp.Base.Identity (newIdentity)+import Berp.Base.LiftedIO (MonadIO)++mkAttributes :: MonadIO m => [(Hashed String, Object)] -> m Object+mkAttributes list = do+   hashTable <- stringTableFromList list +   identity <- newIdentity+   return $ +      Dictionary  +      { object_identity = identity+      , object_hashTable = hashTable +      }
+ src/Berp/Base/Builtins.hs view
@@ -0,0 +1,27 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Base.Builtins+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- A common export point for the builtin functions.+--+-----------------------------------------------------------------------------++module Berp.Base.Builtins +   ( module Exceptions, module Functions, module Constants )+   where++import Berp.Base.Builtins.Constants as Constants +   (_s_object, _s_type)+import Berp.Base.Builtins.Functions as Functions +   (_s_print, _s_dir, _s_input, _s_id, _s_callCC)+import Berp.Base.Builtins.Exceptions as Exceptions +   ( baseException, _s_BaseException+   , exception, _s_Exception+   , stopIteration, _s_StopIteration+   , typeError, _s_TypeError+   , nameError, _s_NameError )
+ src/Berp/Base/Builtins/Constants.hs view
@@ -0,0 +1,27 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Base.Builtins.Constants+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- Constant builtin values (typically constant objects).+--+-----------------------------------------------------------------------------++module Berp.Base.Builtins.Constants+   (_s_object, _s_type)+   where++import Berp.Base.SemanticTypes (ObjectRef)+import Berp.Base.Builtins.Utils (primConstant)+import Berp.Base.StdTypes.Object (object)+import Berp.Base.StdTypes.Type (typeClass)++_s_object :: ObjectRef              +_s_object = primConstant object++_s_type :: ObjectRef+_s_type = primConstant typeClass
+ src/Berp/Base/Builtins/Exceptions.hs view
@@ -0,0 +1,120 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Base.Builtins.Exceptions+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- Standard Python exception classes.+--+-----------------------------------------------------------------------------++{-++From http://docs.python.org/dev/3.0/library/exceptions.html++BaseException+ +-- SystemExit+ +-- KeyboardInterrupt+ +-- GeneratorExit+ +-- Exception+      +-- StopIteration+      +-- ArithmeticError+      |    +-- FloatingPointError+      |    +-- OverflowError+      |    +-- ZeroDivisionError+      +-- AssertionError+      +-- AttributeError+      +-- BufferError+      +-- EnvironmentError+      |    +-- IOError+      |    +-- OSError+      |         +-- WindowsError (Windows)+      |         +-- VMSError (VMS)+      +-- EOFError+      +-- ImportError+      +-- LookupError+      |    +-- IndexError+      |    +-- KeyError+      +-- MemoryError+      +-- NameError+      |    +-- UnboundLocalError+      +-- ReferenceError+      +-- RuntimeError+      |    +-- NotImplementedError+      +-- SyntaxError+      |    +-- IndentationError+      |         +-- TabError+      +-- SystemError+      +-- TypeError+      +-- ValueError+      |    +-- UnicodeError+      |         +-- UnicodeDecodeError+      |         +-- UnicodeEncodeError+      |         +-- UnicodeTranslateError+      +-- Warning+           +-- DeprecationWarning+           +-- PendingDeprecationWarning+           +-- RuntimeWarning+           +-- SyntaxWarning+           +-- UserWarning+           +-- FutureWarning+           +-- ImportWarning+           +-- UnicodeWarning+           +-- BytesWarning+-}++module Berp.Base.Builtins.Exceptions+   ( baseException, _s_BaseException+   , exception, _s_Exception+   , stopIteration, _s_StopIteration+   , typeError, _s_TypeError+   , nameError, _s_NameError) +   where++import Control.Monad.Trans (liftIO)+import Berp.Base.Monad (constantEval)+import Berp.Base.Builtins.Utils (primConstant)+import Berp.Base.SemanticTypes (Object (..), Eval, ObjectRef)+import Berp.Base.StdTypes.Type (newType)+import Berp.Base.StdTypes.Object (object)+import Berp.Base.StdTypes.Tuple (tuple)+import Berp.Base.StdTypes.Dictionary (dictionary)+import Berp.Base.StdTypes.String (string)++mkExceptionType :: String -> [Object] -> Eval Object+mkExceptionType name bases = do+   dict <- dictionary []+   liftIO $ newType [string name, tuple bases, dict]++baseException :: Object+baseException = constantEval $ mkExceptionType "BaseException" [object]++_s_BaseException :: ObjectRef+_s_BaseException = primConstant baseException++exception :: Object+exception = constantEval $ mkExceptionType "Exception" [baseException] ++_s_Exception :: ObjectRef+_s_Exception = primConstant exception++stopIteration :: Object+stopIteration = constantEval $ mkExceptionType "StopIteration" [exception]++_s_StopIteration :: ObjectRef+_s_StopIteration = primConstant stopIteration++typeError :: Object+typeError = constantEval $ mkExceptionType "TypeError" [exception]++_s_TypeError :: ObjectRef+_s_TypeError = primConstant typeError++nameError :: Object+nameError = constantEval $ mkExceptionType "NameError" [exception]++_s_NameError :: ObjectRef+_s_NameError = primConstant nameError
+ src/Berp/Base/Builtins/Exceptions.hs-boot view
@@ -0,0 +1,10 @@+module Berp.Base.Builtins.Exceptions+   (baseException, exception, stopIteration, typeError) +   where++import Berp.Base.SemanticTypes (Object)++baseException :: Object+exception :: Object+stopIteration :: Object+typeError :: Object
+ src/Berp/Base/Builtins/Functions.hs view
@@ -0,0 +1,83 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Base.Builtins.Functions+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- Builtin functions.+--+-----------------------------------------------------------------------------++module Berp.Base.Builtins.Functions +   (_s_print, _s_dir, _s_input, _s_id, _s_callCC)+   where++import Data.List (null)+import Control.Monad (when)+import System.IO (stdout)+import Data.List (intersperse)+import Berp.Base.SemanticTypes (Object (..), Procedure, Eval, ObjectRef)+import Berp.Base.Mangle (mangle)+import qualified Berp.Base.Prims as Prims (printObject, pyCallCC)+import Berp.Base.Builtins.Utils (primFun)+import Berp.Base.LiftedIO as LIO (hFlush, putStr, putChar, getLine)+import Berp.Base.Object (dir, identityOf)+import Berp.Base.Unique (uniqueInteger)+import Berp.Base.StdTypes.None (none)+import Berp.Base.StdTypes.String (string)+import Berp.Base.StdTypes.Integer (int)++_s_input :: ObjectRef +_s_input = do+   primFun (mangle "input") (-1) procedure+   where+   procedure :: Procedure+   procedure objs = do+      when (not $ null objs) $ do+         printer $ head objs+         LIO.hFlush stdout+      str <- LIO.getLine+      return $ string str +   printer :: Object -> Eval ()+   printer obj@(String {}) = LIO.putStr $ object_string obj+   printer other = Prims.printObject other++_s_print :: ObjectRef +_s_print = do+   primFun (mangle "print") (-1) procedure+   where+   procedure :: Procedure+   procedure objs = do+      sequence_ $ intersperse (LIO.putChar ' ') $ map printer objs+      LIO.putChar '\n'+      return none+   printer :: Object -> Eval ()+   printer obj@(String {}) = LIO.putStr $ object_string obj+   printer other = Prims.printObject other++_s_dir :: ObjectRef +_s_dir = do+   primFun (mangle "dir") 1 procedure+   where+   procedure :: Procedure+   procedure (obj:_) = dir obj+   procedure _other = error "dir applied to wrong number of arguments"++_s_id :: ObjectRef+_s_id = do+   primFun (mangle "id") 1 procedure+   where+   procedure :: Procedure+   procedure (obj:_) = return $ int $ uniqueInteger $ identityOf obj+   procedure _other = error "id applied to wrong number of arguments"++_s_callCC :: ObjectRef+_s_callCC = do+   primFun (mangle "callCC") 1 procedure+   where+   procedure :: Procedure+   procedure (obj:_) = Prims.pyCallCC obj +   procedure _other = error "callCC applied to wrong number of arguments"
+ src/Berp/Base/Builtins/Utils.hs view
@@ -0,0 +1,28 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Base.Builtins.Utils+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- Support code for making builtins.+--+-----------------------------------------------------------------------------++module Berp.Base.Builtins.Utils (primFun, primConstant) where++import Data.IORef (newIORef)+import Berp.Base.Ident (Ident)+import Berp.Base.SemanticTypes (Arity, Procedure, ObjectRef, Object)+import Berp.Base.Prims (primitive)+import Berp.Base.Monad (constantIO) ++primFun :: Ident -> Arity -> Procedure -> ObjectRef +primFun _ident arity proc = constantIO $ do+   let primitiveObj = primitive arity proc +   newIORef primitiveObj ++primConstant :: Object -> ObjectRef+primConstant = constantIO . newIORef
+ src/Berp/Base/Class.hs view
@@ -0,0 +1,52 @@+-- {-# OPTIONS_GHC -cpp -DDEBUG #-}+{-# OPTIONS_GHC -cpp #-}+-- uncomment one of the two above lines to turn debugging on/off for this module++-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Base.Class+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- Implementation of the Python "class" keyword. We call it "klass" (with a k) +-- because "class" is a keyword in Haskell.+--+-----------------------------------------------------------------------------++#include "BerpDebug.h"++module Berp.Base.Class (klass) where++import Berp.Base.LiftedIO (liftIO, MonadIO, writeIORef, readIORef)+import Berp.Base.Ident+import Berp.Base.SemanticTypes (Eval, Object (..), ObjectRef)+#ifdef DEBUG+import Berp.Base.Prims (printObject)+#endif+import Berp.Base.Hash (Hashed)+import Berp.Base.Attributes (mkAttributes)+import Berp.Base.StdTypes.Type (newType)+import Berp.Base.StdTypes.String (string)+import Berp.Base.StdTypes.Tuple (tuple)+import Berp.Base.StdTypes.None (none)+import Berp.Base.StdTypes.Object (object)++klass :: Ident -> ObjectRef -> [Object] -> Eval [(Hashed String, ObjectRef)] -> Eval Object +klass className ident srcBases attributesComp = do+   -- if the source lists no bases for the class, then force it to be (object)+   let trueBases = if null srcBases then [object] else srcBases +   attributes <- attributesComp +   attributesObjects <- mapM getIdentObj attributes+   classDict <- mkAttributes attributesObjects+   typeObject <- liftIO $ newType [string className, tuple trueBases, classDict]+   writeIORef ident $ typeObject +   IF_DEBUG((printObject $ object_mro typeObject) >> putStr "\n")+   return none+   where+   getIdentObj :: MonadIO m => (a, ObjectRef) -> m (a, Object) +   getIdentObj (ident, ref) = do+      obj <- readIORef ref+      return (ident, obj)
+ src/Berp/Base/ControlStack.hs view
@@ -0,0 +1,165 @@+-- {-# OPTIONS_GHC -cpp -DDEBUG #-}+{-# OPTIONS_GHC -cpp #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Base.ControlStack+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- Operations on the control stack.+--+-----------------------------------------------------------------------------++#include "BerpDebug.h"++module Berp.Base.ControlStack +   ( isEmpty, isProcedureCall, isExceptionHandler, isWhileLoop, isGeneratorCall+   , unwind, unwindPastWhileLoop, unwindUpToWhileLoop, push, pop, nullifyTopHandler +   , unwindYieldContext, dumpStack, getControlStack, setControlStack+   )+   where++import Control.Monad.State+import Data.Maybe (maybe)+import Berp.Base.SemanticTypes (ControlStack (..), Eval, EvalState (..), Object (..))+import Berp.Base.LiftedIO as LIO (writeIORef, putStrLn)+import {-# SOURCE #-} Berp.Base.StdTypes.None (none)++isEmpty :: ControlStack -> Bool+isEmpty EmptyStack = True+isEmpty _ = False++isProcedureCall :: ControlStack -> Bool+isProcedureCall (ProcedureCall {}) = True+isProcedureCall _ = False++isExceptionHandler :: ControlStack -> Bool+isExceptionHandler (ExceptionHandler {}) = True+isExceptionHandler _ = False++isWhileLoop :: ControlStack -> Bool+isWhileLoop (WhileLoop {}) = True+isWhileLoop _ = False++isGeneratorCall :: ControlStack -> Bool+isGeneratorCall (GeneratorCall {}) = True+isGeneratorCall _ = False++{- Unwind the control stack and execute any "finally" exception handlers+   that we pass along the way. Returns the stack with the most recently popped +   element remaining.+-}+unwind :: (ControlStack -> Bool) -> Eval ControlStack +unwind pred = do+   stack <- gets control_stack+   unwindFrame stack+   where+   unwindFrame :: ControlStack -> Eval ControlStack +   -- XXX should be an exception+   unwindFrame EmptyStack = error $ "unwindFrame: empty control stack" +   unwindFrame stack@(ExceptionHandler { exception_finally = maybeFinally }) = do+      pop+      maybe (return none) id maybeFinally+      if pred stack+         then return stack +         else unwind pred +   unwindFrame stack+      | pred stack = pop >> return stack +      | otherwise = pop >> unwind pred ++unwindYieldContext :: Eval Object -> Eval (Object -> Eval Object) +unwindYieldContext continuation = do+   stack <- gets control_stack+   let (generatorYield, generatorObj, newStack, context) = unwindYieldWorker stack+   LIO.writeIORef (object_continuation generatorObj) continuation +   LIO.writeIORef (object_stack_context generatorObj) context+   setControlStack newStack+   return generatorYield +   where+   unwindYieldWorker :: ControlStack -> (Object -> Eval Object, Object, ControlStack, ControlStack -> ControlStack) +   -- XXX this should be an exception+   unwindYieldWorker EmptyStack = error "unwindYieldWorker: empty control stack"+   unwindYieldWorker (ProcedureCall {}) = error "unwindYieldWorker: procedure call"+   unwindYieldWorker (ExceptionHandler handler finally tail) =+      (yield, obj, stack, ExceptionHandler handler finally . context)+      where+      (yield, obj, stack, context) = unwindYieldWorker tail+   unwindYieldWorker (WhileLoop start end tail) =+      (yield, obj, stack, WhileLoop start end . context)+      where+      (yield, obj, stack, context) = unwindYieldWorker tail+   unwindYieldWorker (GeneratorCall yield obj tail) = (yield, obj, tail, id)++unwindPastWhileLoop :: Eval ControlStack+unwindPastWhileLoop = do+   stack <- unwindUpToWhileLoop+   pop+   return stack++unwindUpToWhileLoop :: Eval ControlStack+unwindUpToWhileLoop = do+   stack <- gets control_stack+   unwindFrame stack+   where+   unwindFrame :: ControlStack -> Eval ControlStack +   -- XXX should be an exception, should mention continue/break called outside of loop+   unwindFrame EmptyStack = error $ "unwindUpToWhileLoop: empty control stack"+   unwindFrame (ExceptionHandler { exception_finally = maybeFinally }) = do+      pop+      maybe (return none) id maybeFinally+      unwindUpToWhileLoop+   unwindFrame stack@(WhileLoop {}) = return stack+   -- XXX should be an exception which mentions continue/break called outside of loop+   unwindFrame (ProcedureCall {}) = error $ "unwindUpToWhileLoop: procedure call"+   unwindFrame (GeneratorCall {}) = error $ "unwindUpToWhileLoop: generator call"++pop :: Eval ()+pop = do+   stack <- gets control_stack+   case stack of+      -- should be an exception+      EmptyStack -> error "pop: empty stack" +      _other -> setControlStack $ control_stack_tail stack++push :: (ControlStack -> ControlStack) -> Eval ()+push frame = do+   stack <- gets control_stack+   setControlStack (frame stack) ++setControlStack :: ControlStack -> Eval ()+setControlStack stack = modify $ \state -> state { control_stack = stack }++getControlStack :: Eval ControlStack+getControlStack = gets control_stack++-- assumes top of stack is an exception handler+nullifyTopHandler :: Eval ()+nullifyTopHandler = do+   IF_DEBUG(dumpStack)+   stack <- gets control_stack+   case stack of+     ExceptionHandler {} -> +        setControlStack $ stack { exception_handler = Nothing } +     _other -> error $ "nullifyTopHandler: top of stack is not an exception handler: " ++ show stack++dumpStack :: Eval ()+dumpStack = do+   LIO.putStrLn "--- Bottom of stack ---"+   stack <- gets control_stack+   mapStackM printer stack+   LIO.putStrLn "--- Top of stack ---"+   where+   printer :: ControlStack -> Eval ()+   printer (ProcedureCall {}) = LIO.putStrLn "ProcedureCall" +   printer (ExceptionHandler {}) = LIO.putStrLn "ExceptionHandler" +   printer (WhileLoop {}) = LIO.putStrLn "WhileLoop" +   printer (GeneratorCall {}) = LIO.putStrLn "GeneratorCall" +   printer (EmptyStack {}) = LIO.putStrLn "EmptyStack" ++mapStackM :: Monad m => (ControlStack -> m ()) -> ControlStack -> m ()+mapStackM _f EmptyStack = return ()+mapStackM f stack = f stack >> mapStackM f (control_stack_tail stack)
+ src/Berp/Base/Exception.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE DeriveDataTypeable #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Base.Exception+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- Custom exception values for Berp. Note: these do not necessarily +-- correspond to Python's exception values. Those are encoded elsewhere.+-- The exceptions in this module are just for the internal use of berp.+--+-----------------------------------------------------------------------------+++module Berp.Base.Exception (RuntimeError (..), module Except) where++import Control.Exception.Extensible as Except+import Data.Typeable++data RuntimeError+   = UncaughtException String+   deriving (Typeable, Show)++instance Exception RuntimeError
+ src/Berp/Base/ExitCodes.hs view
@@ -0,0 +1,19 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Base.ExitCodes+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- Exit codes for the various ways berp can "fail".+--+-----------------------------------------------------------------------------++module Berp.Base.ExitCodes (uncaughtExceptionError) where++import System.Exit (ExitCode (..))++uncaughtExceptionError :: ExitCode+uncaughtExceptionError = ExitFailure 1
+ src/Berp/Base/Hash.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE TemplateHaskell, MagicHash, TypeSynonymInstances #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Base.Hash+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- Hashing functions.+--+-----------------------------------------------------------------------------++module Berp.Base.Hash (Hash (..), Hashed, hashedStr) where++import Berp.Base.Mangle (mangle)+import Language.Haskell.TH+import Data.HashTable as HT (hashString)+import GHC.Integer (hashInteger)+import GHC.Types (Int (..))++type Hashed a = (Int, a)++class Hash a where+   hash :: a -> Int++instance Hash String where+   hash = fromIntegral . HT.hashString++instance Hash Integer where+   hash i = I# (hashInteger i)++hashedStr :: String -> Q Exp+hashedStr str = [| (n, mangle str) |]+   where+   n :: Int+   n = hash str
+ src/Berp/Base/HashTable.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE TemplateHaskell #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Base.HashTable+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- Mutable hashtable for the implementation of Python's dictionaries. +--+-----------------------------------------------------------------------------++module Berp.Base.HashTable +   ( empty+   , insert+   , lookup+   , delete+   , hashObject+   , fromList+   , stringTableFromList+   , stringLookup +   , stringInsert+   , mappings+   , keys+   ) where++import Prelude hiding (lookup)+import qualified Data.IntMap as IntMap +import Control.Applicative ((<$>))+import Control.Monad (foldM)+import Berp.Base.SemanticTypes (Object (..), Eval, HashTable)+import Berp.Base.Object (objectEquality)+import Berp.Base.Prims (callMethod)+import Berp.Base.Hash (hash, Hashed, hashedStr)+import Berp.Base.LiftedIO (MonadIO, readIORef, writeIORef, newIORef)+import {-# SOURCE #-} Berp.Base.StdTypes.String (string)++mappings :: HashTable -> Eval [(Object, Object)]+mappings hashTable = do+   map <- readIORef hashTable+   return $ concat $ IntMap.elems map ++keys :: HashTable -> Eval [Object]+keys hashTable = map fst <$> mappings hashTable++hashObject :: Object -> Eval Int+hashObject obj@(String {}) = return $ hash $ object_string obj+hashObject obj@(Integer {}) = return $ hash $ object_integer obj+hashObject obj@(Bool {}) = if object_bool obj then return 1 else return 0+hashObject obj@(None {}) = return $ hash $ object_identity obj -- copying what Python3.0 seems to do+hashObject obj@(Function {}) = return $ hash $ object_identity obj+hashObject object = do+   hashResult <- callMethod object $(hashedStr "__hash__") []+   case hashResult of+      Integer {} -> return $ fromInteger $ object_integer hashResult+      _other -> fail $ "__hash__ method on object does not return an integer: " ++ show object++empty :: MonadIO m => m HashTable +empty = newIORef IntMap.empty++fromList :: [(Object, Object)] -> Eval HashTable+fromList pairs = do+   keysVals <- mapM toKeyVal pairs+   newIORef $ IntMap.fromListWith (++) keysVals+   where+   toKeyVal :: (Object, Object) -> Eval (Int, [(Object, Object)])+   toKeyVal pair@(key, _val) = do+      hashValue <- hashObject key+      return (hashValue, [pair])++stringTableFromList :: MonadIO m => [(Hashed String, Object)] -> m HashTable+stringTableFromList pairs = do+   let keysVals = map toKeyVal pairs+   newIORef $ IntMap.fromListWith (++) keysVals+   where+   toKeyVal :: (Hashed String, Object) -> (Int, [(Object, Object)])+   toKeyVal ((hashValue,strKey), val) = +      (hashValue, [(strObj, val)])+      where+      strObj = string strKey ++stringLookup :: MonadIO m => Hashed String -> HashTable -> m (Maybe Object)+stringLookup (hashValue, str) hashTable = do+   table <- readIORef hashTable+   case IntMap.lookup hashValue table of+      Nothing -> return Nothing+      Just matches -> return $ linearSearchString str matches+   where+   linearSearchString :: String -> [(Object, Object)] -> Maybe Object+   linearSearchString _ [] = Nothing+   linearSearchString str ((key, value) : rest)+      | objectEqualityString str key = Just value+      | otherwise = linearSearchString str rest++objectEqualityString :: String -> Object -> Bool+objectEqualityString str1 (String { object_string = str2 }) = str1 == str2+objectEqualityString _ _ = False++-- XXX Potential space leak by not deleteing old versions of key in the table.+-- maybe we can delete based on the identity of the object? That would not avoid+-- the leak in all cases, but it might work in common cases.+stringInsert :: Hashed String -> Object -> HashTable -> Eval ()+stringInsert (hashValue, s) value hashTable = do+   table <- readIORef hashTable+   -- hashValue <- hashObject key +   let newTable = IntMap.insertWith (++) hashValue [(string s, value)] table+   writeIORef hashTable newTable ++-- XXX Potential space leak by not deleteing old versions of key in the table.+-- maybe we can delete based on the identity of the object? That would not avoid+-- the leak in all cases, but it might work in common cases.+insert :: Object -> Object -> HashTable -> Eval ()+insert key value hashTable = do+   table <- readIORef hashTable+   hashValue <- hashObject key +   let newTable = IntMap.insertWith (++) hashValue [(key,value)] table+   writeIORef hashTable newTable ++lookup :: Object -> HashTable -> Eval (Maybe Object)+lookup key hashTable = do+   table <- readIORef hashTable+   hashValue <- hashObject key +   case IntMap.lookup hashValue table of+      Nothing -> return Nothing+      Just matches -> linearSearch key matches +   where+   linearSearch :: Object -> [(Object, Object)] -> Eval (Maybe Object)+   linearSearch _ [] = return Nothing+   linearSearch object ((key,value):rest) = do+      areEqual <- objectEquality object key+      if areEqual +         then return (Just value)+         else linearSearch object rest ++linearFilter :: Object -> [(Object, Object)] -> Eval [(Object, Object)]+linearFilter object matches = foldM collectNotEquals [] matches +   where+   collectNotEquals :: [(Object, Object)] -> (Object, Object) -> Eval [(Object, Object)]+   collectNotEquals acc pair@(key, _value) = do+      areEqual <- objectEquality object key+      return $ if areEqual then acc else pair:acc ++delete :: Object -> HashTable -> Eval ()+delete key hashTable = do+   table <- readIORef hashTable+   hashValue <- hashObject key+   case IntMap.lookup hashValue table of+      Nothing -> return ()+      Just matches -> do+         newMatches <- linearFilter key matches+         let newTable = IntMap.adjust (const newMatches) hashValue table+         writeIORef hashTable newTable
+ src/Berp/Base/HashTable.hs-boot view
@@ -0,0 +1,28 @@+module Berp.Base.HashTable+   ( empty+   , insert+   , lookup+   , delete+   , hashObject+   , fromList+   , stringTableFromList+   , stringLookup+   , stringInsert+   , keys+   ) where++import Prelude hiding (lookup)+import Berp.Base.Hash (Hashed)+import Berp.Base.SemanticTypes (Object, Eval, HashTable)+import Berp.Base.LiftedIO (MonadIO)++hashObject :: Object -> Eval Int+empty :: MonadIO m => m HashTable +fromList :: [(Object, Object)] -> Eval HashTable+insert :: Object -> Object -> HashTable -> Eval ()+lookup :: Object -> HashTable -> Eval (Maybe Object)+delete :: Object -> HashTable -> Eval ()+stringTableFromList :: MonadIO m => [(Hashed String, Object)] -> m HashTable+stringLookup :: MonadIO m => Hashed String -> HashTable -> m (Maybe Object)+stringInsert :: Hashed String -> Object -> HashTable -> Eval ()+keys :: HashTable -> Eval [Object]
+ src/Berp/Base/Ident.hs view
@@ -0,0 +1,16 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Base.Ident+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- Encoding of identifiers.+--+-----------------------------------------------------------------------------++module Berp.Base.Ident where++type Ident = String
+ src/Berp/Base/Identity.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE TypeSynonymInstances #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Base.Identity+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- A unique identity. All Python objects have a unique identity. In CPython+-- the identity is the machine address of the object. That relies on the +-- object being kept at a fixed virtual address in memory. We can't do the+-- same thing in Haskell because the garbage collector can move data around.+--+-- TODO: consider lazy identities, which are only constructed on demand.+--+-----------------------------------------------------------------------------++module Berp.Base.Identity (Identity, newIdentity) where++import Berp.Base.Unique+import Berp.Base.Hash (Hash (..))+import Berp.Base.LiftedIO (MonadIO, liftIO)++type Identity = Unique++newIdentity :: MonadIO m => m Unique+newIdentity = liftIO newUnique++instance Hash Identity where+   hash = hashUnique++{- ++Some comments on this important module.++All Python objects have an identity which is unique to the object.+The identity of an object can be obtained by the primitive function id().++id is a "built in type or function". ++It returns an integer (class 'int'). According to the __doc__ for id+in Python 3.0 it says:++   id(...)+       id(object) -> integer+    +       Return the identity of an object.  This is guaranteed to be unique among+       simultaneously existing objects.  (Hint: it's the object's memory address.)++There's probably Python code out there which depends on the result being+an actual integer. But it would be nicer if it returned an abstract type.++There's also a builtin called hash():++   hash(...)+       hash(object) -> integer+    +       Return a hash value for the object.  Two objects with the same value have+       the same hash value.  The reverse is not necessarily true, but likely.+ +In some cases the hash function uses the identity of the object to obtain the hash+value.++The hash is quite useful, particularly because it is used to allow an object to be+a key in a dictionary. ++CPython's garbage collector does not move objects allocated on the heap.+This means it can use the address of the object as its+identity. Obviously this is problematic if we want to use GHC's collector which+does move objects.++Thus we must generate a unique identity for all objects when they are constructed.++A couple of important considerations:+   a) The scheme must scale. We should not have any limit on the number of+      identities that we can generate. +   b) As computation time goes on we'd like to keep+      a handle on the size of individual identities. A constant size would be+      ideal, but we might allow for growth in the size of the identity value+      if it has reasonable asymptotic behaviour.+   c) It should work well with threads. Global counters must be atomically+      updated. +   d) It is better if the scheme is portable (does not rely on deep GHC magic). +   e) Should be fast.++A couple of options for implementation:++   1) A global mutable Integer counter protected by an MVar.+         - Satisfies a).+         - Size of counter grows logaithmically, but very slowly, so may be+           practical for the vast majority of applications. So probably +           satisfies b).+         - Will work with threads, but at what cost? Each time an object+           is constructed the running thread must take the lock on the MVar,+           increment the counter, and release the lock. Incrementing an +           Integer is not trivial, so there may be lock contention. +           Probably satisfies c), but the significance of the time costs+           are unknown. +         - MVars are not too magical, so probably satisfies d).++   2) A Stable Name.+         - Satisfies a). The number of stable names is only limited to the+           number of objects in memory (I think).+         - Satisfies b). The size of a stable name is constant. (good).+         - Satisfies c). I don't think there is any issue with thread +           contention.+         - I think stable names are part of the FFI, so should be portable.+           Better check this. However, I don't think they work with parallel+           Haskell at present. Is this important? Hard to say.++   Regarding the speed of each method: it is hard to say without measuring+   them on real programs. My intution is that Stable Names have some advantage+   in multi-threaded programs because they don't go via MVars (or maybe they+   do, if the stable name table is locked in the runtime - better check this).+   I'm also a bit concerned that Stable Names were not designed to support a very+   large number of objects, and so may perform badly on Python programs which+   allocate many objects. +-}
+ src/Berp/Base/LiftedIO.hs view
@@ -0,0 +1,49 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Base.LiftedIO+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- Lifted versions of standard IO functions. Allows them to be used in any+-- MonadIO context. Saves us from having to write "liftIO" everywhere.+--+-----------------------------------------------------------------------------++module Berp.Base.LiftedIO +   ( liftIO, putStr, putStrLn, putChar, IORef, readIORef+   , writeIORef, newIORef, MonadIO, hFlush, getLine+   ) where++import Prelude hiding (putStr, putStrLn, getLine, putChar)+import qualified Prelude as P (putStr, putStrLn, getLine, putChar)+import Control.Monad.Trans (liftIO, MonadIO)+import Data.IORef hiding (readIORef, writeIORef, newIORef) +import qualified Data.IORef as IORef (readIORef, writeIORef, newIORef)+import qualified System.IO as SIO (hFlush, Handle)++putStr :: MonadIO m => String -> m ()+putStr = liftIO . P.putStr++putStrLn :: MonadIO m => String -> m ()+putStrLn = liftIO . P.putStrLn++putChar :: MonadIO m => Char -> m ()+putChar = liftIO . P.putChar++readIORef :: MonadIO m => IORef a -> m a+readIORef = liftIO . IORef.readIORef++writeIORef :: MonadIO m => IORef a -> a -> m ()+writeIORef x ref = liftIO $ IORef.writeIORef x ref++newIORef :: MonadIO m => a -> m (IORef a)+newIORef = liftIO . IORef.newIORef++getLine :: MonadIO m => m (String)+getLine = liftIO P.getLine++hFlush :: MonadIO m => SIO.Handle -> m ()+hFlush = liftIO . SIO.hFlush
+ src/Berp/Base/Mangle.hs view
@@ -0,0 +1,36 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Base.Mangle+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- Name mangling. +--+-- We need to mangle Python's identifier names when we compiled them to +-- Haskell names because:+--    1) Python allows some identifiers which are illegal in Haskell,+--       such as leading upper case letters.+--    2) We introduce our own "temporary" variables into a compiled program.+--       Name mangling helps to avoid accidental name clash.+--    3) We import many Haskell primitives into the compiled program. +--       Name mangling helps to avoid accidental name clash.+--+-----------------------------------------------------------------------------++module Berp.Base.Mangle (mangle, deMangle) where++import Data.List (isPrefixOf)++sourcePrefix :: String+sourcePrefix = "_s_"++mangle :: String -> String+mangle = (sourcePrefix ++)++deMangle :: String -> String+deMangle str+   | sourcePrefix `isPrefixOf` str = drop (length sourcePrefix) str+   | otherwise = str
+ src/Berp/Base/Monad.hs view
@@ -0,0 +1,59 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Base.Monad+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- Support for the Eval monad.+--+-----------------------------------------------------------------------------++module Berp.Base.Monad (runExpr, runStmt, interpretStmt, constantIO, constantEval) where++import Control.Monad.State.Strict (evalStateT)+import Control.Monad.Cont (runContT)+import System.IO.Unsafe (unsafePerformIO)+import Berp.Base.SemanticTypes (Object (..), Eval, EvalState (..), ControlStack(EmptyStack))+import Berp.Base.Prims (printObject)+import Berp.Base.LiftedIO as LIO (putStr)++runExpr :: Eval Object -> IO Object +runExpr comp +   = runContT (evalStateT comp initState) return +   where+   initState = EvalState { control_stack = EmptyStack } ++runStmt :: Eval Object -> IO Object +runStmt = runExpr ++-- This is used by the interactive interpreter to evaluate the +-- statements entered by the user. Note that it does not print+-- None values, following the same behaviour of CPython.+interpretStmt :: Eval Object -> IO ()+interpretStmt comp = do+   runExpr $ do+      obj <- comp+      case obj of+         None {} -> return () +         _other  -> do +            printObject obj+            LIO.putStr "\n"+      return obj+   return ()++-- The "constant" functions below need to be used with care.+-- We try to make sure they are only used in a safe way. For the most+-- part, it is safe to use them if the IO operation is innocuous, such as+-- allocating IORefs.++constantIO :: IO a -> a +constantIO = unsafePerformIO++constantEval :: Eval Object -> Object +constantEval comp = constantIO $ runContT (evalStateT comp constantState) return++constantState :: EvalState+constantState = EvalState { control_stack = EmptyStack }
+ src/Berp/Base/Object.hs view
@@ -0,0 +1,215 @@+-- {-# OPTIONS_GHC -cpp -DDEBUG #-} +{-# OPTIONS_GHC -cpp #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Base.Object+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- Primitive operations on Objects.+--+-----------------------------------------------------------------------------++#include "BerpDebug.h"++module Berp.Base.Object +   (lookupAttribute, lookupSpecialAttribute, lookupAttributeMaybe, +    typeOf, identityOf, objectEquality, dictOf, dir) where++import Berp.Base.Truth (truth)+import Berp.Base.Prims (callMethod, showObject)+import Data.List (nub)+import Control.Monad (zipWithM)+import Control.Applicative ((<$>))+import Data.Maybe (isJust, catMaybes)+import Berp.Base.SemanticTypes (Object (..), Eval)+import Berp.Base.Mangle (deMangle)+import Berp.Base.Identity (Identity)+import Berp.Base.Hash (Hashed)+import Berp.Base.StdNames (eqName, cmpName)+import Berp.Base.LiftedIO as LIO (MonadIO)+#ifdef DEBUG+import Berp.Base.LiftedIO as LIO (putStrLn)+#endif+import {-# SOURCE #-} Berp.Base.HashTable (stringLookup, keys)+import {-# SOURCE #-} Berp.Base.StdTypes.Integer (intClass, int)+import {-# SOURCE #-} Berp.Base.StdTypes.Bool (boolClass)+import {-# SOURCE #-} Berp.Base.StdTypes.Tuple (tupleClass, getTupleElements)+import {-# SOURCE #-} Berp.Base.StdTypes.Function (functionClass)+import {-# SOURCE #-} Berp.Base.StdTypes.String (stringClass)+import {-# SOURCE #-} Berp.Base.StdTypes.None (noneClass, noneIdentity)+import {-# SOURCE #-} Berp.Base.StdTypes.Dictionary (dictionaryClass)+import {-# SOURCE #-} Berp.Base.StdTypes.List (listClass, list)+import {-# SOURCE #-} Berp.Base.StdTypes.Generator (generatorClass)+import {-# SOURCE #-} Berp.Base.StdTypes.String (string)++-- needed for overloaded numeric literals+instance Num Object where+    fromInteger = int+    (+) = undefined+    (*) = undefined+    abs = undefined+    signum = undefined++-- Python allows the type of an object to change in a limited set of circumstances.+-- But we will ignore that for the moment and make it a pure function.+typeOf :: Object -> Object+typeOf obj@(Object {}) = object_type obj +typeOf obj@(Type {}) = object_type obj+typeOf (Integer {}) = intClass +typeOf (Bool {}) = boolClass+typeOf (Tuple {}) = tupleClass+typeOf (List {}) = listClass +typeOf (Function {}) = functionClass+typeOf (String {}) = stringClass+typeOf (None {}) = noneClass+typeOf (Dictionary {}) = dictionaryClass+typeOf (Generator {}) = generatorClass++-- The identity of an object should never change so this can be a pure function.+identityOf :: Object -> Identity+identityOf None = noneIdentity +identityOf object = object_identity object++dictOf :: Object -> Maybe Object +dictOf obj@(Object {}) = Just $ object_dict obj+dictOf obj@(Type {}) = Just $ object_dict obj+dictOf obj@(Function {}) = Just $ object_dict obj+dictOf _other = Nothing++lookupAttribute :: Object -> Hashed String -> Eval Object+lookupAttribute obj ident = do+   lookupResult <- lookupAttributeMaybe obj ident+   checkLookup obj ident lookupResult ++lookupSpecialAttribute :: Object -> Hashed String -> Eval Object+lookupSpecialAttribute obj ident = do+   lookupResult <- lookupSpecialAttributeMaybe obj ident+   checkLookup obj ident lookupResult ++checkLookup :: Object -> Hashed String -> Maybe Object -> Eval Object+checkLookup obj (_, identStr) lookupResult =+   case lookupResult of+      -- XXX This should raise a proper catchable exception +      Nothing -> do+         objStr <- showObject obj+         fail $ objStr ++ " has no attribute called " ++ deMangle identStr+      Just attributeObj -> do+         case attributeObj of+            -- XXX this should return a bound method object+            Function { object_procedure = proc, object_arity = arity } -> +               return attributeObj { object_procedure = \args -> proc (obj:args), object_arity = arity - 1 }+            _other -> do+               return attributeObj ++-- XXX does not handle descriptors or getattr/getattribute.+-- XXX Hack: If the result of the lookup is a function, then +--     turn it into a bound method on return, by supplying the+--     object as the first argument. This is not ideal, but+--     it will work until descriptors are supported++lookupSpecialAttributeMaybe :: MonadIO m => Object -> Hashed String -> m (Maybe Object)+lookupSpecialAttributeMaybe object ident = do+   BELCH("Looking for special attribute: " ++ show ident ++ " in: " ++ show object)+   lookupAttributeType object ident++lookupAttributeMaybe :: MonadIO m => Object -> Hashed String -> m (Maybe Object)+lookupAttributeMaybe object ident = do+   BELCH("Looking for: " ++ show ident ++ " in: " ++ show object)+   BELCH("Looking in dictionary of object")+   case dictOf object of+      -- The object does have a dictionary; look in there.+      Just dict -> do+         BELCH("Object has a dictionary")+         dictResult <- stringLookup ident $ object_hashTable dict +         case dictResult of+            -- The ident was not found in the object, look in the type, then the bases.+            Nothing -> do+               BELCH("Ident not found in dictionary of object")+               lookupAttributeType object ident+            -- The ident was found in the object; return it.+            Just _ -> do+               BELCH("Ident was found in dictionary of object")+               return dictResult +      -- The object does not have a dictionary; look in the type, then the bases.+      Nothing -> do+         BELCH("Object does not have a dictionary")+         lookupAttributeType object ident++lookupAttributeType :: MonadIO m => Object -> Hashed String -> m (Maybe Object)+lookupAttributeType object ident = do+   BELCH("Looking in dict of the type: " ++ show objectType)+   let mroList = getTupleElements $ object_mro objectType+   searchMRO mroList+   where+   objectType :: Object+   objectType = typeOf object+   searchMRO :: MonadIO m => [Object] -> m (Maybe Object)+   searchMRO [] = do+      BELCH("Ident was not found in the mro of the type of the object")+      return Nothing+   searchMRO (klass:rest) = do+      BELCH("Looking in the dict of the type: " ++ show klass)+      case dictOf klass of+         Nothing -> do+            BELCH("Type does not have a dictionary")+            searchMRO rest +         Just dict -> do+            BELCH("Type does have a dictionary")+            dictResult <- stringLookup ident $ object_hashTable dict+            case dictResult of+               Nothing -> do+                  BELCH("Ident not found in dictionary of type")+                  searchMRO rest +               Just _ -> do+                  BELCH("Ident was found in dictionary of type")+                  return dictResult++hasAttribute :: (Functor m, MonadIO m) => Object -> Hashed String -> m Bool+hasAttribute object ident = isJust <$> lookupAttributeMaybe object ident++-- | Check if two objects are equal. For some objects we might have+--   to call the __eq__ (or __cmp__) method on the objects. This means+--   the result must be in the Eval monad.+objectEquality :: Object -> Object -> Eval Bool+objectEquality obj1@(Integer {}) obj2@(Integer {})+   = return (object_integer obj1 == object_integer obj2)+objectEquality obj1@(Bool {}) obj2@(Bool {})+   = return (object_bool obj1 == object_bool obj2)+objectEquality obj1@(Tuple {}) obj2@(Tuple {})+   | object_identity obj1 == object_identity obj2 = return True+   | object_length obj1 == object_length obj2 =+        and <$> zipWithM objectEquality (object_tuple obj1) (object_tuple obj2)+   | otherwise = return False+objectEquality obj1@(String {}) obj2@(String {})+   = return (object_string obj1 == object_string obj2)+objectEquality None None = return True+objectEquality obj1 obj2 +   | object_identity obj1 == object_identity obj2 = return True+   | otherwise = do+        canEq <- hasAttribute obj1 eqName+        if canEq+           then truth <$> callMethod obj1 eqName [obj2]+           else do+              canCmp <- hasAttribute obj1 cmpName+              if canCmp+                 then do+                    cmpResult <- callMethod obj1 cmpName [obj2]+                    case cmpResult of+                       Integer {} -> return $ object_integer cmpResult == 0+                       _other -> fail $ "__cmp__ method on object does not return an integer: " ++ show obj1+                 else return False -- XXX should this raise an exception?++dir :: Object -> Eval Object+dir object = do+   let maybeObjDict = dictOf object+   let objectBasesDicts = map dictOf $ getTupleElements $ object_mro $ typeOf object+   let allDicts = catMaybes (maybeObjDict : objectBasesDicts)+   let hashTables = map object_hashTable allDicts +   keyObjects <- concat <$> mapM keys hashTables+   let keyStrings = nub $ map (deMangle . object_string) keyObjects+   list $ map string keyStrings
+ src/Berp/Base/Object.hs-boot view
@@ -0,0 +1,16 @@+module Berp.Base.Object +   (lookupAttribute, lookupSpecialAttribute, lookupAttributeMaybe, +    typeOf, dictOf, identityOf, objectEquality) where++import Berp.Base.SemanticTypes (Object, Eval)+import Berp.Base.Identity (Identity)+import Berp.Base.Hash (Hashed)+import Berp.Base.LiftedIO (MonadIO)++typeOf :: Object -> Object+identityOf :: Object -> Identity+dictOf :: Object -> Maybe Object +lookupAttribute :: Object -> Hashed String -> Eval Object+lookupSpecialAttribute :: Object -> Hashed String -> Eval Object+lookupAttributeMaybe :: MonadIO m => Object -> Hashed String -> m (Maybe Object)+objectEquality :: Object -> Object -> Eval Bool
+ src/Berp/Base/Operators.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE TemplateHaskell #-}+-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Base.Operators+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- Implementation of Python's operators. Where possible we should try to+-- specialise them to commonly used types.+--+-----------------------------------------------------------------------------++module Berp.Base.Operators +   ( (+), (-), (*), (/), (==), (<), (>), (<=), (>=), (.), and, or, (%)+   , unaryMinus, unaryPlus, invert) +   where++import Berp.Base.Prims (callMethod, raise)+import Prelude hiding ((+), (-), (*), (.), (/), (==), (<), (>), (<=), (>=), or, and)+import qualified Prelude ((==),(<),(>=),(*),(+),(-),(<=),(>))+import Berp.Base.Builtins.Exceptions (exception)+import Berp.Base.Object (lookupAttribute)+import Berp.Base.SemanticTypes (Object (..), Eval)+import Berp.Base.Hash (Hashed, hashedStr)+import Berp.Base.StdTypes.Integer (int)+import Berp.Base.StdTypes.Bool (bool)+import Berp.Base.StdTypes.None (none)++infixl 9  .+infixl 7 *, /, %+infixl 6  +, -+infix  4  ==, <, <=, >=, >+infixr 3 `and`+infixr 2 `or`++-- XXX Really want to specialise some operations for particular types rather tham+-- going via the method lookups.++binop :: Hashed String -> Object -> Object -> Eval Object+binop str arg1 arg2 = callMethod arg1 str [arg2]++(%), (+), (-), (*), (/), (==), (<), (>), (<=), (>=), or, and :: Object -> Object -> Eval Object++(%) obj1@(Integer {}) obj2@(Integer {}) = +   return $ int (object_integer obj1 `Prelude.mod` object_integer obj2)+(%) x y = binop $(hashedStr "__mod__") x y++(+) obj1@(Integer {}) obj2@(Integer {}) = +   return $ int (object_integer obj1 Prelude.+ object_integer obj2)+(+) x y = binop $(hashedStr "__add__") x y++(-) obj1@(Integer {}) obj2@(Integer {}) = +   return $ int (object_integer obj1 Prelude.- object_integer obj2)+(-) x y = binop $(hashedStr "__sub__") x y++(*) obj1@(Integer {}) obj2@(Integer {}) = +   return $ int (object_integer obj1 Prelude.* object_integer obj2)+(*) x y = binop $(hashedStr "__mul__") x y++(/) (Integer { object_integer = int1 }) (Integer { object_integer = int2 })+   | int2 Prelude.== 0 = raise exception >> return none+   | otherwise = return $ int (int1 `Prelude.div` int2)+(/) x y = binop $(hashedStr "__div__") x y++(<=) obj1@(Integer {}) obj2@(Integer {}) = +   return $ bool (object_integer obj1 Prelude.<= object_integer obj2)+(<=) x y = binop $(hashedStr "__le__") x y++(>) obj1@(Integer {}) obj2@(Integer {}) = +   return $ bool (object_integer obj1 Prelude.> object_integer obj2)+(>) x y = binop $(hashedStr "__gt__") x y++(==) obj1@(Integer {}) obj2@(Integer {}) = +   return $ bool (object_integer obj1 Prelude.== object_integer obj2)+(==) x y = binop $(hashedStr "__eq__") x y++(<) obj1@(Integer {}) obj2@(Integer {}) = +   return $ bool (object_integer obj1 Prelude.< object_integer obj2)+(<) x y = binop $(hashedStr "__lt__") x y++(>=) obj1@(Integer {}) obj2@(Integer {}) = +   return $ bool (object_integer obj1 Prelude.>= object_integer obj2)+(>=) x y = binop $(hashedStr "__ge__") x y++and obj1@(Bool {}) obj2@(Bool {}) = +   return $ bool (object_bool obj1 Prelude.&& object_bool obj2)+and x y = binop $(hashedStr "__and__") x y++or obj1@(Bool {}) obj2@(Bool {}) = +   return $ bool (object_bool obj1 Prelude.|| object_bool obj2)+or x y = binop $(hashedStr "__or__") x y++(.) :: Object -> Hashed String -> Eval Object+(.) object ident = lookupAttribute object ident++unaryMinus :: Object -> Eval Object+unaryMinus obj@(Integer {}) = return $ int $ negate $ object_integer obj+unaryMinus _other = error "unary minus applied to a non integer"++-- This is just the identity function+unaryPlus :: Object -> Eval Object+unaryPlus obj@(Integer {}) = return obj +unaryPlus _other = error "unary plus applied to a non integer"++invert :: Object -> Eval Object+invert (Integer {}) = error "bitwise inversion not implemented" +invert _other = error "unary invert applied to a non integer"
+ src/Berp/Base/Prims.hs view
@@ -0,0 +1,427 @@+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, PatternGuards, TemplateHaskell #-}++-- {-# OPTIONS_GHC -cpp -DDEBUG #-}+{-# OPTIONS_GHC -cpp #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Base.Prims+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- Implementation of primitive functions.+--+-----------------------------------------------------------------------------++#include "BerpDebug.h"++module Berp.Base.Prims +   ( (=:), stmt, ifThenElse, ret, pass, break+   , continue, while, whileElse, for, forElse, ifThen, (@@), tailCall+   , read, var, binOp, setattr, callMethod, callSpecialMethod, subs+   , try, tryElse, tryFinally, tryElseFinally, except, exceptDefault+   , raise, reRaise, raiseFrom, primitive, generator, yield, generatorNext+   , def, lambda, mkGenerator, printObject, topVar, Applicative.pure+   , pureObject, showObject, returningProcedure, pyCallCC ) where++import Prelude hiding (break, read, putStr)+import Control.Monad.State (gets)+import Control.Monad.Cont (callCC)+import Berp.Base.LiftedIO as LIO (readIORef, writeIORef, newIORef, putStr) +#ifdef DEBUG+import Berp.Base.LiftedIO as LIO (putStrLn)+#endif+import qualified Control.Applicative as Applicative (pure)+import Control.Applicative ((<$>))+import Data.Maybe (maybe)+import Berp.Base.Ident (Ident)+import Berp.Base.SemanticTypes (Object (..), ObjectRef, Procedure, Eval, EvalState(..), ControlStack(..), Arity)+import Berp.Base.Truth (truth)+import {-# SOURCE #-} Berp.Base.Object +   ( typeOf, dictOf, lookupAttribute, lookupSpecialAttribute, objectEquality)+import Berp.Base.Hash (Hashed, hashedStr)+import Berp.Base.ControlStack+import Berp.Base.StdNames (docName, strName) +import Berp.Base.Exception (RuntimeError (..), throw)+import {-# SOURCE #-} Berp.Base.StdTypes.Function (function)+import {-# SOURCE #-} Berp.Base.HashTable as Hash (stringInsert)+import {-# SOURCE #-} Berp.Base.StdTypes.None (none)+import {-# SOURCE #-} Berp.Base.StdTypes.Bool (true, false)+import {-# SOURCE #-} Berp.Base.StdTypes.Generator (generator)+import {-# SOURCE #-} Berp.Base.Builtins.Exceptions (stopIteration, typeError)++-- specialised to monomorphic type for the benefit of the interpreter.+-- otherwise we'd need to add a type annotation in the generated code.+pureObject :: Object -> Eval Object+pureObject = Applicative.pure++primitive :: Arity -> Procedure -> Object+primitive arity = function arity . returningProcedure ++returningProcedure :: Procedure -> Procedure+returningProcedure proc args = do+   result <- proc args+   ret result++infix 1 =:  -- assignment+infixl 8 @@ -- procedure application++topVar :: Ident -> IO ObjectRef+topVar s = newIORef (error $ "undefined variable:" ++ s)++var :: Ident -> Eval ObjectRef+var s = newIORef (error $ "undefined variable: " ++ s)++read :: ObjectRef -> Eval Object+read = readIORef ++ret :: Object -> Eval Object+ret obj = do+   stack <- unwind isProcedureCall+   procedure_return stack obj++pass :: Eval Object+pass = return none ++break :: Eval Object+break = do+   stack <- unwindPastWhileLoop +   loop_end stack++continue :: Eval Object+continue = do +   stack <- unwindUpToWhileLoop +   loop_start stack++-- We return None because that works well in the interpreter. None values+-- are not printed by default, so it matches the same behaviour as the+-- CPython interpreter.+(=:) :: ObjectRef -> Object -> Eval Object+ident =: obj = writeIORef ident obj >> return none ++-- XXX we could have specialised versions for certain small arities and thus+-- dispense with the list of objects+(@@) :: Object -> [Object] -> Eval Object +obj @@ args = do+    case obj of +        Function { object_procedure = proc, object_arity = arity }+           | arity == -1 || arity == length args -> +                callProcedure proc args +           -- XXX should be raise of arity, typeError exception+           | otherwise -> raise typeError +        Type { object_constructor = proc } -> callProcedure proc args+        -- XXX should try to find "__call__" attribute on object+        _other -> raise typeError ++callProcedure :: Procedure -> [Object] -> Eval Object+callProcedure proc args = +   callCC $ \ret -> do +      push $ ProcedureCall ret+      proc args ++tailCall :: Object -> [Object] -> Eval Object +tailCall obj args = do+    case obj of +        Function { object_procedure = proc, object_arity = arity }+           | arity == -1 || arity == length args -> proc args+           | otherwise -> raise typeError +        Type { object_constructor = proc } -> proc args+        -- XXX should try to find "__call__" attribute on object+        _other -> raise typeError ++ifThenElse :: Eval Object -> Eval Object -> Eval Object -> Eval Object +ifThenElse condComp trueComp falseComp = do+    cond <- condComp+    if truth cond then trueComp else falseComp++ifThen :: Eval Object -> Eval Object -> Eval Object+ifThen condComp trueComp = do+   cond <- condComp+   if truth cond then trueComp else pass ++{-+Compile for loops by desugaring into while loops.++   for vars in exp:+      suite1+   else:+      suite2++desugars to --->++   fresh_var_1 = exp.__iter__()+   fresh_var_2 = True+   while fresh_var_2:+      try:+         vars = fresh_var_1.__next__()+         suite1+      except StopIteration:+         fresh_var_2 = False+   else:+      suite2+-}++for :: ObjectRef -> Object -> Eval Object -> Eval Object+for var exp body = forElse var exp body pass ++forElse :: ObjectRef -> Object -> Eval Object -> Eval Object -> Eval Object+forElse var expObj suite1 suite2 = do+   iterObj <- callMethod expObj $(hashedStr "__iter__") [] -- this could be specialised+   cond <- newIORef true+   let tryBlock = do nextObj <- callMethod iterObj $(hashedStr "__next__") [] -- this could be specialised+                     writeIORef var nextObj+                     suite1+   let handler e = except e stopIteration ((writeIORef cond false) >> pass) (raise e) +   let whileBlock = try tryBlock handler+   whileElse (readIORef cond) whileBlock suite2++while :: Eval Object -> Eval Object -> Eval Object +while cond loopBlock = whileElse cond loopBlock pass ++whileElse :: Eval Object -> Eval Object -> Eval Object -> Eval Object +whileElse cond loopBlock elseBlock = do+   callCC $ \end -> do +      let afterLoop = end none +          loop = do condVal <- cond+                    if truth condVal+                       then do+                          loopBlock +                          loop+                       -- this does the unwind before the else block,+                       -- otherwise a call to break or continue in the else block+                       -- would have undesired results+                       else do+                          unwindPastWhileLoop+                          elseBlock +                          afterLoop +      push $ WhileLoop loop afterLoop+      loop++stmt :: Eval Object -> Eval Object+-- stmt comp = comp >> pass +-- Extra strictness needed here to ensure the value of the comp is demanded (in case exceptions are raised etc).+-- stmt comp = comp >>= (\obj -> seq obj pass)+stmt = id ++-- XXX could this be turned into a type class?+binOp :: Object -> Object -> (Object -> t) -> (t -> t -> r) -> (r -> Eval Object) -> Eval Object+binOp left right project fun build +   = build (project left `fun` project right)++-- XXX this should also work on Type+-- XXX need to support __setattr__ and descriptors+setattr :: Object -> Hashed String -> Object -> Eval Object+setattr target attribute value +   | Just dict <- dictOf target = do+        let hashTable = object_hashTable dict+        Hash.stringInsert attribute value $ hashTable+        return value+   | otherwise = error $ "setattr on object unimplemented: " ++ show (target, attribute)++callMethod :: Object -> Hashed String -> [Object] -> Eval Object+callMethod object ident args = do+   proc <- lookupAttribute object ident+   proc @@ args++-- this one goes straight to the type, skipping the dictionary of the object+callSpecialMethod :: Object -> Hashed String -> [Object] -> Eval Object+callSpecialMethod object ident args = do+   proc <- lookupSpecialAttribute object ident+   proc @@ args++subs :: Object -> Object -> Eval Object+subs obj subscript = callMethod obj $(hashedStr "__getitem__") [subscript]++try :: Eval Object -> (Object -> Eval Object) -> Eval Object+try tryComp handler = tryWorker tryComp handler pass Nothing ++tryElse :: Eval Object -> (Object -> Eval Object) -> Eval Object -> Eval Object+tryElse tryComp handler elseComp = +   tryWorker tryComp handler elseComp Nothing ++tryFinally :: Eval Object -> (Object -> Eval Object) -> Eval Object -> Eval Object+tryFinally tryComp handler finallyComp +   = tryWorker tryComp handler pass (Just finallyComp) ++tryElseFinally :: Eval Object -> (Object -> Eval Object) -> Eval Object -> Eval Object -> Eval Object+tryElseFinally tryComp handler elseComp finallyComp +   = tryWorker tryComp handler elseComp (Just finallyComp) ++tryWorker :: Eval Object -> (Object -> Eval Object) -> Eval Object -> Maybe (Eval Object) -> Eval Object+tryWorker tryComp handler elseComp maybeFinallyComp = do+   callCC $ \afterTry -> do+      push (ExceptionHandler +              (Just $ \obj -> do+                   handler obj +                   afterTry none) +              maybeFinallyComp)+      tryComp+      -- XXX checkme. we want to be absolutely certain that the top of the stack will+      -- be the just pushed handler frame.+      -- we have to nullify the top handler because the elseComp should not be+      -- executed in the context of the recently pushed handler. We can't simply+      -- pop the stack because we may have to execute a finally clause.+      nullifyTopHandler+      -- this is only executed if the tryComp does not raise an exception. Control+      -- would not reach here if an exception was raised.+      elseComp+   unwind isExceptionHandler +   pass ++{- Python docs:+For an except clause with an expression, that expression is evaluated, and the clause matches the exception if the resulting object is “compatible” with the exception. An object is compatible with an exception if it is the class or a base class of the exception object or a tuple containing an item compatible with the exception.+-}++except :: Object -> Object -> Eval Object -> Eval Object -> Eval Object+except exceptionObj baseObj match noMatch = do+   BELCH("compatible check: " ++ show (exceptionObj, baseObj))+   isCompatible <- compatibleException exceptionObj baseObj+   if isCompatible+      then match+      else noMatch+   where+   -- XXX fixme, this is not correct+   compatibleException :: Object -> Object -> Eval Bool+   compatibleException exceptionObj baseObj = do+      let typeOfException = typeOf exceptionObj+      objectEquality typeOfException baseObj ++exceptDefault :: Eval Object -> Eval Object -> Eval Object+exceptDefault match _noMatch = match++{-+raise_stmt ::=  "raise" [expression ["from" expression]]+If no expressions are present, raise re-raises the last exception that was active in the current scope. If no exception is active in the current scope, a TypeError exception is raised indicating that this is an error (if running under IDLE, a queue.Empty exception is raised instead).++Otherwise, raise evaluates the first expression as the exception object. It must be either a subclass or an instance of BaseException. If it is a class, the exception instance will be obtained when needed by instantiating the class with no arguments.++The type of the exception is the exception instance’s class, the value is the instance itself.+-}++raise :: Object -> Eval Object+raise obj = do+   BELCH("Raising: " ++ show obj)+   IF_DEBUG(dumpStack)+   exceptionObj <- case obj of+      Type { object_constructor = cons } -> +         callProcedure cons []+      other -> return other+   stack <- gets control_stack+   handleFrame exceptionObj stack+   where+   handleFrame :: Object -> ControlStack -> Eval Object+   handleFrame exceptionObj EmptyStack = do+     str <- showObject exceptionObj+     throw $ UncaughtException str+   handleFrame exceptionObj (ExceptionHandler { exception_handler = handler, exception_finally = finally }) = do+      -- BELCH("ExceptionHandler frame")+      case handler of+         -- this is a nullified handler. We (possibly) execute the finally clause +         -- and keep unwinding.+         Nothing -> do+            -- it is important to pop the stack _before_ executing the finally clause,+            -- otherwise the finally clause would be executed in the wrong context.+            pop+            maybe pass id finally+            raise exceptionObj +         Just handlerAction -> do+            -- note we do not pop the stack here because we want the (possible) finally clause+            -- to remain on top of the stack. Instead we nullify the handler so that it is not+            -- executed again by a subsequent nested raise.+            nullifyTopHandler+            handlerAction exceptionObj+   -- if we walk past a GeneratorCall then we need to smash the continuation to always raise an+   -- exception+   handleFrame exceptionObj (GeneratorCall { generator_object = genObj }) = do+      writeIORef (object_continuation genObj) (raise stopIteration)+      pop >> raise exceptionObj+   handleFrame exceptionObj _other = do+      -- BELCH("other frame")+      pop >> raise exceptionObj+   ++-- XXX fixme+-- This requires that we store the last raised exception somewhere+-- possibly in an activation record?+reRaise :: Eval Object+reRaise = error "reRaise not implemented"++-- XXX fixme+raiseFrom :: Object -> Object -> Eval Object+raiseFrom = error "raiseFrom not implemented"++yield :: Object -> Eval Object +yield obj = do+   BELCH("Yielding " ++ show obj)+   -- IF_DEBUG(dumpStack)+   callCC $ \next -> do+      generatorYield <- unwindYieldContext (next none)+      generatorYield obj++-- the next method for generators+generatorNext :: [Object] -> Eval Object+generatorNext (obj:_) = do+   result <- callCC $ \next ->+      case obj of+         Generator {} -> do+            BELCH("Starting generator")+            stackContext <- readIORef $ object_stack_context obj+            push (stackContext . GeneratorCall next obj)+            BELCH("calling continuation")+            action <- readIORef $ object_continuation obj+            action+            BELCH("raising exception")+            raise stopIteration +         _other -> error "next applied to object which is not a generator"+   ret result+generatorNext [] = error "Generator applied to no arguments"++def :: ObjectRef -> Arity -> Object -> ([ObjectRef] -> Eval Object) -> Eval Object +def ident arity docString fun = do+   let procedureObj = function arity closure+   setattr procedureObj docName docString+   writeIORef ident procedureObj+   return none +   where+   closure :: Procedure +   closure params = do+      argsRefs <- mapM newIORef params +      fun argsRefs ++lambda :: Arity -> ([ObjectRef] -> Eval Object) -> Eval Object+lambda arity fun = +   return $ function arity closure +   where+   closure :: Procedure +   closure params = do+      argsRefs <- mapM newIORef params +      fun argsRefs++mkGenerator :: Eval Object -> Eval Object+mkGenerator cont = do+   generatorObj <- generator cont+   ret generatorObj++printObject :: Object -> Eval () +printObject obj = do+   str <- showObject obj+   putStr str ++showObject :: Object -> Eval String+-- XXX this should really choose the right quotes based on the content of the string.+showObject obj@(String {}) = return ("'" ++ object_string obj ++ "'")+showObject obj = object_string <$> callSpecialMethod obj strName []++pyCallCC :: Object -> Eval Object+pyCallCC fun = +   callCC $ \ret -> do+      context <- getControlStack +      let cont = function 1 $ \(obj:_) -> do+                    -- XXX should this run finalisers on the way out?+                    setControlStack context+                    ret obj+      -- XXX can this be a tail call?+      fun @@ [cont]
+ src/Berp/Base/SemanticTypes.hs view
@@ -0,0 +1,177 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Base.SemanticTypes+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- The core types used to represent the state of Python programs. We put+-- them all here in one file because they tend to be mutually recursive.+-- Using one file for such types tends to avoid problems with unbreakable+-- cycles in the Haskell module imports. Try not to put functions in here+-- (except perhaps type class instances).+--+-----------------------------------------------------------------------------++module Berp.Base.SemanticTypes +   ( Procedure, ControlStack (..), EvalState (..), Object (..), Eval, ObjectRef+   , HashTable, ListArray, Arity )  where++import Control.Monad.State.Strict (StateT)+import Control.Monad.Cont (ContT) +import Data.IntMap (IntMap)+import Data.IORef (IORef)+import Data.Array.IO (IOArray)+import Berp.Base.Identity (Identity)++data ControlStack+   = EmptyStack +   | ProcedureCall +     { procedure_return :: Object -> Eval Object +     , control_stack_tail :: ControlStack+     }+   | ExceptionHandler +     { exception_handler :: Maybe (Object -> Eval Object)+     , exception_finally :: Maybe (Eval Object) +     , control_stack_tail :: ControlStack+     }+   | WhileLoop +     { loop_start :: Eval Object+     , loop_end :: Eval Object+     , control_stack_tail :: ControlStack+     }+   | GeneratorCall+     { generator_yield :: Object -> Eval Object+     , generator_object :: Object+     , control_stack_tail :: ControlStack+     } ++instance Show ControlStack where+   show EmptyStack = "EmptyStack"+   show (ProcedureCall {}) = "ProcedureCall"+   show (ExceptionHandler {}) = "ExceptionHandler"+   show (WhileLoop {}) = "WhileLoop"+   show (GeneratorCall {}) = "GeneratorCall"++data EvalState = EvalState { control_stack :: !ControlStack }++type Eval a = StateT EvalState (ContT Object IO) a++type ObjectRef = IORef Object+type Procedure = [Object] -> Eval Object++-- XXX maybe this should be:+-- IORef (IntMap (IORef [(Object, Object)]))+-- or even:+-- IORef (IntMap (IORef [(Object, ObjectRef)]))+type HashTable = IORef (IntMap [(Object, Object)])++type ListArray = IOArray Integer Object+type Arity = Int++{-+-- Here's another possible encoding of objects which is more abstract.+-- It would make it easier to add new object types, and they could be added+-- in separate modules. The problem is that it would make it slower for+-- detecting the kind of object we have, compared to the Alegabraic approach+-- which gives us a tag to match against.++class ObjectLike t where+   identity :: t -> Identity+   ...++data Object = forall t . (ObjectLike t, Typeable t) => O t++instance ObjectLike Object where+   identity (O x) = identity x+   ...+-}++-- XXX probably need Bound Methods.+data Object+   = Object +     { object_identity :: !Identity+     , object_type :: !Object -- type+     , object_dict :: !Object -- dictionary+     }+   | Type +     { object_identity :: !Identity+     , object_type :: Object  -- type+     , object_dict :: !Object  -- dictionary+     , object_bases :: !Object -- tuple +     , object_constructor :: !Procedure +     , object_type_name :: !Object -- string+     , object_mro :: !Object -- tuple. Method Resolution Order.+     }+   | Integer+     { object_identity :: !Identity+     , object_integer :: !Integer+     }+   | Bool+     { object_identity :: !Identity+     , object_bool :: !Bool+     }+   | Tuple+     { object_identity :: !Identity+     , object_tuple :: ![Object]+     , object_length :: !Int+     }+   | List +     { object_identity :: !Identity+     , object_list_elements :: IORef ListArray+     , object_list_num_elements :: Integer+     }+   | Function+     { object_identity :: !Identity+     , object_procedure :: !Procedure+     , object_arity :: !Arity+     , object_dict :: !Object -- dictionary+     } +   | String+     { object_identity :: !Identity+     , object_string :: !String+     }+   | Dictionary+     { object_identity :: !Identity+     , object_hashTable :: !HashTable+     }+   | Generator+     { object_identity :: !Identity+     , object_continuation :: !(IORef (Eval Object))+     , object_stack_context :: !(IORef (ControlStack -> ControlStack))+     }+   | None ++-- For debugging only+instance Show Object where+   show obj@(Object {}) = "object of (" ++ show (object_type obj) ++ ")"+   show obj@(Type {}) = "type(" ++ show (object_type_name obj) ++ ")"+   show obj@(Integer {}) = "integer(" ++ show (object_integer obj) ++ ")"+   show obj@(Bool {}) = "bool(" ++ show (object_bool obj) ++ ")"+   show (Tuple {}) = "tuple"+   show (List {}) = "list"+   show (Function {}) = "function"+   show obj@(String {}) = "string(" ++ show (object_string obj) ++ ")"+   show (Dictionary {}) = "dictionary"+   show (Generator {}) = "generator"+   show (None {}) = "None"++-- equality instance for objects+-- NOTE: use with care. This does not call the user defined equality+-- on the objet. It only uses identity equality.++instance Eq Object where+   None {} == None {} = True+   obj1 == obj2 = object_identity obj1 == object_identity obj2++{-+-- needed for overloaded numeric literals+instance Num Object where+    fromInteger = int+    (+) = undefined+    (*) = undefined+    abs = undefined+    signum = undefined+-}
+ src/Berp/Base/StdNames.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE TemplateHaskell #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Base.StdNames+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- Hashed versions of standard Python identifiers.+--+-----------------------------------------------------------------------------++module Berp.Base.StdNames where++import Berp.Base.Hash (hashedStr, Hashed)++addName :: Hashed String+addName = $(hashedStr "__add__")+andName :: Hashed String+andName = $(hashedStr "__and__")+eqName :: Hashed String+eqName = $(hashedStr "__eq__")+getItemName :: Hashed String+getItemName = $(hashedStr "__getitem__")+geName :: Hashed String+geName = $(hashedStr "__ge__")+gtName :: Hashed String+gtName = $(hashedStr "__gt__")+leName :: Hashed String+leName = $(hashedStr "__le__")+ltName :: Hashed String+ltName = $(hashedStr "__lt__")+cmpName :: Hashed String +cmpName = $(hashedStr "__cmp__")+mulName :: Hashed String+mulName = $(hashedStr "__mul__")+orName :: Hashed String+orName = $(hashedStr "__or__")+setItemName :: Hashed String+setItemName = $(hashedStr "__setitem__")+strName :: Hashed String+strName = $(hashedStr "__str__")+subName :: Hashed String+subName = $(hashedStr "__sub__")+iterName :: Hashed String+iterName = $(hashedStr "__iter__")+nextName :: Hashed String+nextName = $(hashedStr "__next__")+modName :: Hashed String+modName = $(hashedStr "__mod__")+docName :: Hashed String+docName = $(hashedStr "__doc__")+initName :: Hashed String+initName = $(hashedStr "__init__")+mroName :: Hashed String+mroName = $(hashedStr "mro")
+ src/Berp/Base/StdTypes/Bool.hs view
@@ -0,0 +1,69 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Base.StdTypes.Bool+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- The standard boolean type.+--+-----------------------------------------------------------------------------++module Berp.Base.StdTypes.Bool (bool, true, false, boolClass) where++import Prelude hiding (and, or)+import Berp.Base.Monad (constantIO)+import Berp.Base.Prims (binOp, primitive)+import Berp.Base.SemanticTypes (Object (..))+import Berp.Base.Identity (newIdentity)+import Berp.Base.Attributes (mkAttributes)+import Berp.Base.StdNames+import {-# SOURCE #-} Berp.Base.StdTypes.Type (newType)+import Berp.Base.StdTypes.String (string)+import Berp.Base.StdTypes.ObjectBase (objectBase)++bool :: Bool -> Object+bool True = true +bool False = false++{-# NOINLINE true #-}+{-# NOINLINE false #-}+true, false :: Object+true =+   constantIO $ do+      identity <- newIdentity+      return $ Bool { object_identity = identity, object_bool = True }+false =+   constantIO $ do+      identity <- newIdentity+      return $ Bool { object_identity = identity, object_bool = False }++{-# NOINLINE boolClass #-}+boolClass :: Object+boolClass = constantIO $ do+   dict <- attributes+   theType <- newType [string "bool", objectBase, dict]+   return $ theType { object_constructor = \_ -> return false }+    +attributes :: IO Object +attributes = mkAttributes +   [ (andName, and)+   , (orName, or)+   , (strName, str)+   ]++-- XXX this doesn't look safe to me. What if wrong number of arguments? Or +-- argument objects are not booleans?+binOpBool :: (Bool -> Bool -> Bool) -> Object +binOpBool f = primitive 2 $ \[x,y] -> binOp x y object_bool f (Prelude.return . bool)++and :: Object +and = binOpBool (&&) ++or :: Object +or = binOpBool (||)++str :: Object +str = primitive 1 $ \[x] -> Prelude.return $ string $ show $ object_bool x
+ src/Berp/Base/StdTypes/Bool.hs-boot view
@@ -0,0 +1,7 @@+module Berp.Base.StdTypes.Bool (boolClass, bool, true, false) where++import Berp.Base.SemanticTypes (Object)++bool :: Bool -> Object+true,false :: Object+boolClass :: Object
+ src/Berp/Base/StdTypes/Dictionary.hs view
@@ -0,0 +1,84 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Base.StdTypes.Dictionary+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- The standard dictionary type.+--+-----------------------------------------------------------------------------++module Berp.Base.StdTypes.Dictionary (emptyDictionary, dictionary, dictionaryClass) where++import Data.List (intersperse)+import Berp.Base.Prims (primitive, showObject)+import Berp.Base.Monad (constantIO)+import Berp.Base.SemanticTypes (Procedure, Object (..), Eval)+import Berp.Base.Identity (newIdentity)+import Berp.Base.HashTable as Hash (fromList, empty, mappings, lookup)+import Berp.Base.Attributes (mkAttributes)+import Berp.Base.StdNames+import {-# SOURCE #-} Berp.Base.StdTypes.Type (newType)+import Berp.Base.StdTypes.ObjectBase (objectBase)+import Berp.Base.StdTypes.String (string)++emptyDictionary :: IO Object+emptyDictionary = do +   identity <- newIdentity+   hashTable <- Hash.empty +   return $ +      Dictionary +      { object_identity = identity+      , object_hashTable = hashTable +      }++dictionary :: [(Object, Object)] -> Eval Object+dictionary elements = do +   identity <- newIdentity+   hashTable <- fromList elements+   return $ +      Dictionary +      { object_identity = identity+      , object_hashTable = hashTable +      }++{-# NOINLINE dictionaryClass #-}+dictionaryClass :: Object+dictionaryClass = constantIO $ do +   dict <- attributes+   newType [string "dict", objectBase, dict]++attributes :: IO Object +attributes = mkAttributes +   [ (eqName, primitive 2 eq)+   , (strName, primitive 1 str)+   , (getItemName, primitive 2 getItem)+   ]++eq :: Procedure +eq = error "== on dict not defined"++str :: Procedure +str (obj:_) = do+   ms <- mappings $ object_hashTable obj+   strs <- mapM dictEntryString ms+   return $ string ("{" ++ concat (intersperse ", " strs) ++ "}")+   where+   dictEntryString :: (Object, Object) -> Eval String+   dictEntryString (obj1, obj2) = do+      objStr1 <- showObject obj1+      objStr2 <- showObject obj2+      return (objStr1 ++ ": " ++ objStr2)+str _other = error "str conversion on dictionary applied to wrong number of arguments"++getItem :: Procedure+getItem (obj:index:_) = do+   let ht = object_hashTable obj+   maybeVal <- Hash.lookup index ht+   case maybeVal of +      Nothing -> error "dict lookup failed" +      Just val -> return val  +getItem _other = error "getItem on dictionary applied to wrong number of arguments"
+ src/Berp/Base/StdTypes/Dictionary.hs-boot view
@@ -0,0 +1,7 @@+module Berp.Base.StdTypes.Dictionary (emptyDictionary, dictionary, dictionaryClass) where++import Berp.Base.SemanticTypes (Object, Eval)++dictionary :: [(Object, Object)] -> Eval Object+dictionaryClass :: Object+emptyDictionary :: IO Object
+ src/Berp/Base/StdTypes/Function.hs view
@@ -0,0 +1,46 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Base.StdTypes.Function+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- The standard function type.+--+-----------------------------------------------------------------------------++module Berp.Base.StdTypes.Function (function, functionClass) where++import Berp.Base.Monad (constantIO)+import Berp.Base.SemanticTypes (Object (..), Procedure)+import Berp.Base.Identity (newIdentity)+import Berp.Base.Attributes (mkAttributes)+import Berp.Base.StdTypes.Dictionary (emptyDictionary)+import {-# SOURCE #-} Berp.Base.StdTypes.Type (newType)+import Berp.Base.StdTypes.ObjectBase (objectBase)+import Berp.Base.StdTypes.String (string)++{-# NOINLINE function #-}+function :: Int -> Procedure -> Object +function arity p = constantIO $ do +   identity <- newIdentity+   dict <- emptyDictionary+   return $+      Function +      { object_identity = identity +      , object_dict = dict +      , object_procedure = p+      , object_arity = arity+      }++{-# NOINLINE functionClass #-}+functionClass :: Object+functionClass = constantIO $ do +   dict <- attributes+   newType [string "function", objectBase, dict]++-- XXX update my attributes+attributes :: IO Object +attributes = mkAttributes []
+ src/Berp/Base/StdTypes/Function.hs-boot view
@@ -0,0 +1,6 @@+module Berp.Base.StdTypes.Function (function, functionClass) where++import Berp.Base.SemanticTypes (Object (..), Procedure)++function :: Int -> Procedure -> Object +functionClass :: Object
+ src/Berp/Base/StdTypes/Generator.hs view
@@ -0,0 +1,62 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Base.StdTypes.Generator+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- The standard generator type.+--+-----------------------------------------------------------------------------++module Berp.Base.StdTypes.Generator (generator, generatorClass) where++import Berp.Base.Monad (constantIO)+import Berp.Base.SemanticTypes (Object (..), Eval)+import Berp.Base.Identity (newIdentity)+import Berp.Base.Attributes (mkAttributes)+import Berp.Base.StdNames+import Berp.Base.Prims (generatorNext, primitive)+import Berp.Base.LiftedIO (newIORef)+import {-# SOURCE #-} Berp.Base.StdTypes.Type (newType)+import Berp.Base.StdTypes.ObjectBase (objectBase)+import Berp.Base.StdTypes.String (string)+import Berp.Base.StdTypes.Function (function)++generator :: Eval Object -> Eval Object +generator continuation = do +   identity <- newIdentity+   contRef <- newIORef continuation +   stackRef <- newIORef id+   return $+      Generator+      { object_identity = identity +      , object_continuation = contRef +      , object_stack_context = stackRef +      }++{-# NOINLINE generatorClass #-}+generatorClass :: Object+generatorClass = constantIO $ do +   dict <- attributes+   newType [string "generator", objectBase, dict]++-- XXX update my attributes+attributes :: IO Object+attributes = mkAttributes+   [ (iterName, iter)+   , (strName, str)+   , (nextName, next)+   ]++-- XXX fixme+str :: Object+str = primitive 1 $ \_ -> return $ string $ "Generator" ++iter :: Object+iter = primitive 1 $ \(x:_) -> return x++next :: Object+next = function 1 generatorNext
+ src/Berp/Base/StdTypes/Generator.hs-boot view
@@ -0,0 +1,6 @@+module Berp.Base.StdTypes.Generator (generator, generatorClass) where++import Berp.Base.SemanticTypes (Object (..), Eval)++generator :: Eval Object -> Eval Object +generatorClass :: Object
+ src/Berp/Base/StdTypes/Integer.hs view
@@ -0,0 +1,88 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Base.StdTypes.Integer+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- The standard integer type.+--+-----------------------------------------------------------------------------++module Berp.Base.StdTypes.Integer (int, intClass) where++import Berp.Base.Monad (constantIO)+import Berp.Base.Prims (binOp, primitive)+import Berp.Base.SemanticTypes (Object (..))+import Berp.Base.StdTypes.Bool (bool)+import Berp.Base.Identity (newIdentity)+import Berp.Base.Attributes (mkAttributes)+import Berp.Base.StdNames +import {-# SOURCE #-} Berp.Base.StdTypes.Type (newType)+import Berp.Base.StdTypes.ObjectBase (objectBase)+import Berp.Base.StdTypes.String (string)++{-# NOINLINE int #-}+int :: Integer -> Object +int i = constantIO $ do+   identity <- newIdentity+   return $ Integer { object_identity = identity, object_integer = i }++{-# NOINLINE intClass #-}+intClass :: Object+intClass = constantIO $ do+   dict <- attributes+   newType [string "int", objectBase, dict]++attributes :: IO Object +attributes = mkAttributes +   [ (addName, add)+   , (subName, sub)+   , (mulName, mul)+   , (ltName, lt)+   , (leName, le)+   , (gtName, gt)+   , (geName, ge)+   , (eqName, eq)+   , (strName, str)+   , (modName, modulus)+   ]++binOpInteger :: (Integer -> Integer -> Integer) -> Object+binOpInteger f = primitive 2 $ \[x,y] -> binOp x y object_integer f (return . int)++binOpBool :: (Integer -> Integer -> Bool) -> Object +binOpBool f = primitive 2 $ \[x,y] -> binOp x y object_integer f (return . bool)+        +add :: Object +add = binOpInteger (+) ++sub :: Object +sub = binOpInteger (-) ++mul :: Object +mul = binOpInteger (*)++lt :: Object +lt = binOpBool (<) ++le :: Object +le = binOpBool (<=) ++gt :: Object +gt = binOpBool (>)++ge :: Object +ge = binOpBool (>=)++eq :: Object +eq = binOpBool (==) ++modulus :: Object+modulus = binOpInteger mod++str :: Object +str = primitive 1 $ \[x] -> return $ string $ show $ object_integer x+-- str = primitive 1 $ \[x] -> return $ string "wazza"
+ src/Berp/Base/StdTypes/Integer.hs-boot view
@@ -0,0 +1,6 @@+module Berp.Base.StdTypes.Integer (int, intClass) where++import Berp.Base.SemanticTypes (Object)++int :: Integer -> Object +intClass :: Object
+ src/Berp/Base/StdTypes/List.hs view
@@ -0,0 +1,156 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Base.StdTypes.List+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- The standard list type.+--+-----------------------------------------------------------------------------++module Berp.Base.StdTypes.List (list, listClass, listIndex) where++import Control.Monad.Trans (liftIO)+import Berp.Base.LiftedIO (newIORef, readIORef)+import Data.Array.MArray (newListArray, readArray, getElems, getBounds, writeArray, newArray_)+import Data.List (intersperse)+import Data.Foldable (traverse_)+import Berp.Base.Prims (primitive, yield, pass, showObject)+import Berp.Base.Monad (constantIO)+import Berp.Base.SemanticTypes (Procedure, Object (..), Eval, ListArray)+import Berp.Base.Identity (newIdentity)+import Berp.Base.Attributes (mkAttributes)+import Berp.Base.StdNames+import {-# SOURCE #-} Berp.Base.StdTypes.Type (newType)+import Berp.Base.StdTypes.ObjectBase (objectBase)+import Berp.Base.StdTypes.String (string)+import Berp.Base.StdTypes.Generator (generator)++list :: [Object] -> Eval Object+list = liftIO . listIO++listIO :: [Object] -> IO Object+listIO elements = do +   let numElements = fromIntegral (length elements)+   array <- newListArray (0, numElements - 1) elements+   listFromArray numElements array++listFromArray :: Integer -> ListArray -> IO Object+listFromArray numElements array = do+   identity <- newIdentity+   arrayRef <- newIORef array+   return $ +      List +      { object_identity = identity+      , object_list_elements = arrayRef+      , object_list_num_elements = numElements+      }++listIndex :: Object -> Object -> Eval Object+listIndex list index = liftIO $ do+   let numElements = object_list_num_elements list+   normIndex <- normaliseIndex index numElements+   array <- readIORef $ object_list_elements list+   readArray array normIndex ++normaliseIndex :: Object -> Integer -> IO Integer+normaliseIndex index numElements =+   case index of+      Integer {} -> do+         let indexInteger = positiveIndex $ object_integer index+         if indexInteger < 0 || indexInteger >= numElements+            then fail "list index out of range"+            else return indexInteger+      _other -> fail "list indices must be integers"+   where+   positiveIndex index+      | index < 0 = numElements + index+      | otherwise = index++listAppend :: Object -> Object -> Eval Object+listAppend list1 list2 = liftIO $ do+   array1 <- readIORef $ object_list_elements list1 +   array2 <- readIORef $ object_list_elements list2+   (_lo1, hi1) <- getBounds array1+   (_lo2, hi2) <- getBounds array2+   if hi2 < 0+      -- list2 is empty+      then return list1+      else do+         let newUpperBound = hi1 + hi2 + 1+         let size1 = hi1 + 1+         resultArray <- newArray_ (0, newUpperBound)+         copyElements size1 array1 0 resultArray+         copyElements (hi2 + 1) array2 size1 resultArray+         listFromArray (newUpperBound + 1) resultArray ++copyElements :: Integer -> ListArray -> Integer -> ListArray -> IO () +copyElements howMany from toIndex to+   = copyElementsW 0 toIndex+   where+   copyElementsW :: Integer -> Integer -> IO ()+   copyElementsW fromIndex toIndex+      | fromIndex == howMany = return ()+      | otherwise = do+           fromVal <- readArray from fromIndex+           writeArray to toIndex fromVal+           copyElementsW (fromIndex + 1) (toIndex + 1)++updateListElement :: Object -> Object -> Object -> Eval Object+updateListElement list index value = liftIO $ do+   let numElements = object_list_num_elements list+   normIndex <- normaliseIndex index numElements +   array <- readIORef $ object_list_elements list+   writeArray array normIndex value+   return list++{-# NOINLINE listClass #-}+listClass :: Object+listClass = constantIO $ do +   dict <- attributes+   newType [string "list", objectBase, dict]++attributes :: IO Object +attributes = mkAttributes +   [ (eqName, eq)+   , (strName, primitive 1 str)+   , (getItemName, primitive 2 getItem) +   , (addName, primitive 2 add)+   , (setItemName, primitive 3 setItem)+   , (iterName, primitive 1 iter)+   ]++eq :: Object +eq = error "== on list not defined"++getItem :: Procedure +getItem (x:y:_) = listIndex x y+getItem _other = error "getItem on list applied to wrong number of arguments"++str :: Procedure +str (x:_) = do+   elements <- liftIO $ do+      array <- readIORef $ object_list_elements x  +      getElems array+   strings <- mapM showObject elements +   -- let strings = map object_string objStrs+   Prelude.return $ string $ "[" ++ concat (intersperse ", " strings) ++ "]"+str _other = error "str on list applied to wrong number of arguments"++add :: Procedure +add (x:y:_) = listAppend x y +add _other = error "add on list applied to wrong number of arguments"++setItem :: Procedure +setItem (x:y:z:_) = updateListElement x y z+setItem _other = error "setItem on list applied to wrong number of arguments"++iter :: Procedure+iter (x:_) = do+   array <- readIORef $ object_list_elements x+   elements <- liftIO $ getElems array+   generator (traverse_ yield elements >> pass)+iter _other = error "iter on list applied to wrong number of arguments"
+ src/Berp/Base/StdTypes/List.hs-boot view
@@ -0,0 +1,7 @@+module Berp.Base.StdTypes.List (list, listIndex, listClass) where++import Berp.Base.SemanticTypes (Object, Eval)++list :: [Object] -> Eval Object+listClass :: Object+listIndex :: Object -> Object -> Eval Object
+ src/Berp/Base/StdTypes/None.hs view
@@ -0,0 +1,51 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Base.StdTypes.None+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- The standard none type.+--+-----------------------------------------------------------------------------++module Berp.Base.StdTypes.None (none, noneIdentity, noneClass) where++import Berp.Base.Prims (primitive)+import Berp.Base.Monad (constantIO)+import Berp.Base.SemanticTypes (Procedure, Object (..))+import Berp.Base.StdTypes.Bool (true, false)+import Berp.Base.Identity (newIdentity, Identity)+import Berp.Base.Attributes (mkAttributes)+import Berp.Base.StdNames+import {-# SOURCE #-} Berp.Base.StdTypes.Type (newType)+import Berp.Base.StdTypes.ObjectBase (objectBase)+import Berp.Base.StdTypes.String (string)++none :: Object +none = None ++{-# NOINLINE noneIdentity #-}+noneIdentity :: Identity+noneIdentity = constantIO newIdentity++{-# NOINLINE noneClass #-}+noneClass :: Object+noneClass = constantIO $ do +   dict <- attributes+   newType [string "NoneType", objectBase, dict]++attributes :: IO Object +attributes = mkAttributes +   [ (eqName, primitive 2 eq)+   , (strName, primitive 1 str)+   ]+        +eq :: Procedure +eq [None, None] = return true +eq _ = Prelude.return false ++str :: Procedure +str _ = Prelude.return $ string "None"
+ src/Berp/Base/StdTypes/None.hs-boot view
@@ -0,0 +1,8 @@+module Berp.Base.StdTypes.None (noneIdentity, none, noneClass) where++import Berp.Base.SemanticTypes (Object)+import Berp.Base.Identity (Identity)++none :: Object +noneClass :: Object+noneIdentity :: Identity
+ src/Berp/Base/StdTypes/Object.hs view
@@ -0,0 +1,66 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Base.StdTypes.Object+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- The standard object type (the base of all types).+--+-----------------------------------------------------------------------------++module Berp.Base.StdTypes.Object (object) where++import Prelude hiding (init)+import Berp.Base.SemanticTypes (Procedure, Object (..))+import Berp.Base.Monad (constantIO)+import Berp.Base.Attributes (mkAttributes)+import Berp.Base.StdNames (strName, eqName, initName)+import Berp.Base.Prims (primitive)+import Berp.Base.Object (identityOf)+import {-# SOURCE #-} Berp.Base.StdTypes.Type (newType)+import {-# SOURCE #-} Berp.Base.StdTypes.Tuple (emptyTuple)+import {-# SOURCE #-} Berp.Base.StdTypes.String (string)+import {-# SOURCE #-} Berp.Base.StdTypes.Bool (bool)+import {-# SOURCE #-} Berp.Base.StdTypes.None (none)++{-# NOINLINE object #-}+object :: Object+object = constantIO $ do +   dict <- attributes +   newType [string "object", emptyTuple, dict]++attributes :: IO Object+attributes = mkAttributes +   [ (strName, primitive 1 str) +   , (eqName, primitive 2 eq)+   , (initName, primitive 1 init)+   ]++-- does nothing+init :: Procedure+init _ = return none++eq :: Procedure+eq (obj1:obj2:_) = return $ bool (identityOf obj1 == identityOf obj2)+eq _other = error "equality on objects applied to wrong number of arguments"++str :: Procedure+str (x:_) = +   case x of +      Object {} -> do+         let objTypeNameStr = object_string $ object_type_name $ object_type x+         let identity = identityOf x +         return $ string $ "<" ++ objTypeNameStr ++ " object with identity " ++ show identity ++ ">" +      Type {} -> do+         let typeName = object_string $ object_type_name x+         return $ string $ "<class " ++ typeName ++ ">" +      Function {} -> do +         let identity = identityOf x +         return $ string $ "<function with identity " ++ show identity ++ ">"+      -- This should never happen because all other object types have a specialised+      -- str method.+      _other -> return $ string "<unknown object>"+str _other = error "str conversion on object applied to wrong number of arguments"
+ src/Berp/Base/StdTypes/Object.hs-boot view
@@ -0,0 +1,5 @@+module Berp.Base.StdTypes.Object (object) where++import Berp.Base.SemanticTypes (Object)++object :: Object
+ src/Berp/Base/StdTypes/ObjectBase.hs view
@@ -0,0 +1,24 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Base.StdTypes.ObjectBase+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- Most (all?) of the standard types have "object" as their (only) base+-- class. In Python the base classes are stored as a tuple of objects.+-- Since this is shared by many of the standard types it makes sense+-- to define it once, instead of making many copies.+--+-----------------------------------------------------------------------------++module Berp.Base.StdTypes.ObjectBase (objectBase) where++import Berp.Base.SemanticTypes (Object)+import {-# SOURCE #-} Berp.Base.StdTypes.Object (object)+import {-# SOURCE #-} Berp.Base.StdTypes.Tuple (tuple)++objectBase :: Object+objectBase = tuple [object]
+ src/Berp/Base/StdTypes/ObjectBase.hs-boot view
@@ -0,0 +1,5 @@+module Berp.Base.StdTypes.ObjectBase (objectBase) where++import Berp.Base.SemanticTypes (Object)++objectBase :: Object
+ src/Berp/Base/StdTypes/String.hs view
@@ -0,0 +1,60 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Base.StdTypes.String+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- The standard string type.+--+-----------------------------------------------------------------------------++module Berp.Base.StdTypes.String (string, stringClass, emptyString) where++import Berp.Base.Prims (primitive)+import Berp.Base.Monad (constantIO)+import Berp.Base.Prims (binOp)+import Berp.Base.SemanticTypes (Object (..))+import Berp.Base.Identity (newIdentity)+import {-# SOURCE #-} Berp.Base.StdTypes.Bool (bool)+import Berp.Base.Attributes (mkAttributes)+import Berp.Base.StdNames+import {-# SOURCE #-} Berp.Base.StdTypes.Type (newType)+import Berp.Base.StdTypes.ObjectBase (objectBase)++emptyString :: Object+emptyString = string "" ++{-# NOINLINE string #-}+string :: String -> Object+string str = constantIO $ do +   identity <- newIdentity+   return $ +      String+      { object_identity = identity+      , object_string = str +      }++{-# NOINLINE stringClass #-}+stringClass :: Object+stringClass = constantIO $ do+   dict <- attributes+   newType [string "str", objectBase, dict]++attributes :: IO Object +attributes = mkAttributes +   [ (eqName, eq)+   , (strName, str)+   , (addName, add)+   ]+        +eq :: Object +eq = primitive 2 $ \[x,y] -> binOp x y object_string (==) (Prelude.return . bool)++str :: Object +str = primitive 1 $ \[x] -> Prelude.return x ++add :: Object +add = primitive 2 $ \[x,y] -> binOp x y object_string (++) (Prelude.return . string)
+ src/Berp/Base/StdTypes/String.hs-boot view
@@ -0,0 +1,7 @@+module Berp.Base.StdTypes.String (string, stringClass, emptyString) where++import Berp.Base.SemanticTypes (Object)++string :: String -> Object+stringClass :: Object+emptyString :: Object
+ src/Berp/Base/StdTypes/Tuple.hs view
@@ -0,0 +1,65 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Base.StdTypes.Tuple+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- The standard tuple type.+--+-----------------------------------------------------------------------------++module Berp.Base.StdTypes.Tuple (tuple, tupleClass, emptyTuple, getTupleElements) where++import Data.List (intersperse)+import Berp.Base.Monad (constantIO)+import Berp.Base.SemanticTypes (Object (..))+import Berp.Base.Prims (primitive, showObject)+import Berp.Base.Identity (newIdentity)+import Berp.Base.Attributes (mkAttributes)+import Berp.Base.StdNames+import {-# SOURCE #-} Berp.Base.StdTypes.Type (newType)+import Berp.Base.StdTypes.ObjectBase (objectBase)+import Berp.Base.StdTypes.String (string)++emptyTuple :: Object+emptyTuple = tuple []++{-# NOINLINE tuple #-}+tuple :: [Object] -> Object+tuple elements = constantIO $ do +   identity <- newIdentity+   return $ +      Tuple+      { object_identity = identity+      , object_tuple = elements+      , object_length = length elements+      }++{-# NOINLINE tupleClass #-}+tupleClass :: Object+tupleClass = constantIO $ do +   dict <- attributes+   newType [string "tuple", objectBase, dict]++getTupleElements :: Object -> [Object]+getTupleElements (Tuple { object_tuple = objs }) = objs+getTupleElements _other = error "bases of object is not a tuple"++attributes :: IO Object +attributes = mkAttributes +   [ (eqName, eq)+   , (strName, str)+   ]++eq :: Object +eq = error "== on tuple not defined"++str :: Object +str = primitive 1 $ \[x] -> do+   strings <- mapM showObject $ object_tuple x+   case strings of+      [oneString] -> return $ string $ "(" ++ oneString ++ ",)"+      _other -> return $ string $ "(" ++ concat (intersperse ", " strings) ++ ")"
+ src/Berp/Base/StdTypes/Tuple.hs-boot view
@@ -0,0 +1,9 @@+module Berp.Base.StdTypes.Tuple +   (tuple, tupleClass, emptyTuple, getTupleElements) where++import Berp.Base.SemanticTypes (Object)++tuple :: [Object] -> Object+tupleClass :: Object+emptyTuple :: Object+getTupleElements :: Object -> [Object]
+ src/Berp/Base/StdTypes/Type.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE PatternGuards #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Base.StdTypes.Type+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- The standard "type" type.+--+-----------------------------------------------------------------------------++module Berp.Base.StdTypes.Type (typeClass, newType) where++import Data.List (delete)+import Control.Monad.Trans (liftIO)+import Berp.Base.SemanticTypes (Object (..), Procedure)+import Berp.Base.Monad (constantIO)+import Berp.Base.Identity (newIdentity)+import Berp.Base.Attributes (mkAttributes)+import Berp.Base.Object (typeOf)+import Berp.Base.Prims (primitive, callMethod, returningProcedure)+import Berp.Base.StdNames (mroName, initName)+import Berp.Base.StdTypes.Object (object)+import Berp.Base.StdTypes.Dictionary (emptyDictionary)+import Berp.Base.StdTypes.ObjectBase (objectBase)+import Berp.Base.StdTypes.String (string)+import Berp.Base.StdTypes.Tuple (tuple)++{-# NOINLINE typeClass #-}+typeClass :: Object+typeClass = constantIO $ do +   identity <- newIdentity+   dict <- attributes+   return $ +      Type +      { object_identity = identity +      , object_type = typeClass  -- yes it is recursive!+      , object_dict = dict+      , object_bases = objectBase +      , object_constructor = returningProcedure (\args -> liftIO $ newType args)+      , object_type_name = string "type"+      , object_mro = tuple [typeClass, object]+      }++newType :: [Object] -> IO Object +newType args+   | [obj] <- args = return $ typeOf obj +   | [name, bases, dict] <- args = do+        identity <- newIdentity+        let theType =+             Type +             { object_identity = identity+             , object_type = typeClass+             , object_dict = dict+             , object_bases = bases+             , object_constructor = returningProcedure $ instantiate theType +             , object_type_name = name ++             -- XXX we should force the eval of the mro here to catch any errors up front.+             , object_mro = tuple $ mro theType $ getTupleElements bases +             }  +        return theType +   | otherwise = fail "type() takes 1 or 3 arguments"++getTupleElements :: Object -> [Object] +getTupleElements (Tuple { object_tuple = objs }) = objs+getTupleElements _other = error "bases of object is not a tuple"++instantiate :: Object -> Procedure+instantiate objectType args = do+   identity <- liftIO $ newIdentity+   dict <- liftIO $ emptyDictionary+   let object =+         Object+         { object_identity = identity+         , object_type = objectType +         , object_dict = dict+         }+   -- callMethodMaybe object initName []+   -- everything should have an init??+   callMethod object initName args +   return object++attributes :: IO Object+attributes = +   mkAttributes [ (mroName, primitive 1 mroMethod) ]++mroMethod :: Procedure+mroMethod (obj:_) = return $ object_mro obj +mroMethod _other = error "mro called with wrong number of arguments"++{- Compute the linearization of a class with respect to its base classes.++From the Python Pep "The Python 2.3 Method Resolution Order":++   "the linearization of C is the sum of C plus the merge of the +    linearizations of the parents and the list of the parents."++    L[C(B1 ... BN)] = C + merge(L[B1] ... L[BN], B1 ... BN)++-}++mro :: Object -> [Object] -> [Object]+mro klass bases +   = klass : merge (map getMro bases ++ [bases])+   where+   getMro :: Object -> [Object]+   getMro (Type { object_mro = obj }) = getTupleElements obj+   getMro _other = error "Fatal error: object's base is not a type" -- XXX fixme++{-++From the Python Pep "The Python 2.3 Method Resolution Order":++  take the head of the first list, i.e L[B1][0]; if this head is not in the tail +  of any of the other lists, then add it to the linearization of C and remove it +  from the lists in the merge, otherwise look at the head of the next list and +  take it, if it is a good head. Then repeat the operation until all the class +  are removed or it is impossible to find good heads. In this case, it is +  impossible to construct the merge, Python 2.3 will refuse to create the class +  C and will raise an exception.++  NOTE: relies on an Eq instance for Object, which uses only identity equality.++  The code assumes that a given class appears at most once in any sequence.+  XXX need to check this precondition. Can we check statically?+-}++merge :: [[Object]] -> [Object]+merge seqs = +   mergeWork [] $ nonEmptySeqs seqs +   where++   -- Precondition: seqs does not contain any empty sequences.++   mergeWork acc seqs +      | null seqs = reverse acc+      | candidate:_ <- findCandidate seqs+           = mergeWork (candidate:acc) $ +                nonEmptySeqs $ removeCandidate candidate seqs +      | otherwise+           = error "Cannot create a consistent method resolution" -- XXX should we make this an exception? ++   -- Precondition: seqs does not contain any empty sequences.+   -- Otherwise the "head" and "tail" are not safe.++   findCandidate :: [[Object]] -> [Object]+   findCandidate seqs = +      [ candidate | candidate <- map head seqs,+        all (candidate `notElem`) (map tail seqs) ] ++   removeCandidate :: Object -> [[Object]] -> [[Object]]+   removeCandidate candidate = map (delete candidate)++   nonEmptySeqs :: [[Object]] -> [[Object]]+   nonEmptySeqs = filter (not . null)
+ src/Berp/Base/StdTypes/Type.hs-boot view
@@ -0,0 +1,6 @@+module Berp.Base.StdTypes.Type (typeClass, newType) where++import Berp.Base.SemanticTypes (Object)++typeClass :: Object+newType :: [Object] -> IO Object
+ src/Berp/Base/Truth.hs view
@@ -0,0 +1,49 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Base.Truth+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- Implementation of the truth predicate on Python objects.+--+-----------------------------------------------------------------------------++module Berp.Base.Truth (truth) where++import Berp.Base.SemanticTypes (Object (..))++-- XXX incomplete+truth :: Object -> Bool+truth (Bool { object_bool = b }) = b+truth (Integer { object_integer = i }) = i /= 0+truth None = False +truth _other = False++{-+   From the Python Docs: http://docs.python.org/library/stdtypes.html#truth-value-testing++   Any object can be tested for truth value, for use in an if or while condition or as operand of +   the Boolean operations below. The following values are considered false:++   None++   False++   zero of any numeric type, for example, 0, 0L, 0.0, 0j.++   any empty sequence, for example, '', (), [].++   any empty mapping, for example, {}.++   instances of user-defined classes, if the class defines a __nonzero__() or __len__() method, when +   that method returns the integer zero or bool value False. [1]++   All other values are considered true — so objects of many types are always true.++   Operations and built-in functions that have a Boolean result always return 0 or False +   for false and 1 or True for true, unless otherwise stated. +   (Important exception: the Boolean operations or and and always return one of their operands.)+-}
+ src/Berp/Base/Unique.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE MagicHash #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Base+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- A thread-safe supply of unique values.+-- Same as the version in GHC but with added show instance.+--+-----------------------------------------------------------------------------+++module Berp.Base.Unique (+   -- * Unique objects+   Unique (..),         -- instance (Eq, Ord)+   newUnique,           -- :: IO Unique+   hashUnique           -- :: Unique -> Int+ ) where++import Prelude++import Control.Concurrent.MVar+import System.IO.Unsafe (unsafePerformIO)++import GHC.Base+import GHC.Num++-- | An abstract unique object.  Objects of type 'Unique' may be+-- compared for equality and ordering and hashed into 'Int'.+newtype Unique = Unique { uniqueInteger :: Integer } deriving (Eq,Ord)++-- not safe, but needed for printing purposes. +instance Show Unique where+   show (Unique i) = show i++{-# NOINLINE uniqSource #-}+uniqSource :: MVar Integer+uniqSource = unsafePerformIO (newMVar 0)++-- | Creates a new object of type 'Unique'.  The value returned will+-- not compare equal to any other value of type 'Unique' returned by+-- previous calls to 'newUnique'.  There is no limit on the number of+-- times 'newUnique' may be called.+newUnique :: IO Unique+newUnique = do+   val <- takeMVar uniqSource+   let next = val+1+   putMVar uniqSource next+   return (Unique next)++-- | Hashes a 'Unique' into an 'Int'.  Two 'Unique's may hash to the+-- same value, although in practice this is unlikely.  The 'Int'+-- returned makes a good hash key.+hashUnique :: Unique -> Int+hashUnique (Unique i) = I# (hashInteger i)
+ src/Berp/Compile/Compile.hs view
@@ -0,0 +1,545 @@+{-# LANGUAGE PatternGuards, TypeSynonymInstances, TypeFamilies, FlexibleInstances #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Compile.Compile+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- The compiler for berp. The compiler translates Python 3 into Haskell.+--+-----------------------------------------------------------------------------++module Berp.Compile.Compile (compiler, Compilable (..)) where++import Prelude hiding (read, init, mapM, putStrLn)+import Language.Python.Common.AST as Py+import Data.Traversable+import Data.Foldable (foldrM)+import Language.Haskell.Exts.Syntax as Hask+import Language.Haskell.Exts.Build+-- import Language.Haskell.Exts.Pretty+import Control.Applicative+import qualified Data.Set as Set+import Data.Set ((\\))+import Control.Monad hiding (mapM)+import qualified Berp.Compile.PrimName as Prim+import Berp.Compile.Monad+import Berp.Compile.HsSyntaxUtils+import Berp.Compile.PySyntaxUtils+import Berp.Compile.Utils+import Berp.Base.Mangle (mangle)+import Berp.Base.Hash (Hash (..))+import Berp.Compile.IdentString (IdentString (..), ToIdentString (..), identString)++compiler :: Compilable a => a -> IO (CompileResult a)+compiler = runCompileMonad . compile ++class Compilable a where+   type CompileResult a :: *+   compile :: a -> Compile (CompileResult a)++instance Compilable a => Compilable [a] where+   type CompileResult [a] = [CompileResult a]+   compile = mapM compile++instance Compilable a => Compilable (Maybe a) where+   type CompileResult (Maybe a) = Maybe (CompileResult a)+   compile = mapM compile++instance Compilable InterpreterStmt where+   type CompileResult InterpreterStmt = [Hask.Stmt]+   compile (InterpreterStmt suite) = do +      suiteBindings <- checkEither $ topBindings suite+      oldScope <- getScope+      let oldLocals = localVars oldScope +      let suiteLocals = localVars suiteBindings +          newLocals = suiteLocals \\ oldLocals+          nestedBindings = suiteBindings { localVars = newLocals } +      (vars, stmts) <- nestedScope nestedBindings $ compile $ TopBlock suite +      let init = initStmt $ doBlock stmts+      let accumLocals = oldLocals `Set.union` newLocals+      setScope $ oldScope { localVars = accumLocals }+      return (vars ++ [init])+      where+      initStmt :: Hask.Exp -> Hask.Stmt+      initStmt exp = letStmt [initDecl exp] +      initDecl :: Hask.Exp -> Hask.Decl+      initDecl = patBind bogusSrcLoc $ pvar Prim.initName++instance Compilable ModuleSpan where+   type CompileResult ModuleSpan = Hask.Module+   compile (Py.Module suite) = do+      bindings <- checkEither $ topBindings suite+      stmts <- nestedScope bindings $ compileBlockDo $ Block suite +      let init = initDecl stmts+      return $ Hask.Module bogusSrcLoc modName pragmas warnings exports imports +                           [mainDecl, init] +      where+      modName = ModuleName "Main"+      mainDecl :: Hask.Decl+      mainDecl = +         patBind bogusSrcLoc mainPatName $ app Prim.runStmt Prim.init+         where+         mainPatName = pvar $ name "main"+      initDecl :: Hask.Exp -> Hask.Decl+      initDecl = patBind bogusSrcLoc $ pvar Prim.initName+      pragmas = []+      warnings = Nothing+      exports = Nothing++instance Compilable StatementSpan where+   type (CompileResult StatementSpan) = [Stmt] ++   compile (Fun {fun_name = fun, fun_args = params, fun_body = body}) = do+      oldSeenYield <- getSeenYield+      unSetSeenYield+      bindings <- checkEither $ funBindings params body+      compiledBody <- nestedScope bindings $ compileBlockDo $ Block body+      let args = Hask.PList $ map (identToMangledPatVar . paramIdent) params+      isGenerator <- getSeenYield +      setSeenYield oldSeenYield+      let lambdaBody = if isGenerator+                          then app Prim.mkGenerator (parens compiledBody)+                          else compiledBody+      let lambda = lamE bogusSrcLoc [args] lambdaBody +      let arityExp = intE $ fromIntegral $ length params+      let doc = docString body+      returnStmt $ appFun Prim.def [identToMangledVar fun, arityExp, doc, parens lambda]+   compile (Assign { assign_to = target, assign_expr = expr }) = +      compileAssign (head target) expr+   compile (Conditional { cond_guards = guards, cond_else = elseBranch })+      | length guards == 1 && isEmptySuite elseBranch,+        (condExp, condSuite) <- head guards = do+           condVal <- compileExprBlock condExp+           condBody <- compileSuiteDo condSuite+           returnStmt $ appFun Prim.ifThen [parens condVal, parens condBody]+      | otherwise = do+           elseExp <- compileSuiteDo elseBranch+           condExp <- foldM compileGuard elseExp $ reverse guards+           returnStmt condExp+   compile (Return { return_expr = maybeExpr }) +      | Just call@(Call {}) <- maybeExpr = do+           (stmts, compiledExpr) <- compileTailCall call +           let newStmt = qualStmt compiledExpr+           return (stmts ++ [newStmt]) +      | otherwise = do+           (stmts, compiledExpr) <- maybe (returnExp Prim.none) compileExprObject maybeExpr+           let newStmt = qualStmt $ app Prim.ret $ parens compiledExpr+           return (stmts ++ [newStmt])+   {- +      Even though it looks like we could eliminate stmt expressions, we do need to +      compile them to code just in case they have side effects (like raising exceptions).+      It is very hard to determine that an expression is effect free. Constant values+      are the easy case, but probably not worth the effort. Furthermore, top-level+      constant expressions must be preserved for the repl of the interpreter.+   -}+   compile (StmtExpr { stmt_expr = expr }) = do+      (stmts, compiledExpr) <- compileExprComp expr+      -- let newStmt = qualStmt $ app Prim.stmt $ parens compiledExpr+      let newStmt = qualStmt $ compiledExpr+      return (stmts ++ [newStmt])+   compile (While { while_cond = cond, while_body = body, while_else = elseSuite }) = do+      condVal <- compileExprBlock cond+      bodyExp <- compileSuiteDo body+      if isEmptySuite elseSuite+         then returnStmt $ appFun Prim.while [parens condVal, parens bodyExp]+         else do+            elseExp <- compileSuiteDo elseSuite+            returnStmt $ appFun Prim.whileElse [parens condVal, parens bodyExp, parens elseExp]+   -- XXX fixme, only supports one target+   compile (For { for_targets = [var], for_generator = generator, for_body = body, for_else = elseSuite }) = do+      (generatorStmts, compiledGenerator) <- compileExprObject generator+      compiledBody <- compileSuiteDo body+      let compiledVar = identToMangledVar var+      if isEmptySuite elseSuite+         then return (generatorStmts ++ [qualStmt $ appFun Prim.for [compiledVar, compiledGenerator, parens compiledBody]])+         else do+            compiledElse <- compileSuiteDo elseSuite+            return (generatorStmts ++ [qualStmt $ appFun Prim.forElse [compiledVar, compiledGenerator, parens compiledBody, parens compiledElse]])+   compile (Pass {}) = returnStmt Prim.pass+   compile (NonLocal {}) = return [] +   compile (Global {}) = return [] +   compile (Class { class_name = ident, class_args = args, class_body = body }) = do+      bindings <- checkEither $ funBindings [] body+      -- XXX slightly dodgy since the syntax allows Argument types in class definitions but+      -- I'm not sure what their meaning is, or if it is just a case of the grammar over specifying+      -- the language+      (argsStmtss, compiledArgs) <- mapAndUnzipM (compileExprObject . arg_expr) args+      compiledBody <- nestedScope bindings $ compile $ Block body+      let locals = Set.toList $ localVars bindings+      attributes <- qualStmt <$> app Prim.pure <$> listE <$> mapM compileClassLocal locals +      let newStmt = qualStmt $ appFun Prim.klass+                       [ strE $ identString ident+                       , identToMangledVar ident+                       , listE compiledArgs +                       , parens $ doBlock $ compiledBody ++ [attributes]]+      return (concat argsStmtss ++ [newStmt])+      where+      compileClassLocal :: IdentString -> Compile Hask.Exp+      compileClassLocal ident = do+         hashedIdent <- compile ident+         let mangledIdent = identToMangledVar ident+         return $ tuple [hashedIdent, mangledIdent] +   compile (Try { try_body = body, try_excepts = handlers, try_else = elseSuite, try_finally = finally }) = do+      bodyExp <- compileSuiteDo body+      asName <- freshHaskellVar+      handlerExp <- compileHandlers (var asName) handlers+      let handlerLam = lamE bogusSrcLoc [pvar asName] handlerExp+      compiledElse <- compile elseSuite+      compiledFinally <- compile finally+      -- returnStmt $ appFun Prim.try [parens bodyExp, handlerLam]+      returnStmt $ mkTry (parens bodyExp) handlerLam (concat compiledElse) (concat compiledFinally)+   compile (Raise { raise_expr = RaiseV3 raised }) = +      case raised of+         Nothing -> returnStmt Prim.reRaise+         Just (e, maybeFrom) ->+            case maybeFrom of+               Nothing -> do+                 (stmts, obj) <- compileExprObject e+                 let newStmt = qualStmt $ app Prim.raise obj +                 return (stmts ++ [newStmt])+               Just fromExp -> do+                 (stmts1, obj1) <- compileExprObject e+                 (stmts2, obj2) <- compileExprObject fromExp+                 let newStmt = qualStmt $ appFun Prim.raiseFrom [obj1, obj2]+                 return (stmts1 ++ stmts2 ++ [newStmt])+   compile (Break {}) = returnStmt Prim.break+   compile (Continue {}) = returnStmt Prim.continue+   compile other = error $ "compile on " ++ show other ++ " unsupported"++docString :: SuiteSpan -> Exp+docString (StmtExpr { stmt_expr = Strings { strings_strings = ss }} : _)+   = parens $ Prim.string $ trimString $ concat ss+docString _other = Prim.none++mkTry :: Exp -> Exp -> [Stmt] -> [Stmt] -> Exp +mkTry body handler elseSuite finally = +   case (elseSuite, finally) of+      ([], []) -> appFun Prim.try [body, handler]+      (_:_, []) -> appFun Prim.tryElse [body, handler, elseBlock] +      ([], _:_) -> appFun Prim.tryFinally [body, handler, finallyBlock] +      (_:_, _:_) -> appFun Prim.tryElseFinally [body, handler, elseBlock, finallyBlock]  +   where+   elseBlock = parens $ doBlock elseSuite+   finallyBlock = parens $ doBlock finally ++instance Compilable IdentSpan where+   type CompileResult IdentSpan = Hask.Exp+   compile = compile . toIdentString ++instance Compilable IdentString where+   type CompileResult IdentString = Hask.Exp+   compile ident = do+      let str = identString ident+          mangled = mangle str+          hashedVal = intE $ fromIntegral $ hash str+      return $ tuple [hashedVal, strE mangled] ++instance Compilable ExprSpan where+   type (CompileResult ExprSpan) = ([Stmt], Exp)++   compile (Py.Strings { strings_strings = ss }) = +      returnExp $ Prim.string $ concat $ map trimString ss +   compile (Py.Bool { bool_value = b}) = returnExp $ Prim.bool b+   compile (Py.Int { int_value = i}) = returnExp $ intE i+   compile (Py.Var { var_ident = ident}) =+      returnExp $ app Prim.read $ identToMangledVar ident+   compile (Py.BinaryOp { operator = op, left_op_arg = leftExp, right_op_arg = rightExp }) +      | Dot {} <- op, Py.Var { var_ident = method } <- rightExp = do+           (leftStmts, compiledLeft) <- compileExprObject leftExp+           compiledMethod <- compile method+           let newExp = infixApp compiledLeft (Prim.opExp op) compiledMethod +           return (leftStmts, newExp)+      | otherwise = do+           (leftStmts, compiledLeft) <- compileExprObject leftExp+           (rightStmts, compiledRight) <- compileExprObject rightExp+           let newExp = infixApp compiledLeft (Prim.opExp op) compiledRight+           return (leftStmts ++ rightStmts, newExp)+   compile (Py.UnaryOp { operator = op, op_arg = arg }) = do+      (argStmts, compiledArg) <- compileExprObject arg +      let compiledOp = compileUnaryOp op+      return (argStmts, app compiledOp compiledArg)+   compile (Call { call_fun = fun, call_args = args }) = do+      (funStmts, compiledFun) <- compileExprObject fun+      (argsStmtss, compiledArgs) <- mapAndUnzipM compile args +      let newExp = infixApp compiledFun Prim.apply (listE compiledArgs)+      return (funStmts ++ concat argsStmtss, newExp) +   compile (Py.Tuple { tuple_exprs = elements }) = do+      (stmtss, exprs) <- mapAndUnzipM compileExprObject elements +      let newExp = app Prim.tuple $ listE exprs+      return (concat stmtss, newExp)+   compile (Py.Lambda { lambda_args = params, lambda_body = body }) = do+      bindings <- checkEither $ funBindings params body+      compiledBody <- nestedScope bindings $ compileExprBlock body+      let args = Hask.PList $ map (identToMangledPatVar . paramIdent) params+      let lambda = lamE bogusSrcLoc [args] compiledBody+      returnExp $ appFun Prim.lambda [intE (fromIntegral $ length params), parens lambda]+   compile (Py.List { list_exprs = elements }) = do+      (stmtss, exprs) <- mapAndUnzipM compileExprObject elements +      let newExp = app Prim.list $ listE exprs+      return (concat stmtss, newExp)+   compile (Py.Dictionary { dict_mappings = mappings }) = do+      let compileExprObjectPair (e1, e2) = do+             (stmts1, compiledE1) <- compileExprObject e1 +             (stmts2, compiledE2) <- compileExprObject e2 +             return (stmts1 ++ stmts2, (compiledE1, compiledE2))+      (stmtss, exprPairs) <- mapAndUnzipM compileExprObjectPair mappings +      let newExp = app Prim.dict $ listE $ map (\(x,y) -> tuple [x,y]) exprPairs+      return (concat stmtss, newExp)+   compile (Subscript { subscriptee = obj_expr, subscript_expr = sub }) = do+      (stmtss, exprs) <- mapAndUnzipM compileExprObject [obj_expr, sub]+      let newExp = appFun Prim.subscript exprs+      return (concat stmtss, newExp)+   compile (Yield { yield_expr = maybeExpr }) = do+      (stmts, compiledExpr) <- maybe (returnExp Prim.none) compileExprObject maybeExpr+      let newExpr = app Prim.yield $ parens compiledExpr+      setSeenYield True+      return (stmts, newExpr)+   compile (Py.Paren { paren_expr = e }) = compile e+   compile (None {}) = returnExp Prim.none+   compile other = unsupported $ "compile: " ++ show other++compileTailCall :: ExprSpan -> Compile ([Stmt], Exp)+compileTailCall (Call { call_fun = fun, call_args = args }) = do+      (funStmts, compiledFun) <- compileExprObject fun+      (argsStmtss, compiledArgs) <- mapAndUnzipM compile args +      -- let newExp = infixApp compiledFun Prim.apply (listE compiledArgs)+      let newExp = appFun Prim.tailCall [compiledFun, listE compiledArgs]+      return (funStmts ++ concat argsStmtss, newExp) +compileTailCall other = error $ "compileTailCall on non call expression: " ++ show other++instance Compilable ArgumentSpan where+   type (CompileResult ArgumentSpan) = ([Stmt], Exp)+   compile (ArgExpr { arg_expr = expr }) = compileExprObject expr+   compile other = unsupported $ show other++newtype Block = Block [StatementSpan]+newtype TopBlock = TopBlock [StatementSpan]++instance Compilable TopBlock where+   type (CompileResult TopBlock) = ([Hask.Stmt], [Hask.Stmt])+   compile (TopBlock []) = return ([], [qualStmt Prim.pass]) +   compile (TopBlock stmts) = do+      scope <- getScope +      let locals = localVars scope+      varDecls <- mapM declareTopInterpreterVar $ Set.toList locals+      haskStmtss <- compile stmts+      return (varDecls, concat haskStmtss)++instance Compilable Block where+   type (CompileResult Block) = [Hask.Stmt]+   compile (Block []) = return [qualStmt Prim.pass] +   compile (Block stmts) = do+      scope <- getScope +      let locals = localVars scope+      varDecls <- mapM declareVar $ Set.toList locals+      haskStmtss <- compile stmts+      return (varDecls ++ concat haskStmtss)++-- This compiles an Expression to something with type (Eval Object). In cases where+-- the expression is atomic, it wraps the result in a call to "pure".+-- This is because compiling an atomic expression gives something+-- of type Object.+compileExprComp :: Py.ExprSpan -> Compile ([Stmt], Exp)+compileExprComp exp +   | isAtomicExpr exp = do+        (stmts, compiledExp) <- compile exp+        return (stmts, app Prim.pureObj $ parens compiledExp)+   | otherwise = compile exp++-- This compiles an expression to something with type Object. In cases where+-- the expression is non-atomic, it binds the result of evaluating the expression+-- to a variable. This is because compiling a non-atomic expression gives something+-- of type (Eval Object)+compileExprObject :: Py.ExprSpan -> Compile ([Stmt], Exp)+compileExprObject exp+   | isAtomicExpr exp = compile exp+   | otherwise = do+      (expStmts, compiledExp) <- compile exp+      (binderStmts, binderExp) <- stmtBinder compiledExp +      return (expStmts ++ binderStmts, binderExp)++compileHandlers :: Exp -> [HandlerSpan] -> Compile Exp +compileHandlers asName handlers = do+   validate handlers +   -- foldrM (compileHandler asName) Prim.pass handlers +   foldrM (compileHandler asName) (parens $ app Prim.raise asName) handlers ++compileHandler :: Exp -> HandlerSpan -> Exp -> Compile Exp+compileHandler asName (Handler { handler_clause = clause, handler_suite = body }) nextHandler = do+   bodyStmts <- compile body+   case except_clause clause of+      Nothing -> return $ appFun Prim.exceptDefault+                    [parens $ doBlock $ concat bodyStmts, parens nextHandler]+      Just (exceptClass, maybeExceptVar) -> do+         varStmts <- +            case maybeExceptVar of+               Nothing -> return [] +               Just (Py.Var { var_ident = ident }) -> do+                  identDecl <- declareVar ident+                  let newAssign = qualStmt $ infixApp (var $ identToMangledName ident) Prim.assignOp asName +                  return [identDecl, newAssign]+               other -> error $ "exception expression not a variable: " ++ show other+         (classStmts, classObj) <- compileExprObject exceptClass+         let newBody = parens $ doBlock (varStmts ++ concat bodyStmts)+             newStmt = qualStmt $ appFun Prim.except [asName, classObj, newBody, parens nextHandler]+         return $ doBlock (classStmts ++ [newStmt]) +++compileAssign :: Py.ExprSpan -> Py.ExprSpan -> Compile [Stmt] +-- Right argument of dot is always a variable, because dot associates to the left+compileAssign (Py.BinaryOp { operator = Dot {}+                           , left_op_arg = lhs +                           , right_op_arg = Py.Var { var_ident = attribute}} +              ) rhs = do+   (stmtsLhs, compiledLhs) <- compileExprObject lhs +   (stmtsRhs, compiledRhs) <- compileExprObject rhs +   compiledAttribute <- compile attribute+   let newStmt = qualStmt $ appFun Prim.setAttr [compiledLhs, compiledAttribute, compiledRhs]+   return (stmtsLhs ++ stmtsRhs ++ [newStmt])+compileAssign (Py.Var { var_ident = ident}) expr = do+   (exprStmts, compiledExp) <- compileExprObject expr+   let newStmt = qualStmt $ infixApp (identToMangledVar ident) Prim.assignOp compiledExp+   return (exprStmts ++ [newStmt])+compileAssign e1 e2 = unsupported $ "assignment for " ++ show e1 ++ " and " ++ show e2 ++compileUnaryOp :: Py.OpSpan -> Hask.Exp+compileUnaryOp (Plus {}) = Prim.unaryPlus+compileUnaryOp (Minus {}) = Prim.unaryMinus+compileUnaryOp (Invert {}) = Prim.invert+compileUnaryOp other = error $ "Syntax Error: not a valid unary operator: " ++ show other++stmtBinder :: Exp -> Compile ([Stmt], Exp)+stmtBinder exp = do+   v <- freshHaskellVar+   let newStmt = genStmt bogusSrcLoc (pvar v) exp+   return ([newStmt], var v)++compileExprBlock :: ExprSpan -> Compile Hask.Exp+compileExprBlock exp = do+    (stmts, exp) <- compileExprComp exp+    return $ doBlock (stmts ++ [qualStmt exp])++compileBlockDo :: Block -> Compile Hask.Exp+compileBlockDo block = doBlock <$> compile block ++compileSuiteDo :: SuiteSpan -> Compile Exp+compileSuiteDo [] = return Prim.pass+compileSuiteDo stmts = do+   compiledStmtss <- compile stmts+   return $ doBlock $ concat compiledStmtss ++nestedScope :: Scope -> Compile a -> Compile a+nestedScope bindings comp = do+   outerScope <- getScope+   let newEnclosingVars = enclosingVars outerScope `Set.union` +                          localVars outerScope `Set.union`+                          paramVars outerScope+   let newLevel = nestingLevel outerScope + 1+       newScope = bindings { nestingLevel = newLevel, enclosingVars = newEnclosingVars }+   -- local (const newScope) comp+   setScope newScope+   result <- comp+   setScope outerScope+   return result++returnStmt :: Exp -> Compile [Stmt]+returnStmt e = return [qualStmt e]++returnExp :: Exp -> Compile ([Stmt], Exp)+returnExp e = return ([], e)++declareTopInterpreterVar :: ToIdentString a => a -> Compile Hask.Stmt+declareTopInterpreterVar ident = do+   let mangledPatVar = identToMangledPatVar ident+       str = strE $ identString ident+   return $ genStmt bogusSrcLoc mangledPatVar $ app Prim.topVar str++declareVar :: ToIdentString a => a -> Compile Hask.Stmt+declareVar ident = do+   let mangledPatVar = identToMangledPatVar ident+       str = strE $ identString ident+   return $ genStmt bogusSrcLoc mangledPatVar $ app Prim.variable str ++compileGuard :: Hask.Exp -> (ExprSpan, SuiteSpan) -> Compile Hask.Exp+compileGuard elseExp (guard, body) = +   conditional <$> compileExprBlock guard <*> compileSuiteDo body <*> pure elseExp++imports :: [ImportDecl]+imports = [importBerp, importPrelude]++importBerp :: ImportDecl+importBerp = +   ImportDecl+   { importLoc = bogusSrcLoc +   , importModule = Prim.berpModuleName +   , importQualified = False +   , importSrc = False +   , importAs  = Nothing +   , importSpecs = Nothing +   , importPkg = Nothing+   }++importPrelude :: ImportDecl+importPrelude = +   ImportDecl+   { importLoc = bogusSrcLoc +   , importModule = Prim.preludeModuleName +   , importQualified = True +   , importSrc = False +   , importAs  = Nothing +   , importSpecs = Nothing +   , importPkg = Nothing+   }++identToMangledName :: ToIdentString a => a -> Hask.Name+identToMangledName = name . mangle . identString  ++identToMangledVar :: ToIdentString a => a -> Hask.Exp+identToMangledVar = var . identToMangledName++identToMangledPatVar :: ToIdentString a => a -> Hask.Pat+identToMangledPatVar = pvar . identToMangledName++-- Check that the syntax is valid Python (the parser is sometimes too liberal).+class Validate t where+   validate :: t -> Compile ()++instance Validate [HandlerSpan] where+   validate [] = fail "Syntax Error: Syntax Error: try statement must have one or more handlers"+   validate [_] = return ()+   validate (h:hs) +       | Nothing <- except_clause $ handler_clause h+            = if null hs then return () +                         else fail "Syntax Error: default 'except:' must be last"+       | otherwise = validate hs++-- Trim (one or three) quote marks off front and end of string which are left by the lexer/parser.+trimString :: String -> String+trimString [] = []+trimString (w:x:y:zs)+   | all isQuote [w,x,y] && all (== w) [x,y] = trimStringEnd zs+   | isQuote w = trimStringEnd (x:y:zs)+   | otherwise = w:x:y:trimStringEnd zs+trimString (x:xs)+   | isQuote x = trimStringEnd xs+   | otherwise = x : trimStringEnd xs++trimStringEnd :: String -> String+trimStringEnd [] = [] +trimStringEnd str@[x]+      | isQuote x = []+      | otherwise = str+trimStringEnd str@[x,y,z]+      | all isQuote str && all (== x) [y,z] = []+      | otherwise = x : trimStringEnd [y,z] +trimStringEnd (x:xs) = x : trimStringEnd xs ++isQuote :: Char -> Bool+isQuote '\'' = True+isQuote '"' = True+isQuote _ = False
+ src/Berp/Compile/HsSyntaxUtils.hs view
@@ -0,0 +1,46 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Compile.HsSyntaxUtils+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- Utilities for processing Haskell syntax.+--+-----------------------------------------------------------------------------++module Berp.Compile.HsSyntaxUtils  where++import Language.Haskell.Exts.Syntax+import Language.Haskell.Exts.Build+import Berp.Compile.PrimName as Prim++bogusSrcLoc :: SrcLoc+bogusSrcLoc = SrcLoc { srcFilename = "", srcLine = -1, srcColumn = -1 }++class Parens a where+   parens :: a -> a++-- not exhaustive+instance Parens Exp where+   parens e@(Var {}) = e+   parens e@(IPVar {}) = e+   parens e@(Con {}) = e+   parens e@(Lit {}) = e+   parens e@(Tuple {}) = e+   parens e@(List {}) = e+   parens e@(Paren {}) = e+   parens e@(ListComp {}) = e+   parens e = paren e++-- turn a list of statements into a do block, avoiding redundant do.+doBlock :: [Stmt] -> Exp+doBlock [Qualifier e] = e+doBlock stmts = doE stmts++conditional :: Exp -> Exp -> Exp -> Exp+conditional cond trueBranch falseBranch+   = appFun Prim.ite [parens cond, parens trueBranch, parens falseBranch]+
+ src/Berp/Compile/IdentString.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE TypeSynonymInstances #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Compile.IdentString+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- Strings encoding identifiers and ways to convert other things to them.+--+-----------------------------------------------------------------------------++module Berp.Compile.IdentString where++import Language.Python.Common.AST++newtype IdentString = IdentString { fromIdentString :: String }+   deriving (Eq, Ord, Show)++class ToIdentString t where+   toIdentString :: t -> IdentString ++instance ToIdentString IdentString where+   toIdentString = id++instance ToIdentString String where+   toIdentString str = IdentString str++instance ToIdentString (Ident a) where+   toIdentString (Ident { ident_string = name }) = IdentString name++instance ToIdentString (Expr a) where+   toIdentString (Var { var_ident = ident }) = toIdentString ident+   toIdentString _other = error "toIdentString applied to an expression which is not a variable"++identString :: ToIdentString a => a -> String+identString = fromIdentString . toIdentString
+ src/Berp/Compile/Monad.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, TypeFamilies #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Compile.Monad+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- Monad code to support the compiler.+--+-----------------------------------------------------------------------------++module Berp.Compile.Monad where++import Prelude hiding (catch)+import Control.Monad.State.Strict as State hiding (State) +import Language.Python.Common.AST +import Language.Python.Common.SrcLocation+import Language.Haskell.Exts.Syntax (Name) +import Language.Haskell.Exts.Build (name) +import Data.Set+import Control.Applicative hiding (empty)+import Berp.Compile.VarSet (VarSet)+-- import Berp.Compile.IdentString (IdentString (..))+import qualified MonadUtils (MonadIO (..))+import Exception (ExceptionMonad (..))+import Control.Exception.Extensible (block, unblock, catch)++data State = State { unique :: !Integer, seen_yield :: !Bool, scope :: Scope }++data Scope +   = Scope +     { localVars :: !VarSet     -- local to a block (not params)+     , paramVars :: !VarSet     -- bound in the parameters of the innermost enclosing function +     , globalVars :: !VarSet    -- declared as "global" in the source +     , enclosingVars :: !VarSet -- in scope enclosing a block, but not global+     , nestingLevel :: !NestingLevel+     }+     deriving (Show)++-- This must remain empty, because it is used to create new scopes.+emptyScope :: Scope +emptyScope+   = Scope +     { localVars = empty+     , paramVars = empty+     , globalVars = empty+     , enclosingVars = empty +     , nestingLevel = 0+     }++getScope :: Compile Scope+getScope = gets scope++setScope :: Scope -> Compile ()+setScope s = modify $ \state -> state { scope = s }++initState :: State+initState = State { unique = 0, seen_yield = False, scope = emptyScope } ++type NestingLevel = Int++newtype Compile a +   = Compile (StateT State IO a)+   deriving (Monad, Functor, MonadIO, ExceptionMonad, Applicative)++-- the MonadState instance can't be derived by GHC+-- because we're using the monads-tf (type families), and they +-- cause the GHC deriver to choke. Sigh.++instance MonadState Compile where+   type (StateType Compile) = State+   get = Compile get+   put s = Compile $ put s++-- needed to use Compile inside the GhcT monad transformer.+instance MonadUtils.MonadIO Compile where+   liftIO = State.liftIO ++-- needed to use Compile inside the GhcT monad transformer.+-- instance (Monoid w) => ExceptionMonad (RWST r w s IO) where+instance ExceptionMonad (StateT s IO) where+    gcatch m f = StateT $ \s -> runStateT m s+                           `catch` \e -> runStateT (f e) s+    gblock       = mapStateT block+    gunblock     = mapStateT unblock++runCompileMonad :: Compile a -> IO a+runCompileMonad (Compile comp) = +   evalStateT comp initState ++getSeenYield :: Compile Bool+getSeenYield = gets seen_yield++unSetSeenYield :: Compile ()+unSetSeenYield = setSeenYield False ++setSeenYield :: Bool -> Compile ()+setSeenYield b = modify $ \state -> state { seen_yield = b }++isTopLevel :: Compile Bool+isTopLevel = gets ((== 1) . nestingLevel . scope)++incNestingLevel :: Scope -> Scope +incNestingLevel scope = scope { nestingLevel = nestingLevel scope + 1 } ++freshVarRaw :: Compile String+freshVarRaw = do+   u <- gets unique+   modify $ \state -> state { unique = u + 1 } +   return ("_t_" ++ show u)++freshHaskellVar :: Compile Name+freshHaskellVar = name <$> freshVarRaw ++freshPythonVar :: Compile IdentSpan+freshPythonVar = do+   rawVar <- freshVarRaw+   return $ Ident { ident_string = rawVar, ident_annot = SpanEmpty }++checkEither :: Either String b -> Compile b+checkEither (Left e) = fail e+checkEither (Right v) = return v
+ src/Berp/Compile/PrimName.hs view
@@ -0,0 +1,221 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Compile.PrimName+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- Names for primtive functions used in the output of the compiler.+--+-----------------------------------------------------------------------------++module Berp.Compile.PrimName where++import Language.Haskell.Exts.Syntax as Hask+import Language.Python.Common.AST as Py+import Prelude hiding (read, init)+import Language.Haskell.Exts.Build+import Berp.Compile.Utils++preludeModuleName, berpModuleName :: ModuleName+berpModuleName = ModuleName "Berp.Base"+preludeModuleName = ModuleName "Prelude"++prim :: String -> Exp+prim = var . name ++tailCall :: Exp+tailCall = prim "tailCall"++dict :: Exp+dict = prim "dictionary"++unaryPlus :: Exp+unaryPlus = prim "unaryPlus"++unaryMinus :: Exp+unaryMinus = prim "unaryMinus"++invert :: Exp+invert = prim "invert"++mkGenerator :: Exp+mkGenerator = prim "mkGenerator"++yield :: Exp+yield = prim "yield"++for :: Exp+for = prim "for"++forElse :: Exp+forElse = prim "forElse"++break :: Exp+break = prim "break"++continue :: Exp+continue = prim "continue"++raise :: Exp+raise = prim "raise"++raiseFrom :: Exp+raiseFrom = prim "raiseFrom"++reRaise :: Exp+reRaise = prim "reRaise"++exceptDefault :: Exp+exceptDefault = prim "exceptDefault"++except :: Exp+except = prim "except"++exceptAs :: Exp+exceptAs = prim "exceptAs"++stmt :: Exp+stmt = prim "stmt"++list :: Exp+list = prim "list"++try :: Exp+try = prim "try"++tryElse :: Exp+tryElse = prim "tryElse"++tryFinally :: Exp+tryFinally = prim "tryFinally"++tryElseFinally :: Exp+tryElseFinally = prim "tryElseFinally"++subscript :: Exp+subscript = prim "subs"++pure :: Exp+pure = prim "pure"++pureObj :: Exp+pureObj = prim "pureObject"++primOp :: String -> QOp+primOp = op . sym ++assignOp :: QOp+assignOp = primOp "=:"++setAttr :: Exp+setAttr = prim "setattr"++while :: Exp+while = prim "while"++global :: Exp+global = prim "global"++globalRef :: Exp+globalRef = prim "globalRef"++topVar :: Exp+topVar = prim "topVar"++variable :: Exp+variable = prim "var"++globalVariable :: Exp+globalVariable = prim "globalVar"++tuple :: Exp+tuple = prim "tuple"++whileElse :: Exp+whileElse = prim "whileElse"++runStmt :: Exp+runStmt = prim "runStmt"++interpretStmt :: Exp+interpretStmt = prim "interpretStmt"++initName :: Name+initName = name "init"++init :: Exp+init = var initName ++ret :: Exp+ret = prim "ret"++ite :: Exp+ite = prim "ifThenElse"++ifThen :: Exp+ifThen = prim "ifThen"++def :: Exp+def = prim "def"++klass :: Exp+klass = prim "klass"++lambda :: Exp+lambda = prim "lambda"++call :: Exp+call = prim "call"++apply :: QOp +apply = primOp "@@"++read :: Exp+read = prim "read"++integer :: Integer -> Exp+integer i = app (prim "integer") (intE i)++bool :: Bool -> Exp+bool b = if b then true else false ++true,false :: Exp+true = prim "true"+false = prim "false"++none :: Exp+none = prim "none"++pass :: Exp+pass = prim "pass"++string :: String -> Exp+string s = app (prim "string") (strE s)++opExp :: Py.OpSpan -> Hask.QOp+opExp (And {}) = op $ name "and"+opExp (Or {}) = op $ name "or"+opExp (Exponent {}) = primOp "**"+opExp (LessThan {}) = primOp "<"+opExp (GreaterThan {}) = primOp ">"+opExp (Equality {}) = primOp "=="+opExp (GreaterThanEquals {}) = primOp ">=" -- not sure if this is official+opExp (LessThanEquals {}) = primOp "<="+opExp (NotEquals {}) = primOp "!="+opExp (BinaryOr {}) = primOp "||"+opExp (Xor {}) = primOp "^"+opExp (BinaryAnd {}) = primOp "&"+opExp (ShiftLeft {}) = primOp "<<"+opExp (ShiftRight {}) = primOp ">>"+opExp (Multiply {}) = primOp "*"+opExp (Plus {}) = primOp "+"+opExp (Minus {}) = primOp "-"+opExp (Divide {}) = primOp "/"+opExp (FloorDivide {}) = primOp "//"+opExp (Invert {}) = primOp "~" +opExp (Modulo {}) = primOp "%"+opExp (Dot {}) = primOp "."+opExp other = unsupported $ "opExp: " ++ show other
+ src/Berp/Compile/PySyntaxUtils.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE TypeSynonymInstances #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Compile.PySyntaxUtils+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- Utilities for processing Python syntax.+--+-----------------------------------------------------------------------------++module Berp.Compile.PySyntaxUtils where++import Language.Python.Common.AST as Py+import Data.Set as Set +import Data.List (intersperse, foldl')+import Data.Monoid+import Berp.Compile.Monad (Scope (..), emptyScope)+import Berp.Compile.IdentString (ToIdentString (..), IdentString (..))+import Berp.Compile.VarSet (VarSet)++data InterpreterStmt = InterpreterStmt Py.SuiteSpan++isEmptySuite :: Suite a -> Bool+isEmptySuite [] = True+isEmptySuite _ = False++-- Incomplete+assignTargets :: [ExprSpan] -> VarSet +assignTargets = foldl' addTarget mempty+   where+   addTarget :: VarSet -> ExprSpan -> VarSet+   addTarget set var@(Var {}) = Set.insert (varToString var) set+   addTarget set _other = set++varToString :: Show a => Expr a -> IdentString+varToString v@(Var {}) = toIdentString $ var_ident v+varToString other = error $ "fatal error: varToString called on non variable argument" ++ show other++{-+toIdentString :: Ident a -> IdentString+toIdentString (Ident { ident_string = name }) = IdentString name+-}++paramIdent :: Parameter a -> Ident a+paramIdent = param_name ++topBindings :: SuiteSpan -> Either String Scope+topBindings stmts+   | not $ Set.null nonLocals +        = Left $ "These variables are declared nonlocal at the top level: " ++ prettyVarSet nonLocals+   | otherwise = Right $ emptyScope { localVars = locals, globalVars = globals }+   where+   (locals, nonLocals, globals) = termBindings stmts +   +funBindings :: DefinedVars t => [ParameterSpan] -> t -> Either String Scope +funBindings params term +   = case allDisjoint paramIdents nonLocals globals of+        Nothing -> Right $ emptyScope +           { localVars = locals \\ paramIdents+           , paramVars = paramIdents +           , globalVars = globals } +        Just error -> Left error+   where+   paramIdents = fromList $ Prelude.map (toIdentString . paramIdent) params +   (locals, nonLocals, globals) = termBindings term ++termBindings :: DefinedVars t => t -> (VarSet, VarSet, VarSet)+termBindings term +   = (theseLocals, theseNonLocals, theseGlobals) +   where+   varBindings = definedVars term +   theseGlobals = globals varBindings+   theseNonLocals = nonlocals varBindings+   theseLocals = ((assigned varBindings \\ theseGlobals) \\ theseNonLocals) ++allDisjoint :: VarSet -> VarSet -> VarSet -> Maybe String +allDisjoint params nonlocals globals +   = if not (Set.null ps_ns)+        then Just $ "These variables are parameters and declared nonlocal: " ++ prettyVarSet ps_ns +        else if not (Set.null ps_gs)+                then Just $ "These variables are parameters and declared global: " ++ prettyVarSet ps_gs+                else if not (Set.null ns_gs)+                        then Just $ "These variables are declared nonlocal and global: " ++ prettyVarSet ns_gs+                        else Nothing+   where+   ps_ns = params `intersection` nonlocals+   ps_gs = params `intersection` globals+   ns_gs = nonlocals `intersection` globals ++prettyVarSet :: VarSet -> String+prettyVarSet = concat . intersperse "," . Prelude.map fromIdentString . toList ++data BindingSets+   = BindingSets { assigned :: VarSet, nonlocals :: VarSet, globals :: VarSet }++instance Monoid BindingSets where+   mempty = BindingSets { assigned = empty, nonlocals = empty, globals = empty }+   mappend x y+      = BindingSets+        { assigned = assigned x `mappend` assigned y +        , nonlocals = nonlocals x `mappend` nonlocals y+        , globals = globals x `mappend` globals y }++class DefinedVars t where+   definedVars :: t -> BindingSets ++instance DefinedVars t => DefinedVars [t] where+   definedVars = mconcat . Prelude.map definedVars ++instance (DefinedVars t1, DefinedVars t2) => DefinedVars (t1, t2) where+   definedVars (x,y) = definedVars x `mappend` definedVars y++instance DefinedVars (StatementSpan) where+   definedVars (While { while_body = b, while_else = e })+      = definedVars b `mappend` definedVars e +   definedVars (For { for_targets = t, for_body = b, for_else = e })+      = mempty { assigned = assignTargets t} `mappend` definedVars b `mappend` definedVars e +   -- Any definedVars made inside a function body are not collected.+   -- The function name _is_ collected.+   definedVars (Fun { fun_name = n })+      = mempty { assigned = singleton $ toIdentString n }+   definedVars (Class { class_name = ident, class_body = _b })+      = mempty { assigned = singleton $ toIdentString ident } -- `mappend` definedVars b +   definedVars (Conditional { cond_guards = g, cond_else = e })     +      = definedVars g `mappend` definedVars e+   definedVars (Assign { assign_to = t })+      = mempty { assigned = assignTargets t }+   definedVars (Decorated { decorated_def = d })+       = definedVars d+   definedVars (Try { try_body = b, try_else = e, try_finally = f})+       = definedVars [b,e,f]+   definedVars (With { with_body = b })+      = definedVars b+   definedVars (Global { global_vars = idents })+      = mempty { globals = fromList $ Prelude.map toIdentString idents } +   definedVars (NonLocal { nonLocal_vars = idents })+      = mempty { nonlocals = fromList $ Prelude.map toIdentString idents }+   definedVars _other = mempty++instance DefinedVars (Expr a) where+   definedVars = mempty ++-- (currently) variables are not atomic because they are always mutable+-- and reading a variable is an effect. If we add single binding variables+-- then they would be atomic.+isAtomicExpr :: Py.ExprSpan -> Bool+isAtomicExpr (Py.Strings {}) = True+isAtomicExpr (Py.Bool {}) = True+isAtomicExpr (Py.Int {}) = True+isAtomicExpr (Py.Float {}) = True+isAtomicExpr (Py.Imaginary {}) = True+isAtomicExpr (Py.Tuple {}) = True+isAtomicExpr (Py.Paren { paren_expr = e }) = isAtomicExpr e+isAtomicExpr (Py.None {}) = True+isAtomicExpr _other = False
+ src/Berp/Compile/Utils.hs view
@@ -0,0 +1,17 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Compile.Utils+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- Utilities that have no better home.+--+-----------------------------------------------------------------------------++module Berp.Compile.Utils where++unsupported :: String -> a+unsupported str = error $ "berp unsupported. " ++ str
+ src/Berp/Compile/VarSet.hs view
@@ -0,0 +1,19 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Compile.VarSet+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- A set of variables. XXX Does this need to be in its own module?+--+-----------------------------------------------------------------------------++module Berp.Compile.VarSet where++import Data.Set+import Berp.Compile.IdentString++type VarSet = Set IdentString
+ src/Berp/Interpreter/Input.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE PatternGuards #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Interpreter.Input+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- Prompt for and read input lines. Handle input continuations for multi-line+-- statemtents. +--+-----------------------------------------------------------------------------++module Berp.Interpreter.Input (getInputLines) where++import System.Console.Haskeline as Haskeline (getInputLine)+import System.Console.Haskeline.IO (queryInput)+import Berp.Interpreter.Monad (Repl, withInputState)+import Control.Monad.Trans (liftIO)+import Language.Python.Version3.Lexer (lexer, initLexState)+import Language.Python.Common.Token (Token (..))+import Language.Python.Common.ParserMonad +   (runParser, ParseState (..))  +import Language.Python.Common.PrettyParseError ()++lexState :: String -> ParseState +lexState input = initLexState input "<stdin>"++getInputLines :: Repl (Maybe String)+getInputLines = do+   maybeInput <- prompt ">>> " +   case maybeInput of+      Nothing -> return Nothing+      Just line+         | null line -> return $ Just [] +         | Right (tokens, state) <- lexResult,+           lastTokenIsColon tokens -> do+             restLines <- getIndentContinueLines state []+             return $ Just $ unlines (line:restLines)+         | Right (_tokens, state) <- lexResult,+           nonEmptyParenStack state -> do+             restLines <- getParenContinueLines state []+             return $ Just $ unlines (line:restLines)+         | otherwise -> return $ Just line+         where+         lexResult = runParser lexer $ lexState line++lastTokenIsColon :: [Token] -> Bool+lastTokenIsColon [] = False+lastTokenIsColon tokens = +   isColon $ last tokens+   where+   isColon :: Token -> Bool+   isColon (ColonToken {}) = True+   isColon _other = False++nonEmptyParenStack :: ParseState -> Bool+nonEmptyParenStack state = not $ null $ parenStack state++getIndentContinueLines :: ParseState -> [String] -> Repl [String]+getIndentContinueLines state acc = do+   maybeInput <- prompt "... " +   case maybeInput of+      Nothing -> return $ reverse acc+      Just line+         | Right (_tokens, newState) <- lexResult,+           nonEmptyParenStack newState -> do+              getIndentContinueLines newState (line:acc)+         | Right (_tokens, newState) <- lexResult,+           length line > 0 -> do+              -- liftIO $ print newState+              -- liftIO $ print tokens +              getIndentContinueLines newState (line:acc)+         | otherwise -> return $ reverse (line:acc)+         where+         lexResult = runParser lexer $ stateWithLine +         stateWithLine = state { input = '\n':line }++getParenContinueLines :: ParseState -> [String] -> Repl [String]+getParenContinueLines state acc = do+   maybeInput <- prompt "... " +   case maybeInput of+      Nothing -> return $ reverse acc+      Just line+         | Right (_tokens, newState) <- lexResult,+           nonEmptyParenStack newState ->+              getParenContinueLines newState (line:acc)+         | otherwise -> return $ reverse (line:acc)+         where+         lexResult = runParser lexer $ stateWithLine +         stateWithLine = state { input = '\n':line }++prompt :: String -> Repl (Maybe String)+prompt str = +   withInputState prompter+   where+   prompter state = liftIO $ queryInput state $ getInputLine str
+ src/Berp/Interpreter/Monad.hs view
@@ -0,0 +1,51 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Interpreter.Monad+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- Monad type and routines for the interpreter.+--+-----------------------------------------------------------------------------++module Berp.Interpreter.Monad (Repl, runRepl, withInputState) where++import Exception (ExceptionMonad (..))+import qualified MonadUtils as MU (MonadIO, liftIO)+import Control.Monad.Trans as MT (MonadIO (..))+import Control.Monad.State.Strict (StateT (..), evalStateT, gets, mapStateT) +import GHC (GhcT, runGhcT)+import HscTypes (liftGhcT)+import System.Console.Haskeline as Haskeline (defaultSettings)+import System.Console.Haskeline.IO (initializeInput, InputState)+import Berp.Compile.Monad (Compile, runCompileMonad)++type Repl a = GhcT (StateT ReplState Compile) a++data ReplState = ReplState { repl_inputState :: !InputState }++runRepl :: Maybe FilePath -> Repl a -> IO a+runRepl filePath comp = do+   initInputState <- initializeInput defaultSettings+   let initReplState = ReplState { repl_inputState = initInputState }+   runCompileMonad $ (flip evalStateT) initReplState $ runGhcT filePath comp++withInputState :: (InputState -> Repl a) -> Repl a+withInputState f = do+   state <- liftGhcT $ gets repl_inputState+   f state++-- Ugliness because GHC has its own MonadIO class+instance MU.MonadIO m => MonadIO (GhcT m) where+   liftIO = MU.liftIO++instance MonadIO m => MU.MonadIO (StateT s m) where+   liftIO = MT.liftIO++instance ExceptionMonad m => ExceptionMonad (StateT s m) where+    gcatch f h = StateT $ \s -> gcatch (runStateT f s) (\e -> runStateT (h e) s)+    gblock = mapStateT gblock+    gunblock = mapStateT gunblock
+ src/Berp/Interpreter/Repl.hs view
@@ -0,0 +1,102 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Interpreter.Repl+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- The Read Eval Print Loop (REPL) of the interpreter.+--+-----------------------------------------------------------------------------++module Berp.Interpreter.Repl (repl) where++import MonadUtils+import HscTypes (liftGhcT)+import Control.Monad.Trans (lift)+import GHC+   ( defaultErrorHandler, getSessionDynFlags, setSessionDynFlags+   , findModule, mkModuleName, setContext, SingleStep (RunToCompletion)+   , runStmt, gcatch, RunResult (..))+import Control.Monad (when)+import Control.Exception.Extensible (SomeException (..))+import GHC.Paths (libdir)+import DynFlags (defaultDynFlags)+import System.IO (hSetBuffering, stdout, BufferMode (..))+import Language.Python.Version3.Parser (parseStmt)+-- import Language.Python.Common.PrettyParseError +import Language.Python.Common.Pretty (prettyText)+import Language.Python.Common.AST (StatementSpan)+import Language.Haskell.Exts.Pretty +   ( prettyPrintStyleMode, defaultMode, style, Style (..), PPHsMode (..)+   , Mode (..), PPLayout (PPSemiColon))+import Language.Haskell.Exts.Build (app, qualStmt) +import Language.Haskell.Exts.Syntax (Stmt) +import Berp.Version (version)+import Berp.Compile.Compile (compile)+import Berp.Compile.PrimName as Prim (interpretStmt, init)+import Berp.Compile.PySyntaxUtils (InterpreterStmt (..))+import Berp.Interpreter.Monad (Repl, runRepl)+import Berp.Interpreter.Input (getInputLines)+ +repl :: IO ()+repl = do+    hSetBuffering stdout NoBuffering+    greeting+    defaultErrorHandler defaultDynFlags $ do+      runRepl (Just libdir) $ do+         dflags <- getSessionDynFlags+         setSessionDynFlags dflags+         -- target <- guessTarget "test_main.hs" Nothing+         -- setTargets [target]+         -- load LoadAllTargets+         -- prel_mod <- findModule (mkModuleName "Prelude") Nothing+         berp_base_mod <- findModule (mkModuleName "Berp.Base") Nothing+         -- setContext [] [prel_mod, berp_base_mod]+         setContext [] [berp_base_mod]+         replLoop++greeting :: IO ()+greeting = putStrLn $ "Berp version " ++ version ++ ", type control-d to exit."++replLoop :: Repl ()+replLoop = do+   maybeInput <- getInputLines+   case maybeInput of +      Nothing -> return () +      Just input -> do+         when (not $ null input) $ do+            pyStmts <- liftIO $ parseAndCheckErrors (input ++ "\n")+            when (not $ null pyStmts) $ do+               stmts <- liftGhcT $ lift $ compile $ InterpreterStmt pyStmts+               let finalStmt = qualStmt (app Prim.interpretStmt Prim.init)+               let stmtStrs = map oneLinePrinter (stmts ++ [finalStmt])+               -- liftIO $ mapM_ putStrLn stmtStrs+               mapM_ runAndCatch stmtStrs+         replLoop++runAndCatch :: String -> Repl ()+runAndCatch stmt = do +   gcatch (runStmt stmt RunToCompletion >>= printRunResult) catcher+   where+   catcher :: SomeException -> Repl ()+   catcher e = liftIO $ print e ++printRunResult :: RunResult -> Repl ()+printRunResult (RunException e) = liftIO $ putStrLn ("Exception " ++ show e)+printRunResult _other = return () ++oneLinePrinter :: Stmt -> String+oneLinePrinter = +   prettyPrintStyleMode newStyle newMode+   where+   newStyle = style { mode = OneLineMode } +   newMode = defaultMode { layout = PPSemiColon }++parseAndCheckErrors :: String -> IO [StatementSpan]+parseAndCheckErrors fileContents =+   case parseStmt fileContents "<stdin>" of+      Left e -> (putStrLn $ prettyText e) >> return [] +      Right (pyStmt, _comments) -> return pyStmt
+ src/Berp/Main.hs view
@@ -0,0 +1,174 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Main +-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- The Main module of Berp. Both the compiler and the interactive interpreter+-- are started from here.+--+-----------------------------------------------------------------------------++module Main where++import Language.Python.Version3.Parser (parseModule)+import Language.Python.Common.AST (ModuleSpan)+import Data.Maybe (maybe)+import Control.Monad (when)+import Control.Applicative ((<$>))+import Language.Haskell.Exts.Pretty+import Berp.Compile.Compile (compiler)+import System.Console.ParseArgs +   (Argtype (..), argDataOptional, argDataDefaulted, Arg (..)+   , gotArg, getArg, parseArgsIO, ArgsComplete (..), Args(..))+import System.Cmd (system)+import System.Exit (ExitCode (..), exitWith)+import System.FilePath ((</>), (<.>), takeBaseName)+import System.Directory (removeFile)+import Berp.Interpreter.Repl (repl)++main :: IO ()+main = do+   let args = [withGHC, help, clobber, clean, showHaskell, compile, inputFile]+   argMap <- parseArgsIO ArgsComplete args +   giveHelp argMap+   maybeInputDetails <- getInputDetails argMap+   case maybeInputDetails of+      Nothing -> repl +      Just (sourceName, fileContents) -> +         compileAndExecute argMap sourceName fileContents+ +compileAndExecute :: Args ArgIndex -> FilePath -> String -> IO ()+compileAndExecute argMap sourceName fileContents = do+   pyModule <- parseAndCheckErrors fileContents sourceName+   haskellSrc <- prettyPrint <$> compiler pyModule +   when (gotArg argMap ShowHaskell) $ do+      putStrLn haskellSrc+      exitWith ExitSuccess+   let outputName = takeBaseName sourceName +       haskellFilename = outputName <.> "hs"+       interfaceFilename = outputName <.> "hi" +       objectFilename = outputName <.> "o" +       exeFilename = "." </> outputName+   writeFile haskellFilename (haskellSrc ++ "\n")+   exitCodeCompile <- system $ ghcCommand argMap "-O2" "-v0" haskellFilename+   when (gotArg argMap Compile) $ exitWith ExitSuccess+   case exitCodeCompile of+      ExitFailure {} -> exitWith exitCodeCompile+      ExitSuccess -> do+         exeStatus <- system exeFilename +         let tempFiles = [haskellFilename, interfaceFilename, objectFilename]+         when (gotArg argMap Clean) $ do+            mapM_ removeFile tempFiles +         when (gotArg argMap Clobber) $ do+            mapM_ removeFile (exeFilename : tempFiles)+         exitWith exeStatus++parseAndCheckErrors :: String -> FilePath -> IO ModuleSpan+parseAndCheckErrors fileContents sourceName =+   case parseModule fileContents sourceName of+      Left e -> error $ show e+      Right (pyModule, _comments) -> return pyModule ++getInputDetails :: Args ArgIndex -> IO (Maybe (FilePath, String))+getInputDetails argMap = +   case getArg argMap InputFile of+      Nothing -> return Nothing +      Just inputFileName -> do+         cs <- readFile inputFileName+         return $ Just (inputFileName, cs)++giveHelp :: Args ArgIndex -> IO ()+giveHelp argMap =+   if gotArg argMap Help +      then error $ argsUsage argMap+      else return ()++ghcCommand :: Args ArgIndex -> String -> String -> String -> String +ghcCommand argMap optimise verbosity inputFile =+   unwords [ghcName, "--make", optimise, verbosity, inputFile]+   where+   ghcName = maybe "ghc" id (getArg argMap WithGHC)++data ArgIndex+   = Help +   | ShowHaskell     +   | InputFile +   | Compile+   | Clobber +   | Clean+   | WithGHC+   deriving (Eq, Ord, Show)++help :: Arg ArgIndex+help = +   Arg +   { argIndex = Help+   , argAbbr = Just 'h'+   , argName = Just "help"+   , argData = Nothing+   , argDesc = "Display a help message."+   }++showHaskell :: Arg ArgIndex+showHaskell = +   Arg+   { argIndex = ShowHaskell +   , argAbbr = Just 't' +   , argName = Just "showhaskell"+   , argData = Nothing +   , argDesc = "Output translated Haskell code on standard output and exit."+   }++inputFile :: Arg ArgIndex+inputFile = +   Arg+   { argIndex = InputFile +   , argAbbr = Nothing +   , argName = Nothing +   , argData = argDataOptional "input file" ArgtypeString+   , argDesc = "Name of the input Python file."+   }++compile :: Arg ArgIndex+compile = +   Arg+   { argIndex = Compile +   , argAbbr = Just 'c' +   , argName = Just "compile" +   , argData = Nothing +   , argDesc = "Compile the input program, but do not run it."+   }++clobber :: Arg ArgIndex+clobber = +   Arg+   { argIndex = Clobber +   , argAbbr = Nothing+   , argName = Just "clobber" +   , argData = Nothing +   , argDesc = "Remove all compiler generated files after the compiled program has run."+   }++clean :: Arg ArgIndex+clean = +   Arg+   { argIndex = Clean +   , argAbbr = Nothing+   , argName = Just "clean" +   , argData = Nothing +   , argDesc = "Remove all compiler generated files except the executable after the compiled program has run."+   }++withGHC :: Arg ArgIndex+withGHC = +   Arg +   { argIndex = WithGHC +   , argAbbr = Nothing +   , argName = Just "with-ghc"+   , argData = argDataDefaulted "filepath to ghc" ArgtypeString "ghc"+   , argDesc = "Specify the filepath of ghc."+   }
+ src/Berp/Version.hs view
@@ -0,0 +1,17 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Berp.Version+-- Copyright   : (c) 2010 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- The current version of berp, exported as a Haskell string.+--+-----------------------------------------------------------------------------++module Berp.Version (version) where++version :: String+version = "0.0.1"
+ src/include/BerpDebug.h view
@@ -0,0 +1,18 @@+/*+ Copyright   : (c) 2010 Bernie Pope+ License     : BSD-style+ Maintainer  : florbitous@gmail.com ++ Debugging CPP macros.++ LIO refers to the LiftedIO library. This allows us to use putStrLn in any+ MonadIO context.+*/++#ifdef DEBUG+#define BELCH(str) (LIO.putStrLn (str))+#define IF_DEBUG(action) (action)+#else+#define BELCH(str)+#define IF_DEBUG(action)+#endif