{-# LANGUAGE TypeFamilies, TypeSynonymInstances, FlexibleInstances,
    PatternGuards, RecordWildCards #-}
-----------------------------------------------------------------------------
-- |
-- Module      : Blip.Compiler.Compile
-- Copyright   : (c) 2012, 2013, 2014 Bernie Pope
-- License     : BSD-style
-- Maintainer  : florbitous@gmail.com
-- Stability   : experimental
-- Portability : ghc
--
-- Compilation of Python 3 source code into bytecode.
-- 
-- Basic algorithm:
--
-- 1) Parse the source code into an AST.
-- 2) Compute the scope of all variables in the module
--    (one pass over the AST).
-- 3) Compile the AST for the whole module into a (possibly nested)
--    code object (one pass over the AST).
-- 4) Write the code object to a .pyc file.
--
-- The following Python constructs are compiled into code objects:
--    - The top-level of the module.
--    - Function definitions (def and lambda).
--    - Class definitions.
--    - Comprehensions.
--
-- The statements and expressions in each of the above constructs are
-- recursively compiled into bytecode instructions. Initially, the actual
-- addresses of jump instruction targets are not known. Instead the jump
-- targets are just labels. At the end of the compilation of each
-- construct the labelled instructions are converted into jumps to
-- actual addresses (one pass over the bytecode stream).
-- Also the maximum stack size of each code object is computed (one pass
-- over the bytecode stream).
--
-- We currently make no attempt to optimise the generated code.
--
-- Bytecode is generated directly from the AST, there is no intermediate
-- language, and no explict control-flow graph.
--
-----------------------------------------------------------------------------

module Blip.Compiler.Compile
   (compileFile, compileReplInput, writePycFile)
   where

import Prelude hiding (mapM)
import Blip.Compiler.Desugar (desugarComprehension, desugarWith, resultName)
import Blip.Compiler.Utils 
   ( isPureExpr, isPyObjectExpr, mkAssignVar, mkList
   , mkVar, mkMethodCall, mkStmtExpr, mkSet, mkDict, mkAssign
   , mkSubscript, mkReturn, mkYield, spanToScopeIdentifier )
import Blip.Compiler.StackDepth (maxStackDepth)
import Blip.Compiler.State
   ( setBlockState, getBlockState, initBlockState, initState
   , emitCodeNoArg, emitCodeArg, compileConstantEmit
   , compileConstant, getFileName, newLabel, labelNextInstruction
   , getObjectName, setObjectName
   , getNestedScope, ifDump, getLocalScope
   , indexedVarSetKeys, emitReadVar, emitWriteVar, emitDeleteVar
   , lookupNameVar, lookupClosureVar, setFlag
   , peekFrameBlock, withFrameBlock, setFastLocals, setArgCount
   , setLineNumber, setFirstLineNumber )
import Blip.Compiler.Assemble (assemble)
import Blip.Compiler.Monad (Compile (..), runCompileMonad)
import Blip.Compiler.Types
   ( Identifier, CompileConfig (..)
   , CompileState (..), BlockState (..)
   , AnnotatedCode (..), Dumpable (..), IndexedVarSet, VarInfo (..)
   , FrameBlockInfo (..), Context (..), ParameterTypes (..), LocalScope (..) )
import Blip.Compiler.Scope (topScope, renderScope)
import Blip.Marshal as Blip
   ( writePyc, PycFile (..), PyObject (..), co_generator )
import Blip.Bytecode (Opcode (..), encode)
import Language.Python.Version3.Parser (parseModule, parseStmt)
import Language.Python.Common.AST as AST
   ( Annotated (..), ModuleSpan, Module (..), StatementSpan, Statement (..)
   , ExprSpan, Expr (..), Ident (..), ArgumentSpan, Argument (..)
   , OpSpan, Op (..), Handler (..), HandlerSpan, ExceptClause (..)
   , ExceptClauseSpan, ImportItem (..), ImportItemSpan, ImportRelative (..)
   , ImportRelativeSpan, FromItems (..), FromItemsSpan, FromItem (..)
   , FromItemSpan, DecoratorSpan, Decorator (..), ComprehensionSpan
   , Comprehension (..), SliceSpan, Slice (..), AssignOpSpan, AssignOp (..)
   , ComprehensionExpr (..), ComprehensionExprSpan
   , ParameterSpan, Parameter (..), RaiseExpr (..), RaiseExprSpan
   , DictKeyDatumList(DictMappingPair), YieldArg (..), YieldArgSpan )
import Language.Python.Common (prettyText)
import Language.Python.Common.StringEscape (unescapeString)
import Language.Python.Common.SrcLocation (SrcSpan (..))
import System.FilePath ((<.>), takeBaseName)
-- XXX Commented out to avoid bug in unix package when building on OS X, 
-- The unix package is depended on by the directory package.
-- import System.Directory (getModificationTime, canonicalizePath)
-- import System.Time (ClockTime (..))
import System.IO (openFile, IOMode(..), hClose, hFileSize, hGetContents)
import Data.Word (Word32, Word16)
import Data.Int (Int32)
import Data.Traversable as Traversable (mapM)
import qualified Data.ByteString.Lazy as B (pack)
import Data.String (fromString)
import Data.List (intersperse)
import Control.Monad (unless, forM_, when, replicateM_, foldM)
import Control.Monad.Trans (liftIO)
import Data.Bits ((.|.), shiftL)

-- Compile the input from the REPL command line to an object.
compileReplInput :: CompileConfig -> String -> IO PyObject
compileReplInput config replString = do
   stmts <- parseStmtAndCheckErrors replString
   let printWrapped = wrapWithPrint stmts
   -- pretend that the statements are a module on their own to calculate the variable scope
   (moduleLocals, nestedScope) <- topScope $ Module printWrapped
   let state = initState ModuleContext moduleLocals
                  nestedScope config ""
   compileReplStmts state printWrapped

-- Support for REPL printing of expressions.
-- If the statement entered at the REPL is an expression, then
-- we try to print it out.
-- We transform an expression E into:
--    _ = E
--    print(_)
--
-- XXX if the result of E is None then we should not print it out,
-- to be consistent with CPython.
-- Want something like this:
--    try:
--       _ = E
--    catch Exception as e:
--       stackTrace e
--    elif _ is not None:
--       print(e)      
wrapWithPrint :: [StatementSpan] -> [StatementSpan]
wrapWithPrint [StmtExpr {..}] = 
   [assignStmt, printStmt]
   where
   assignStmt = Assign { assign_to = [underscoreVar], assign_expr = stmt_expr, stmt_annot = SpanEmpty }
   underscoreIdent = Ident { ident_string = "_", ident_annot = SpanEmpty }
   underscoreVar = Var { var_ident = underscoreIdent, expr_annot = SpanEmpty }
   printIdent = Ident { ident_string = "print", ident_annot = SpanEmpty }
   printVar = Var { var_ident = printIdent, expr_annot = SpanEmpty }
   printArg = ArgExpr { arg_expr = underscoreVar, arg_annot = SpanEmpty }
   printExpr = Call { call_fun = printVar, call_args = [printArg], expr_annot = SpanEmpty }
   printStmt = StmtExpr { stmt_expr = printExpr, stmt_annot = SpanEmpty }
wrapWithPrint other = other

-- Compile Python source code to bytecode, returing a representation
-- of a .pyc file contents.
compileFile :: CompileConfig -- Configuration options
            -> FilePath      -- The file path of the input Python source
            -> IO PycFile
compileFile config path = do
   pyHandle <- openFile path ReadMode
   sizeInBytes <- hFileSize pyHandle
   fileContents <- hGetContents pyHandle
   -- modifiedTime <- getModificationTime path
   -- let modSeconds = case modifiedTime of TOD secs _picoSecs -> secs
   let modSeconds = (0 :: Integer)
   pyModule <- parseFileAndCheckErrors fileContents path
   (moduleLocals, nestedScope) <- topScope pyModule
   -- canonicalPath <- canonicalizePath path 
   canonicalPath <- return path 
   let state = initState ModuleContext moduleLocals 
                  nestedScope config canonicalPath
   pyc <- compileModule state (fromIntegral modSeconds)
             (fromIntegral sizeInBytes) pyModule
   return pyc

