module IPrims(doPrimOp) where

import Error(internalError, ErrMsg)
import PPrint(ppReadable)
import Position
import IntLit
import ISyntax
import ISyntaxUtil(iMkLitSizeAt, iMkBoolAt, iMkLitAt, iMkRealLitAt,
                   iMkPairAt, iMkTripleAt, iMkStringAt, iMkList,
                   itInteger, itBit1, itReal, itList)
import Prim

-- ---------------

-- This returns a Maybe for two reasons:
-- (1) The check for whether the arguments are known constants is inside
--     doPrimOp.  And so we have to return Maybe in the case that the
--     arguments are not known.
-- (2) ITransform's "iTrAp" calls this without any guard as to whether
--     the operator is one that should be handled
--     XXX perhaps it needs no guard, but that investigation needs to be done
--
-- If these two issues can be resolved, then we can remove the Maybe
-- and internal error on any conditions which are not expected.

doPrimOp :: Position -> PrimOp -> [IType] -> [IExpr a] ->
            Maybe (Either ErrMsg (IExpr a))
doPrimOp pos op ts es =
  let isLit e = isIConInt e || isIConReal e
      mkPrimArg (ICon _ (ICInt { iVal = IntLit { ilValue = v } })) = I v
      mkPrimArg (ICon _ (ICReal { iReal = v })) = D v
      mkPrimArg e = internalError ("mkPrimArg: " ++ ppReadable e)
  in  if (all isLit es)
      then let tints = [ i | ITNum i <- ts]
               eints = map mkPrimArg es
           in  doPrimOp' pos op tints eints
      else Nothing

-- ---------------

use :: (a -> b) -> (Maybe (Either ErrMsg a)) -> (Maybe (Either ErrMsg b))
use fn (Just (Right x)) = Just (Right (fn x))
use _  (Just (Left x))  = Just (Left x)
use _  Nothing          = Nothing

-- This does primResult to compute the value and then applies the right literal
-- creation function to produce the IExpr for each primitive result.
doPrimOp' :: Position -> PrimOp -> [Integer] -> [PrimArg] ->
             Maybe (Either ErrMsg (IExpr a))
doPrimOp' pos op@PrimAdd  ss@[s]     vs = use (iMkLitSizeAt pos s) (primResult op ss vs)
doPrimOp' pos op@PrimSub  ss@[s]     vs = use (iMkLitSizeAt pos s) (primResult op ss vs)
doPrimOp' pos op@PrimMul  ss@[_,_,s] vs = use (iMkLitSizeAt pos s) (primResult op ss vs)
doPrimOp' pos op@PrimQuot ss@[s,_]   vs = use (iMkLitSizeAt pos s) (primResult op ss vs)
doPrimOp' pos op@PrimRem  ss@[_,s]   vs = use (iMkLitSizeAt pos s) (primResult op ss vs)
doPrimOp' pos op@PrimAnd  ss@[s]     vs = use (iMkLitSizeAt pos s) (primResult op ss vs)
doPrimOp' pos op@PrimOr   ss@[s]     vs = use (iMkLitSizeAt pos s) (primResult op ss vs)
doPrimOp' pos op@PrimXor  ss@[s]     vs = use (iMkLitSizeAt pos s) (primResult op ss vs)
doPrimOp' pos op@PrimSL   ss@[s,_]   vs = use (iMkLitSizeAt pos s) (primResult op ss vs)
doPrimOp' pos op@PrimSRL  ss@[s,_]   vs = use (iMkLitSizeAt pos s) (primResult op ss vs)
doPrimOp' pos op@PrimSRA  ss@[s,_]   vs = use (iMkLitSizeAt pos s) (primResult op ss vs)
doPrimOp' pos op@PrimNeg  ss@[s]     vs = use (iMkLitSizeAt pos s) (primResult op ss vs)
doPrimOp' pos op@PrimInv  ss@[s]     vs = use (iMkLitSizeAt pos s) (primResult op ss vs)

doPrimOp' pos op@PrimEQ  ss vs = use (iMkBoolAt pos) (primResult op ss vs)
doPrimOp' pos op@PrimEQ3 ss vs = use (iMkBoolAt pos) (primResult op ss vs)
doPrimOp' pos op@PrimULE ss vs = use (iMkBoolAt pos) (primResult op ss vs)
doPrimOp' pos op@PrimULT ss vs = use (iMkBoolAt pos) (primResult op ss vs)
doPrimOp' pos op@PrimSLE ss vs = use (iMkBoolAt pos) (primResult op ss vs)
doPrimOp' pos op@PrimSLT ss vs = use (iMkBoolAt pos) (primResult op ss vs)

--doPrimOp' pos op@PrimZeroExt ss@[_,_,s] vs = use (iMkLitSizeAt pos s) (primResult op ss vs)
doPrimOp' pos op@PrimSignExt ss@[_,_,s] vs = use (iMkLitSizeAt pos s) (primResult op ss vs)
--doPrimOp' pos op@PrimTrunc ss@[_,s,_] vs = use (iMkLitSizeAt pos s) (primResult op ss vs)

