--------------------------------------------------------------------------------
-- |
-- Module       :  Language.Netlist.GenVHDL
-- Copyright    :  (c) University of Kansas 2010
-- License      :  All rights reserved
--
-- Maintainer   : garrin.kimmell@gmail.com
-- Stability    : experimental
-- Portability  : non-portable
--
-- Translates a Netlist AST ('Language.Netlist.AST') to VHDL.
--------------------------------------------------------------------------------

{-# LANGUAGE CPP #-}
module Language.Netlist.GenVHDL(genVHDL) where

import Language.Netlist.AST

#if MIN_VERSION_base(4,11,0)
import Prelude hiding ((<>))
#endif
import Text.PrettyPrint
import Data.Maybe(catMaybes, mapMaybe)


-- | Generate a 'Language.Netlist.AST.Module' as a VHDL file . The ['String'] argument
-- is the list of extra modules to import, typically [\"work.all\"].
genVHDL :: Module -> [String] -> String
genVHDL :: Module -> [String] -> String
genVHDL m :: Module
m others :: [String]
others = Doc -> String
render Doc
vhdl String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\n"
  where
    vhdl :: Doc
vhdl  =  [String] -> Doc
imports [String]
others Doc -> Doc -> Doc
$$
             Module -> Doc
entity Module
m Doc -> Doc -> Doc
$$
             Module -> Doc
architecture Module
m

imports :: [String] -> Doc
imports :: [String] -> Doc
imports others :: [String]
others = [Doc] -> Doc
vcat
	[ String -> Doc
text "library IEEE" Doc -> Doc -> Doc
<> Doc
semi
        , String -> Doc
text "use IEEE.STD_LOGIC_1164.ALL" Doc -> Doc -> Doc
<> Doc
semi
        , String -> Doc
text "use IEEE.NUMERIC_STD.ALL" Doc -> Doc -> Doc
<> Doc
semi
	] Doc -> Doc -> Doc
$$ [Doc] -> Doc
vcat [
          String -> Doc
text ("use " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
other) Doc -> Doc -> Doc
<> Doc
semi
	| String
other <- [String]
others
        ]


entity :: Module -> Doc
entity :: Module -> Doc
entity m :: Module
m = String -> Doc
text "entity" Doc -> Doc -> Doc
<+> String -> Doc
text (Module -> String
module_name Module
m) Doc -> Doc -> Doc
<+> String -> Doc
text "is" Doc -> Doc -> Doc
$$
            Int -> Doc -> Doc
nest 2 (String -> Doc
text "port" Doc -> Doc -> Doc
<> Doc -> Doc
parens ([Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate Doc
semi [Doc]
ports) Doc -> Doc -> Doc
<> Doc
semi) Doc -> Doc -> Doc
$$
            String -> Doc
text "end" Doc -> Doc -> Doc
<+> String -> Doc
text "entity" Doc -> Doc -> Doc
<+> String -> Doc
text (Module -> String
module_name Module
m) Doc -> Doc -> Doc
<> Doc
semi

  where ports :: [Doc]
ports = [String -> Doc
text String
i Doc -> Doc -> Doc
<+> Doc
colon Doc -> Doc -> Doc
<+> String -> Doc
text "in" Doc -> Doc -> Doc
<+> Maybe Range -> Doc
slv_type Maybe Range
ran | (i :: String
i,ran :: Maybe Range
ran) <- Module -> [(String, Maybe Range)]
module_inputs Module
m ] [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++
                [String -> Doc
text String
i Doc -> Doc -> Doc
<+> Doc
colon Doc -> Doc -> Doc
<+> String -> Doc
text "out" Doc -> Doc -> Doc
<+> Maybe Range -> Doc
slv_type Maybe Range
ran | (i :: String
i,ran :: Maybe Range
ran) <- Module -> [(String, Maybe Range)]
module_outputs Module
m ]


architecture :: Module -> Doc
architecture :: Module -> Doc
architecture m :: Module
m = String -> Doc
text "architecture" Doc -> Doc -> Doc
<+> String -> Doc
text "str" Doc -> Doc -> Doc
<+> String -> Doc
text "of" Doc -> Doc -> Doc
<+>  String -> Doc
text (Module -> String
module_name Module
m) Doc -> Doc -> Doc
<+> String -> Doc
text "is" Doc -> Doc -> Doc
$$
                 Int -> Doc -> Doc
nest 2 ([Decl] -> Doc
decls (Module -> [Decl]
module_decls Module
m)) Doc -> Doc -> Doc
$$
                 String -> Doc
text "begin" Doc -> Doc -> Doc
$$
                 Int -> Doc -> Doc
nest 2 ([Decl] -> Doc
insts (Module -> [Decl]
module_decls Module
m)) Doc -> Doc -> Doc
$$
                 String -> Doc
text "end" Doc -> Doc -> Doc
<+> String -> Doc
text "architecture" Doc -> Doc -> Doc
<+> String -> Doc
text "str" Doc -> Doc -> Doc
<> Doc
semi

decls :: [Decl] -> Doc
decls :: [Decl] -> Doc
decls = [Doc] -> Doc
vcat ([Doc] -> Doc) -> ([Decl] -> [Doc]) -> [Decl] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Doc -> Doc) -> [Doc] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Doc -> Doc -> Doc
<> Doc
semi) ([Doc] -> [Doc]) -> ([Decl] -> [Doc]) -> [Decl] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Decl -> Maybe Doc) -> [Decl] -> [Doc]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Decl -> Maybe Doc
decl

decl :: Decl -> Maybe Doc
decl :: Decl -> Maybe Doc
decl (NetDecl i :: String
i r :: Maybe Range
r Nothing) = Doc -> Maybe Doc
forall a. a -> Maybe a
Just (Doc -> Maybe Doc) -> Doc -> Maybe Doc
forall a b. (a -> b) -> a -> b
$
  String -> Doc
text "signal" Doc -> Doc -> Doc
<+> String -> Doc
text String
i Doc -> Doc -> Doc
<+> Doc
colon Doc -> Doc -> Doc
<+> Maybe Range -> Doc
slv_type Maybe Range
r

decl (NetDecl i :: String
i r :: Maybe Range
r (Just init :: Expr
init)) = Doc -> Maybe Doc
forall a. a -> Maybe a
Just (Doc -> Maybe Doc) -> Doc -> Maybe Doc
forall a b. (a -> b) -> a -> b
$
  String -> Doc
text "signal" Doc -> Doc -> Doc
<+> String -> Doc
text String
i Doc -> Doc -> Doc
<+> Doc
colon Doc -> Doc -> Doc
<+> Maybe Range -> Doc
slv_type Maybe Range
r Doc -> Doc -> Doc
<+> String -> Doc
text ":=" Doc -> Doc -> Doc
<+> Expr -> Doc
expr Expr
init

decl (MemDecl i :: String
i Nothing dsize :: Maybe Range
dsize Nothing) = Doc -> Maybe Doc
forall a. a -> Maybe a
Just (Doc -> Maybe Doc) -> Doc -> Maybe Doc
forall a b. (a -> b) -> a -> b
$
    String -> Doc
text "signal" Doc -> Doc -> Doc
<+> String -> Doc
text String
i Doc -> Doc -> Doc
<+> Doc
colon Doc -> Doc -> Doc
<+> Maybe Range -> Doc
slv_type Maybe Range
dsize

decl (MemDecl i :: String
i (Just asize :: Range
asize) dsize :: Maybe Range
dsize def :: Maybe [Expr]
def) = Doc -> Maybe Doc
forall a. a -> Maybe a
Just (Doc -> Maybe Doc) -> Doc -> Maybe Doc
forall a b. (a -> b) -> a -> b
$
  String -> Doc
text "type" Doc -> Doc -> Doc
<+> Doc
mtype  Doc -> Doc -> Doc
<+> String -> Doc
text "is" Doc -> Doc -> Doc
<+>
       String -> Doc
text "array" Doc -> Doc -> Doc
<+> Range -> Doc
range Range
asize Doc -> Doc -> Doc
<+> String -> Doc
text "of" Doc -> Doc -> Doc
<+> Maybe Range -> Doc
slv_type Maybe Range
dsize Doc -> Doc -> Doc
<> Doc
semi Doc -> Doc -> Doc
$$
  String -> Doc
text "signal" Doc -> Doc -> Doc
<+> String -> Doc
text String
i Doc -> Doc -> Doc
<+> Doc
colon Doc -> Doc -> Doc
<+> Doc
mtype Doc -> Doc -> Doc
<> Doc
def_txt
 where mtype :: Doc
mtype = String -> Doc
text String
i Doc -> Doc -> Doc
<> String -> Doc
text "_type"
       def_txt :: Doc
def_txt = case Maybe [Expr]
def of
                  Nothing -> Doc
empty
                  Just [xs :: Expr
xs] -> Doc
empty Doc -> Doc -> Doc
<+> String -> Doc
text ":=" Doc -> Doc -> Doc
<+> Doc -> Doc
parens (String -> Doc
text "0 =>" Doc -> Doc -> Doc
<+> Expr -> Doc
expr Expr
xs)
                  Just xs :: [Expr]
xs -> Doc
empty Doc -> Doc -> Doc
<+> String -> Doc
text ":=" Doc -> Doc -> Doc
<+> Doc -> Doc
parens ([Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate Doc
comma ((Expr -> Doc) -> [Expr] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Expr -> Doc
expr [Expr]
xs))

decl _d :: Decl
_d = Maybe Doc
forall a. Maybe a
Nothing

insts ::  [Decl] -> Doc
insts :: [Decl] -> Doc
insts = [Doc] -> Doc
vcat ([Doc] -> Doc) -> ([Decl] -> [Doc]) -> [Decl] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Doc -> Doc) -> [Doc] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Doc -> Doc -> Doc
<> Doc
semi) ([Doc] -> [Doc]) -> ([Decl] -> [Doc]) -> [Decl] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe Doc] -> [Doc]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Doc] -> [Doc])
-> ([Decl] -> [Maybe Doc]) -> [Decl] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Decl -> Maybe Doc) -> [String] -> [Decl] -> [Maybe Doc]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith String -> Decl -> Maybe Doc
inst [String]
gensyms
  where gensyms :: [String]