writePycFile :: PycFile -> FilePath -> IO ()
writePycFile pyc path = do
   let pycFilePath = takeBaseName path <.> ".pyc"
   pycHandle <- openFile pycFilePath WriteMode 
   writePyc pycHandle pyc
   hClose pycHandle

-- Parse the Python source from a statement into an AST, check for any syntax errors.
parseStmtAndCheckErrors :: String -> IO [StatementSpan]
parseStmtAndCheckErrors stmtString =
   case parseStmt stmtString "<stdin>" of
      Left e -> error $ "parse error: " ++ prettyText e
      Right (stmts, _comments) -> return stmts

-- Parse the Python source from a File into an AST, check for any syntax errors.
parseFileAndCheckErrors :: String -> FilePath -> IO ModuleSpan
parseFileAndCheckErrors fileContents sourceName =
   case parseModule fileContents sourceName of
      Left e -> error $ "parse error: " ++ prettyText e
      Right (pyModule, _comments) -> return pyModule

compileModule :: CompileState   -- initial compiler state
              -> Word32         -- modification time
              -> Word32         -- size in bytes
              -> ModuleSpan     -- AST
              -> IO PycFile
compileModule state pyFileModifiedTime pyFileSizeBytes mod = do
   obj <- compiler mod state
   return $ PycFile
      { magic = compileConfig_magic $ state_config state
      , modified_time = pyFileModifiedTime 
      , size = pyFileSizeBytes
      , object = obj }

compileReplStmts :: CompileState -> [StatementSpan] -> IO PyObject
compileReplStmts state replStatements =
   compiler (Body replStatements) state

compiler :: Compilable a => a -> CompileState -> 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 ModuleSpan where
   type CompileResult ModuleSpan = PyObject
   compile ast@(Module stmts) = do
      maybeDumpScope 
      maybeDumpAST ast
      setObjectName "<module>"
      compileClassModuleDocString stmts
      compile $ Body stmts

-- body of module, function and class
newtype Body = Body [StatementSpan]

instance Compilable Body where
   type CompileResult Body = PyObject
   compile (Body stmts) = do
      mapM_ compile stmts
      -- XXX we could avoid this 'return None' if all branches in the code
      -- ended with a return statement. Can fix this in an optimisation step
      -- with control flow analysis.
      returnNone
      assemble
      makeObject

-- Build an object from all the state computed during compilation, such
-- as the bytecode sequence, variable information and so on.
-- argcount is the number of arguments, not counting *varargs or **kwargs.
makeObject :: Compile PyObject
makeObject = do
   annotatedCode <- getBlockState state_instructions
   let stackDepth = maxStackDepth annotatedCode
   names <- getBlockState state_names
   constants <- getBlockState state_constants
   freeVars <- getBlockState state_freeVars
   cellVars <- getBlockState state_cellVars
   argcount <- getBlockState state_argcount
   flags <- getBlockState state_flags
   fastLocals <- getBlockState state_fastLocals
   firstLineNumber <- getBlockState state_firstLineNumber
   lineNumberTable <- compileLineNumberTable firstLineNumber
   let code = map annotatedCode_bytecode annotatedCode 
       localVarNames = map Unicode $ indexedVarSetKeys fastLocals
       maxStackDepth = maxBound 
   if stackDepth > maxStackDepth
      -- XXX make a better error message
      then error $ "Maximum stack depth " ++ show maxStackDepth ++
                   " exceeded: " ++ show stackDepth
      else do
         pyFileName <- getFileName
         objectName <- getObjectName
         let obj = Code
                   { argcount = argcount
                   , kwonlyargcount = 0
                   , nlocals = fromIntegral $ length localVarNames
                   , stacksize = stackDepth 
                   , flags = flags 
                   , code = String $ encode code
                   , consts = makeConstants constants
                   , names = makeNames names
                   , varnames = Blip.Tuple localVarNames
                   , freevars = makeVarSetTuple freeVars
                   , cellvars = makeVarSetTuple cellVars
                   , filename = Unicode pyFileName
                   , name = Unicode objectName
                   , firstlineno = firstLineNumber
                   , lnotab = lineNumberTable
                   }
         return obj
   where
   makeVarSetTuple :: IndexedVarSet -> PyObject
   makeVarSetTuple varSet =
      Blip.Tuple $ map Unicode $ indexedVarSetKeys varSet
   makeConstants :: [PyObject] -> PyObject
   makeConstants = Blip.Tuple . reverse
   makeNames :: [Identifier] -> PyObject
   makeNames = Blip.Tuple . map Unicode . reverse 

instance Compilable StatementSpan where
   type CompileResult StatementSpan = ()
   compile stmt =
      setLineNumber (annot stmt) >>
      compileStmt stmt
  
compileStmt :: StatementSpan -> Compile ()
compileStmt (Assign {..}) = do
   compile assign_expr
   compileAssignments assign_to
compileStmt (AugmentedAssign {..}) =
   case aug_assign_to of
      Var {..} -> do
         let varIdent = ident_string var_ident
         emitReadVar varIdent
         compile aug_assign_expr
         compile aug_assign_op
         emitWriteVar varIdent
      Subscript {..} -> do
         compile subscriptee
         compile subscript_expr
         emitCodeNoArg DUP_TOP_TWO -- avoids re-doing the above two later when we store
         emitCodeNoArg BINARY_SUBSCR
         compile aug_assign_expr
         compile aug_assign_op
         emitCodeNoArg ROT_THREE
         emitCodeNoArg STORE_SUBSCR
      SlicedExpr {..} -> do
         compile slicee
         compileSlices slices
         emitCodeNoArg DUP_TOP_TWO -- avoids re-doing the above two later when we store
         emitCodeNoArg BINARY_SUBSCR
         compile aug_assign_expr
         compile aug_assign_op
         emitCodeNoArg ROT_THREE
         emitCodeNoArg STORE_SUBSCR
      expr@(Dot {..}) -> do
         compile dot_expr 
         emitCodeNoArg DUP_TOP
         index <- lookupNameVar $ ident_string $ dot_attribute 
         emitCodeArg LOAD_ATTR index 
         compile aug_assign_expr
         compile aug_assign_op
         emitCodeNoArg ROT_TWO
         emitCodeArg STORE_ATTR index 
{-
      expr@(BinaryOp { operator = Dot {}, right_op_arg = Var {..}}) -> do
         compile $ left_op_arg expr
         emitCodeNoArg DUP_TOP
         index <- lookupNameVar $ ident_string $ var_ident
         emitCodeArg LOAD_ATTR index 
         compile aug_assign_expr
         compile aug_assign_op
         emitCodeNoArg ROT_TWO
         emitCodeArg STORE_ATTR index 
-}
      other -> error $ "unexpected expression in augmented assignment: " ++ prettyText other
compileStmt (Return { return_expr = Nothing }) = returnNone
compileStmt (Return { return_expr = Just expr }) =  
   compile expr >> emitCodeNoArg RETURN_VALUE
compileStmt (Pass {}) = return ()
compileStmt (StmtExpr {..}) = 
   unless (isPureExpr stmt_expr) $ 
      compile stmt_expr >> emitCodeNoArg POP_TOP
compileStmt (Conditional {..}) = do
   restLabel <- newLabel
   mapM_ (compileGuard restLabel) cond_guards 
   mapM_ compile cond_else
   labelNextInstruction restLabel
compileStmt (While {..}) = do
   startLoop <- newLabel
   endLoop <- newLabel
   anchor <- newLabel
   emitCodeArg SETUP_LOOP endLoop
   withFrameBlock (FrameBlockLoop startLoop) $ do
       labelNextInstruction startLoop
       compile while_cond
       emitCodeArg POP_JUMP_IF_FALSE anchor
       mapM_ compile while_body
       emitCodeArg JUMP_ABSOLUTE startLoop
       labelNextInstruction anchor 
       emitCodeNoArg POP_BLOCK
   mapM_ compile while_else
   labelNextInstruction endLoop
