module Lava.Vhdl
  ( writeVhdl
  , writeVhdlInput
  , writeVhdlInputOutput
  )
 where

import Lava.Signal
import Lava.Netlist
import Lava.Generic
import Lava.Sequent
import Lava.Error
import Lava.LavaDir

import Data.List
  ( intersperse
  , nub
  )

import System.IO
  ( openFile
  , IOMode(..)
  , hPutStr
  , hClose
  )

import System.IO
  ( stdout
  , BufferMode (..)
  , hSetBuffering
  )

import Data.IORef

import System.Process (system)
import System.Exit (ExitCode(..))

----------------------------------------------------------------
-- write vhdl

writeVhdl :: (Constructive a, Generic b) => String -> (a -> b) -> IO ()
writeVhdl :: String -> (a -> b) -> IO ()
writeVhdl name :: String
name circ :: a -> b
circ =
  do String -> (a -> b) -> a -> IO ()
forall a b.
(Generic a, Generic b) =>
String -> (a -> b) -> a -> IO ()
writeVhdlInput String
name a -> b
circ (String -> a
forall a. Constructive a => String -> a
var "inp")

writeVhdlInput :: (Generic a, Generic b) => String -> (a -> b) -> a -> IO ()
writeVhdlInput :: String -> (a -> b) -> a -> IO ()
writeVhdlInput name :: String
name circ :: a -> b
circ inp :: a
inp =
  do String -> (a -> b) -> a -> b -> IO ()
forall a b.
(Generic a, Generic b) =>
String -> (a -> b) -> a -> b -> IO ()
writeVhdlInputOutput String
name a -> b
circ a
inp (String -> b -> b
forall a. Generic a => String -> a -> a
symbolize "outp" (a -> b
circ a
inp))

writeVhdlInputOutput :: (Generic a, Generic b)
                     => String -> (a -> b) -> a -> b -> IO ()
writeVhdlInputOutput :: String -> (a -> b) -> a -> b -> IO ()
writeVhdlInputOutput name :: String
name circ :: a -> b
circ inp :: a
inp out :: b
out =
  do String -> a -> b -> b -> IO ()
forall a b.
(Generic a, Generic b) =>
String -> a -> b -> b -> IO ()
writeItAll String
name a
inp (a -> b
circ a
inp) b
out

writeItAll :: (Generic a, Generic b) => String -> a -> b -> b -> IO ()
writeItAll :: String -> a -> b -> b -> IO ()
writeItAll name :: String
name inp :: a
inp out :: b
out out' :: b
out' =
  do Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdout BufferMode
NoBuffering
     String -> IO ()
putStr ("Writing to file \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
file String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\" ... ")
     String -> String -> a -> b -> b -> IO ()
forall a b.
(Generic a, Generic b) =>
String -> String -> a -> b -> b -> IO ()
writeDefinitions String
file String
name a
inp b
out b
out'
     String -> IO ()
putStrLn "Done."
 where
  file :: String
file = String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ ".vhd"

----------------------------------------------------------------
-- definitions

writeDefinitions :: (Generic a, Generic b)
                 => FilePath -> String -> a -> b -> b -> IO ()
writeDefinitions :: String -> String -> a -> b -> b -> IO ()
writeDefinitions file :: String
file name :: String
name inp :: a
inp out :: b
out out' :: b
out' =
  do Handle
firstHandle  <- String -> IOMode -> IO Handle
openFile String
firstFile IOMode
WriteMode
     Handle
secondHandle <- String -> IOMode -> IO Handle
openFile String
secondFile IOMode
WriteMode
     IORef Integer
var <- Integer -> IO (IORef Integer)
forall a. a -> IO (IORef a)
newIORef 0

     Handle -> String -> IO ()
