{-|
Copyright   : (C) 2021, QBayLogic B.V.
License     : BSD2 (see the file LICENSE)
Maintainer  : QBayLogic B.V. <devops@qbaylogic.com>

Random type-directed generation of literals.
-}

{-# LANGUAGE CPP #-}

module Clash.Hedgehog.Core.Literal
  ( genLiteralFrom
  ) where

import Data.Binary.IEEE754 (doubleToWord, floatToWord)
import qualified Data.Primitive.ByteArray as BA (byteArrayFromList)
import Hedgehog (MonadGen)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range

import Clash.Core.Literal
import Clash.Core.Pretty (showPpr)
import Clash.Core.Subst (aeqType)
import Clash.Core.Type (Type)
import Clash.Core.TysPrim

-- | Generate a 'Literal' with the specified core type. If the type does not
-- correspond to a known @PrimTyCon@ (as defined in @Clash.Core.TysPrim@) then
-- an error is returned.
--
genLiteralFrom
  :: forall m
   . MonadGen m
  => Type
  -- ^ The type of the literal to generate
  -> m Literal
genLiteralFrom :: Type -> m Literal
genLiteralFrom Type
ty
  | Type -> Type -> Bool
aeqType Type
ty Type
integerPrimTy = m Literal
forall (m :: Type -> Type). MonadGen m => m Literal
genIntegerLiteral
  | Type -> Type -> Bool
aeqType Type
ty Type
intPrimTy = m Literal
forall (m :: Type -> Type). MonadGen m => m Literal
genIntLiteral
  | Type -> Type -> Bool
aeqType Type
ty Type
wordPrimTy = m Literal
forall (m :: Type -> Type). MonadGen m => m Literal
genWordLiteral
  | Type -> Type -> Bool
aeqType Type
ty Type
int64PrimTy = m Literal
forall (m :: Type -> Type). MonadGen m => m Literal
genInt64Literal
  | Type -> Type -> Bool
aeqType Type
ty Type
word64PrimTy = m Literal
forall (m :: Type -> Type). MonadGen m => m Literal
genWord64Literal
#if MIN_VERSION_base(4,16,0)
  | aeqType ty int8PrimTy = genInt8Literal
  | aeqType ty int16PrimTy = genInt16Literal
  | aeqType ty int32PrimTy = genInt32Literal
  | aeqType ty word8PrimTy = genWord8Literal
  | aeqType ty word16PrimTy = genWord16Literal
  | aeqType ty word32PrimTy = genWord32Literal
#endif
  | Type -> Type -> Bool
aeqType Type
ty Type
stringPrimTy = m Literal
forall (m :: Type -> Type). MonadGen m => m Literal
genStringLiteral
  | Type -> Type -> Bool
aeqType Type
ty Type
floatPrimTy = m Literal
forall (m :: Type -> Type). MonadGen m => m Literal
genFloatLiteral
  | Type -> Type -> Bool
aeqType Type
ty Type
doublePrimTy = m Literal
forall (m :: Type -> Type). MonadGen m => m Literal
genDoubleLiteral
  | Type -> Type -> Bool
aeqType Type
ty Type
charPrimTy = m Literal
forall (m :: Type -> Type). MonadGen m => m Literal
genCharLiteral
  | Type -> Type -> Bool
aeqType Type
ty Type
naturalPrimTy = m Literal
forall (m :: Type -> Type). MonadGen m => m Literal
genNaturalLiteral
  | Type -> Type -> Bool
aeqType Type
ty Type
byteArrayPrimTy = m Literal
forall (m :: Type -> Type). MonadGen m => m Literal
genByteArrayLiteral
  | Bool
otherwise =
      [Char] -> m Literal
forall a. HasCallStack => [Char] -> a
error ([Char] -> m Literal) -> [Char] -> m Literal
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines
        [ [Char]
"genLiteralFrom: No constructors for " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Type -> [Char]
forall p. PrettyPrec p => p -> [Char]
showPpr Type
ty
        , [Char]
"Check that this type is a primitive, and is not a void type."
        ]

-- TODO It would be nice to pass ranges into these types instead of just
-- guessing using some default range. However, that makes 'genLiteralFrom'
-- slightly more involved to write.
--
-- Without passing ranges to these, they may bias towards unrealistic values
-- which makes generating entire random programs less realistic.

genIntegerLiteral :: forall m. MonadGen m => m Literal
genIntegerLiteral :: m Literal
genIntegerLiteral =
  (Integer -> Literal) -> m Integer -> m Literal
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> Literal
IntegerLiteral (m Integer -> m Literal)
-> ((Size -> m Integer) -> m Integer)
-> (Size -> m Integer)
-> m Literal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Size -> m Integer) -> m Integer
forall (m :: Type -> Type) a. MonadGen m => (Size -> m a) -> m a
Gen.sized ((Size -> m Integer) -> m Literal)
-> (Size -> m Integer) -> m Literal
forall a b. (a -> b) -> a -> b
$ \Size
size ->
    let upper :: Integer
