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

  I\/O actions that are translatable to HDL
-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns, MagicHash, TypeOperators, ScopedTypeVariables, FlexibleContexts #-}
{-# LANGUAGE DataKinds, GADTs, TypeApplications #-}

module Clash.Explicit.SimIO
  ( -- * I\/O environment for simulation
    mealyIO
  , SimIO
  -- * Display on stdout
  , display
  -- * End of simulation
  , finish
  -- * Mutable values
  , Reg
  , reg
  , readReg
  , writeReg
  -- * File I\/O
  , File
  , openFile
  , closeFile
  -- ** Reading and writing characters
  , getChar
  , putChar
  -- ** Reading strings
  , getLine
  -- ** Detecting the end of input
  , isEOF
    -- ** Buffering operations
  , flush
    -- ** Repositioning handles
  , seek
  , rewind
  , tell
  )
where

import Control.Monad (when)
#if __GLASGOW_HASKELL__ < 900
import Data.Coerce
#endif
import Data.IORef
import GHC.TypeLits
import Prelude hiding (getChar, putChar, getLine)
import qualified System.IO as IO
import System.IO.Unsafe

import Clash.Annotations.Primitive (hasBlackBox)
import Clash.Promoted.Nat
import Clash.Signal.Internal
import Clash.Sized.Unsigned
import Clash.Sized.Vector (Vec (..))
import Clash.XException (seqX)

-- | Simulation-level I\/O environment; synthesizable to HDL I\/O, which in
-- itself is unlikely to be synthesisable to a digital circuit.
--
-- See 'mealyIO' as to its use.
#if __GLASGOW_HASKELL__ >= 900
data SimIO a = SimIO {unSimIO :: !(IO a)}
#else
newtype SimIO a = SimIO {SimIO a -> IO a
unSimIO :: IO a}
#endif

instance Functor SimIO where
  fmap :: (a -> b) -> SimIO a -> SimIO b
fmap = (a -> b) -> SimIO a -> SimIO b
forall a b. (a -> b) -> SimIO a -> SimIO b
fmapSimIO#

fmapSimIO# :: (a -> b) -> SimIO a -> SimIO b
fmapSimIO# :: (a -> b) -> SimIO a -> SimIO b
fmapSimIO# a -> b
f (SimIO IO a
m) = IO b -> SimIO b
forall a. IO a -> SimIO a
SimIO ((a -> b) -> IO a -> IO b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f IO a
m)
{-# NOINLINE fmapSimIO# #-}

instance Applicative SimIO where
  pure :: a -> SimIO a
pure  = a -> SimIO a
forall a. a -> SimIO a
pureSimIO#
  <*> :: SimIO (a -> b) -> SimIO a -> SimIO b
(<*>) = SimIO (a -> b) -> SimIO a -> SimIO b
forall a b. SimIO (a -> b) -> SimIO a -> SimIO b
apSimIO#

pureSimIO# :: a -> SimIO a
pureSimIO# :: a -> SimIO a
pureSimIO# a
a = IO a -> SimIO a
forall a. IO a -> SimIO a
SimIO (a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure a
a)
{-# NOINLINE pureSimIO# #-}

apSimIO# :: SimIO (a -> b) -> SimIO a -> SimIO b
apSimIO# :: SimIO (a -> b) -> SimIO a -> SimIO b
apSimIO# (SimIO IO (a -> b)
f) (SimIO IO a
m) = IO b -> SimIO b
forall a. IO a -> SimIO a
SimIO (IO (a -> b)
f IO (a -> b) -> IO a -> IO b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> IO a
m)
{-# NOINLINE apSimIO# #-}

instance Monad SimIO where
  return :: a -> SimIO a
return = a -> SimIO a
forall a. a -> SimIO a
pureSimIO#
  >>= :: SimIO a -> (a -> SimIO b) -> SimIO b
(>>=)  = SimIO a -> (a -> SimIO b) -> SimIO b
forall a b. SimIO a -> (a -> SimIO b) -> SimIO b
bindSimIO#

bindSimIO# :: SimIO a -> (a -> SimIO b) -> SimIO b
#if __GLASGOW_HASKELL__ >= 900
bindSimIO# (SimIO m) k = SimIO (m >>= (\x -> x `seqX` unSimIO (k x)))
#else
bindSimIO# :: SimIO a -> (a -> SimIO b) -> SimIO b
bindSimIO# (SimIO IO a
m) a -> SimIO b
k = IO b -> SimIO b
forall a. IO a -> SimIO a
SimIO (IO a
m IO a -> (a -> IO b) -> IO b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\a
x -> a
x a -> IO b -> IO b
forall a b. a -> b -> b
`seqX` (a -> SimIO b) -> a -> IO b
coerce a -> SimIO b
k a
x))
#endif
{-# NOINLINE bindSimIO# #-}

-- | Display a string on /stdout/
display
  :: String
  -- ^ String you want to display
  -> SimIO ()
display :: String -> SimIO ()
display String
s = IO () -> SimIO ()
forall a. IO a -> SimIO a
SimIO (String -> IO ()
putStrLn String
s)
{-# NOINLINE display #-}
{-# ANN display hasBlackBox #-}

-- | Finish the simulation with an exit code
finish
  :: Integer
  -- ^ The exit code you want to return at the end of the simulation
  -> SimIO a
finish :: Integer -> SimIO a
finish Integer
i = a -> SimIO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (String -> a
forall a. HasCallStack => String -> a
error (Integer -> String
forall a. Show a => a -> String
show Integer
i))
{-# NOINLINE finish #-}
{-# ANN finish hasBlackBox #-}

-- | Mutable reference
#if __GLASGOW_HASKELL__ >= 900
data Reg a = Reg !(IORef a)
#else
newtype Reg a = Reg (IORef a)
#endif

-- | Create a new mutable reference with the given starting value
reg
  :: a
  -- ^ The starting value
  -> SimIO (Reg a)
reg :: a -> SimIO (Reg a)
reg a
a = IO (Reg a) -> SimIO (Reg a)
forall a. IO a -> SimIO a
SimIO (IORef a -> Reg a
forall a. IORef a -> Reg a
Reg (IORef a -> Reg a) -> IO (IORef a) -> IO (Reg a)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> IO (IORef a)
forall a. a -> IO (IORef a)
newIORef a
a)
{-# NOINLINE reg #-}
{-# ANN reg hasBlackBox #-}

-- | Read value from a mutable reference
readReg :: Reg a -> SimIO a
readReg :: Reg a -> SimIO a
readReg (Reg IORef a
a) = IO a -> SimIO a
forall a. IO a -> SimIO a
SimIO (IORef a -> IO a
forall a. IORef a -> IO a
readIORef IORef a
a)
{-# NOINLINE readReg #-}
{-# ANN readReg hasBlackBox #-}

-- | Write new value to the mutable reference
writeReg
  :: Reg a
  -- ^ The mutable reference
  -> a
  -- ^ The new value
  -> SimIO ()
writeReg :: Reg a -> a -> SimIO ()
writeReg (Reg IORef a
r) a
a = IO () -> SimIO ()
forall a. IO a -> SimIO a
SimIO (IORef a -> a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef a
r a
a)
{-# NOINLINE writeReg #-}
{-# ANN writeReg hasBlackBox #-}

-- | File handle
#if __GLASGOW_HASKELL__ >= 900
data File = File !IO.Handle
#else
newtype File = File IO.Handle
#endif

-- | Open a file
openFile
  :: FilePath
  -- ^ File to open
  -> String
  -- ^ File mode:
  --
  -- * "r": Open for reading
  -- * "w": Create for writing
  -- * "a": Append
  -- * "r+": Open for update (reading and writing)
  -- * "w+": Create for update
  -- * "a+": Append, open or create for update at end-of-file
  -> SimIO File
#if __GLASGOW_HASKELL__ >= 900
openFile fp "r"   = SimIO $ fmap File (IO.openFile fp IO.ReadMode)
openFile fp "w"   = SimIO $ fmap File (IO.openFile fp IO.WriteMode)
openFile fp "a"   = SimIO $ fmap File (IO.openFile fp IO.AppendMode)
openFile fp "rb"  = SimIO $ fmap File (IO.openBinaryFile fp IO.ReadMode)
openFile fp "wb"  = SimIO $ fmap File (IO.openBinaryFile fp IO.WriteMode)
openFile fp "ab"  = SimIO $ fmap File (IO.openBinaryFile fp IO.AppendMode)
openFile fp "r+"  = SimIO $ fmap File (IO.openFile fp IO.ReadWriteMode)
openFile fp "w+"  = SimIO $ fmap File (IO.openFile fp IO.WriteMode)
openFile fp "a+"  = SimIO $ fmap File (IO.openFile fp IO.AppendMode)
openFile fp "r+b" = SimIO $ fmap File (IO.openBinaryFile fp IO.ReadWriteMode)
openFile fp "w+b" = SimIO $ fmap File (IO.openBinaryFile fp IO.WriteMode)
openFile fp "a+b" = SimIO $ fmap File (IO.openBinaryFile fp IO.AppendMode)
openFile fp "rb+" = SimIO $ fmap File (IO.openBinaryFile fp IO.ReadWriteMode)
openFile fp "wb+" = SimIO $ fmap File (IO.openBinaryFile fp IO.WriteMode)
openFile fp "ab+" = SimIO $ fmap File (IO.openBinaryFile fp IO.AppendMode)
#else
openFile :: String -> String -> SimIO File
openFile String
fp String
"r"   = IO Handle -> SimIO File
coerce (String -> IOMode -> IO Handle
IO.openFile String
fp IOMode
IO.ReadMode)
openFile String
fp String
"w"   = IO Handle -> SimIO File
coerce (String -> IOMode -> IO Handle
IO.openFile String
fp IOMode
IO.WriteMode)
openFile String
fp String
"a"   = IO Handle -> SimIO File
coerce (String -> IOMode -> IO Handle
IO.openFile String
fp IOMode
IO.AppendMode)
openFile String
fp String
"rb"  = IO Handle -> SimIO File
coerce (String -> IOMode -> IO Handle
IO.openBinaryFile String
fp IOMode
IO.ReadMode)
openFile String
fp String
"wb"  = IO Handle -> SimIO File
coerce (String -> IOMode -> IO Handle
IO.openBinaryFile String
fp IOMode
IO.WriteMode)
openFile String
fp String
"ab"  = IO Handle -> SimIO File
coerce (String -> IOMode -> IO Handle
IO.openBinaryFile String
fp IOMode
IO.AppendMode)
openFile String
fp String
"r+"  = IO Handle -> SimIO File
coerce (String -> IOMode -> IO Handle
IO.openFile String
fp IOMode
IO.ReadWriteMode)
openFile String
fp String
"w+"  = IO Handle -> SimIO File
coerce (String -> IOMode -> IO Handle
IO.openFile String
fp IOMode
IO.WriteMode)
openFile String
fp String
"a+"  = IO Handle -> SimIO File
coerce (String -> IOMode -> IO Handle
IO.openFile String
fp IOMode
IO.AppendMode)
openFile String
fp String
"r+b" = IO Handle -> SimIO File
coerce (String -> IOMode -> IO Handle
IO.openBinaryFile String
fp IOMode
IO.ReadWriteMode)
openFile String
fp String
"w+b" = IO Handle -> SimIO File
coerce (String -> IOMode -> IO Handle
IO.openBinaryFile String
fp IOMode
IO.WriteMode)
openFile String
fp String
"a+b" = IO Handle -> SimIO File
coerce (String -> IOMode -> IO Handle
IO.openBinaryFile String
fp IOMode
IO.AppendMode)
openFile String
fp String
"rb+" = IO Handle -> SimIO File
coerce (String -> IOMode -> IO Handle
IO.openBinaryFile String
fp IOMode
IO.ReadWriteMode)
openFile String
fp String
"wb+" = IO Handle -> SimIO File
coerce (String -> IOMode -> IO Handle
IO.openBinaryFile String
fp IOMode
IO.WriteMode)
openFile String
fp String
"ab+" = IO Handle -> SimIO File
coerce (String -> IOMode -> IO Handle
IO.openBinaryFile String
fp IOMode
IO.AppendMode)
#endif
openFile String
_  String
m     = String -> SimIO File
forall a. HasCallStack => String -> a
error (String
"openFile unknown mode: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
m)
{-# NOINLINE openFile #-}
{-# ANN openFile hasBlackBox #-}

-- | Close a file
closeFile
  :: File
  -> SimIO ()
closeFile :: File -> SimIO ()
closeFile (File Handle
fp) = IO () -> SimIO ()
forall a. IO a -> SimIO a
SimIO (Handle -> IO ()
IO.hClose Handle
fp)
{-# NOINLINE closeFile #-}
{-# ANN closeFile hasBlackBox #-}

-- | Read one character from a file
getChar
  :: File
  -- ^ File to read from
  -> SimIO Char
getChar :: File -> SimIO Char
getChar (File Handle
fp) = IO Char -> SimIO Char
forall a. IO a -> SimIO a
SimIO (Handle -> IO Char
IO.hGetChar Handle
fp)
{-# NOINLINE getChar #-}
{-# ANN getChar hasBlackBox #-}

-- | Insert a character into a buffer specified by the file
putChar
  :: Char
  -- ^ Character to insert
  -> File
  -- ^ Buffer to insert to
  -> SimIO ()
putChar :: Char -> File -> SimIO ()
putChar Char
c (File Handle
fp) = IO () -> SimIO ()
forall a. IO a -> SimIO a
SimIO (Handle -> Char -> IO ()
IO.hPutChar Handle
fp Char
c)
{-# NOINLINE putChar #-}
{-# ANN putChar hasBlackBox #-}

-- | Read one line from a file
getLine
  :: forall n
   . KnownNat n
  => File
  -- ^ File to read from
  -> Reg (Vec n (Unsigned 8))
  -- ^ Vector to store the content
  -> SimIO Int
getLine :: File -> Reg (Vec n (Unsigned 8)) -> SimIO Int
getLine (File Handle
fp) (Reg IORef (Vec n (Unsigned 8))
r) = IO Int -> SimIO Int
forall a. IO a -> SimIO a
SimIO (IO Int -> SimIO Int) -> IO Int -> SimIO Int
forall a b. (a -> b) -> a -> b
$ do
  String
s <- Handle -> IO String
IO.hGetLine Handle
fp
  let d :: Int
d = SNat n -> Int
forall a (n :: Nat). Num a => SNat n -> a
snatToNum (KnownNat n => SNat n
forall (n :: Nat). KnownNat n => SNat n
SNat @n) Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length String
s
  Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0) (Handle -> SeekMode -> Integer -> IO ()
IO.hSeek Handle
fp SeekMode
IO.RelativeSeek (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
d))
  IORef (Vec n (Unsigned 8))
-> (Vec n (Unsigned 8) -> Vec n (Unsigned 8)) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef (Vec n (Unsigned 8))
r (String -> Vec n (Unsigned 8) -> Vec n (Unsigned 8)
forall (m :: Nat).
String -> Vec m (Unsigned 8) -> Vec m (Unsigned 8)
rep String
s)
  Int -> IO Int
forall (m :: Type -> Type) a. Monad m => a -> m a
return Int
0
 where
   rep :: String -> Vec m (Unsigned 8) -> Vec m (Unsigned 8)
   rep :: String -> Vec m (Unsigned 8) -> Vec m (Unsigned 8)
rep []     Vec m (Unsigned 8)
vs          = Vec m (Unsigned 8)
vs
   rep (Char
x:String
xs) (Cons Unsigned 8
_ Vec n (Unsigned 8)
vs) = Unsigned 8 -> Vec n (Unsigned 8) -> Vec (n + 1) (Unsigned 8)
forall a (n :: Nat). a -> Vec n a -> Vec (n + 1) a
Cons (Int -> Unsigned 8
forall a. Enum a => Int -> a
toEnum (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
x)) (String -> Vec n (Unsigned 8) -> Vec n (Unsigned 8)
forall (m :: Nat).
String -> Vec m (Unsigned 8) -> Vec m (Unsigned 8)
rep String
xs Vec n (Unsigned 8)
vs)
   rep String
_      Vec m (Unsigned 8)
Nil         = Vec m (Unsigned 8)
forall a. Vec 0 a
Nil
{-# NOINLINE getLine #-}
{-# ANN getLine hasBlackBox #-}

-- | Determine whether we've reached the end of the file
isEOF
  :: File
  -- ^ File we want to inspect
  -> SimIO Bool
isEOF :: File -> SimIO Bool
isEOF (File Handle
fp) = IO Bool -> SimIO Bool
forall a. IO a -> SimIO a
SimIO (Handle -> IO Bool
IO.hIsEOF Handle
fp)
{-# NOINLINE isEOF #-}
{-# ANN isEOF hasBlackBox #-}

-- | Set the position of the next operation on the file
seek
  :: File
  -- ^ File to set the position for
  -> Integer
  -- ^ Position
  -> Int
  -- ^ Mode:
  --
  -- * 0: From the beginning of the file
  -- * 1: From the current position
  -- * 2: From the end of the file
  -> SimIO Int
seek :: File -> Integer -> Int -> SimIO Int
seek (File Handle
fp) Integer
pos Int
mode = IO Int -> SimIO Int
forall a. IO a -> SimIO a
SimIO (Handle -> SeekMode -> Integer -> IO ()
IO.hSeek Handle
fp (Int -> SeekMode
forall a. Enum a => Int -> a
toEnum Int
mode) Integer
pos IO () -> IO Int -> IO Int
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> Int -> IO Int
forall (m :: Type -> Type) a. Monad m => a -> m a
return Int
0)
{-# NOINLINE seek #-}
{-# ANN seek hasBlackBox #-}

-- | Set the position of the next operation to the beginning of the file
rewind
  :: File
  -> SimIO Int
rewind :: File -> SimIO Int
rewind (File Handle
fp) = IO Int -> SimIO Int
forall a. IO a -> SimIO a
SimIO (Handle -> SeekMode -> Integer -> IO ()
IO.hSeek Handle
fp SeekMode
IO.AbsoluteSeek Integer
0 IO () -> IO Int -> IO Int
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> Int -> IO Int
forall (m :: Type -> Type) a. Monad m => a -> m a
return Int
0)
{-# NOINLINE rewind #-}
{-# ANN rewind hasBlackBox #-}

-- | Returns the offset from the beginning of the file (in bytes).
tell
  :: File
  -- ^ File we want to inspect
  -> SimIO Integer
tell :: File -> SimIO Integer
tell (File Handle
fp) = IO Integer -> SimIO Integer
forall a. IO a -> SimIO a
SimIO (Handle -> IO Integer
IO.hTell Handle
fp)
{-# NOINLINE tell #-}
{-# ANN tell hasBlackBox #-}

-- | Write any buffered output to file
flush
  :: File
  -> SimIO ()
flush :: File -> SimIO ()
flush (File Handle
fp) = IO () -> SimIO ()
forall a. IO a -> SimIO a
SimIO (Handle -> IO ()
IO.hFlush Handle
fp)
{-# NOINLINE flush #-}
{-# ANN flush hasBlackBox #-}

-- | Simulation-level I/O environment that can be synthesized to HDL-level I\/O.
-- Note that it is unlikely that the HDL-level I\/O can subsequently be
-- synthesized to a circuit.
--
-- = Example
--
-- @
-- tbMachine :: (File,File) -> Int -> SimIO Int
-- tbMachine (fileIn,fileOut) regOut = do
--   eofFileOut <- 'isEOF' fileOut
--   eofFileIn  <- 'isEOF' fileIn
--   when (eofFileIn || eofFileOut) $ do
--     'display' "success"
--     'finish' 0
--
--   goldenIn  <- 'getChar' fileIn
--   goldenOut <- 'getChar' fileOut
--   res <- if regOut == fromEnum goldenOut then do
--            return (fromEnum goldenIn)
--          else do
--            'display' "Output doesn't match golden output"
--            'finish' 1
--   display ("Output matches golden output")
--   return res
--
-- tbInit :: (File,File)
-- tbInit = do
--   fileIn  <- 'openFile' "./goldenInput00.txt" "r"
--   fileOut <- 'openFile' "./goldenOutput00.txt" "r"
--   return (fileIn,fileOut)
--
-- topEntity :: Signal System Int
-- topEntity = regOut
--   where
--     clk = systemClockGen
--     rst = resetGen
--     ena = enableGen
--
--     regOut = register clk rst ena (fromEnum \'a\') regIn
--     regIn  = 'mealyIO' clk tbMachine tbInit regOut
-- @
mealyIO
  :: KnownDomain dom
  => Clock dom
  -- ^ Clock at which rate the I\/O environment progresses
  -> (s -> i -> SimIO o)
  -- ^ Transition function inside an I\/O environment
  -> SimIO s
  -- ^ I/O action to create the initial state
  -> Signal dom i
  -> Signal dom o
mealyIO :: Clock dom
-> (s -> i -> SimIO o) -> SimIO s -> Signal dom i -> Signal dom o
mealyIO !Clock dom
_ s -> i -> SimIO o
f (SimIO IO s
i) Signal dom i
inp = IO (Signal dom o) -> Signal dom o
forall a. IO a -> a
unsafePerformIO (IO s
i IO s -> (s -> IO (Signal dom o)) -> IO (Signal dom o)
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= Signal dom i -> s -> IO (Signal dom o)
go Signal dom i
inp)
 where
  go :: Signal dom i -> s -> IO (Signal dom o)
go q :: Signal dom i
q@(~(i
k :- Signal dom i
ks)) s
s =
    o -> Signal dom o -> Signal dom o
forall (dom :: Domain) a. a -> Signal dom a -> Signal dom a
(:-) (o -> Signal dom o -> Signal dom o)
-> IO o -> IO (Signal dom o -> Signal dom o)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> SimIO o -> IO o
forall a. SimIO a -> IO a
unSimIO (s -> i -> SimIO o
f s
s i
k) IO (Signal dom o -> Signal dom o)
-> IO (Signal dom o) -> IO (Signal dom o)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> IO (Signal dom o) -> IO (Signal dom o)
forall a. IO a -> IO a
unsafeInterleaveIO ((Signal dom i
q Signal dom i -> IO (Signal dom o) -> IO (Signal dom o)
`seq` Signal dom i -> s -> IO (Signal dom o)
go Signal dom i
ks s
s))
{-# NOINLINE mealyIO #-}