compileStmt (For {..}) = do
   startLoop <- newLabel
   endLoop <- newLabel
   withFrameBlock (FrameBlockLoop startLoop) $ do
      anchor <- newLabel
      emitCodeArg SETUP_LOOP endLoop
      compile for_generator
      emitCodeNoArg GET_ITER
      labelNextInstruction startLoop
      emitCodeArg FOR_ITER anchor
      let num_targets = length for_targets
      when (num_targets > 1) $ do
         emitCodeArg UNPACK_SEQUENCE $ fromIntegral num_targets
      mapM_ compileAssignTo for_targets 
      mapM_ compile for_body 
      emitCodeArg JUMP_ABSOLUTE startLoop
      labelNextInstruction anchor
      emitCodeNoArg POP_BLOCK
   mapM_ compile for_else
   labelNextInstruction endLoop
compileStmt stmt@(Fun {..}) = compileFun stmt []
compileStmt stmt@(Class {..}) = compileClass stmt []
-- XXX assertions appear to be turned off if the code is compiled
-- for optimisation
-- If the assertion expression is a tuple of non-zero length, then
-- it is always True: CPython warns about this
compileStmt (Assert {..}) = do
   case assert_exprs of
      test_expr:restAssertExprs -> do
         compile test_expr
         end <- newLabel
         emitCodeArg POP_JUMP_IF_TRUE end
         assertionErrorVar <- lookupNameVar "AssertionError"
         emitCodeArg LOAD_GLOBAL assertionErrorVar
         case restAssertExprs of
            assertMsgExpr:_ -> do
               compile assertMsgExpr
               emitCodeArg CALL_FUNCTION 1
            _other -> return ()
         emitCodeArg RAISE_VARARGS 1
         labelNextInstruction end
      _other -> error "assert with no test"
compileStmt stmt@(Try {..}) = compileTry stmt
compileStmt (Import {..}) = mapM_ compile import_items
-- XXX need to handle from __future__ 
compileStmt (FromImport {..}) = do
   let level = 0 -- XXX this should be the level of nesting
   compileConstantEmit $ Blip.Int level
   let names = fromItemsIdentifiers from_items 
       namesTuple = Blip.Tuple $ map Unicode names
   compileConstantEmit namesTuple
   compileFromModule from_module
   case from_items of
      ImportEverything {} -> do
         emitCodeNoArg IMPORT_STAR
      FromItems {..} -> do
         forM_ from_items_items $ \FromItem {..} -> do
             index <- lookupNameVar $ ident_string from_item_name
             emitCodeArg IMPORT_FROM index
             let storeName = case from_as_name of
                    Nothing -> from_item_name
                    Just asName -> asName
             emitWriteVar $ ident_string storeName
         emitCodeNoArg POP_TOP
-- XXX should check that we are inside a loop
compileStmt (Break {}) = emitCodeNoArg BREAK_LOOP
compileStmt (Continue {}) = do
   maybeFrameBlockInfo <- peekFrameBlock
   case maybeFrameBlockInfo of
      Nothing -> error loopError
      Just (FrameBlockLoop label) -> emitCodeArg JUMP_ABSOLUTE label 
      Just FrameBlockFinallyEnd ->
         error finallyError
      Just _other -> checkFrameBlocks
   where
   -- keep blocking the frame block stack until we either find
   -- a loop entry, otherwise generate an error
   checkFrameBlocks :: Compile ()
   checkFrameBlocks = do
      maybeFrameBlockInfo <- peekFrameBlock
      case maybeFrameBlockInfo of
         Nothing -> error loopError
         Just FrameBlockFinallyEnd -> error finallyError 
         Just (FrameBlockLoop label) ->
            emitCodeArg CONTINUE_LOOP label
         Just _other -> checkFrameBlocks
   loopError = "'continue' not properly in loop"
   finallyError = "'continue' not supported inside 'finally' clause"
compileStmt (NonLocal {}) = return ()
compileStmt (Global {}) = return ()
compileStmt (Decorated {..}) =
   case decorated_def of
      Fun {} -> compileFun decorated_def decorated_decorators
      Class {} -> compileClass decorated_def decorated_decorators
      other -> error $ "Decorated statement is not a function or a class: " ++ prettyText other
compileStmt (Delete {..}) = mapM_ compileDelete del_exprs
compileStmt stmt@(With {..})
   -- desugar with statements containing multiple contexts into nested
   -- with statements containing single contexts
   | length with_context > 1 = compileWith $ desugarWith stmt 
   | otherwise = compileWith stmt
compileStmt (Raise {..}) = compile raise_expr
compileStmt other = error $ "Unsupported statement:\n" ++ prettyText other

instance Compilable ExprSpan where
   type CompileResult ExprSpan = ()
   compile expr = 
      setLineNumber (annot expr) >>
      compileExpr expr

compileExpr :: ExprSpan -> Compile ()
compileExpr (Var { var_ident = ident }) = do
   emitReadVar $ ident_string ident
compileExpr expr@(AST.Strings {}) =
   compileConstantEmit $ constantToPyObject expr 
compileExpr expr@(AST.ByteStrings {}) =
   compileConstantEmit $ constantToPyObject expr 
compileExpr expr@(AST.Int {}) =
   compileConstantEmit $ constantToPyObject expr
compileExpr expr@(AST.Float {}) =
   compileConstantEmit $ constantToPyObject expr
compileExpr expr@(AST.Imaginary {}) =
   compileConstantEmit $ constantToPyObject expr
compileExpr expr@(AST.Bool {}) =
   compileConstantEmit $ constantToPyObject expr
compileExpr expr@(AST.None {}) =
   compileConstantEmit $ constantToPyObject expr
compileExpr expr@(AST.Ellipsis {}) =
   compileConstantEmit $ constantToPyObject expr
compileExpr (AST.Paren {..}) = compile paren_expr
compileExpr (AST.CondExpr {..}) = do
   compile ce_condition
   falseLabel <- newLabel
   emitCodeArg POP_JUMP_IF_FALSE falseLabel
   compile ce_true_branch
   restLabel <- newLabel
   emitCodeArg JUMP_FORWARD restLabel
   labelNextInstruction falseLabel 
   compile ce_false_branch
   labelNextInstruction restLabel
compileExpr expr@(AST.Tuple {..})
   | isPyObjectExpr expr =
        compileConstantEmit $ constantToPyObject expr
   | otherwise = do
        mapM_ compile tuple_exprs
        emitCodeArg BUILD_TUPLE $ fromIntegral $ length tuple_exprs
compileExpr (AST.List {..}) = do
   mapM_ compile list_exprs
   emitCodeArg BUILD_LIST $ fromIntegral $ length list_exprs
compileExpr (AST.Set {..}) = do
   mapM_ compile set_exprs
   emitCodeArg BUILD_SET $ fromIntegral $ length set_exprs
compileExpr (Dictionary {..}) = do
   emitCodeArg BUILD_MAP $ fromIntegral $ length dict_mappings
   forM_ dict_mappings $ \(DictMappingPair key value) -> do
      compile value
      compile key
      emitCodeNoArg STORE_MAP
compileExpr (ListComp {..}) = do
   let initStmt = [mkAssignVar resultName (mkList [])]
       updater = \(ComprehensionExpr expr) -> mkStmtExpr $ mkMethodCall (mkVar $ resultName) "append" expr
       returnStmt = [mkReturn $ mkVar $ resultName]
   compileComprehension "<listcomp>" initStmt updater returnStmt list_comprehension
compileExpr (SetComp {..}) = do
   let initStmt = [mkAssignVar resultName (mkSet [])]
       updater = \(ComprehensionExpr expr) -> mkStmtExpr $ mkMethodCall (mkVar $ resultName) "add" expr
       returnStmt = [mkReturn $ mkVar $ resultName]
   compileComprehension "<setcomp>" initStmt updater returnStmt set_comprehension
compileExpr (DictComp {..}) = do
   let initStmt = [mkAssignVar resultName (mkDict [])]
       updater = \(ComprehensionDict (DictMappingPair key val)) -> 
          mkAssign (mkSubscript (mkVar $ resultName) key) val
       returnStmt = [mkReturn $ mkVar $ resultName]
   compileComprehension "<dictcomp>" initStmt updater returnStmt dict_comprehension
