{-# LANGUAGE OverloadedStrings #-}
module Language.Del.Ops (loadOps) where
import Language.Del.AST
import Language.Del.AstUtils
import Language.Del.CompileDefs
loadOpsExpr :: Expr -> Artifact Expr
loadOpsExpr e@(Apply hd rest) =
case hd of
Id "+" -> return $ Add rest
Id "*" -> return $ Mul rest
Id "-" -> createSub rest
Id "/" -> binop "/" Div
Id "^" -> binop "^" Pow
Id "<" -> binop "<" Lt
Id ">" -> binop ">" Gt
Id "<=" -> binop "<=" LtE
Id ">=" -> binop ">=" GtE
Id "if" -> createIf rest
Id "$" -> createNative rest
_ -> return e
where binop opname ctor =
if length rest == 2
then return $ ctor (rest !! 0) (rest !! 1)
else Failure $ BadArity opname 2 (length rest)
createSub exprs =
case exprs of
[x] -> return $ Negate x
[x, y] -> return $ Sub x y
_ -> Failure $ BadArity "-" 2 (length exprs)
createIf exprs =
if length exprs == 3
then return $ If (rest !! 0) (rest !! 1) (rest !! 2)
else Failure $ BadArity "if" 3 (length exprs)
createNative exprs =
case exprs of
[] -> Failure $ BadArity "$" 1 (length exprs)
(name:args) ->
case name of
Id n -> return $ NativeCall n args
_ -> Failure $ BadNativeName name e
loadOpsExpr e = return e
loadOpsDef :: Def -> Artifact Def
loadOpsDef (Def n ret a b) = mapexprM loadOpsExpr b >>= return . Def n ret a
loadOps :: AST -> Artifact AST
loadOps = mapastM loadOpsDef