upper = Integer
2 Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ Size -> Int
Range.unSize Size
size
        lower :: Integer
lower = Integer -> Integer
forall a. Num a => a -> a
negate Integer
upper
     in Range Integer -> m Integer
forall (m :: Type -> Type) a.
(MonadGen m, Integral a) =>
Range a -> m a
Gen.integral (Integer -> Integer -> Range Integer
forall a. Integral a => a -> a -> Range a
Range.linear Integer
lower Integer
upper)

genIntLiteral :: forall m. MonadGen m => m Literal
genIntLiteral :: m Literal
genIntLiteral =
  Integer -> Literal
IntLiteral (Integer -> Literal) -> m Integer -> m Literal
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> m Int -> m Integer
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Range Int -> m Int
forall (m :: Type -> Type). MonadGen m => Range Int -> m Int
Gen.int Range Int
forall a. (Bounded a, Integral a) => Range a
Range.linearBounded)

genWordLiteral :: forall m. MonadGen m => m Literal
genWordLiteral :: m Literal
genWordLiteral =
  Integer -> Literal
WordLiteral (Integer -> Literal) -> m Integer -> m Literal
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word -> Integer
forall a. Integral a => a -> Integer
toInteger (Word -> Integer) -> m Word -> m Integer
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Range Word -> m Word
forall (m :: Type -> Type). MonadGen m => Range Word -> m Word
Gen.word Range Word
forall a. (Bounded a, Integral a) => Range a
Range.linearBounded)

genInt64Literal :: forall m. MonadGen m => m Literal
genInt64Literal :: m Literal
genInt64Literal =
  Integer -> Literal
Int64Literal (Integer -> Literal) -> m Integer -> m Literal
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Int64 -> Integer) -> m Int64 -> m Integer
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Range Int64 -> m Int64
forall (m :: Type -> Type). MonadGen m => Range Int64 -> m Int64
Gen.int64 Range Int64
forall a. (Bounded a, Integral a) => Range a
Range.linearBounded)

genWord64Literal :: forall m. MonadGen m => m Literal
genWord64Literal :: m Literal
genWord64Literal =
  Integer -> Literal
Word64Literal (Integer -> Literal) -> m Integer -> m Literal
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Word64 -> Integer) -> m Word64 -> m Integer
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Range Word64 -> m Word64
forall (m :: Type -> Type). MonadGen m => Range Word64 -> m Word64
Gen.word64 Range Word64
forall a. (Bounded a, Integral a) => Range a
Range.linearBounded)

#if MIN_VERSION_base(4,16,0)
genInt8Literal :: forall m. MonadGen m => m Literal
genInt8Literal =
  Int8Literal <$> (toInteger <$> Gen.int8 Range.linearBounded)

genInt16Literal :: forall m. MonadGen m => m Literal
genInt16Literal =
  Int16Literal <$> (toInteger <$> Gen.int16 Range.linearBounded)

genInt32Literal :: forall m. MonadGen m => m Literal
genInt32Literal =
  Int32Literal <$> (toInteger <$> Gen.int32 Range.linearBounded)

genWord8Literal :: forall m. MonadGen m => m Literal
genWord8Literal =
  Word8Literal <$> (toInteger <$> Gen.word8 Range.linearBounded)

genWord16Literal :: forall m. MonadGen m => m Literal
genWord16Literal =
  Word16Literal <$> (toInteger <$> Gen.word16 Range.linearBounded)