gensyms = ["proc" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
i | Integer
i <- [(0::Integer)..]]

inst :: String -> Decl -> Maybe Doc
inst :: String -> Decl -> Maybe Doc
inst _ (NetAssign i :: String
i e :: Expr
e) = Doc -> Maybe Doc
forall a. a -> Maybe a
Just (Doc -> Maybe Doc) -> Doc -> Maybe Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
i Doc -> Doc -> Doc
<+> String -> Doc
text "<=" Doc -> Doc -> Doc
<+> Expr -> Doc
expr Expr
e
inst _ (MemAssign i :: String
i idx :: Expr
idx e :: Expr
e) = Doc -> Maybe Doc
forall a. a -> Maybe a
Just (Doc -> Maybe Doc) -> Doc -> Maybe Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
i Doc -> Doc -> Doc
<> Doc -> Doc
parens (Expr -> Doc
expr Expr
idx) Doc -> Doc -> Doc
<+> String -> Doc
text "<=" Doc -> Doc -> Doc
<+> Expr -> Doc
expr Expr
e

inst gensym :: String
gensym (ProcessDecl (Event clk :: Expr
clk edge :: Edge
edge) Nothing s :: Stmt
s) = Doc -> Maybe Doc
forall a. a -> Maybe a
Just (Doc -> Maybe Doc) -> Doc -> Maybe Doc
forall a b. (a -> b) -> a -> b
$
    String -> Doc