hPutStr Handle
firstHandle (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
       [ "-- Generated by Lava 2000"
       , ""
       , "use work.all;"
       , ""
       , "entity"
       , "  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name
       , "is"
       , "port"
       , "  -- clock"
       , "  ( " String -> String -> String
forall a. [a] -> [a] -> [a]
++ "clk" String -> String -> String
forall a. [a] -> [a] -> [a]
++ " : in bit"
       , ""
       , "  -- inputs"
       ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
       [ "  ; " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ " : in bit"
       | VarBool v :: String
v <- [S Symbol]
inps
       ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
       [ ""
       , "  -- outputs"
       ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
       [ "  ; " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ " : out bit"
       | VarBool v :: String
v <- [S Symbol]
outs'
       ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
       [ "  );"
       , "end entity " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ ";"
       , ""
       , "architecture"
       , "  structural"
       , "of"
       , "  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name
       , "is"
       ]

     Handle -> String -> IO ()
hPutStr Handle
secondHandle (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
       [ "begin"
       ]

     let new :: IO String
new =
           do Integer
n <- IORef Integer -> IO Integer
forall a. IORef a -> IO a
readIORef IORef Integer
var
              let n' :: Integer
n' = Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+1; v :: String
v = "w" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
n'
              IORef Integer -> Integer -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Integer
var Integer
n'
              Handle -> String -> IO ()
hPutStr Handle
firstHandle ("  signal " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ " : bit;\n")
              String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
v

         define :: String -> S String -> IO ()
define v :: String
v s :: S String
s =
           case S String
s of
             Bool True     -> String -> [String] -> IO ()
port "vdd"  []
             Bool False    -> String -> [String] -> IO ()
port "gnd"  []
             Inv x :: String
x         -> String -> [String] -> IO ()
port "inv"  [String
x]

             And []        -> String -> S String -> IO ()
define String
v (Bool -> S String
forall s. Bool -> S s
Bool Bool
True)
             And [x :: String
x]       -> String -> [String] -> IO ()
port "id"   [String
x]
             And [x :: String
x,y :: String
y]     -> String -> [String] -> IO ()
port "and2" [String
x,String
y]
             And (x :: String
x:xs :: [String]
xs)    -> String -> S String -> IO ()
define (Integer -> String
forall a. Show a => a -> String
w 0) ([String] -> S String
forall s. [s] -> S s
And [String]
xs)
                           IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> S String -> IO ()
define String
v ([String] -> S String
forall s. [s] -> S s
And [String
x,Integer -> String
forall a. Show a => a -> String
w 0])

             Or  []        -> String -> S String -> IO ()
define String
v (Bool -> S String
forall s. Bool -> S s
Bool Bool
False)
             Or  [x :: String
x]       -> String -> [String] -> IO ()
port "id"   [String
x]
             Or  [x :: String
x,y :: String
y]     -> String -> [String] -> IO ()
port "or2"  [String
x,String
y]
             Or  (x :: String
x:xs :: [String]
xs)    -> String -> S String -> IO ()
define (Integer -> String
forall a. Show a => a -> String
w 0) ([String] -> S String
forall s. [s] -> S s
Or [String]
xs)
                           IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> S String -> IO ()
define String
v ([String] -> S String
forall s. [s] -> S s
Or [String
x,Integer -> String
forall a. Show a => a -> String
w 0])

             Xor  []       -> String -> S String -> IO ()
define String
v (Bool -> S String
forall s. Bool -> S s
Bool Bool
False)
             Xor  [x :: String
x]      -> String -> [String] -> IO ()
port "id"   [String
x]
             Xor  [x :: String
x,y :: String
y]    -> String -> [String] -> IO ()
port "xor2" [String
x,String
y]
             Xor  (x :: String
x:xs :: [String]
xs)   -> String -> S String -> IO ()
define (Integer -> String
forall a. Show a => a -> String
w 0) ([String] -> S String
forall s. [s] -> S s
Or [String]
xs)
                           IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> S String -> IO ()
define (Integer -> String
forall a. Show a => a -> String
w 1) (String -> S String
forall s. s -> S s
Inv (Integer -> String
forall a. Show a => a -> String
w 0))
                           IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> S String -> IO ()
define (Integer -> String
forall a. Show a => a -> String
w 2) ([String] -> S String
forall s. [s] -> S s
And [String
x, Integer -> String
forall a. Show a => a -> String
w 1])

                           IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> S String -> IO ()
define (Integer -> String
forall a. Show a => a -> String
w 3) (String -> S String
forall s. s -> S s
Inv String
x)
                           IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> S String -> IO ()
define (Integer -> String
forall a. Show a => a -> String
w 4) ([String] -> S String
forall s. [s] -> S s
Xor [String]
xs)
                           IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> S String -> IO ()
define (Integer -> String
forall a. Show a => a -> String
w 5) ([String] -> S String
forall s. [s] -> S s
And [Integer -> String
forall a. Show a => a -> String
w 3, Integer -> String
forall a. Show a => a -> String
w 4])
                           IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> S String -> IO ()
define String
v     ([String] -> S String
forall s. [s] -> S s
Or [Integer -> String
forall a. Show a => a -> String
w 2, Integer -> String
forall a. Show a => a -> String
w 5])

             VarBool s :: String
s     -> String -> [String] -> IO ()
port "id" [String
s]
             DelayBool x :: String
x y :: String
y -> String -> [String] -> IO ()
port "delay" [String
x, String
y]

             _             -> Error -> IO ()
forall a. Error -> a
wrong Error
Lava.Error.NoArithmetic
           where
            w :: a -> String
w i :: a
i = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
i

            port :: String -> [String] -> IO ()
port name :: String
name args :: [String]
args =
              do Handle -> String -> IO ()
hPutStr Handle
secondHandle (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
                      "  "
                   String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String
make 9 ("c_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
v)
                   String -> String -> String
forall a. [a] -> [a] -> [a]
++ " : entity "
                   String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String
make 5 String
name
                   String -> String -> String
forall a. [a] -> [a] -> [a]
++ " port map ("
                   String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse ", " ("clk" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
args [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
v]))
                   String -> String -> String
forall a. [a] -> [a] -> [a]
++ ");\n"

     Struct String
outvs <- IO String
-> (String -> S String -> IO ())
-> Struct Symbol
-> IO (Struct String)
forall (f :: * -> *) v.
Sequent f =>
IO v -> (v -> S v -> IO ()) -> f Symbol -> IO (f v)
netlistIO IO String
new String -> S String -> IO ()
define (b -> Struct Symbol
forall a. Generic a => a -> Struct Symbol
struct b
out)
     Handle -> String -> IO ()
hPutStr Handle
secondHandle (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
       [ ""
       , "  -- naming outputs"
       ]

     [IO ()] -> IO [()]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
       [ String -> S String -> IO ()
define String
v' (String -> S String
forall s. String -> S s
VarBool String
v)
       | (v :: String
v,v' :: String
v') <- Struct String -> [String]
forall a. Struct a -> [a]
flatten Struct String
outvs [String] -> [String] -> [(String, String)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [ String
v' | VarBool v' :: String
v' <- [S Symbol]
outs' ]
       ]

     Handle -> String -> IO ()
hPutStr Handle
secondHandle (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
       [ "end structural;"
       ]

     Handle -> IO ()
hClose Handle
firstHandle
     Handle -> IO ()
hClose Handle
secondHandle

     String -> IO ExitCode
system ("cat " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
firstFile String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
secondFile String -> String -> String
forall a. [a] -> [a] -> [a]
++ " > " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
file)
     String -> IO ExitCode
system ("rm " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
firstFile String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
secondFile)
     () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
 where
  sigs :: a -> [S Symbol]
sigs x :: a
x = (Symbol -> S Symbol) -> [Symbol] -> [S Symbol]
forall a b. (a -> b) -> [a] -> [b]
map Symbol -> S Symbol
unsymbol ([Symbol] -> [S Symbol]) -> (a -> [Symbol]) -> a -> [S Symbol]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Struct Symbol -> [Symbol]
forall a. Struct a -> [a]
flatten (Struct Symbol -> [Symbol])
-> (a -> Struct Symbol) -> a -> [Symbol]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Struct Symbol
forall a. Generic a => a -> Struct Symbol
struct (a -> [S Symbol]) -> a -> [S Symbol]
forall a b. (a -> b) -> a -> b
$ a
x

  inps :: [S Symbol]
inps  = a -> [S Symbol]
forall a. Generic a => a -> [S Symbol]
sigs a
inp
  outs' :: [S Symbol]
outs' = b -> [S Symbol]
forall a. Generic a => a -> [S Symbol]
sigs b
out'

  firstFile :: String
firstFile  = String
file String -> String -> String
forall a. [a] -> [a] -> [a]
++ "-1"
  secondFile :: String
secondFile = String
file String -> String -> String
forall a. [a] -> [a] -> [a]
++ "-2"

  make :: Int -> String -> String
make n :: Int
n s :: String
s = Int -> String -> String
forall a. Int -> [a] -> [a]
take (Int
n Int -> Int -> Int
forall a. Ord a => a -> a -> a
`max` String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s) (String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. a -> [a]
repeat ' ')


----------------------------------------------------------------
-- the end.