{-|
  Copyright  :  (C) 2019, Myrtle Software Ltd
  License    :  BSD2 (see the file LICENSE)
  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>

  Blackbox generation for literal data constructors. (System)Verilog only!
-}
{-# LANGUAGE OverloadedStrings #-}

module Clash.Primitives.GHC.Literal
 ( assign
 , signed
 , signedLiteral
 , unsigned
 , unsignedLiteral
 , literalTF
 )
 where

import           Data.List.NonEmpty           (NonEmpty)
import qualified Data.List.NonEmpty           as NE
import qualified Data.Text.Lazy               as LT
import           Data.Text
  (Text, stripPrefix, stripSuffix, unpack)
import           Data.Text.Extra              (showtl)
import           Text.Read                    (readMaybe)

import           Clash.Core.Term              (Term)
import           Clash.Core.Type              (Type)
import           Clash.Netlist.Types          (BlackBox)
import           Clash.Netlist.BlackBox.Types
  (BlackBoxFunction, Element(Text), BlackBoxMeta)

unsigned :: Element -> [Element]
unsigned :: Element -> [Element]
unsigned Element
el = [Text -> Element
Text Text
"$unsigned(", Element
el, Text -> Element
Text Text
")"]

signed :: Element -> [Element]
signed :: Element -> [Element]
signed Element
el = [Text -> Element
Text Text
"$signed(", Element
el, Text -> Element
Text Text
")"]

assign :: Element -> [Element] -> [Element]
assign :: Element -> [Element] -> [Element]
assign Element
lhs [Element]
rhs = Text -> Element
Text Text
"assign " Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: Element
lhs Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: Text -> Element
Text Text
" = " Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: [Element]
rhs [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++ [Text -> Element
Text Text
";"]

signedLiteral :: Int -> Integer -> Element
signedLiteral :: Int -> Integer -> Element
signedLiteral Int
wordSize Integer
wordVal =
  Text -> Element
Text ([Text] -> Text
LT.concat [ if Integer
wordVal Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 then Text
"-" else Text
""
                  , Int -> Text
forall a. Show a => a -> Text
showtl Int
wordSize
                  , Text
"'sd"
                  , Integer -> Text
forall a. Show a => a -> Text
showtl (Integer -> Integer
forall a. Num a => a -> a
abs Integer
wordVal)
                  ])

unsignedLiteral :: Int -> Integer -> Element
unsignedLiteral :: Int -> Integer -> Element
unsignedLiteral Int
wordSize Integer
wordVal =
  Text -> Element
Text ([Text] -> Text
LT.concat [ if Integer
wordVal Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 then Text
"-" else Text
""
                  , Int -> Text
forall a. Show a => a -> Text
showtl Int
wordSize
                  , Text
"'d"
                  , Integer -> Text
forall a. Show a => a -> Text
showtl (Integer -> Integer
forall a. Num a => a -> a
abs Integer
wordVal)
                  ])

-- | Parse integer in strings of the form "GHC.Word.WordX#" where
-- "GHC.Word.Word" is the prefix given. The first prefix that matches wins.
readSize :: NonEmpty Text -> Text -> Maybe Int
readSize :: NonEmpty Text -> Text -> Maybe Int
readSize NonEmpty Text
prefixes Text
nm0 = do
  let go :: [Text] -> Maybe Text
go [] = Maybe Text
forall a. Maybe a
Nothing
      go (Text
p:[Text]
ps) = case Text -> Text -> Maybe Text
stripPrefix Text
p Text
nm0 of
        Just Text
nm1 -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
nm1
        Maybe Text
Nothing  -> [Text] -> Maybe Text
go [Text]
ps
  Text
nm1 <- [Text] -> Maybe Text
go (NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Text
prefixes)
  Text
nm2 <- Text -> Text -> Maybe Text
stripSuffix Text
"#" Text
nm1
  [Char] -> Maybe Int
forall a. Read a => [Char] -> Maybe a
readMaybe (Text -> [Char]
unpack Text
nm2)

-- | Constructs "clean" literals.
literalTF
  :: NonEmpty Text
  -- ^ Base names of constructors (for example: @"GHC.Word.W" :| ["GHC.Internal.Word.W"]@).
  -- The 'GHC.Internal.*' variant is needed for GHC >= 9.14, which moved the
  -- constructors into 'ghc-internal'; 'base' re-exports them.
  -> (Bool -> [Either Term Type] -> Int -> (BlackBoxMeta, BlackBox))
  -- ^ Functions processing
  -> BlackBoxFunction
literalTF :: NonEmpty Text
-> (Bool -> [Either Term Type] -> Int -> (BlackBoxMeta, BlackBox))
-> BlackBoxFunction
literalTF NonEmpty Text
baseNames Bool -> [Either Term Type] -> Int -> (BlackBoxMeta, BlackBox)
tf Bool
isDecl Text
primName [Either Term Type]
args [Type]
_resTy = Either [Char] (BlackBoxMeta, BlackBox)
-> NetlistMonad (Either [Char] (BlackBoxMeta, BlackBox))
forall a. a -> NetlistMonad a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Either [Char] (BlackBoxMeta, BlackBox)
 -> NetlistMonad (Either [Char] (BlackBoxMeta, BlackBox)))
-> Either [Char] (BlackBoxMeta, BlackBox)
-> NetlistMonad (Either [Char] (BlackBoxMeta, BlackBox))
forall a b. (a -> b) -> a -> b
$
  case NonEmpty Text -> Text -> Maybe Int
readSize NonEmpty Text
baseNames Text
primName of
    Maybe Int
Nothing ->
      [Char] -> Either [Char] (BlackBoxMeta, BlackBox)
forall a b. a -> Either a b
Left ([[Char]] -> [Char]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Char]
"Can only make blackboxes for '", Text -> [Char]
unpack (NonEmpty Text -> Text
forall a. NonEmpty a -> a
NE.head NonEmpty Text
baseNames), [Char]
"X#'"])
    Just Int
n ->
      (BlackBoxMeta, BlackBox) -> Either [Char] (BlackBoxMeta, BlackBox)
forall a b. b -> Either a b
Right (Bool -> [Either Term Type] -> Int -> (BlackBoxMeta, BlackBox)
tf Bool
isDecl [Either Term Type]
args Int
n)