{-|
  Copyright   :  (C) 2013-2016, University of Twente,
                     2016-2017, Myrtle Software Ltd,
                     2017-2022, Google Inc.,
                     2017-2026, QBayLogic B.V.
  License     :  BSD2 (see the file LICENSE)
  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>
-}

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}

{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

module Clash.GHC.Evaluator.Primitives.GHC.Internal.Float
  ( primitives
  ) where

import           Data.Proxy          (Proxy)
import           Data.Reflection     (reifyNat)
import           Data.Text           (Text)
import           Data.Text.Extra     (showt)
import           GHC.Float
import           GHC.TypeLits        (KnownNat)
import           Data.Bifunctor      (first)

import           Clash.Core.Evaluator.Types
import           Clash.Core.Literal  (Literal (..))
import Clash.Core.Name (Name (..))
import Clash.Core.Term (Term (..), mkApps)
import Clash.Core.Type (Type (..), LitTy (..), TypeView (..), splitFunForallTy, tyView)
import Clash.Core.TyCon (tyConDataCons)
import qualified Clash.Data.UniqMap as UniqMap

import Clash.Sized.Internal.Signed   (Signed   (..))

import Clash.GHC.Evaluator.Primitive.Util

primitives :: [(Text, PrimStep)]
primitives :: [(Text, PrimStep)]
primitives =
  [ Text -> (PrimStepContext -> Maybe Machine) -> (Text, PrimStep)
primStepEntry Text
"GHC.Internal.Float.$wproperFractionDouble" ((PrimStepContext -> Maybe Machine) -> (Text, PrimStep))
-> (PrimStepContext -> Maybe Machine) -> (Text, PrimStep)
forall a b. (a -> b) -> a -> b
$ \case
      PrimStepContext{Bool
[Type]
[Value]
Type
TyConMap
Machine
PrimInfo
Term -> Maybe Machine
Term -> Term
Type
-> Integer -> Integer -> (Natural -> Natural -> Natural) -> Term
Type -> Integer -> (Natural -> Natural) -> Term
Type -> [Integer] -> ([Natural] -> Term) -> Term
Machine -> Term -> Maybe Machine
tcm :: TyConMap
isSubj :: Bool
pInfo :: PrimInfo
tys :: [Type]
args :: [Value]
mach :: Machine
ty :: Type
checkNaturalRange1 :: Type -> Integer -> (Natural -> Natural) -> Term
checkNaturalRange2 :: Type
-> Integer -> Integer -> (Natural -> Natural -> Natural) -> Term
checkNaturalRange :: Type -> [Integer] -> ([Natural] -> Term) -> Term
reduce :: Term -> Maybe Machine
reduceWith :: Machine -> Term -> Maybe Machine
reduceWHNF :: Term -> Maybe Machine
reduceWHNF' :: Machine -> Term -> Maybe Machine
catchDivByZero :: Term -> Term
catchErrorCall :: Term -> Term
tcm :: PrimStepContext -> TyConMap
isSubj :: PrimStepContext -> Bool
pInfo :: PrimStepContext -> PrimInfo
tys :: PrimStepContext -> [Type]
args :: PrimStepContext -> [Value]
mach :: PrimStepContext -> Machine
ty :: PrimStepContext -> Type
checkNaturalRange1 :: PrimStepContext -> Type -> Integer -> (Natural -> Natural) -> Term
checkNaturalRange2 :: PrimStepContext
-> Type
-> Integer
-> Integer
-> (Natural -> Natural -> Natural)
-> Term
checkNaturalRange :: PrimStepContext -> Type -> [Integer] -> ([Natural] -> Term) -> Term
reduce :: PrimStepContext -> Term -> Maybe Machine
reduceWith :: PrimStepContext -> Machine -> Term -> Maybe Machine
reduceWHNF :: PrimStepContext -> Term -> Maybe Machine
reduceWHNF' :: PrimStepContext -> Machine -> Term -> Maybe Machine
catchDivByZero :: PrimStepContext -> Term -> Term
catchErrorCall :: PrimStepContext -> Term -> Term
..}
        | Value
_ : Lit (DoubleLiteral Word64
d) : [Value]
_ <- [Value]
args
        , [sty :: Type
sty@(Type -> TypeView
tyView -> TyConApp TyConName
signedTcNm [nTy :: Type
nTy@(LitTy (NumTy Integer
kn))])] <- [Type]
tys
        , TyConName -> Text
forall a. Name a -> Text
nameOcc TyConName
signedTcNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Text
forall a. Show a => a -> Text
showt ''Clash.Sized.Internal.Signed.Signed
        , ([Either TyVar Type]
_, Type -> TypeView
tyView -> TyConApp TyConName
tupTcNm [Type]
tyArgs) <- Type -> ([Either TyVar Type], Type)
splitFunForallTy Type
ty
        , Just TyCon
tupTc <- TyConName -> TyConMap -> Maybe TyCon
forall a b. Uniquable a => a -> UniqMap b -> Maybe b
UniqMap.lookup TyConName
tupTcNm TyConMap
tcm
        , [DataCon
tupDc] <- TyCon -> [DataCon]
tyConDataCons TyCon
tupTc
        -> let (Integer
sn, Double
d1) = Integer
-> (forall (n :: Natural).
    KnownNat n =>
    Proxy n -> (Integer, Double))
-> (Integer, Double)
forall r.
Integer -> (forall (n :: Natural). KnownNat n => Proxy n -> r) -> r
reifyNat Integer
kn (\Proxy n
p -> (Signed n -> Integer) -> (Signed n, Double) -> (Integer, Double)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: Type -> Type -> Type) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Signed n -> Integer
forall a. Integral a => a -> Integer
toInteger (Proxy n -> Double -> (Signed n, Double)
forall (n :: Natural).
KnownNat n =>
Proxy n -> Double -> (Signed n, Double)
op Proxy n
p (Word64 -> Double
castWord64ToDouble Word64
d)))
               ret :: Term
ret = Term -> [Either Term Type] -> Term
mkApps (DataCon -> Term
Data DataCon
tupDc) ((Type -> Either Term Type) -> [Type] -> [Either Term Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Either Term Type
forall a b. b -> Either a b
Right [Type]
tyArgs [Either Term Type] -> [Either Term Type] -> [Either Term Type]
forall a. [a] -> [a] -> [a]
++
                      [ Term -> Either Term Type
forall a b. a -> Either a b
Left (Type -> Type -> Integer -> Integer -> Term
mkSignedLit Type
sty Type
nTy Integer
kn Integer
sn)
                      , Term -> Either Term Type
forall a b. a -> Either a b
Left (TyConMap -> Word64 -> Type -> Term
mkDoubleCLit TyConMap
tcm (Double -> Word64
castDoubleToWord64 Double
d1) ([Type] -> Type
forall a. HasCallStack => [a] -> a
last [Type]
tyArgs))
                      ])
            in Term -> Maybe Machine
reduce Term
ret
        where
          op :: KnownNat n => Proxy n -> Double -> (Signed n, Double)
          op :: forall (n :: Natural).
KnownNat n =>
Proxy n -> Double -> (Signed n, Double)
op Proxy n
_ = Double -> (Signed n, Double)
forall b. Integral b => Double -> (b, Double)
forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction
      PrimStepContext
_ -> Maybe Machine
forall a. Maybe a
Nothing

  ]