compileExpr (Generator {..}) = do
   let updater = \(ComprehensionExpr expr) -> mkStmtExpr $ mkYield expr
   compileComprehension "<gencomp>" [] updater [] gen_comprehension
compileExpr (Yield { yield_arg = Nothing }) =
   compileConstantEmit Blip.None >> emitCodeNoArg YIELD_VALUE >> setFlag co_generator
compileExpr (Yield { yield_arg = Just (YieldExpr expr) }) =
   compile expr >> emitCodeNoArg YIELD_VALUE >> setFlag co_generator
compileExpr e@(Yield { yield_arg = Just (YieldFrom expr _) })
   = error $ "yield from not supported: " ++ show e
compileExpr (Call {..}) = do
   compile call_fun
   compileCall 0 call_args
compileExpr (Subscript {..}) = do
   compile subscriptee
   compile subscript_expr
   emitCodeNoArg BINARY_SUBSCR
compileExpr (SlicedExpr {..}) = do
   compile slicee
   compileSlices slices
   emitCodeNoArg BINARY_SUBSCR
compileExpr (Dot {..}) = do
   compile dot_expr 
   varInfo <- lookupNameVar $ ident_string dot_attribute 
   emitCodeArg LOAD_ATTR varInfo 
compileExpr exp@(BinaryOp {..})
   | isBoolean operator = compileBoolOpExpr exp
   | isComparison operator = compileCompareOpExpr exp
   | otherwise = do 
        compile left_op_arg
        compile right_op_arg
        compileOp operator 
compileExpr (UnaryOp {..}) = do
   compile op_arg
   compileUnaryOp operator
compileExpr (Lambda {..}) = do
   funBodyObj <- nestedBlock FunctionContext expr_annot $ do
      -- make the first constant None, to indicate no doc string
      -- for the lambda
      _ <- compileConstant Blip.None
      compile lambda_body
      emitCodeNoArg RETURN_VALUE
      assemble
      makeObject
   numDefaults <- compileDefaultParams lambda_args
   compileClosure "<lambda>" funBodyObj numDefaults
compileExpr other = error $ "Unsupported expr:\n" ++ prettyText other

instance Compilable AssignOpSpan where
   type CompileResult AssignOpSpan = ()
   compile = emitCodeNoArg . assignOpCode

instance Compilable DecoratorSpan where
   type CompileResult DecoratorSpan = ()
   compile dec@(Decorator {..}) = do
      compileDottedName decorator_name
      let numDecorators = length decorator_args
      when (numDecorators > 0) $ 
          compileCall 0 decorator_args
      where
      compileDottedName (name:rest) = do
         emitReadVar $ ident_string name
         forM_ rest $ \var -> do
            index <- lookupNameVar $ ident_string var
            emitCodeArg LOAD_ATTR index
      compileDottedName [] =
         error $ "decorator with no name: " ++ prettyText dec

instance Compilable ArgumentSpan where
   type CompileResult ArgumentSpan = ()
   compile (ArgExpr {..}) = compile arg_expr
   compile other = error $ "Unsupported argument:\n" ++ prettyText other

instance Compilable ImportItemSpan where
   type CompileResult ImportItemSpan = ()
   compile (ImportItem {..}) = do
      compileConstantEmit $ Blip.Int 0 -- this always seems to be zero
      compileConstantEmit Blip.None
      let dottedNames = map ident_string import_item_name
      -- assert (length dottedNames > 0)
      let dottedNameStr =
             concat $ intersperse "." dottedNames
      index <- lookupNameVar dottedNameStr
      emitCodeArg IMPORT_NAME index
      storeName <- 
         case import_as_name of
            Nothing -> return $ head import_item_name
            Just asName -> do
               forM_ (tail dottedNames) $ \attribute -> do
                  index <- lookupNameVar attribute
                  emitCodeArg LOAD_ATTR index 
               return asName
      emitWriteVar $ ident_string storeName

instance Compilable RaiseExprSpan where
   type CompileResult RaiseExprSpan = ()
   compile (RaiseV3 maybeRaiseArg) = do
      n <- case maybeRaiseArg of
              Nothing -> return 0
              Just (raiseExpr, maybeFrom) -> do
                 compile raiseExpr
                 case maybeFrom of
                    Nothing -> return 1
                    Just fromExpr -> do
                       compile fromExpr
                       return 2
      emitCodeArg RAISE_VARARGS n 
   compile stmt@(RaiseV2 _) =
      error $ "Python version 2 raise statement encountered: " ++ prettyText stmt

{-
   From CPython compile.c

   Code generated for "try: S except E1 as V1: S1 except E2 as V2: S2 ...":
   (The contents of the value stack is shown in [], with the top
   at the right; 'tb' is trace-back info, 'val' the exception's
   associated value, and 'exc' the exception.)

   Value stack          Label   Instruction     Argument
   []                           SETUP_EXCEPT    L1
   []                           <code for S>
   []                           POP_BLOCK
   []                           JUMP_FORWARD    L0

   [tb, val, exc]       L1:     DUP                             )
   [tb, val, exc, exc]          <evaluate E1>                   )
   [tb, val, exc, exc, E1]      COMPARE_OP      EXC_MATCH       ) only if E1
   [tb, val, exc, 1-or-0]       POP_JUMP_IF_FALSE       L2      )
   [tb, val, exc]               POP
   [tb, val]                    <assign to V1>  (or POP if no V1)
   [tb]                         POP
   []                           <code for S1>
                                POP_EXCEPT
                                JUMP_FORWARD    L0

   [tb, val, exc]       L2:     DUP
   .............................etc.......................

   [tb, val, exc]       Ln+1:   END_FINALLY     # re-raise exception

   []                   L0:     <next statement>

   Of course, parts are not generated if Vi or Ei is not present.
-}

compileTry :: StatementSpan -> Compile ()
compileTry stmt@(Try {..})
   | length try_finally == 0 = compileTryExcept stmt
   | otherwise = compileTryFinally stmt
compileTry other =
   error $ "Unexpected statement when compiling a try-except: " ++ prettyText other 

compileTryFinally :: StatementSpan -> Compile ()
compileTryFinally stmt@(Try {..}) = do
   end <- newLabel
   emitCodeArg SETUP_FINALLY end
   body <- newLabel
   labelNextInstruction body
   withFrameBlock FrameBlockFinallyTry $ do
      if length try_excepts > 0
         then compileTryExcept stmt 
         else mapM_ compile try_body
      emitCodeNoArg POP_BLOCK
   _ <- compileConstantEmit Blip.None
   labelNextInstruction end
   withFrameBlock FrameBlockFinallyEnd $ do
      mapM_ compile try_finally
      emitCodeNoArg END_FINALLY
compileTryFinally other =
   error $ "Unexpected statement when compiling a try-except: " ++ prettyText other 

compileTryExcept :: StatementSpan -> Compile ()
compileTryExcept (Try {..}) = do
   firstHandler <- newLabel                      -- L1
   emitCodeArg SETUP_EXCEPT firstHandler         -- pushes handler onto block stack
   withFrameBlock FrameBlockExcept $ do
      mapM_ compile try_body                     -- <code for S>
      emitCodeNoArg POP_BLOCK                    -- pops handler off block stack
   orElse <- newLabel
   emitCodeArg JUMP_FORWARD orElse 
   end <- newLabel                               -- L0
   compileHandlers end firstHandler try_excepts
   labelNextInstruction orElse
   mapM_ compile try_else
   labelNextInstruction end                      -- L0: <next statement>
compileTryExcept other =
   error $ "Unexpected statement when compiling a try-except: " ++ prettyText other 

-- Compile a sequence of exception handlers
compileHandlers :: Word16 -> Word16 -> [HandlerSpan] -> Compile ()
compileHandlers _end handlerLabel [] = do
   labelNextInstruction handlerLabel             -- Ln+1, # re-raise exception
   emitCodeNoArg END_FINALLY
