{-|
  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 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)
import Data.Coerce
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.
newtype SimIO a = SimIO {SimIO a -> IO a
unSimIO :: IO a}

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# f :: a -> b
f (SimIO m :: 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
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 f :: IO (a -> b)
f) (SimIO m :: 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
bindSimIO# :: SimIO a -> (a -> SimIO b) -> SimIO b
bindSimIO# (SimIO m :: IO a
m) k :: 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
>>= (\x :: a
x -> a
x a -> IO b -> IO b
forall a b. a -> b -> b
`seqX` (a -> SimIO b) -> a -> IO b
forall a b. Coercible a b => a -> b
coerce a -> SimIO b
k a
x))
{-# NOINLINE bindSimIO# #-}

-- | Display a string on /stdout/
display
  :: String
  -- ^ String you want to display
  -> SimIO ()
display :: String -> SimIO ()
display s :: 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 i :: 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
newtype Reg a = Reg (IORef a)

-- | 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
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 a :: 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 r :: IORef a
r) a :: 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
newtype File = File IO.Handle

-- | 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
openFile :: String -> String -> SimIO File
openFile fp :: String
fp "r"   = IO Handle -> SimIO File
forall a b. Coercible a b => a -> b
coerce (String -> IOMode -> IO Handle
IO.openFile String
fp IOMode
IO.ReadMode)
openFile fp :: String
fp "w"   = IO Handle -> SimIO File
forall a b. Coercible a b => a -> b
coerce (String -> IOMode -> IO Handle
IO.openFile String
fp IOMode
IO.WriteMode)
openFile fp :: String
fp "a"   = IO Handle -> SimIO File
forall a b. Coercible a b => a -> b
coerce (String -> IOMode -> IO Handle
IO.openFile String
fp IOMode
IO.AppendMode)
openFile fp :: String
fp "rb"  = IO Handle -> SimIO File
forall a b. Coercible a b => a -> b
coerce (String -> IOMode -> IO Handle
IO.openBinaryFile String
fp IOMode
IO.ReadMode)
openFile fp :: String
fp "wb"  = IO Handle -> SimIO File
forall a b. Coercible a b => a -> b
coerce (String -> IOMode -> IO Handle
IO.openBinaryFile String
fp IOMode
IO.WriteMode)
openFile fp :: String
fp "ab"  = IO Handle -> SimIO File
forall a b. Coercible a b => a -> b
coerce (String -> IOMode -> IO Handle
IO.openBinaryFile String
fp IOMode
IO.AppendMode)
openFile fp :: String
fp "r+"  = IO Handle -> SimIO File
forall a b. Coercible a b => a -> b
coerce (String -> IOMode -> IO Handle
IO.openFile String
fp IOMode
IO.ReadWriteMode)
openFile fp :: String
fp "w+"  = IO Handle -> SimIO File
forall a b. Coercible a b => a -> b
coerce (String -> IOMode -> IO Handle
IO.openFile String
fp IOMode
IO.WriteMode)
openFile fp :: String
fp "a+"  = IO Handle -> SimIO File
forall a b. Coercible a b => a -> b
coerce (String -> IOMode -> IO Handle
IO.openFile String
fp IOMode
IO.AppendMode)
openFile fp :: String
fp "r+b" = IO Handle -> SimIO File
forall a b. Coercible a b => a -> b
coerce (String -> IOMode -> IO Handle
IO.openBinaryFile String
fp IOMode
IO.ReadWriteMode)
openFile fp :: String
fp "w+b" = IO Handle -> SimIO File
forall a b. Coercible a b => a -> b
coerce (String -> IOMode -> IO Handle
IO.openBinaryFile String
fp IOMode
IO.WriteMode)
openFile fp :: String
fp "a+b" = IO Handle -> SimIO File
forall a b. Coercible a b => a -> b
coerce (String -> IOMode -> IO Handle
IO.openBinaryFile String
fp IOMode
IO.AppendMode)
openFile fp :: String
fp "rb+" = IO Handle -> SimIO File
forall a b. Coercible a b => a -> b
coerce (String -> IOMode -> IO Handle
IO.openBinaryFile String
fp IOMode
IO.ReadWriteMode)
openFile fp :: String
fp "wb+" = IO Handle -> SimIO File
forall a b. Coercible a b => a -> b
coerce (String -> IOMode -> IO Handle
IO.openBinaryFile String
fp IOMode
IO.WriteMode)
openFile fp :: String
fp "ab+" = IO Handle -> SimIO File
forall a b. Coercible a b => a -> b
coerce (String -> IOMode -> IO Handle
IO.openBinaryFile String
fp IOMode
IO.AppendMode)
openFile _  m :: String
m     = String -> SimIO File
forall a. HasCallStack => String -> a
error ("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 fp :: 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 fp :: 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 c :: Char
c (File fp :: 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 fp :: Handle
fp) (Reg r :: 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
< 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 0
 where
   rep :: String -> Vec m (Unsigned 8) -> Vec m (Unsigned 8)
   rep :: String -> Vec m (Unsigned 8) -> Vec m (Unsigned 8)
rep []     vs :: Vec m (Unsigned 8)
vs          = Vec m (Unsigned 8)
vs
   rep (x :: Char
x:xs :: String
xs) (Cons _ vs :: 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 _      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 fp :: 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 fp :: Handle
fp) pos :: Integer
pos mode :: 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 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 fp :: Handle
fp) = IO Int -> SimIO Int
forall a. IO a -> SimIO a
SimIO (Handle -> SeekMode -> Integer -> IO ()
IO.hSeek Handle
fp SeekMode
IO.AbsoluteSeek 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 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 fp :: 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 fp :: 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
_ f :: s -> i -> SimIO o
f (SimIO i :: IO s
i) inp :: 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@(~(k :: i
k :- ks :: Signal dom i
ks)) s :: 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)
forall a b. a -> b -> b
`seq` Signal dom i -> s -> IO (Signal dom o)
go Signal dom i
ks s
s))
{-# NOINLINE mealyIO #-}