GenInstances.hs

{-# LANGUAGE TemplateHaskellQuotes #-}

module C.Operator.GenInstances
  ( cExprInstances ) where

import Prelude hiding (Fractional (..), Integral (..), Num (..))
import Prelude qualified

import Control.Monad (guard)
import Data.Bits qualified as Bits
import Foreign.C.Types
import Language.Haskell.TH qualified as TH

import C.Type qualified as C

import C.Operator.Classes qualified as C
import C.Operator.Internal qualified as C
import C.Operator.TH

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

-- | All instances for arithmetic classes on standard types, for the given
-- 'C.Platform'.
cExprInstances :: C.Platform -> TH.Q [ TH.Dec ]
cExprInstances platform = do
  concat <$> sequence [

    ----------------------------------------------------------------------------
    -- Not, Logical

    do impl <- [| \ i -> if C.notNull i then 0 else 1 |]
       withInstanceProofs
         [ genUnaryInstances ''C.Not ( Left $ TH.ConT ''CInt ) ( C.unaryLogicalType platform )
           [ ClassMethod 'C.not "singNot" 1 impl ]
         ]
    ,

    do impl1 <- [| \ i j -> if C.notNull i Prelude.&& C.notNull j then 1 else 0 |]
       impl2 <- [| \ i j -> if C.notNull i Prelude.|| C.notNull j then 1 else 0 |]
       withInstanceProofs
         [ genBinaryInstances ''C.Logical ( Left $ TH.ConT ''CInt ) ( C.binaryLogicalType platform )
           [ ClassMethod '(C.&&) "singAnd" 2 impl1
           , ClassMethod '(C.||) "singOr"  2 impl2
           ]
         ]
    ,

    ----------------------------------------------------------------------------
    -- RelEq, RelOrd

    do impl1 <- [| \ a b -> if a Prelude.== b then 1 else 0 |]
       impl2 <- [| \ a b -> if a Prelude./= b then 1 else 0 |]
       withInstanceProofs
         [ genBinaryInstances ''C.RelEq ( Left $ TH.ConT ''CInt ) ( C.binaryEqType platform )
           [ ClassMethod '(C.==) "singEq"  2 impl1
           , ClassMethod '(C.!=) "singNEq" 2 impl2
           ]
         ]
    ,

    do impl1 <- [| \ a b -> if a Prelude.>  b then 1 else 0 |]
       impl2 <- [| \ a b -> if a Prelude.>= b then 1 else 0 |]
       impl3 <- [| \ a b -> if a Prelude.<  b then 1 else 0 |]
       impl4 <- [| \ a b -> if a Prelude.<= b then 1 else 0 |]
       withInstanceProofs
         [ genBinaryInstances ''C.RelOrd ( Left $ TH.ConT ''CInt ) ( C.binaryRelType platform )
           [ ClassMethod '(C.>)  "singGT" 2 impl1
           , ClassMethod '(C.>=) "singGTE" 2 impl2
           , ClassMethod '(C.<)  "singLT" 2 impl3
           , ClassMethod '(C.<=) "singLTE" 2 impl4
           ]
         ]
    ,

    ----------------------------------------------------------------------------
    -- Plus, Minus

    withInstanceProofs
      [ genUnaryInstances ''C.Plus ( withAssoc "PlusRes" "PlusResImpl" SameArgs )
        ( C.unaryPlusType platform )
        [ ClassMethod 'C.plus "singPlus" 1 ( TH.VarE 'Prelude.id ) ]
      ]
    ,

    genUnaryTyFam platform ( TH.mkName "PlusResImpl" ) C.unaryPlusType
    ,

    withInstanceProofs
      [ genUnaryInstances ''C.Minus ( withAssoc "MinusRes" "MinusResImpl" SameArgs )
        ( C.unaryMinusType platform )
        [ ClassMethod 'C.negate "singNegate" 1 ( TH.VarE 'Prelude.negate ) ]
      ]
    ,

    genUnaryTyFam platform ( TH.mkName "MinusResImpl" ) C.unaryMinusType
    ,

    ----------------------------------------------------------------------------
    -- Add, Sub, Mult, Div, Rem

    withInstanceProofs
      [ genBinaryInstances ''C.Add ( withAssoc "AddRes" "AddResImpl" SameArgs )
        ( C.binaryAddType platform )
        [ ClassMethod '(C.+) "singAdd" 2 ( TH.VarE '(Prelude.+) ) ]
      ]
    ,

    genBinaryTyFam platform ( TH.mkName "AddResImpl" ) C.binaryAddType
    ,

    withInstanceProofs
      [ genBinaryInstances ''C.Sub ( withAssoc "SubRes" "SubResImpl" SameArgs )
        ( C.binarySubType platform )
        [ ClassMethod '(C.-) "singSub" 2 ( TH.VarE '(Prelude.-) ) ]
      ]
    ,

    genBinaryTyFam platform ( TH.mkName "SubResImpl" ) C.binarySubType
    ,

    withInstanceProofs
      [ genBinaryInstances ''C.Mult ( withAssoc "MultRes" "MultResImpl" SameArgs )
        ( C.binaryMultiplicativeType platform )
        [ ClassMethod '(C.*) "singMult" 2 ( TH.VarE '(Prelude.*) ) ]
      ]
    ,

    genBinaryTyFam platform ( TH.mkName "MultResImpl" ) C.binaryMultiplicativeType
    ,

    -- NB: this is the key usage of 'withInstanceProofs' with a non-singleton list
    withInstanceProofs
        -- division for integral types
      [ genBinaryInstances ''C.Div ( withAssoc "DivRes" "MultResImpl" SameArgs ) -- NB: re-use 'MultResImpl'
          ( \ a b ->
            do op@( resTy, _ ) <- C.integralBinaryType platform a b
               guard ( case resTy of C.Arithmetic ( C.FloatLike {} ) -> False; _ -> True )
               return op
          )
          [ ClassMethod '(C./) "singDiv" 2 ( TH.VarE 'Prelude.div ) ]
        -- division for floating-point types
      , genBinaryInstances ''C.Div ( withAssoc "DivRes" "MultResImpl" SameArgs ) -- NB: re-use 'MultResImpl'
          ( \ a b ->
            do op@( resTy, _ ) <- C.binaryMultiplicativeType platform a b
               guard ( case resTy of C.Arithmetic ( C.FloatLike {} ) -> True; _ -> False )
               return op
          )
          [ ClassMethod '(C./) "singDiv" 2 ( TH.VarE '(Prelude./) ) ]
      ]
    ,

    withInstanceProofs
      [ genBinaryInstances ''C.Rem ( withAssoc "RemRes" "BinResImpl" SameArgs ) -- NB: use 'BinResImpl'
        ( C.integralBinaryType platform )
        [ ClassMethod '(C.%) "singRem" 2 ( TH.VarE 'Prelude.rem ) ]
      ]
    ,

    genBinaryTyFam platform ( TH.mkName "BinResImpl" ) C.integralBinaryType
    ,

    ----------------------------------------------------------------------------
    -- Complement, Bitwise, Shift

    withInstanceProofs
      [ genUnaryInstances ''C.Complement ( withAssoc "ComplementRes" "ComplementResImpl" SameArgs )
        ( C.integralUnaryType platform )
        [ ClassMethod '(C..~) "singComplement" 1 ( TH.VarE 'Bits.complement ) ]
      ]
    ,

    genUnaryTyFam platform ( TH.mkName "ComplementResImpl" ) C.integralUnaryType
    ,

    withInstanceProofs
      [ genBinaryInstances ''C.Bitwise ( withAssoc "BitsRes" "BinResImpl" SameArgs ) -- NB: use 'BinResImpl'
        ( C.integralBinaryType platform )
          [ ClassMethod '(C..&.) "singBitAnd" 2 ( TH.VarE '(Bits..&.) )
          , ClassMethod '(C..|.) "singBitOr" 2 ( TH.VarE '(Bits..|.) )
          , ClassMethod '(C..^.) "singBitXor" 2 ( TH.VarE 'Bits.xor )
          ]
      ]
    ,

    do impl1 <- [| \ a i -> Bits.shiftL a ( Prelude.fromIntegral i ) |]
       impl2 <- [| \ a i -> Bits.shiftR a ( Prelude.fromIntegral i ) |]
       withInstanceProofs
         [ genBinaryInstances ''C.Shift ( withAssoc "ShiftRes" "ShiftResImpl" FirstArgOnly )
              -- NB: use 'FirstArgOnly', because the result type only depends on the
              -- first argument.
             ( C.shiftType platform )
             [ ClassMethod '(C.<<) "singShiftL" 2 impl1
             , ClassMethod '(C.>>) "singShiftR" 2 impl2
             ]
         ]
    ,

    genUnaryTyFam platform ( TH.mkName "ShiftResImpl" ) $
      -- The associated type family for Shift is unary, as the result type
      -- only depends on the shiftee type, not the type of the shift amount,
      -- which undergoes an independent arithmetic promotion.
      \ plat ty -> C.shiftType plat ty ( C.Arithmetic $ C.Integral $ C.IntLike $ C.Int C.Signed )


    ]

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

-- | Utility function to construct a 'C.Operator.TH.AssocTyFam' argument to pass
-- to 'genUnaryInstances' or 'genBinaryInstances'.
withAssoc :: String -> String -> AssocTyFamArgs -> Either TH.Type AssocTyFam
withAssoc famName implName args =
  Right $
    AssocTyFam
      { assocTyFamName     = TH.mkName famName
      , assocTyFamImplName = TH.mkName implName
      , assocTyFamArgs     = args
      }