compileHandlers end handlerLabel (Handler {..} : rest) = do
   labelNextInstruction handlerLabel
   nextLabel <- newLabel 
   compileHandlerClause nextLabel handler_clause
   emitCodeNoArg POP_TOP                         -- pop the traceback (tb) off the stack
   withFrameBlock FrameBlockFinallyTry $ do
      mapM_ compile handler_suite                   -- <code for S1, S2 ..>
      emitCodeNoArg POP_EXCEPT                      -- pop handler off the block stack
   emitCodeArg JUMP_FORWARD end
   compileHandlers end nextLabel rest 

-- enter here with stack == (s ++ [tb, val, exc]), leave with stack == s
compileHandlerClause :: Word16 -> ExceptClauseSpan -> Compile ()
compileHandlerClause nextHandler (ExceptClause {..}) = do
   case except_clause of
      Nothing -> do
         emitCodeNoArg POP_TOP                  -- pop exc off the stack
         emitCodeNoArg POP_TOP                  -- pop val off the stack
      Just (target, asExpr) -> do
         emitCodeNoArg DUP_TOP                  -- duplicate exc on stack
         compile target                         -- <evaluate E1>
         emitCodeArg COMPARE_OP exactMatchOp    -- compare E1 to exc
         emitCodeArg POP_JUMP_IF_FALSE nextHandler -- pop True/False and if no match try next handler
         emitCodeNoArg POP_TOP                  -- pop exc off the stack
         case asExpr of
            Nothing -> emitCodeNoArg POP_TOP    -- pop val off the stack
            -- XXX we should del this name at the end.
            Just expr -> compileAssignTo expr   -- assign the exception to the as name, will remove val from stack
   where
   -- The code for an exact match operator.
   exactMatchOp :: Word16
   exactMatchOp = 10

withDecorators :: [DecoratorSpan] -> Compile () -> Compile ()
withDecorators decorators comp = do
   -- push each of the decorators on the stack
   mapM_ compile decorators
   -- run the enclosed computation
   comp
   -- call each of the decorators
   replicateM_ (length decorators) $ 
      emitCodeArg CALL_FUNCTION 1

nestedBlock :: Context -> SrcSpan -> Compile a -> Compile a
nestedBlock context span comp = do
   -- save the current block state
   oldBlockState <- getBlockState id
   -- set the new block state to initial values, and the
   -- scope of the current definition
   (name, localScope) <- getLocalScope $ spanToScopeIdentifier span 
   setBlockState $ initBlockState context localScope
   -- set the new object name
   setObjectName name
   -- set the first line number of the block
   setFirstLineNumber span
   -- run the nested computation
   result <- comp
   -- restore the original block state
   setBlockState oldBlockState
   return result

-- Compile a function definition, possibly with decorators.
compileFun :: StatementSpan -> [DecoratorSpan] -> Compile ()
compileFun (Fun {..}) decorators = do
   let funName = ident_string $ fun_name
   withDecorators decorators $ do
      funBodyObj <- nestedBlock FunctionContext stmt_annot $ do
         compileFunDocString fun_body
         compile $ Body fun_body
      numDefaults <- compileDefaultParams fun_args
      compileClosure funName funBodyObj numDefaults
   emitWriteVar funName
compileFun other _decorators = error $ "compileFun applied to a non function: " ++ prettyText other

-- Compile a class definition, possibly with decorators.
compileClass :: StatementSpan -> [DecoratorSpan] -> Compile ()
compileClass (Class {..}) decorators = do
   let className = ident_string $ class_name
   withDecorators decorators $ do
      classBodyObj <- nestedBlock ClassContext stmt_annot $ do
         -- classes have a special argument called __locals__
         -- it is the only argument they have in the byte code, but it
         -- does not come from the source code, so we have to add it.
         setFastLocals ["__locals__"]
         setArgCount 1
         emitCodeArg LOAD_FAST 0
         emitCodeNoArg STORE_LOCALS
         emitReadVar "__name__"
         emitWriteVar "__module__"
         compileConstantEmit $ Unicode className
         emitWriteVar "__qualname__"
         compileClassModuleDocString class_body
         compile $ Body class_body
      emitCodeNoArg LOAD_BUILD_CLASS
      compileClosure className classBodyObj 0
      compileConstantEmit $ Unicode className
      compileCall 2 class_args
   emitWriteVar className
compileClass other _decorators = error $ "compileClass applied to a non class: " ++ prettyText other

-- XXX CPython uses a "qualified" name for the code object. For instance
-- nested functions look like "f.<locals>.g", whereas we currently use
-- just "g".

-- The free variables in a code object will either be cell variables
-- or free variables in the enclosing object. If there are no free
-- variables then we can avoid building the closure, and just make the function.
compileClosure :: String -> PyObject -> Word16 -> Compile ()
compileClosure name obj numDefaults = do
   -- get the list of free variables from the code object
   let Blip.Tuple freeVarStringObjs = freevars obj
       freeVarIdentifiers = map unicode freeVarStringObjs
       numFreeVars = length freeVarIdentifiers
   if numFreeVars == 0
      then do
         compileConstantEmit obj 
         compileConstantEmit $ Unicode name
         emitCodeArg MAKE_FUNCTION numDefaults  
      else do
         forM_ freeVarIdentifiers $ \var -> do
            maybeVarInfo <- lookupClosureVar var
            -- we don't use emitReadVar because it would generate
            -- LOAD_DEREF instructions, but we want LOAD_CLOSURE
            -- instead.
            case maybeVarInfo of
               Just (CellVar index) -> emitCodeArg LOAD_CLOSURE index
               Just (FreeVar index) -> emitCodeArg LOAD_CLOSURE index
               _other -> error $ name ++ " closure free variable not cell or free var in outer context: " ++ var
         emitCodeArg BUILD_TUPLE $ fromIntegral numFreeVars
         compileConstantEmit obj 
         compileConstantEmit $ Unicode name
         emitCodeArg MAKE_CLOSURE numDefaults

-- Compile default parameters and return how many there are
compileDefaultParams :: [ParameterSpan] -> Compile Word16
compileDefaultParams = foldM compileParam 0
   where
   compileParam :: Word16 -> ParameterSpan -> Compile Word16
   compileParam count (Param {..}) = do
      case param_default of
         Nothing -> return count
         Just expr -> do
            compile expr
            return $ count + 1
   compileParam count _other = return count

-- Compile a 'from module import'.
compileFromModule :: ImportRelativeSpan -> Compile ()
-- XXX what to do about the initial dots?
compileFromModule (ImportRelative {..}) = do
   let moduleName =
          case import_relative_module of
             Nothing -> ""
             Just dottedNames ->
                concat $ intersperse "." $ map ident_string dottedNames
   index <- lookupNameVar moduleName 
   emitCodeArg IMPORT_NAME index

fromItemsIdentifiers :: FromItemsSpan -> [Identifier]
fromItemsIdentifiers (ImportEverything {}) = ["*"]
fromItemsIdentifiers (FromItems {..}) =
   map fromItemIdentifier from_items_items
   where
   fromItemIdentifier :: FromItemSpan -> Identifier
   fromItemIdentifier (FromItem {..}) = ident_string $ from_item_name

-- compile multiple possible assignments:
-- x = y = z = rhs
compileAssignments :: [ExprSpan] -> Compile ()
compileAssignments [] = return ()
compileAssignments [e] = compileAssignTo e
compileAssignments (e1:e2:rest) = do
   emitCodeNoArg DUP_TOP
   compileAssignTo e1
   compileAssignments (e2:rest)

-- the lhs of an assignment statement
-- we can assume that the parser has only accepted the appropriate
-- subset of expression types
compileAssignTo :: ExprSpan -> Compile ()
compileAssignTo (Var {..}) =
   emitWriteVar $ ident_string var_ident
compileAssignTo (Subscript {..}) = 
   compile subscriptee >>
   compile subscript_expr >>
   emitCodeNoArg STORE_SUBSCR