text String
gensym Doc -> Doc -> Doc
<+> Doc
colon Doc -> Doc -> Doc
<+> String -> Doc
text "process" Doc -> Doc -> Doc
<> Doc
senlist Doc -> Doc -> Doc
<+> String -> Doc
text "is" Doc -> Doc -> Doc
$$
    String -> Doc
text "begin" Doc -> Doc -> Doc
$$
    Int -> Doc -> Doc
nest 2 (String -> Doc
text "if" Doc -> Doc -> Doc
<+> Int -> Doc -> Doc
nest 2 Doc
event Doc -> Doc -> Doc
<+> String -> Doc
text "then" Doc -> Doc -> Doc
$$
            Int -> Doc -> Doc
nest 2 (Stmt -> Doc
stmt Stmt
s) Doc -> Doc -> Doc
$$
            String -> Doc
text "end if" Doc -> Doc -> Doc
<> Doc
semi) Doc -> Doc -> Doc
$$
    String -> Doc
text "end process" Doc -> Doc -> Doc
<+> String -> Doc
text String
gensym
  where
    senlist :: Doc
senlist = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Expr -> Doc
expr Expr
clk
    event :: Doc
event   = case Edge
edge of
                PosEdge -> String -> Doc
text "rising_edge" Doc -> Doc -> Doc
<> Doc -> Doc
parens (Expr -> Doc
expr Expr
clk)
                NegEdge -> String -> Doc
