berp-0.0.2: src/Berp/Compile/Compile.hs
{-# 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.PrettyAST ()
import Language.Python.Common.Pretty (prettyText)
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 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 = unsupported $ prettyText other
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 $ prettyText 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 $ prettyText 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 $ unwords [prettyText e1, "=", prettyText 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