-- XXX this can be optimised in places where the rhs is a
-- manifest list or tuple, avoiding the building list/tuple
-- only to deconstruct again
compileAssignTo (AST.Tuple {..}) = do
   emitCodeArg UNPACK_SEQUENCE $ fromIntegral $ length tuple_exprs
   mapM_ compileAssignTo tuple_exprs
compileAssignTo (AST.List {..}) = do
   emitCodeArg UNPACK_SEQUENCE $ fromIntegral $ length list_exprs
   mapM_ compileAssignTo list_exprs
compileAssignTo (AST.Paren {..}) = compileAssignTo paren_expr
compileAssignTo expr@(Dot {..} ) = do
   compile dot_expr 
   index <- lookupNameVar $ ident_string dot_attribute
   emitCodeArg STORE_ATTR index
{-
compileAssignTo expr@(BinaryOp { operator = Dot {}, right_op_arg = Var {..}}) = do
   compile $ left_op_arg expr
   index <- lookupNameVar $ ident_string $ var_ident
   emitCodeArg STORE_ATTR index
-}
compileAssignTo (SlicedExpr {..}) = do
   compile slicee
   compileSlices slices
   emitCodeNoArg STORE_SUBSCR  
compileAssignTo other = error $ "assignment to unexpected expression:\n" ++ prettyText other

compileDelete :: ExprSpan -> Compile ()
compileDelete (Var {..}) = do
   emitDeleteVar $ ident_string var_ident
compileDelete (Subscript {..}) =
   compile subscriptee >>
   compile subscript_expr >>
   emitCodeNoArg DELETE_SUBSCR
compileDelete (AST.Paren {..}) = compileDelete paren_expr
compileDelete (Dot {..}) = do
   compile dot_expr 
   index <- lookupNameVar $ ident_string dot_attribute
   emitCodeArg DELETE_ATTR index
{-
compileDelete (expr@(BinaryOp { operator = Dot {}, right_op_arg = Var {..}})) = do
   compile $ left_op_arg expr
   index <- lookupNameVar $ ident_string $ var_ident
   emitCodeArg DELETE_ATTR index
-}
compileDelete (SlicedExpr {..}) = do
   compile slicee
   compileSlices slices
   emitCodeNoArg DELETE_SUBSCR  
compileDelete other = error $ "delete of unexpected expression:\n" ++ prettyText other

compileWith :: StatementSpan -> Compile ()
compileWith stmt@(With {..}) = 
   case with_context of
      [(context, maybeAs)] -> do
         blockLabel <- newLabel
         finallyLabel <- newLabel
         compile context
         emitCodeArg SETUP_WITH finallyLabel
         labelNextInstruction blockLabel
         withFrameBlock FrameBlockFinallyTry $ do
            case maybeAs of
               -- Discard result from context.__enter__()
               Nothing -> emitCodeNoArg POP_TOP
               Just expr -> compileAssignTo expr
            mapM_ compile with_body
            emitCodeNoArg POP_BLOCK
         _ <- compileConstantEmit Blip.None
         labelNextInstruction finallyLabel
         withFrameBlock FrameBlockFinallyEnd $ do
            emitCodeNoArg WITH_CLEANUP
            emitCodeNoArg END_FINALLY
      _other -> error $ "compileWith applied to non desugared with statement: " ++ prettyText stmt 
compileWith other = error $ "compileWith applied to non with statement: " ++ prettyText other

-- Check for a docstring in the first statement of a function body.
-- The first constant in the corresponding code object is inspected
-- by the interpreter for the docstring. If there is no docstring
-- then the first constant must be None
compileFunDocString :: [StatementSpan] -> Compile ()
compileFunDocString (firstStmt:_stmts)
   | StmtExpr {..} <- firstStmt,
     Strings {} <- stmt_expr
        = compileConstant (constantToPyObject stmt_expr) >> return ()
   | otherwise = compileConstant Blip.None >> return ()
compileFunDocString [] = compileConstant Blip.None >> return ()

compileClassModuleDocString :: [StatementSpan] -> Compile ()
compileClassModuleDocString (firstStmt:_stmts)
   | StmtExpr {..} <- firstStmt,
     Strings {} <- stmt_expr
        -- XXX what if another __doc__ is in scope?
        = do compileConstantEmit $ constantToPyObject stmt_expr
             emitWriteVar "__doc__"
   | otherwise = return ()
compileClassModuleDocString [] = return ()

-- Compile a conditional guard
compileGuard :: Word16 -> (ExprSpan, [StatementSpan]) -> Compile ()
compileGuard restLabel (expr, stmts) = do
   compile expr
   falseLabel <- newLabel
   emitCodeArg POP_JUMP_IF_FALSE falseLabel
   mapM_ compile stmts
   emitCodeArg JUMP_FORWARD restLabel
   labelNextInstruction falseLabel 

-- Desugar the comprehension into a zero-arity function (body) with
-- a (possibly nested) for loop, then call the function.
compileComprehension
   :: Identifier 
   -> [StatementSpan]
   -> (ComprehensionExprSpan -> StatementSpan) 
   -> [StatementSpan]
   -> ComprehensionSpan
   -> Compile ()
compileComprehension name initStmt updater returnStmt comprehension = do
   let desugaredComp = desugarComprehension initStmt updater returnStmt comprehension 
       comprehensionSpan = comprehension_annot comprehension
   funObj <- nestedBlock
                FunctionContext
                comprehensionSpan 
                (compile $ Body desugaredComp)
   compileClosure name funObj 0
   (_name, localScope) <- getLocalScope $ spanToScopeIdentifier comprehensionSpan
   let parameterNames = parameterTypes_pos $ localScope_params localScope 
   mapM_ emitReadVar parameterNames
   emitCodeArg CALL_FUNCTION $ fromIntegral $ length parameterNames

-- Convert a constant expression into the equivalent object. This
-- only works for expressions which have a counterpart in the object
-- representation used in .pyc files.
constantToPyObject :: ExprSpan -> PyObject
constantToPyObject (AST.Int {..})
   | int_value > (fromIntegral max32BitSignedInt) ||
     int_value < (fromIntegral min32BitSignedInt)
      =  Blip.Long int_value
   | otherwise = Blip.Int $ fromIntegral int_value
   where
   max32BitSignedInt :: Int32
   max32BitSignedInt = maxBound 
   min32BitSignedInt :: Int32
   min32BitSignedInt = minBound 
constantToPyObject (AST.Float {..}) = Blip.Float $ float_value 
-- XXX we could optimise the case where we have 'float + imaginary j',
-- to generate a Complex number directly, rather than by doing
-- the addition operation.
constantToPyObject (AST.Imaginary {..}) =
   Blip.Complex { real = 0.0, imaginary = imaginary_value }
constantToPyObject (AST.Bool { bool_value = True }) = Blip.TrueObj
constantToPyObject (AST.Bool { bool_value = False }) = Blip.FalseObj
constantToPyObject (AST.None {}) = Blip.None
constantToPyObject (AST.Ellipsis {}) = Blip.Ellipsis
-- assumes all the tuple elements are constant
constantToPyObject (AST.Tuple {..}) =
   Blip.Tuple { elements = map constantToPyObject tuple_exprs }
constantToPyObject (AST.Strings {..}) =
   Blip.Unicode { unicode = concat $ map normaliseString strings_strings }
constantToPyObject (AST.ByteStrings {..}) =
  -- error $ show $ map normaliseString byte_string_strings
  Blip.String { string = fromString $ concat $ map normaliseString byte_string_strings }
constantToPyObject other =
   error $ "constantToPyObject applied to an unexpected expression: " ++ prettyText other

-- The strings in the AST retain their original quote marks which
-- need to be removed, we have to remove single or triple quotes.
-- We assume the parser has correctly matched the quotes.
-- Escaped characters such as \n \t are parsed as multiple characters
-- and need to be converted back into single characters.
normaliseString :: String -> String
normaliseString ('r':'b':rest) = removeQuotes rest
normaliseString ('b':'r':rest) = removeQuotes rest
normaliseString ('b':rest) = unescapeString $ removeQuotes rest
normaliseString ('r':rest) = removeQuotes rest
normaliseString other = unescapeString $ removeQuotes other 