genWord32Literal :: forall m. MonadGen m => m Literal
genWord32Literal =
  Word32Literal <$> (toInteger <$> Gen.word32 Range.linearBounded)
#endif

genStringLiteral :: forall m. MonadGen m => m Literal
genStringLiteral :: m Literal
genStringLiteral =
  [Char] -> Literal
StringLiteral ([Char] -> Literal) -> m [Char] -> m Literal
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Range Int -> m Char -> m [Char]
forall (m :: Type -> Type).
MonadGen m =>
Range Int -> m Char -> m [Char]
Gen.string (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
10 Int
50) m Char
forall (m :: Type -> Type). MonadGen m => m Char
Gen.unicode

genFloatLiteral :: forall m. MonadGen m => m Literal
genFloatLiteral :: m Literal
genFloatLiteral =
  let range :: Range Float
range = Float -> Float -> Range Float
forall a. (Fractional a, Ord a) => a -> a -> Range a
Range.linearFrac Float
1.17549435e-38 Float
3.40282347e+38
   in Word32 -> Literal
FloatLiteral (Word32 -> Literal) -> m Word32 -> m Literal
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Float -> Word32
floatToWord (Float -> Word32) -> m Float -> m Word32
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Range Float -> m Float
forall (m :: Type -> Type). MonadGen m => Range Float -> m Float
Gen.float Range Float
range)

genDoubleLiteral :: forall m. MonadGen m => m Literal
genDoubleLiteral :: m Literal
genDoubleLiteral =
  let range :: Range Double
range = Double -> Double -> Range Double
forall a. (Fractional a, Ord a) => a -> a -> Range a
Range.linearFrac Double
2.2250738585072014e-308 Double
1.7976931348623157e+308
   in Word64 -> Literal
DoubleLiteral (Word64 -> Literal) -> m Word64 -> m Literal
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Double -> Word64
doubleToWord (Double -> Word64) -> m Double -> m Word64
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Range Double -> m Double
forall (m :: Type -> Type). MonadGen m => Range Double -> m Double
Gen.double Range Double
range)

genCharLiteral :: forall m. MonadGen m => m Literal
genCharLiteral :: m Literal
genCharLiteral =
  Char -> Literal
CharLiteral (Char -> Literal) -> m Char -> m Literal
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> m Char
forall (m :: Type -> Type). MonadGen m => m Char
Gen.ascii

genNaturalLiteral :: forall m. MonadGen m => m Literal
genNaturalLiteral :: m Literal
genNaturalLiteral =
  (Integer -> Literal) -> m Integer -> m Literal
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> Literal
NaturalLiteral (m Integer -> m Literal)
-> ((Size -> m Integer) -> m Integer)
-> (Size -> m Integer)
-> m Literal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Size -> m Integer) -> m Integer
forall (m :: Type -> Type) a. MonadGen m => (Size -> m a) -> m a
Gen.sized ((Size -> m Integer) -> m Literal)
-> (Size -> m Integer) -> m Literal
forall a b. (a -> b) -> a -> b
$ \Size
size ->
    let upper :: Integer
upper = Integer
2 Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ Size -> Int
Range.unSize Size
size
     in Range Integer -> m Integer
forall (m :: Type -> Type) a.
(MonadGen m, Integral a) =>
Range a -> m a
Gen.integral (Integer -> Integer -> Range Integer
forall a. Integral a => a -> a -> Range a
Range.linear Integer
0 Integer
upper)

genByteArrayLiteral :: forall m. MonadGen m => m Literal
genByteArrayLiteral :: m Literal
genByteArrayLiteral = do
  [Word8]
bytes <- Range Int -> m Word8 -> m [Word8]
forall (m :: Type -> Type) a.
MonadGen m =>
Range Int -> m a -> m [a]
Gen.list (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
0 Int
16) (Range Word8 -> m Word8
forall (m :: Type -> Type). MonadGen m => Range Word8 -> m Word8
Gen.word8 Range Word8
forall a. (Bounded a, Integral a) => Range a
Range.linearBounded)
  Literal -> m Literal
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ByteArray -> Literal
ByteArrayLiteral ([Word8] -> ByteArray
forall a. Prim a => [a] -> ByteArray
BA.byteArrayFromList [Word8]
bytes))