RationalsBuiltin.hs

{-# LANGUAGE OverloadedStrings #-}

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

import Funcons.EDSL
import Funcons.Types
import Funcons.Core.Values.Primitive.BoolBuiltin

library = libFromList [
        ("is-less", ValueOp is_less_op)
    ,   ("is-less-or-equal", ValueOp is_less_or_equal_op)
    ,   ("is-greater", ValueOp is_greater_op)
    ,   ("is-greater-or-equal", ValueOp is_greater_or_equal_op)
    ,   ("rational-to-ieee-float", ValueOp stepRational_To_IEEE_Float)
    ,   ("add", ValueOp add_op)
    ]

is_less_ = applyFuncon "is-less" 
is_less_op [vx, vy]
    | (Rational x, Rational y) <- (upcastRationals vx, upcastRationals vy)
        = rewriteTo $ FValue $ tobool (x < y)
is_less_op vs = sortErr (is_less_ (fvalues vs)) "is-less not applied to rationals"

is_less_or_equal_ = FApp "is-less-or-equal" . FTuple
is_less_or_equal_op [vx, vy]
    | (Rational x, Rational y) <- (upcastRationals vx, upcastRationals vy)
        = rewriteTo $ FValue $ tobool (x <= y) 
is_less_or_equal_op vs = sortErr (is_less_or_equal_ (fvalues vs)) 
                            "is_less_or_equal not applied to two arguments"

is_greater_ = FApp "is-greater" . FTuple
is_greater_op [vx, vy]
    | (Rational x, Rational y) <- (upcastRationals vx, upcastRationals vy)
        = rewriteTo $ FValue $ tobool (x > y) 
is_greater_op vs = sortErr (is_greater_ (fvalues vs)) "is-greater not applied to two arguments"

is_greater_or_equal_ = FApp "is-greater-or-equal" . FTuple
is_greater_or_equal_op [vx, vy]
    | (Rational x, Rational y) <- (upcastRationals vx, upcastRationals vy)
        = rewriteTo $ FValue $ tobool (x >= y) 
is_greater_or_equal_op vs = sortErr (is_greater_or_equal_ (fvalues vs)) 
                            "is-greater-or-equal not applied to rationals"

stepRational_To_IEEE_Float [f, vn]
  |  Rational r <- upcastRationals vn = rewriteTo $ FValue $ IEEE_Float_64 (fromRational r)
stepRational_To_IEEE_Float vs = sortErr (applyFuncon "rational-to-ieee-float" (fvalues vs)) 
                                    "rational-to-ieee-float not applied to a rational"

rational_op:: String -> ([Funcons] -> Funcons)
                   -> (Rational -> Rational -> Rational) 
                    -> Rational -> [Values] -> Rewrite Rewritten
rational_op str cons f b vs | all isRat vs = rewriteTo $ rational_ $ foldr f b $ map toRat vs
                            | otherwise = sortErr (cons (fvalues vs)) err
    where   isRat v | Rational _ <- upcastRationals v = True
                    | otherwise = False
            toRat v | Rational r <- upcastRationals v = r
                    | otherwise = error err
            err     = str ++ " not applied to rationals"


add = applyFuncon "add"
add_op = rational_op "add" add (+) 0