removeQuotes :: String -> String
removeQuotes ('\'':'\'':'\'':rest) = take (length rest - 3) rest
removeQuotes ('"':'"':'"':rest) = take (length rest - 3) rest
removeQuotes ('\'':rest) = init rest
removeQuotes ('"':rest) = init rest
removeQuotes other = error $ "bad literal string: " ++ other

data CallArgs =
   CallArgs
   { callArgs_pos :: !Word16
   , callArgs_keyword :: !Word16
   , callArgs_varPos :: !Bool
   , callArgs_varKeyword :: !Bool
   }

initCallArgs :: CallArgs
initCallArgs =
   CallArgs
   { callArgs_pos = 0
   , callArgs_keyword = 0
   , callArgs_varPos = False
   , callArgs_varKeyword = False
   }

-- Compile the arguments to a call and
-- decide which particular CALL_FUNCTION bytecode to emit.
-- numExtraArgs counts any additional arguments the function
-- might have been applied to, which is necessary for classes
-- which get extra arguments beyond the ones mentioned in the
-- program source.
compileCall :: Word16 -> [ArgumentSpan] -> Compile ()
compileCall numExtraArgs args = do
   CallArgs {..} <- compileCallArgs args 
   let opArg = (callArgs_pos + numExtraArgs) .|. callArgs_keyword `shiftL` 8
   case (callArgs_varPos, callArgs_varKeyword) of
      (False, False) -> emitCodeArg CALL_FUNCTION opArg 
      (True, False) -> emitCodeArg CALL_FUNCTION_VAR opArg 
      (False, True) -> emitCodeArg CALL_FUNCTION_KW opArg 
      (True, True) -> emitCodeArg CALL_FUNCTION_VAR_KW opArg 

-- Compile the arguments to a function call and return the number
-- of positional arguments, and the number of keyword arguments.
compileCallArgs :: [ArgumentSpan] -> Compile CallArgs
compileCallArgs = foldM compileArg initCallArgs 
   where
   compileArg :: CallArgs  -> ArgumentSpan -> Compile CallArgs 
   compileArg callArgs@(CallArgs {..}) (ArgExpr {..}) = do
      compile arg_expr
      return $ callArgs { callArgs_pos = callArgs_pos + 1 }
   compileArg callArgs@(CallArgs {..}) (ArgKeyword {..}) = do
      compileConstantEmit $ Unicode $ ident_string arg_keyword
      compile arg_expr
      return $ callArgs { callArgs_keyword = callArgs_keyword + 1 }
   compileArg callArgs@(CallArgs {..}) (ArgVarArgsPos {..}) = do
      compile arg_expr
      return $ callArgs { callArgs_varPos = True }
   compileArg callArgs@(CallArgs {..}) (ArgVarArgsKeyword {..}) = do
      compile arg_expr
      return $ callArgs { callArgs_varKeyword = True }

-- XXX need to handle extended slices, slice expressions and ellipsis
compileSlices :: [SliceSpan] -> Compile ()
compileSlices [SliceProper {..}] = do
   case slice_lower of
      Nothing -> compileConstantEmit Blip.None
      Just expr -> compile expr
   case slice_upper of
      Nothing -> compileConstantEmit Blip.None
      Just expr -> compile expr
   case slice_stride of
      Nothing -> emitCodeArg BUILD_SLICE 2
      -- Not sure about this, maybe it is None
      Just Nothing -> emitCodeArg BUILD_SLICE 2
      Just (Just expr) -> do
         compile expr
         emitCodeArg BUILD_SLICE 3
compileSlices other = error $ "unsupported slice: " ++ show other

-- Return the opcode for a given assignment operator.
assignOpCode :: AssignOpSpan -> Opcode
assignOpCode assign = 
   case assign of
      PlusAssign {} -> INPLACE_ADD
      MinusAssign {} -> INPLACE_SUBTRACT
      MultAssign {} -> INPLACE_MULTIPLY
      DivAssign {} -> INPLACE_TRUE_DIVIDE
      ModAssign {} -> INPLACE_MODULO
      PowAssign {} -> INPLACE_POWER
      BinAndAssign {} -> INPLACE_AND
      BinOrAssign {} -> INPLACE_OR
      BinXorAssign {} -> INPLACE_XOR
      LeftShiftAssign {} -> INPLACE_LSHIFT
      RightShiftAssign {} -> INPLACE_RSHIFT
      FloorDivAssign {} -> INPLACE_FLOOR_DIVIDE

{-
isDot :: OpSpan -> Bool
isDot (Dot {}) = True
isDot _other = False
-}

isBoolean :: OpSpan -> Bool
isBoolean (And {}) = True
isBoolean (Or {}) = True
isBoolean _other = False

isComparison :: OpSpan -> Bool
isComparison (LessThan {}) = True
isComparison (GreaterThan {}) = True
isComparison (Equality {}) = True
isComparison (GreaterThanEquals {}) = True
isComparison (LessThanEquals {}) = True
isComparison (NotEquals  {}) = True
isComparison (In {}) = True
isComparison (NotIn {}) = True
isComparison (IsNot {}) = True
isComparison (Is {}) = True
isComparison _other = False

{-
compileDot :: ExprSpan -> Compile ()
compileDot (BinaryOp {..}) = do
   compile left_op_arg
   case right_op_arg of
      Var {..} -> do
         -- the right argument should be treated like name variable
         varInfo <- lookupNameVar $ ident_string var_ident
         emitCodeArg LOAD_ATTR varInfo 
      other -> error $ "right argument of dot operator not a variable:\n" ++ prettyText other
compileDot other =
   error $ "compileDot applied to an unexpected expression: " ++ prettyText other
-}

compileBoolOpExpr :: ExprSpan -> Compile ()
compileBoolOpExpr (BinaryOp {..}) = do
   endLabel <- newLabel
   compile left_op_arg
   case operator of
      And {..} -> emitCodeArg JUMP_IF_FALSE_OR_POP endLabel
      Or {..} ->  emitCodeArg JUMP_IF_TRUE_OR_POP endLabel
      other -> error $ "Unexpected boolean operator:\n" ++ prettyText other
   compile right_op_arg
   labelNextInstruction endLabel
compileBoolOpExpr other =
   error $ "compileBoolOpExpr applied to an unexpected expression: " ++ prettyText other

compileOp :: OpSpan -> Compile ()
compileOp operator =
   emitCodeNoArg $ case operator of
      BinaryOr {} -> BINARY_OR
      Xor {} -> BINARY_XOR
      BinaryAnd {} -> BINARY_AND
      ShiftLeft {} -> BINARY_LSHIFT
      ShiftRight {} -> BINARY_RSHIFT
      Exponent {} -> BINARY_POWER
      Multiply {} -> BINARY_MULTIPLY
      Plus {} -> BINARY_ADD
      Minus {} -> BINARY_SUBTRACT
      Divide {} -> BINARY_TRUE_DIVIDE
      FloorDivide {} -> BINARY_FLOOR_DIVIDE
      Modulo {} -> BINARY_MODULO
      _other -> error $ "Unexpected operator:\n" ++ prettyText operator

compileUnaryOp :: OpSpan -> Compile ()
compileUnaryOp operator =
   emitCodeNoArg $ case operator of
      Minus {} -> UNARY_NEGATIVE
      Plus {} -> UNARY_POSITIVE
      Not {} -> UNARY_NOT
      Invert {} -> UNARY_INVERT
      other ->  error $ "Unexpected unary operator: " ++ prettyText other

{-
from object.h

#define Py_LT 0
#define Py_LE 1
#define Py_EQ 2
#define Py_NE 3
#define Py_GT 4
#define Py_GE 5

and from opcode.h 

enum cmp_op {PyCmp_LT=Py_LT, PyCmp_LE=Py_LE, PyCmp_EQ=Py_EQ, PyCmp_NE=Py_NE, PyCmp_GT=Py_GT, PyCmp_GE=Py_GE,
             PyCmp_IN, PyCmp_NOT_IN, PyCmp_IS, PyCmp_IS_NOT, PyCmp_EXC_MATCH, PyCmp_BAD};
-}

