content: -- {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE ExistentialQuantification #-}
  {-# LANGUAGE TypeSynonymInstances #-}
  {-# LANGUAGE GADTs #-}
  {-# LANGUAGE PatternSynonyms #-}
  {-# LANGUAGE CPP #-}
  {-# LANGUAGE TypeOperators #-}
  {-# LANGUAGE ConstraintKinds #-}
  {-# LANGUAGE TypeFamilies #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE TypeApplications #-}
  {-# LANGUAGE LambdaCase #-}
  
  {-# OPTIONS_GHC -Wall #-}
  {-# OPTIONS_GHC -Wno-orphans #-} -- TEMP
  
  -- | Generate Verilog code from a circuit graph
  
  module ConCat.Hardware.Verilog
    ( genVerilog,runVerilog
    ) where
  
  import Control.Arrow    (first, second)
  import Data.List        ({-intercalate,(\\),-}  intersect, nub)
  import System.Directory (createDirectoryIfMissing)
  import Text.PrettyPrint.HughesPJClass hiding (first)
  
  import Language.Netlist.AST
  import Language.Netlist.Util
  import Language.Netlist.GenVerilog
  import Language.Verilog.PrettyPrint
  
  import ConCat.Circuit
    (Bus(..),GenBuses,(:>),simpleComp,mkGraph,CompS(..),busTy)  -- ,systemSuccess,)
  import qualified ConCat.Circuit as C
  
  effectVerilog :: (GenBuses a, GenBuses b) => String -> (a :> b) -> String
  effectVerilog name circ = unlines
    [ "/***"
    , "* Automatically generated Verilog code. Do not edit."
    , "*"
    , "* This code was generated by the Haskell ConCat library, via compiling to categories."
    , "***/"
    , render $ ppModule $ mk_module (verilog name circ)
    ]
  
  genVerilog :: (GenBuses a, GenBuses b) => String -> (a :> b) -> IO ()
  genVerilog name circ =
    do createDirectoryIfMissing False outDir
       let o = outFile name
       writeFile o (effectVerilog name circ)
       putStrLn ("Wrote " ++ o)
  
  runVerilog :: (GenBuses a, GenBuses b) => String -> (a :> b) -> IO ()
  runVerilog name circ =
    do genVerilog name circ
       -- systemSuccess $ printf "%s %s" open (outFile name)
  
  outDir :: String
  outDir = "out"
  
  outFile :: String -> String
  outFile name = outDir++"/"++name++".v"
  
  -- Generate Verilog code for a circuit.
  verilog :: (GenBuses a, GenBuses b) => String -> (a :> b) -> Module
  verilog name  = mkModule name
                . fmap simpleComp
                . mkGraph
  -- TODO: Abstract fmap simpleComp . mkGraph, which also appears in Show (a :> b)
  -- and SMT and GLSL.
  
  -- ProcessDecl Event (Maybe (Event, Stmt)) Stmt
  mkModule :: String -> [CompS] -> Module
  mkModule name cs = Module name
                            (("clk", Nothing) : map (first (++ "_d")) (f modIns))
                            (map (first (++ "_q")) (f modOuts))
                            []
                            ( map (busToReg "")   modIns  ++
                              map (busToReg "_q") modOuts ++
                              map busToNet        modNets ++
                              [ProcessDecl (Event (ExprVar "clk") PosEdge) Nothing
                                (Seq (map ((\x -> Assign (ExprVar x) (ExprVar (x ++ "_d"))) . busName) modIns ++
                                      map ((\x -> Assign (ExprVar (x ++ "_q")) (ExprVar x)) . busName) modOuts
                                     )
                                )
                              ] ++
                              map mkAssignment cs'
                            )
    where
      f       = map (second (makeRange Down) . busId')
      modIns  = compOuts inComp
      modOuts = compIns  outComp
      modNets = allIns `intersect` allOuts
      allIns  = nub $ concatMap compIns  cs'
      allOuts = concatMap compOuts cs'
      cs'     = filter (flip notElem ["In", "Out"] . compName) cs
      inComp  = firstCompNamed "In"
      outComp = firstCompNamed "Out"
      firstCompNamed nm = head $ filter ((== nm) . compName) cs
  
  busId' :: Bus -> (String, Int)
  busId' (Bus cId ix ty) = ('n' : show cId ++ ('_' : show ix), fromIntegral $ width ty)
    where width = \case
                    C.Void       -> err "Void"
                    C.Unit       -> 0
                    C.Bool       -> 1
                    C.Int        -> 32
                    C.Integer    -> 32   -- Is there a right choice here?
                    C.Float      -> 32
                    C.Double     -> 64
                    C.Finite n   -> ceiling (log (fromInteger n) :: Double)
                    C.Vector n a -> n * width a
                    C.Prod   _ _ -> err "Prod"
                    C.Sum    _ _ -> err "Sum"
                    C.Fun    _ _ -> err "Fun"
          err t = error $ "ConCat.Hardware.Verilog.busId': Don't know what to do with Bus of type " ++ t ++ ", yet."
  
  busName :: Bus -> String
  busName  = fst . busId'
  
  busWidth :: Bus -> Int
  busWidth = snd . busId'
  
  -- busType :: Bus -> C.Ty
  -- busType (Bus _ _ ty) = ty
  
  busToNet :: Bus -> Decl
  busToNet b = NetDecl (busName b) (makeRange Down (busWidth b)) Nothing
  
  busToReg :: String -> Bus -> Decl
  busToReg suf b = MemDecl (busName b ++ suf) Nothing (makeRange Down (busWidth b)) Nothing
  
  -- NetAssign Ident Expr
  mkAssignment :: CompS -> Decl
  mkAssignment c | [o] <- outs = assign o prim ins ty
                 | otherwise   = CommentDecl $ "Concat.Hardware.Verilog.mkAssignment: Component, '" ++ prim ++ "', has no outputs!"
    where prim   = compName c
          ins    = map busName $ compIns  c
          outs   = map busName $ compOuts c
          ty     = busTy . head $ compOuts c
  
  assign :: String -> String -> [String] -> C.Ty -> Decl
  assign o prim ins ty =
    case prim of
      "not"    -> assignUnary  LNeg
      "&&"     -> assignBinary LAnd
      "||"     -> assignBinary LOr
      "<"      -> assignBinary LessThan
      ">"      -> assignBinary GreaterThan
      "<="     -> assignBinary LessEqual
      ">="     -> assignBinary GreaterEqual
      "=="     -> assignBinary Equals
      "/="     -> assignBinary NotEquals
      "negate" -> assignUnary  UMinus
      "+"      -> assignBinary Plus
      "-"      -> assignBinary Minus
      "−"      -> assignBinary Minus
      "*"      -> assignBinary Times
      "/"      -> assignBinary Divide
      "mod"    -> assignBinary Modulo
      "xor"    -> assignBinary Xor
      "if"     -> assignConditional
      -- "In"     -> Seq []
      -- "Out"    -> Seq []
      _        -> NetAssign o $ constExpr ty prim
    where
      assignUnary op
        | [in1]      <- ins = NetAssign o $ ExprUnary op (ExprVar in1)
        | otherwise         = error $ errStr "unary"
      assignBinary op
        | [in1, in2] <- ins = NetAssign o $ ExprBinary op (ExprVar in1) (ExprVar in2)
        | otherwise         = error $ errStr "binary"
      assignConditional
        | [p, t, f]  <- ins = NetAssign o $ ExprCond (ExprVar p) (ExprVar t) (ExprVar f)
        | otherwise         = error $ errStr "conditional"
      errStr _ = "ConCat.Hardware.Verilog.assign: I received an incorrect number of inputs.\n"
  
  constExpr :: C.Ty -> String -> Expr
  constExpr ty prim = case ty of
                        C.Bool   -> ExprLit (Just   1) (ExprBit . boolToBit    $ rp)
                        C.Int    -> ExprLit (Just  32) (ExprNum                $ rp)
                        C.Float  -> ExprLit Nothing    (ExprFloat              $ rp)
                        -- C.Double -> ExprLit (Just 128) (ExprDouble             $ rp)
                        _        -> error $ "ConCat.Hardware.Verilog.constExpr: Unrecognized type: " ++ show ty
    where rp :: Read a => a
          rp = read prim
  
  boolToBit :: Bool -> Bit
  boolToBit True  = T
  boolToBit False = F
  
  -- These are, currently, commented out of ConCat/Circuit.hs.
  -- compId :: CompS -> CompId
  -- compId :: CompS -> Int
  -- compId (CompS n _ _ _) = n
  -- compName :: CompS -> PrimName
  compName :: CompS -> String
  compName (CompS _ nm _ _) = nm
  -- compIns :: CompS -> [Input]
  compIns :: CompS -> [Bus]
  compIns (CompS _ _ ins _) = ins
  -- compOuts :: CompS -> [Output]
  compOuts :: CompS -> [Bus]
  compOuts (CompS _ _ _ outs) = outs
  
  