text "falling_edge" Doc -> Doc -> Doc
<> Doc -> Doc
parens (Expr -> Doc
expr Expr
clk)

inst gensym :: String
gensym (ProcessDecl (Event clk :: Expr
clk clk_edge :: Edge
clk_edge)
             (Just (Event reset :: Expr
reset reset_edge :: Edge
reset_edge, reset_stmt :: Stmt
reset_stmt)) s :: Stmt
s) = Doc -> Maybe Doc
forall a. a -> Maybe a
Just (Doc -> Maybe Doc) -> Doc -> Maybe Doc
forall a b. (a -> b) -> a -> b
$
    String -> Doc
text String
gensym Doc -> Doc -> Doc
<+> Doc
colon Doc -> Doc -> Doc
<+> String -> Doc
text "process" Doc -> Doc -> Doc
<> Doc
senlist Doc -> Doc -> Doc
<+> String -> Doc
text "is" Doc -> Doc -> Doc
$$
    String -> Doc
text "begin" Doc -> Doc -> Doc
$$
    Int -> Doc -> Doc
nest 2 (String -> Doc
text "if" Doc -> Doc -> Doc
<+> Int -> Doc -> Doc
nest 2 Doc
reset_event Doc -> Doc -> Doc
<+> String -> Doc
text "then" Doc -> Doc -> Doc
$$
            Int -> Doc -> Doc
nest 2 (Stmt -> Doc
stmt Stmt
reset_stmt) Doc -> Doc -> Doc
$$
            String -> Doc
text "elsif" Doc -> Doc -> Doc
<+> Int -> Doc -> Doc
nest 2 Doc
clk_event Doc -> Doc -> Doc
<+> String -> Doc
text "then" Doc -> Doc -> Doc
$$
            Int -> Doc -> Doc
nest 2 (Stmt -> Doc
stmt Stmt
s) Doc -> Doc -> Doc
$$
            String -> Doc
text "end if" Doc -> Doc -> Doc
<> Doc
semi) Doc -> Doc -> Doc
$$
    String -> Doc
text "end process" Doc -> Doc -> Doc
<+> String -> Doc
text String
gensym
  where
    senlist :: Doc
senlist     = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
cat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate Doc
comma ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ (Expr -> Doc) -> [Expr] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Expr -> Doc
expr [ Expr
clk, Expr
reset ]
    clk_event :: Doc
clk_event   = case Edge
clk_edge of
                    PosEdge -> String -> Doc
text "rising_edge" Doc -> Doc -> Doc
<> Doc -> Doc
parens (Expr -> Doc
expr Expr
clk)
                    NegEdge -> String -> Doc
text "falling_edge" Doc -> Doc -> Doc
<> Doc -> Doc
parens (Expr -> Doc
expr Expr
clk)
    reset_event :: Doc
reset_event = case Edge
reset_edge of
                    PosEdge -> Expr -> Doc
expr Expr
reset Doc -> Doc -> Doc
<+> String -> Doc
text "= '1'"
                    NegEdge -> Expr -> Doc
expr Expr
reset Doc -> Doc -> Doc
<+> String -> Doc
text "= '0'"


inst _ (InstDecl nm :: String
nm inst :: String
inst gens :: [(String, Expr)]
gens ins :: [(String, Expr)]
ins outs :: [(String, Expr)]
outs) = Doc -> Maybe Doc
forall a. a -> Maybe a
Just (Doc -> Maybe Doc) -> Doc -> Maybe Doc
forall a b. (a -> b) -> a -> b
$
  String -> Doc
text String
inst Doc -> Doc -> Doc
<+> Doc
colon Doc -> Doc -> Doc
<+> String -> Doc
text "entity" Doc -> Doc -> Doc
<+> String -> Doc
text String
nm Doc -> Doc -> Doc
$$
       Doc
gs Doc -> Doc -> Doc
$$
       Doc