doPrimOp' pos op@PrimRange ss@[s] vs = use (iMkLitSizeAt pos s) (primResult op ss vs)
doPrimOp' pos op@PrimExtract ss@[_,_,s] vs = use (iMkLitSizeAt pos s) (primResult op ss vs)
doPrimOp' pos op@PrimConcat ss@[_,_,s] vs = use (iMkLitSizeAt pos s) (primResult op ss vs)
--doPrimOp' pos PrimSplit _ _ =

doPrimOp' pos op@PrimBNot ss vs = use (iMkBoolAt pos) (primResult op ss vs)
doPrimOp' pos op@PrimBAnd ss vs = use (iMkBoolAt pos) (primResult op ss vs)
doPrimOp' pos op@PrimBOr  ss vs = use (iMkBoolAt pos) (primResult op ss vs)

doPrimOp' pos op@PrimIf ss@[s] vs = use (iMkLitSizeAt pos s) (primResult op ss vs)

doPrimOp' pos op@PrimSelect ss@[s,_,_] vs = use (iMkLitSizeAt pos s) (primResult op ss vs)

doPrimOp' pos op@PrimIntegerToBit ss@[s] vs = use (iMkLitSizeAt pos s) (primResult op ss vs)
doPrimOp' pos op@PrimBitToInteger ss vs = use (iMkLitAt pos itInteger) (primResult op ss vs)

doPrimOp' pos op@PrimIntegerAdd ss vs = use (iMkLitAt pos itInteger) (primResult op ss vs)
doPrimOp' pos op@PrimIntegerSub ss vs = use (iMkLitAt pos itInteger) (primResult op ss vs)
doPrimOp' pos op@PrimIntegerNeg ss vs = use (iMkLitAt pos itInteger) (primResult op ss vs)
doPrimOp' pos op@PrimIntegerMul ss vs = use (iMkLitAt pos itInteger) (primResult op ss vs)
doPrimOp' pos op@PrimIntegerDiv ss vs = use (iMkLitAt pos itInteger) (primResult op ss vs)
doPrimOp' pos op@PrimIntegerMod ss vs = use (iMkLitAt pos itInteger) (primResult op ss vs)
doPrimOp' pos op@PrimIntegerQuot ss vs = use (iMkLitAt pos itInteger) (primResult op ss vs)
doPrimOp' pos op@PrimIntegerRem ss vs = use (iMkLitAt pos itInteger) (primResult op ss vs)
doPrimOp' pos op@PrimIntegerExp ss vs = use (iMkLitAt pos itInteger) (primResult op ss vs)
doPrimOp' pos op@PrimIntegerLog2 ss vs = use (iMkLitAt pos itInteger) (primResult op ss vs)

doPrimOp' pos op@PrimIntegerEQ ss vs = use (iMkBoolAt pos) (primResult op ss vs)
doPrimOp' pos op@PrimIntegerLE ss vs = use (iMkBoolAt pos) (primResult op ss vs)
doPrimOp' pos op@PrimIntegerLT ss vs = use (iMkBoolAt pos) (primResult op ss vs)


doPrimOp' pos op@PrimIntegerToReal ss vs = use (iMkRealLitAt pos) (primResult op ss vs)
doPrimOp' pos op@PrimBitsToReal    ss vs = use (iMkRealLitAt pos) (primResult op ss vs)

doPrimOp' pos op@PrimRealEQ ss vs = use (iMkBoolAt pos) (primResult op ss vs)
doPrimOp' pos op@PrimRealLE ss vs = use (iMkBoolAt pos) (primResult op ss vs)
doPrimOp' pos op@PrimRealLT ss vs = use (iMkBoolAt pos) (primResult op ss vs)

doPrimOp' pos op@PrimRealToString ss vs = use (iMkStringAt pos) (primResult op ss vs)

doPrimOp' pos op@PrimRealAdd     ss vs = use (iMkRealLitAt pos) (primResult op ss vs)
doPrimOp' pos op@PrimRealSub     ss vs = use (iMkRealLitAt pos) (primResult op ss vs)
doPrimOp' pos op@PrimRealNeg     ss vs = use (iMkRealLitAt pos) (primResult op ss vs)
doPrimOp' pos op@PrimRealMul     ss vs = use (iMkRealLitAt pos) (primResult op ss vs)
doPrimOp' pos op@PrimRealDiv     ss vs = use (iMkRealLitAt pos) (primResult op ss vs)
doPrimOp' pos op@PrimRealAbs     ss vs = use (iMkRealLitAt pos) (primResult op ss vs)
doPrimOp' pos op@PrimRealSignum  ss vs = use (iMkRealLitAt pos) (primResult op ss vs)
doPrimOp' pos op@PrimRealExpE    ss vs = use (iMkRealLitAt pos) (primResult op ss vs)
doPrimOp' pos op@PrimRealPow     ss vs = use (iMkRealLitAt pos) (primResult op ss vs)
doPrimOp' pos op@PrimRealLogE    ss vs = use (iMkRealLitAt pos) (primResult op ss vs)
doPrimOp' pos op@PrimRealLogBase ss vs = use (iMkRealLitAt pos) (primResult op ss vs)
doPrimOp' pos op@PrimRealLog2    ss vs = use (iMkRealLitAt pos) (primResult op ss vs)
doPrimOp' pos op@PrimRealLog10   ss vs = use (iMkRealLitAt pos) (primResult op ss vs)
doPrimOp' pos op@PrimRealSqrt    ss vs = use (iMkRealLitAt pos) (primResult op ss vs)

