Integers.hs

{-# LANGUAGE OverloadedStrings #-}

module Funcons.Core.Values.Primitive.Numbers.Integers where

import Funcons.EDSL
import Funcons.Types

library = libFromList [
        ("integer-add", ValueOp integer_add_op)
    ,   ("integer-multiply", ValueOp integer_multiply_op)
    ,   ("integer-divide", ValueOp integer_divide_op)
    ,   ("integer-subtract", ValueOp integer_subtract_op)
    ,   ("integer-power", ValueOp integer_power_op)
--    ,   ("integer-negate", ValueOp stepInteger_Negate)
    ,   ("integer-list", ValueOp stepInteger_List)
    ,   ("integer-modulo", ValueOp stepInteger_Modulo)
    ,   ("integer-absolute-value", ValueOp stepInteger_Absolute_Value) 
    ]

integer_op :: String -> ([Funcons] -> Funcons)
                     -> (Integer -> Integer -> Integer) 
                     -> Integer -> [Values] -> Rewrite Rewritten 
integer_op str cons f b vs | all isInt vs = 
    rewriteTo $ int_ $ fromInteger $ foldr f b $ map toInt vs
                           | otherwise = sortErr (cons (map FValue vs)) err
    where   isInt v | Int _ <- upcastIntegers v = True
                    | otherwise = False
            toInt v | Int i <- upcastIntegers v = i
                    | otherwise = error err
            err     = str ++ " not applied to integers"

integer_add_ = FApp "integer-add" . FTuple

integer_add_op vs = integer_op "integer-add" integer_add_ (+) 0 vs

integer_multiply_ = FApp "integer-multiple" . FTuple
integer_multiply_op vs = integer_op "integer-multiply" integer_multiply_ (*) 1 vs

integer_divide_ = FApp "integer-divide" . FTuple
integer_divide_op [vx,vy]
    | (Int x,Int y) <- (upcastIntegers vx, upcastIntegers vy) = 
        rewriteTo $ int_ $ fromInteger (x `div` y)
    | True = sortErr (integer_divide_ [FValue vx, FValue vy]) "integer-divide not applied to ints" 
integer_divide_op vx = sortErr (integer_divide_ (fvalues vx)) "integer-divide not applied to two arguments" 

integer_subtract = applyFuncon "integer-subtract"
integer_subtract_op [vx,vy]
    | (Int x, Int y) <- (upcastIntegers vx, upcastIntegers vy)= 
        rewriteTo $ int_ $ fromInteger (x - y)
    | otherwise = sortErr (applyFuncon "integer-subtract" [FValue vx, FValue vy])
                            "integer-subtract not applied to ints"
integer_subtract_op v = sortErr (applyFuncon "integer-subtract" (fvalues v)) "integer-subtract should receive two integers"

integer_power = applyFuncon "integer-power"
integer_power_op [vx, vy]
    | (Int x, Int y) <- (upcastIntegers vx, upcastIntegers vy) = 
        rewriteTo $ int_ $ fromInteger $(x ^ y)
integer_power_op vx = sortErr (applyFuncon "integer-power" (fvalues vx))
                            "integer-power not applied to two integers"

integer_negate = applyFuncon "integer-negate"
stepInteger_Negate [v]
    | (Int i) <- upcastIntegers v = rewriteTo $ int_ (- (fromInteger i))
stepInteger_Negate vs = sortErr (integer_negate (fvalues vs)) "integer-negate not applied to an integer"

integer_list = applyFuncon "integer-list"
stepInteger_List [vi1,vi2]
    | (Int i1, Int i2) <- (upcastIntegers vi1, upcastIntegers vi2)
            = rewriteTo $ FValue $ List (map mk_integers [i1.. i2])
stepInteger_List vs = sortErr (integer_list (fvalues vs)) "sort check: integer-list(I,J)"

integer_modulo = applyFuncon "integer-modulo"
stepInteger_Modulo [i1,i2] = integer_modulo_op i1 i2
stepInteger_Modulo vs = sortErr (integer_modulo (fvalues vs)) 
                            "sort check: integer-modulo(I1,I2)"
integer_modulo_op vx vy
    | (Int x,Int y) <- (upcastIntegers vx, upcastIntegers vy)= 
        rewriteTo $ int_ $ fromInteger (x `mod` y)
integer_modulo_op vx vy = sortErr (integer_modulo [FValue vx, FValue vy])
                         "integer-modulo not applied to ints"

integer_absolute_value = applyFuncon "integer-absolute-value"
stepInteger_Absolute_Value [v]
        | Int  i <- upcastIntegers v = rewriteTo $ FValue $ mk_integers (Prelude.abs i)
stepInteger_Absolute_Value vs = sortErr (integer_absolute_value $ fvalues vs) 
                                    "sort check: integer-absolute-value(I1)"