ps
 where
   gs :: Doc
gs | [(String, Expr)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(String, Expr)]
gens = Doc
empty
      | Bool
otherwise =
        String -> Doc
text "generic map" Doc -> Doc -> Doc
<+>
         (Doc -> Doc
parens ([Doc] -> Doc
cat (Doc -> [Doc] -> [Doc]
punctuate Doc
comma  [String -> Doc
text String
i Doc -> Doc -> Doc
<+> String -> Doc
text "=>" Doc -> Doc -> Doc
<+> Expr -> Doc
expr Expr
e | (i :: String
i,e :: Expr
e) <- [(String, Expr)]
gens])))
   -- Assume that ports is never null
   ps :: Doc
ps = String -> Doc
text "port map" Doc -> Doc -> Doc
<+>
         Doc -> Doc
parens ([Doc] -> Doc
cat (Doc -> [Doc] -> [Doc]
punctuate Doc
comma  [String -> Doc
text String
i Doc -> Doc -> Doc
<+> String -> Doc
text "=>" Doc -> Doc -> Doc
<+> Expr -> Doc
expr Expr
e | (i :: String
i,e :: Expr
e) <- ([(String, Expr)]
ins [(String, Expr)] -> [(String, Expr)] -> [(String, Expr)]
forall a. [a] -> [a] -> [a]
++ [(String, Expr)]
outs)]))


inst gensym :: String
gensym (InitProcessDecl s :: Stmt
s) = Doc -> Maybe Doc
forall a. a -> Maybe a
Just (Doc -> Maybe Doc) -> Doc -> Maybe Doc
forall a b. (a -> b) -> a -> b
$
    String -> Doc
text "-- synthesis_off" Doc -> Doc -> Doc
$$
    String -> Doc
text String
gensym Doc -> Doc -> Doc
<+> Doc
colon Doc -> Doc -> Doc
<+> String -> Doc
text "process" Doc -> Doc -> Doc
<> Doc
senlist Doc -> Doc -> Doc
<+> String -> Doc
text "is" Doc -> Doc -> Doc
$$
    String -> Doc
text "begin" Doc -> Doc -> Doc
$$
    Int -> Doc -> Doc
nest 2 (Stmt -> Doc
stmt Stmt
s) Doc -> Doc -> Doc
$$
    String -> Doc
text "wait" Doc -> Doc -> Doc
<> Doc
semi Doc -> Doc -> Doc
$$
    String -> Doc
text "end process" Doc -> Doc -> Doc
<+> String -> Doc
text String
gensym Doc -> Doc -> Doc
$$
    String -> Doc
text "-- synthesis_on"
  where senlist :: Doc
senlist = Doc -> Doc
parens Doc
empty

-- TODO: get multline working
inst _ (CommentDecl msg :: String
msg) = Doc -> Maybe Doc
forall a. a -> Maybe a
Just (Doc -> Maybe Doc) -> Doc -> Maybe Doc
forall a b. (a -> b) -> a -> b
$
	([Doc] -> Doc
vcat [ String -> Doc
text "--" Doc -> Doc -> Doc
<+> String -> Doc
text String
m | String
m <- String -> [String]
lines String
msg ])

inst _ _d :: Decl
_d = Maybe Doc
forall a. Maybe a
Nothing

stmt :: Stmt -> Doc
stmt :: Stmt -> Doc
stmt (Assign l :: Expr
l r :: Expr
r) = Expr -> Doc
expr Expr
l Doc -> Doc -> Doc
<+> String -> Doc
text "<=" Doc -> Doc -> Doc
<+> Expr -> Doc
expr Expr
r Doc -> Doc -> Doc
<> Doc
semi
stmt (Seq ss :: [Stmt]
ss) = [Doc] -> Doc
vcat ((Stmt -> Doc) -> [Stmt] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Stmt -> Doc
stmt [Stmt]
ss)
stmt (If e :: Expr
e t :: Stmt
t Nothing) =
  String -> Doc
text "if" Doc -> Doc -> Doc
<+> Expr -> Doc
expr Expr
e Doc -> Doc -> Doc
<+> String -> Doc
text "then" Doc -> Doc -> Doc
$$
  Int -> Doc -> Doc