{- Operator chaining:

   The parser treats comparison operators as left associative.

   So: w < x < y < z is parsed as

   (((w < x) < y) < z)

   We want to compile this to:

         [w]
         [x]
         DUP_TOP   # make a copy of the result of x
         ROT_THREE # put the copy of [x] to the bottom
         <
         JUMP_IF_FALSE_OR_POP cleanup
         [y]
         DUP_TOP   # make a copy of [y]
         ROT_THREE # put the copy of [y] to the bottom
         <
         JUMP_IF_FALSE_OR_POP cleanup
         [z]
         <
         JUMP_FORWARD end
   cleanup:
         ROT_TWO  # put the result of the last comparison on the bottom 
                  # and put the duplicated [y] on the top
         POP_TOP  # remove the duplicated [y] from the top
   end:
         # whatever code follows
-}

compileCompareOpExpr :: ExprSpan -> Compile ()
compileCompareOpExpr expr@(BinaryOp {}) =
   compileChain numOps chain
   where
   chain :: [ChainItem]
   chain = flattenComparisonChain [] expr
   numOps :: Int
   numOps = length chain `div` 2

   compileChain :: Int -> [ChainItem] -> Compile ()
   compileChain numOps (Comparator e1 : internal@(Operator op : Comparator e2 : _rest)) = do
      compile e1
      if numOps == 1
         then do
            compile e2
            emitCodeArg COMPARE_OP $ comparisonOpCode op
         else do
            cleanup <- newLabel
            (lastOp, lastArg) <- compileChainInternal cleanup internal 
            compile lastArg
            emitCodeArg COMPARE_OP $ comparisonOpCode lastOp
            end <- newLabel
            emitCodeArg JUMP_FORWARD end
            labelNextInstruction cleanup
            emitCodeNoArg ROT_TWO
            emitCodeNoArg POP_TOP
            labelNextInstruction end
   compileChain _numOps _items = error $ "bad operator chain: " ++ prettyText expr
   compileChainInternal :: Word16 -> [ChainItem] -> Compile (OpSpan, ExprSpan)
   compileChainInternal _cleanup [Operator op, Comparator exp] = return (op, exp)
   compileChainInternal cleanup (Operator op : Comparator e : rest) = do
      compile e
      emitCodeNoArg DUP_TOP
      emitCodeNoArg ROT_THREE
      emitCodeArg COMPARE_OP $ comparisonOpCode op
      emitCodeArg JUMP_IF_FALSE_OR_POP cleanup
      compileChainInternal cleanup rest
   compileChainInternal _cleanup _other = error $ "bad comparison chain: " ++ prettyText expr 
        
   comparisonOpCode :: OpSpan -> Word16
   comparisonOpCode (LessThan {}) = 0 
   comparisonOpCode (LessThanEquals {}) = 1
   comparisonOpCode (Equality {}) = 2 
   comparisonOpCode (NotEquals {}) = 3 
   comparisonOpCode (GreaterThan {}) = 4 
   comparisonOpCode (GreaterThanEquals {}) = 5 
   comparisonOpCode (In {}) = 6
   comparisonOpCode (NotIn {}) = 7
   comparisonOpCode (Is {}) = 8
   comparisonOpCode (IsNot {}) = 9
   -- XXX we don't appear to have an exact match operator in the AST
   comparisonOpCode operator = error $ "Unexpected comparison operator:\n" ++ prettyText operator
compileCompareOpExpr other = error $ "Unexpected comparison operator:\n" ++ prettyText other 

data ChainItem = Comparator ExprSpan | Operator OpSpan

flattenComparisonChain :: [ChainItem] -> ExprSpan -> [ChainItem] 
flattenComparisonChain acc opExpr@(BinaryOp {..}) 
   | isComparison operator
        = flattenComparisonChain newAcc left_op_arg
   | otherwise = [Comparator opExpr] ++ acc 
   where
   newAcc = [Operator operator, Comparator right_op_arg] ++ acc
flattenComparisonChain acc other = [Comparator other] ++ acc
 
-- Emit an instruction that returns the None contant.
returnNone :: Compile ()
returnNone = compileConstantEmit Blip.None >> emitCodeNoArg RETURN_VALUE

-- Print out the variable scope of the module if requested on the command line.
maybeDumpScope :: Compile ()
maybeDumpScope = 
   ifDump DumpScope $ do
      nestedScope <- getNestedScope
      liftIO $ putStrLn $ renderScope nestedScope

-- Print out the AST of the module if requested on the command line.
maybeDumpAST :: ModuleSpan -> Compile ()
maybeDumpAST ast = do
   ifDump DumpAST $ do
      liftIO $ putStrLn "Abstract Syntax Tree:"
      liftIO $ putStrLn $ show ast

{- 
   From Cpython: Objects/lnotab_notes.txt

Code objects store a field named co_lnotab.  This is an array of unsigned bytes
disguised as a Python string. It is used to map bytecode offsets to source code
line #s for tracebacks and to identify line number boundaries for line tracing.

The array is conceptually a compressed list of
    (bytecode offset increment, line number increment)
pairs.  The details are important and delicate, best illustrated by example:

    byte code offset    source code line number
        0                   1
        6                   2
       50                   7
      350                 307
      361                 308

Instead of storing these numbers literally, we compress the list by storing only
the increments from one row to the next.  Conceptually, the stored list might
look like:

    0, 1,  6, 1,  44, 5,  300, 300,  11, 1

The above doesn't really work, but it's a start. Note that an unsigned byte
can't hold negative values, or values larger than 255, and the above example
contains two such values. So we make two tweaks:  


 (a) there's a deep assumption that byte code offsets and their corresponding
 line #s both increase monotonically, and
 (b) if at least one column jumps by more than 255 from one row to the next,
 more than one pair is written to the table. In case #b, there's no way to know
 from looking at the table later how many were written.  That's the delicate
 part.  A user of co_lnotab desiring to find the source line number
 corresponding to a bytecode address A should do something like this

    lineno = addr = 0
    for addr_incr, line_incr in co_lnotab:
        addr += addr_incr
        if addr > A:
            return lineno
        lineno += line_incr

(In C, this is implemented by PyCode_Addr2Line().)  In order for this to work,
when the addr field increments by more than 255, the line # increment in each
pair generated must be 0 until the remaining addr increment is < 256.  So, in
the example above, assemble_lnotab in compile.c should not (as was actually done
until 2.2) expand 300, 300 to
    255, 255, 45, 45,
but to
    255, 0, 45, 255, 0, 45.
-}

-- Returns the bytestring representation of the compressed line number table
compileLineNumberTable :: Word32 -> Compile PyObject
compileLineNumberTable firstLineNumber = do
   offsetToLine <- reverse `fmap` getBlockState state_lineNumberTable
   let compressedTable = compress (0, firstLineNumber) offsetToLine 
       bs = B.pack $ concat 
               [ [fromIntegral offset, fromIntegral line] | 
                    (offset, line) <- compressedTable ]
   return Blip.String { string = bs }
   where
   compress :: (Word16, Word32) -> [(Word16, Word32)] -> [(Word16, Word32)]
   compress _prev [] = []
   compress (prevOffset, prevLine) (next@(nextOffset, nextLine):rest)
      -- make sure all increments are non-negative
      -- skipping any entries which are less than the predecessor
      | nextLine < prevLine || nextOffset < prevOffset =
           compress (prevOffset, prevLine) rest
      | otherwise = chunkDeltas (offsetDelta, lineDelta) ++ compress next rest
      where 
      offsetDelta = nextOffset - prevOffset
      lineDelta = nextLine - prevLine

-- both offsetDelta and lineDelta must be non-negative
chunkDeltas :: (Word16, Word32) -> [(Word16, Word32)]
chunkDeltas (offsetDelta, lineDelta)
   | offsetDelta < 256 =
      if lineDelta < 256
         then [(offsetDelta, lineDelta)]
         else (offsetDelta, 255) : chunkDeltas (0, lineDelta - 255)
   -- we must wait until offsetDelta is less than 256 before reducing lineDelta
   | otherwise = (255, 0) : chunkDeltas (offsetDelta - 255, lineDelta)
