content: {-# LANGUAGE TemplateHaskellQuotes #-}
  
  module C.Operator.GenInstances
    ( cExprInstances ) where
  
  -- base
  import Prelude
    hiding ( Num(..), Fractional(..), Integral(..) )
  import Prelude qualified
  import Control.Monad
    ( guard )
  import Data.Bits qualified as Bits
  import Foreign.C.Types
  
  -- template-haskell
  import Language.Haskell.TH qualified as TH
  
  -- c-expr
  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 '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
        }
  