nest 2 (Stmt -> Doc
stmt Stmt
t) Doc -> Doc -> Doc
$$
  String -> Doc
text "end if" Doc -> Doc -> Doc
<> Doc
semi
stmt (If p :: Expr
p t :: Stmt
t (Just e :: Stmt
e)) =
  String -> Doc
text "if" Doc -> Doc -> Doc
<+> Expr -> Doc
expr Expr
p Doc -> Doc -> Doc
<+> String -> Doc
text "then" Doc -> Doc -> Doc
$$
  Int -> Doc -> Doc
nest 2 (Stmt -> Doc
stmt Stmt
t) Doc -> Doc -> Doc
$$
  String -> Doc
text "else" Doc -> Doc -> Doc
$$
  Int -> Doc -> Doc
nest 2 (Stmt -> Doc
stmt Stmt
e) Doc -> Doc -> Doc
$$
  String -> Doc
text "end if" Doc -> Doc -> Doc
<> Doc
semi
stmt (Case d :: Expr
d ps :: [([Expr], Stmt)]
ps def :: Maybe Stmt
def) =
    String -> Doc
text "case" Doc -> Doc -> Doc
<+> Expr -> Doc
expr Expr
d Doc -> Doc -> Doc
<+> String -> Doc
text "of" Doc -> Doc -> Doc
$$
    [Doc] -> Doc
vcat ((([Expr], Stmt) -> Doc) -> [([Expr], Stmt)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ([Expr], Stmt) -> Doc
mkAlt [([Expr], Stmt)]
ps) Doc -> Doc -> Doc
$$
    Doc
defDoc Doc -> Doc -> Doc
$$
    String -> Doc
text "end case" Doc -> Doc -> Doc
<> Doc
semi
  where defDoc :: Doc
defDoc = Doc -> (Stmt -> Doc) -> Maybe Stmt -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
empty Stmt -> Doc
mkDefault Maybe Stmt
def
        mkDefault :: Stmt -> Doc
mkDefault s :: Stmt
s = String -> Doc
text "when others =>" Doc -> Doc -> Doc
$$
                      Int -> Doc -> Doc
nest 2 (Stmt -> Doc
stmt Stmt
s)
        mkAlt :: ([Expr], Stmt) -> Doc
mkAlt ([g :: Expr
g],s :: Stmt
s) = String -> Doc
text "when" Doc -> Doc -> Doc
<+> Expr -> Doc
expr Expr
g Doc -> Doc -> Doc
<+> String -> Doc
text "=>" Doc -> Doc -> Doc
$$
                        Int -> Doc -> Doc
nest 2 (Stmt -> Doc
stmt Stmt
s)


to_bits :: Integral a => Int -> a -> [Bit]
to_bits :: Int -> a -> [Bit]
to_bits size :: Int
size val :: a
val = (a -> Bit) -> [a] -> [Bit]
forall a b. (a -> b) -> [a] -> [b]
map (\x :: a
x -> if a -> Bool
forall a. Integral a => a -> Bool
odd a
x then Bit
T else Bit
F)
                   ([a] -> [Bit]) -> [a] -> [Bit]
forall a b. (a -> b) -> a -> b
$ [a] -> [a]
forall a. [a] -> [a]
reverse
                   ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
size
                   ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ (a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a -> a -> a
forall a. Integral a => a -> a -> a
`mod` 2)
                   ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ (a -> a) -> a -> [a]
forall a. (a -> a) -> a -> [a]
iterate (a -> a -> a
forall a. Integral a => a -> a -> a
`div` 2)
                   (a -> [a]) -> a -> [a]
forall a b. (a -> b) -> a -> b
$ a
val

bit_char :: Bit -> Char
bit_char :: Bit -> Char
bit_char T = '1'
bit_char F = '0'
bit_char U = 'U'  -- 'U' means uninitialized,
                  -- 'X' means forced to unknown.
                  -- not completely sure that 'U' is the right choice here.
bit_char Z = 'Z'

bits :: [Bit] -> Doc
bits :: [Bit] -> Doc
bits = Doc -> Doc
doubleQuotes (Doc -> Doc) -> ([Bit] -> Doc) -> [Bit] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text (String -> Doc) -> ([Bit] -> String) -> [Bit] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bit -> Char) -> [Bit] -> String
forall a b. (a -> b) -> [a] -> [b]
map Bit -> Char
bit_char