doPrimOp' pos op@PrimRealToBits ss vs = use (iMkLitSizeAt pos 64) (primResult op ss vs)

doPrimOp' pos op@PrimRealSin   ss vs = use (iMkRealLitAt pos) (primResult op ss vs)
doPrimOp' pos op@PrimRealCos   ss vs = use (iMkRealLitAt pos) (primResult op ss vs)
doPrimOp' pos op@PrimRealTan   ss vs = use (iMkRealLitAt pos) (primResult op ss vs)
doPrimOp' pos op@PrimRealSinH  ss vs = use (iMkRealLitAt pos) (primResult op ss vs)
doPrimOp' pos op@PrimRealCosH  ss vs = use (iMkRealLitAt pos) (primResult op ss vs)
doPrimOp' pos op@PrimRealTanH  ss vs = use (iMkRealLitAt pos) (primResult op ss vs)
doPrimOp' pos op@PrimRealASin  ss vs = use (iMkRealLitAt pos) (primResult op ss vs)
doPrimOp' pos op@PrimRealACos  ss vs = use (iMkRealLitAt pos) (primResult op ss vs)
doPrimOp' pos op@PrimRealATan  ss vs = use (iMkRealLitAt pos) (primResult op ss vs)
doPrimOp' pos op@PrimRealASinH ss vs = use (iMkRealLitAt pos) (primResult op ss vs)
doPrimOp' pos op@PrimRealACosH ss vs = use (iMkRealLitAt pos) (primResult op ss vs)
doPrimOp' pos op@PrimRealATanH ss vs = use (iMkRealLitAt pos) (primResult op ss vs)
doPrimOp' pos op@PrimRealATan2 ss vs = use (iMkRealLitAt pos) (primResult op ss vs)

doPrimOp' pos op@PrimRealTrunc ss vs = use (iMkLitAt pos itInteger) (primResult op ss vs)
doPrimOp' pos op@PrimRealCeil  ss vs = use (iMkLitAt pos itInteger) (primResult op ss vs)
doPrimOp' pos op@PrimRealFloor ss vs = use (iMkLitAt pos itInteger) (primResult op ss vs)
doPrimOp' pos op@PrimRealRound ss vs = use (iMkLitAt pos itInteger) (primResult op ss vs)

doPrimOp' pos op@PrimSplitReal ss vs = use mk_pair (primResult op ss vs)
    where mk_pair (whole,fraction) =
              let w = iMkLitAt pos itInteger whole
                  f = iMkRealLitAt pos fraction
              in  iMkPairAt pos itInteger itReal w f

doPrimOp' pos op@PrimDecodeReal ss vs = use mk_triple (primResult op ss vs)
    where mk_triple (is_pos, mantissa, exponent) =
              let s = iMkBoolAt pos is_pos
                  m = iMkLitAt pos itInteger mantissa
                  e = iMkLitAt pos itInteger exponent
              in  iMkTripleAt pos itBit1 itInteger itInteger s m e

doPrimOp' pos op@PrimRealToDigits ss vs = use mk_pair (primResult op ss vs)
    where mk_pair (digits, exponent) =
              let ds = iMkList itInteger (map (iMkLitAt pos itInteger) digits)
                  e = iMkLitAt pos itInteger exponent
              in  iMkPairAt pos (itList itInteger) itInteger ds e

doPrimOp' pos op@PrimRealIsInfinite ss vs = use (iMkBoolAt pos) (primResult op ss vs)
doPrimOp' pos op@PrimRealIsNegativeZero ss vs = use (iMkBoolAt pos) (primResult op ss vs)

-- The rest are presumably here to allow replacing of the default "Nothing"
-- with a trace or error, for debugging, without triggering these prims:

doPrimOp' pos PrimChr _ _ = Nothing
--doPrimOp' pos PrimOrd _ _ =

doPrimOp' pos PrimNoRules ts es = internalError ("primNoRules " ++ ppReadable (ts, es))
doPrimOp' pos PrimNoActions ts es = internalError ("primNoActions " ++ ppReadable (ts ,es))

--doPrimOp' pos PrimError _ _ =

-- other prims may be called by ITransform, but we don't know how to "do" them
doPrimOp' _ op _ _ = Nothing
-- doPrimOp' p ts es = internalError ("doPrimOp' " ++ ppReadable (p, ts, es))