expr_lit :: Maybe Size -> ExprLit -> Doc
expr_lit :: Maybe Int -> ExprLit -> Doc
expr_lit Nothing (ExprNum i :: Integer
i)          = Int -> Doc
int (Int -> Doc) -> Int -> Doc
forall a b. (a -> b) -> a -> b
$ Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i
expr_lit (Just sz :: Int
sz) (ExprNum i :: Integer
i)        = [Bit] -> Doc
bits (Int -> Integer -> [Bit]
forall a. Integral a => Int -> a -> [Bit]
to_bits Int
sz Integer
i)
expr_lit _ (ExprBit x :: Bit
x)                = Doc -> Doc
quotes (Char -> Doc
char (Bit -> Char
bit_char Bit
x))
                                        -- ok to ignore the size here?
expr_lit Nothing (ExprBitVector xs :: [Bit]
xs)   = [Bit] -> Doc
bits [Bit]
xs
expr_lit (Just sz :: Int
sz) (ExprBitVector xs :: [Bit]
xs) = [Bit] -> Doc
bits ([Bit] -> Doc) -> [Bit] -> Doc
forall a b. (a -> b) -> a -> b
$ Int -> [Bit] -> [Bit]
forall a. Int -> [a] -> [a]
take Int
sz [Bit]
xs

expr :: Expr -> Doc
expr :: Expr -> Doc
expr (ExprLit mb_sz :: Maybe Int
mb_sz lit :: ExprLit
lit) = Maybe Int -> ExprLit -> Doc
expr_lit Maybe Int
mb_sz ExprLit
lit
expr (ExprVar n :: String
n) = String -> Doc
text String
n
expr (ExprIndex s :: String
s i :: Expr
i) = String -> Doc
text String
s Doc -> Doc -> Doc
<> Doc -> Doc
parens (Expr -> Doc
expr Expr
i)
expr (ExprSlice s :: String
s h :: Expr
h l :: Expr
l)
  | Expr
h Expr -> Expr -> Bool
forall a. Ord a => a -> a -> Bool
>= Expr
l = String -> Doc
text String
s Doc -> Doc -> Doc
<> Doc -> Doc
parens (Expr -> Doc
expr Expr
h Doc -> Doc -> Doc
<+> String -> Doc
text "downto" Doc -> Doc -> Doc
<+> Expr -> Doc
expr Expr
l)
  | Bool
otherwise = String -> Doc
text String
s Doc -> Doc -> Doc
<> Doc -> Doc
parens (Expr -> Doc
expr Expr
h Doc -> Doc -> Doc
<+> String -> Doc
text "to" Doc -> Doc -> Doc
<+> Expr -> Doc
expr Expr
l)

expr (ExprConcat ss :: [Expr]
ss) = [Doc] -> Doc
hcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate (String -> Doc
text " & ") ((Expr -> Doc) -> [Expr] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Expr -> Doc
expr [Expr]
ss)
expr (ExprUnary op :: UnaryOp
op e :: Expr
e) = UnaryOp -> Doc -> Doc
lookupUnary UnaryOp
op (Expr -> Doc
expr Expr
e)
expr (ExprBinary op :: BinaryOp
op a :: Expr
a b :: Expr
b) = BinaryOp -> Doc -> Doc -> Doc
lookupBinary BinaryOp
op (Expr -> Doc
expr Expr
a) (Expr -> Doc
expr Expr
b)
expr (ExprFunCall f :: String
f args :: [Expr]
args) = String -> Doc
text String
f Doc -> Doc -> Doc
<> Doc -> Doc
parens ([Doc] -> Doc
cat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate Doc
comma ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ (Expr -> Doc) -> [Expr] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Expr -> Doc
expr [Expr]
args)
expr (ExprCond c :: Expr
c t :: Expr
t e :: Expr
e) = Expr -> Doc
expr Expr
t Doc -> Doc -> Doc
<+> String -> Doc
text "when" Doc -> Doc -> Doc
<+> Expr -> Doc
expr Expr
c Doc -> Doc -> Doc
<+> String -> Doc
text "else" Doc -> Doc -> Doc
$$ Expr -> Doc
expr Expr
e
expr (ExprCase _ [] Nothing) = String -> Doc
forall a. HasCallStack => String -> a
error "VHDL does not support non-defaulted ExprCase"
expr (ExprCase _ [] (Just e :: Expr
e)) = Expr -> Doc
expr Expr
e
expr (ExprCase e :: Expr
e (([],_):alts :: [([Expr], Expr)]
alts) def :: Maybe Expr
def) = Expr -> Doc
expr (Expr -> [([Expr], Expr)] -> Maybe Expr -> Expr
ExprCase Expr
e [([Expr], Expr)]
alts Maybe Expr
def)
expr (ExprCase e :: Expr
e ((p :: Expr
p:ps :: [Expr]
ps,alt :: Expr
alt):alts :: [([Expr], Expr)]
alts) def :: Maybe Expr
def) =
	Expr -> Doc
expr (Expr -> Expr -> Expr -> Expr
ExprCond (BinaryOp -> Expr -> Expr -> Expr
ExprBinary BinaryOp
Equals Expr
e Expr
p) Expr
alt (Expr -> [([Expr], Expr)] -> Maybe Expr -> Expr
ExprCase Expr
e (([Expr]
ps,Expr
alt)([Expr], Expr) -> [([Expr], Expr)] -> [([Expr], Expr)]
forall a. a -> [a] -> [a]
:[([Expr], Expr)]
alts) Maybe Expr
def))
expr x :: Expr
x = String -> Doc
text (Expr -> String
forall a. Show a => a -> String
show Expr
x)


lookupUnary :: UnaryOp -> Doc -> Doc
lookupUnary :: UnaryOp -> Doc -> Doc
lookupUnary op :: UnaryOp
op e :: Doc
e = String -> Doc
text (UnaryOp -> String
unOp UnaryOp
op) Doc -> Doc -> Doc
<> Doc -> Doc
parens Doc
e

unOp :: UnaryOp -> String
unOp :: UnaryOp -> String
unOp UPlus = ""
unOp UMinus = "-"
unOp LNeg = "not"
unOp UAnd = "and"
unOp UNand = "nand"
unOp UOr = "or"
unOp UNor = "nor"
unOp UXor = "xor"
unOp UXnor = "xnor"
unOp Neg = "-"


-- "(\\(.*\\), text \\(.*\\)),"
lookupBinary :: BinaryOp -> Doc -> Doc -> Doc
lookupBinary :: BinaryOp -> Doc -> Doc -> Doc
lookupBinary op :: BinaryOp
op a :: Doc
a b :: Doc
b = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc
a Doc -> Doc -> Doc
<+> String -> Doc
text (BinaryOp -> String
binOp BinaryOp
op) Doc -> Doc -> Doc
<+> Doc
b

binOp :: BinaryOp -> String
binOp :: BinaryOp -> String
binOp Pow = "**"
binOp Plus = "+"
binOp Minus = "-"
binOp Times = "*"
binOp Divide = "/"
binOp Modulo = "mod"
binOp Equals = "="
binOp NotEquals = "!="
binOp CEquals = "="
binOp CNotEquals = "!="
binOp LAnd = "and"
binOp LOr = "or"
binOp LessThan = "<"
binOp LessEqual = "<="
binOp GreaterThan = ">"
binOp GreaterEqual = ">="
binOp And = "and"
binOp Nand = "nand"
binOp Or = "or"
binOp Nor = "nor"
binOp Xor = "xor"
binOp Xnor = "xnor"
binOp ShiftLeft = "sll"
binOp ShiftRight = "srl"
binOp RotateLeft = "rol"
binOp RotateRight = "ror"
binOp ShiftLeftArith = "sla"
binOp ShiftRightArith = "sra"

slv_type :: Maybe Range -> Doc
slv_type :: Maybe Range -> Doc
slv_type Nothing = String -> Doc
text "std_logic"
slv_type (Just r :: Range
r) =  String -> Doc
text "std_logic_vector" Doc -> Doc -> Doc
<> Range -> Doc
range Range
r

range :: Range -> Doc
range :: Range -> Doc
range (Range high :: Expr
high low :: Expr
low) = Doc -> Doc
parens (Expr -> Doc
expr Expr
high Doc -> Doc -> Doc
<+> String -> Doc
text "downto" Doc -> Doc -> Doc
<+> Expr -> Doc
expr Expr
low)