{-# LANGUAGE TemplateHaskell, TypeOperators #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  ForSyDe.Deep.Backend.VHDL.Traverse
-- Copyright   :  (c) ES Group, KTH/ICT/ES 2007-2013
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  forsyde-dev@ict.kth.se
-- Stability   :  experimental
-- Portability :  portable
--
-- Functions to translate elements of the intermediate system
-- representation to elements of the VHDL AST.
-----------------------------------------------------------------------------
module ForSyDe.Deep.Backend.VHDL.Translate where

import ForSyDe.Deep.Backend.VHDL.AST
import qualified ForSyDe.Deep.Backend.VHDL.AST as VHDL
import ForSyDe.Deep.Backend.VHDL.Constants
import ForSyDe.Deep.Backend.VHDL.Generate
import ForSyDe.Deep.Backend.VHDL.Traverse.VHDLM
import ForSyDe.Deep.Backend.VHDL.Translate.HigherOrderFunctions

import ForSyDe.Deep.Ids
import ForSyDe.Deep.AbsentExt
import ForSyDe.Deep.Signal
import ForSyDe.Deep.Bit hiding (not)
import ForSyDe.Deep.ForSyDeErr
import ForSyDe.Deep.System.SysDef
import ForSyDe.Deep.Process.ProcFun
import ForSyDe.Deep.Process.ProcVal
import ForSyDe.Deep.Process.ProcType

import Data.Data (tyconUQname)
import Data.Int
import Data.Char (digitToInt)
import Data.List (intersperse)
import Data.Maybe (isJust, fromJust)
import Control.Monad.State
import qualified Data.Set as S
import qualified Language.Haskell.TH as TH
import Language.Haskell.TH hiding (global,Loc)
import qualified Data.Traversable as DT
import Data.Typeable
import Data.Typeable.Internal
import qualified Data.Param.FSVec as V
import Text.Regex.Posix ((=~))

import Data.TypeLevel.Num.Reps
import Data.Typeable.FSDTypeRepLib

-- enable tracing of type translation

-- import Debug.Trace
debug :: a -> String -> a
-- debug = flip trace
debug a _ = a


-- | Translate a System Definition to an Entity, explicitly returning
--   the VHDL identifiers of its output signals.
transSysDef2Ent :: SysLogic -- ^ logic of the system
                -> SysDefVal -- ^ system to translate
                -> VHDLM EntityDec
transSysDef2Ent logic sysDefVal = do
 entId <- transSysId2VHDL (sid sysDefVal)
 inDecs  <- mapM (uncurry $ transPort2IfaceSigDec In)  (iIface sysDefVal)
 outDecs <- mapM (uncurry $ transPort2IfaceSigDec Out) (oIface sysDefVal)
 -- clock and reset implicit declarations
 let implicitDecs = if logic == Sequential then
                     [IfaceSigDec resetId In std_logicTM,
                      IfaceSigDec clockId In std_logicTM]
                     else []
 return $ EntityDec entId (implicitDecs ++ inDecs ++ outDecs)

-- | Translate a 'ZipwithNSY' process to a block returning a declaration of
--   the resulting signal.
transZipWithN2Block :: Label -- ^ process identifier
                    -> [VHDLId] -- ^ input signals
                    -> Loc -- ^ location of the inner function
                    -> TypedProcFunAST -- ^ AST of the inner function
                    -> VHDLId -- ^ output signal
                    -> VHDLM (BlockSm, SigDec)
transZipWithN2Block vPid ins loc ast out = do
 -- Translate the process function
 (f,fName , inFPars, inFTypes, retFType) <-
        withProcFunC ((name.tpast) ast) loc $ transProcFun2VHDL ast
 -- Generate the formal parameters of the block
 let inPars = map (\n -> unsafeIdAppend vPid ("_in" ++ show n)) [1..length ins]
     outPar = unsafeIdAppend vPid "_out"
 -- Generate the port interface of the block
     inDecs = zipWith (\par typ -> IfaceSigDec par In typ) inPars inFTypes
     outDec = IfaceSigDec outPar Out retFType
     iface = inDecs ++ [outDec]
 -- Generate the port map
     pMap = genPMap  (inPars ++ [outPar]) (ins ++ [out])
 -- Generate the function call and signal assignment
     outAssign = genFCallAssign out fName inFPars ins
 return  (BlockSm vPid iface pMap [BDISPB f] [CSSASm outAssign],
          SigDec out retFType Nothing)


-- | Translate a 'ZipwithxSY' process to a block returning a declaration of
--   the resulting signal.
transZipWithx2Block :: Label -- ^ process identifier
                    -> [VHDLId] -- ^ input signals
                    -> Loc -- ^ location of the inner function
                    -> TypedProcFunAST -- ^ AST of the inner function
                    -> VHDLId -- ^ output signal
                    -> VHDLM (BlockSm, SigDec)
transZipWithx2Block vPid ins loc ast out = do
 -- Translate the process function
 (f, fName, [inFPar], [inFType], retFType) <-
        withProcFunC ((name.tpast) ast) loc $ transProcFun2VHDL ast
 -- Figure out the type of the inputs from the
 -- function's input vector type (horrible hack, but it works)
 let [[_,suffix]] = (fromVHDLId inFType) =~ "^fsvec_[0-9]*_(.*)$"
     inType = unsafeVHDLBasicId $ suffix
 -- Generate the formal parameters of the block
     inPars = map (\n -> unsafeIdAppend vPid ("_in" ++ show n)) [1..length ins]
     outPar = unsafeIdAppend vPid "_out"
 -- Generate the port interface of the block
     inDecs = map (\par -> IfaceSigDec par In inType) inPars
     outDec = IfaceSigDec outPar Out retFType
     iface = inDecs ++ [outDec]
 -- Generate the port map
     pMap = genPMap  (inPars ++ [outPar]) (ins ++ [out])
 -- Generate the function call and signal assignment
     aggregate = Aggregate $
                  map (\e -> ElemAssoc Nothing (PrimName(NSimple e))) inPars
     fCall = PrimFCall $ FCall (NSimple fName)
                               [Just inFPar :=>: ADExpr aggregate]
     outAssign = genExprAssign outPar fCall
 return  (BlockSm vPid iface pMap [BDISPB f] [CSSASm outAssign],
          SigDec out retFType Nothing)

-- | Translate a 'UnzipNSY' process to a block returning a declaration of
--   the resulting signal.
transUnzipNSY2Block :: Label -- ^ process identifier
                    -> VHDLId -- ^ input signal
                    -> [VHDLId] -- ^ output signals
                    -> [FSDTypeRep] -- ^ output signal types
                    -> VHDLM (BlockSm, [SigDec])
transUnzipNSY2Block vPid inSig outSigs outTRTypes = do
 -- Generate the formal parameters of the block
 let inPar = unsafeIdAppend vPid "_in"
     outPars = map (\n -> unsafeIdAppend vPid ("_out" ++ show n))
                   [1..length outSigs]
 -- Generate the port interface of the block
     nOuts = length outSigs
     inTRType = (fsdTupleTyCon nOuts) `fsdTyConApp` outTRTypes
 outTMTypes <- mapM transTR2TM outTRTypes
 inTMType <- transTR2TM inTRType
 let inDec = IfaceSigDec inPar In inTMType
     outDecs = zipWith (\par typ -> IfaceSigDec par Out typ) outPars outTMTypes
     iface = inDec : outDecs
 -- Generate the port map
     pMap = genPMap  (inPar : outPars) (inSig : outSigs)
 -- Generate the signal assignments
     genOrigExp n = (PrimName $ NSelected
                              (NSimple inPar :.: tupVHDLSuffix n))
     genOutAssign outSig n = CSSASm $ genExprAssign outSig (genOrigExp n)
     outAssigns = zipWith genOutAssign outPars [(1::Int)..]
 return  (BlockSm vPid iface pMap [] outAssigns,
          zipWith (\sig typ -> SigDec sig typ Nothing) outSigs outTMTypes)



-- | Translate a 'UnzipxSY' process to a block returning a declaration of
--   the resulting signal.
transUnzipxSY2Block :: Label -- ^ process identifier
                    -> VHDLId -- ^ input signal
                    -> [VHDLId] -- ^ output signals
                    -> FSDTypeRep -- ^ type of vector elements
                    -> Int -- ^ vector Size
                    -> VHDLM (BlockSm, [SigDec])
transUnzipxSY2Block vPid inSig outSigs elemTR vSize = do
 -- Generate the formal parameters of the block
 let inPar = unsafeIdAppend vPid "_in"
     outPars = map (\n -> unsafeIdAppend vPid ("_out" ++ show n))
                   [1..length outSigs]
 -- Generate the port interface of the block
     inTRType = fSVecTyCon `fsdTyConApp` [transInt2TLNat vSize, elemTR]
 inTMType <- transTR2TM inTRType
 elemTM <- transTR2TM elemTR
 let inDec = IfaceSigDec inPar In inTMType
     outDecs = map (\par -> IfaceSigDec par Out elemTM) outPars
     iface = inDec : outDecs
 -- Generate the port map
     pMap = genPMap  (inPar : outPars) (inSig : outSigs)
 -- Generate the signal assignments
     genOrigExp n =
        PrimName $ NIndexed (NSimple inPar `IndexedName` [PrimLit  $ show n])
     genOutAssign outSig n = CSSASm $ genExprAssign outSig (genOrigExp n)
     outAssigns = zipWith genOutAssign outPars [(0::Int)..]
 return  (BlockSm vPid iface pMap [] outAssigns,
          map (\sig -> SigDec sig elemTM Nothing) outSigs)




-- | Translate a 'DelaySY' process to a block returning a declaration of
--   the resulting signal.
transDelay2Block ::  Label -- ^ process identifier
                  -> VHDLId -- ^ input signal
                  -> ProcValAST -- ^ AST of the initial value
                                -- of the delay process
                  -> VHDLId   -- ^ output signal
                  -> VHDLM (BlockSm, SigDec)
transDelay2Block vPid inS (ProcValAST exp tr enums) outS = do
 -- Add the enumerated types associated with the value to the global results
 addEnumTypes enums
 -- Get the type of the initial value
 initTR <- transTR2TM tr
 -- Translate the initial value
 initExp <- withProcValC exp $ withInitFunTransST $ (transExp2VHDL exp)
 -- Build the block
 let formalIn  = unsafeIdAppend vPid "_in"
     formalOut = unsafeIdAppend vPid "_out"
     iface = [IfaceSigDec resetId   In  std_logicTM,
              IfaceSigDec clockId   In  std_logicTM,
              IfaceSigDec formalIn  In  initTR,
              IfaceSigDec formalOut Out initTR]
     assocs = [Just resetId   :=>: ADName (NSimple resetId),
               Just clockId   :=>: ADName (NSimple clockId),
               Just formalIn  :=>: ADName (NSimple inS),
               Just formalOut :=>: ADName (NSimple outS)]
     sigAssign = CSSASm (NSimple formalOut :<==:
                           (ConWforms [whenElseReset] inWform (Just whenRE)))
     whenElseReset = WhenElse (Wform [WformElem initExp Nothing])
                               (PrimName (NSimple resetId) :=: PrimLit "'0'")
     inWform = Wform [WformElem (PrimName $ NSimple formalIn) Nothing]
     whenRE = When (PrimFCall $ FCall (NSimple $ unsafeVHDLBasicId "rising_edge")
                                      [Nothing :=>: ADName (NSimple clockId) ])
 return  (BlockSm vPid iface (PMapAspect assocs) [] [sigAssign],
          SigDec outS initTR Nothing)

-- | Translate a System instance into a VHDL component instantion
--   returning the declartion of the output signals
transSysIns2CompIns :: SysLogic -- ^ parent system logic
                    -> Label -- ^ instance identifier
                    -> [VHDLId] -- ^ input signals
                    -> [(VHDLId, FSDTypeRep)] -- ^ output signals
                    -> SysId -- ^ parent system identifier
                    -> [PortId] -- ^ parent input identifiers
                    -> [PortId] -- ^ parent output identifiers
                    -> VHDLM (Maybe CompInsSm, [SigDec])
transSysIns2CompIns logic vPid ins typedOuts parentId parentInIds parentOutIds = do
 if length ins == 0 && length typedOuts == 0
  then return (Nothing, [])
  else do
   -- Create the declarations for the signals
   decs <- mapM (\(name,typ) -> transVHDLName2SigDec name typ Nothing) typedOuts
   -- Create the portmap
   vParentId <- transSysId2VHDL parentId
   vParentInIds <- liftEProne $ mapM mkVHDLExtId parentInIds
   vParentOutIds <- liftEProne $ mapM mkVHDLExtId parentOutIds
   let implicitAssocIds = if logic == Sequential then [resetId, clockId] else []
       assocs =  genAssocElems
                   (implicitAssocIds ++ vParentInIds ++ vParentOutIds)
                   (implicitAssocIds ++ ins          ++ map fst typedOuts)
       entityName = NSelected (NSimple workId :.: SSimple vParentId)
       instantiation = CompInsSm vPid (IUEntity entityName) (PMapAspect assocs)
   return (Just instantiation, decs)


-- | Translate a VHDL Signal to a VHDL Signal declaration
transVHDLName2SigDec ::  SimpleName -- ^ Signal name
             -> FSDTypeRep -- ^ Type of the intermediate signal
             -> Maybe TH.Exp -- ^ Maybe an initializer expression for the signal
             -> VHDLM SigDec
transVHDLName2SigDec vId tr mExp = do
 tm <- transTR2TM tr
 mVExp <- DT.mapM (\e -> withInitFunTransST (transExp2VHDL e)) mExp
 return $ SigDec vId tm mVExp



-------------------------
-- Identifier translation
-------------------------


-- | Translate a VHDL identifier and a type to an interface signal declaration
transVHDLId2IfaceSigDec :: Mode -> VHDLId -> FSDTypeRep -> VHDLM IfaceSigDec
transVHDLId2IfaceSigDec m vid trep = do
 tm  <- transTR2TM trep
 return $ IfaceSigDec vid m tm


-- | Translate a Port to a VHDL Interface signal declaration
transPort2IfaceSigDec :: Mode -> PortId -> FSDTypeRep -> VHDLM IfaceSigDec
transPort2IfaceSigDec m pid trep = do
 sid <- transPortId2VHDL pid
 transVHDLId2IfaceSigDec m sid trep

-- | Translate a local TH name to a VHDL Identifier
transTHName2VHDL :: TH.Name -> VHDLM VHDLId
-- we use pprint becase it shows unique names for local names
-- e.g. let x = 1 in let x =2 in x is printed as
--      let x_0 = 1 in let x_1 = 2 in x_1
-- we want unique names because it saves us from dealing wiht
-- name scopes and having a global name table.
transTHName2VHDL = transPortId2VHDL . tyconUQname  . pprint

-- | Translate a system identifier to a VHDL identifier
transSysId2VHDL :: SysId -> VHDLM VHDLId
transSysId2VHDL = transPortId2VHDL

-- | Translate a process identifier to a VHDL identifier
transProcId2VHDL :: ProcId -> VHDLM VHDLId
transProcId2VHDL = transPortId2VHDL

-- | translate a port identifier to a VHDL Identifier
transPortId2VHDL :: PortId -> VHDLM VHDLId
transPortId2VHDL str = liftEProne $ mkVHDLExtId str


-------------------
-- Type translation
-------------------


-- | translate a 'TypeRep' to a VHDL 'TypeMark'
-- We don't distinguish between a type and its version nested in 'Signal'
-- since it makes no difference in VHDL
transTR2TM :: FSDTypeRep -> VHDLM TypeMark
transTR2TM rep
 -- Is it a Signal?
 | isSignal = transTR2TM  nestedTR `debug` (dbgStr "S")
 -- Is it a primitive type?
 | isJust mPrimitiveTM = return $ fromJust mPrimitiveTM `debug` (dbgStr "P")
 -- Non-Primitive type, try to translate it
 | otherwise = customTR2TM rep `debug` (dbgStr "T")
 where (isSignal, nestedTR) = let (tc,~[tr]) = fsdSplitTyConApp rep
                              in  (tc == signalTyCon, tr)
       signalTyCon  = fsdTyConOf (undefined :: Signal ())
       mPrimitiveTM = lookup rep primTypeTable
       dbgStr k = ">>>>" ++ k ++ " " ++ (typeRepQName rep) ++ "/" ++ (show rep)


-- | Translate a custom 'TypeRep' to a VHDL 'TypeMark'
customTR2TM :: FSDTypeRep -> VHDLM TypeMark
customTR2TM rep = do
 -- Check if it was previously translated
 mTranslated <- lookupCustomType rep
 case mTranslated of
   -- Not translated previously
   Nothing -> do
      -- translate it
      e <- doCustomTR2TM rep
      -- update the translation table and the accumulated type declarations
      addCustomType rep e
      -- return the translation
      case e of
        Left (TypeDec id _) -> return id
        Right (SubtypeDec id _) -> return id
   -- Translated previously
   Just tm -> return tm `debug` "'--> (cache hit)"

-- | Really do the translation (customTR2TM deals with caching)
doCustomTR2TM :: FSDTypeRep -> VHDLM (Either TypeDec SubtypeDec)

-- | FSVec?
--   FSVecs are translated to subtypes of unconstrained vectors.
--   All FSVec operations are translated as operations for the
--   unconstrained type.
doCustomTR2TM rep | isFSVec = do
 -- Translate the type of the elements contained in the vector
 valTM <- transTR2TM valueType
 -- Build the unconstrained vector identifier
 let vectorId = unsafeVHDLContainerId [valTM] ("fsvec_"++ fromVHDLId valTM)
 -- Obtain the unconstrained vector together with its functions and add them
 -- to the global traversing-results (if this wasn't previously done):
 --  * Check if the unconstrained array was previously translated
 vecs <- gets (transUnconsFSVecs.global)
 --  * if it wasn't ...
 when (not $ elem valueType vecs) `debug` (" vectors: " ++ (show vecs)) $ do
      -- create the unconstrained vector type and add it to the global
      -- results. _Only_ if we are not working with "FSVec _ Bit" becuase
      -- "type fsvec_std_logic" is already included in forsyde.vhd.
      when (valueType /= (fsdTy $ typeOf (undefined :: Bit)))
           ((addTypeDec $ TypeDec vectorId (TDA (UnconsArrayDef [fsvec_indexTM] valTM))) `debug` "allegiedly not FSVec _ Bit")
      -- Add the default functions for the unconstrained
      -- vector type to the global results
      let funs =  genUnconsVectorFuns valTM vectorId
      mapM_ addSubProgBody funs
      -- Mark the unconstrained array as translated
      addUnconsFSVec $ valueType

 -- Create the vector subtype identifier
 let subvectorId = unsafeVHDLBasicId ("fsvec_" ++ show size ++ "_" ++
                                     fromVHDLId valTM)
 -- Create the vector subtype declaration
 return $ Right $
     SubtypeDec subvectorId (SubtypeIn vectorId
              (Just $ IndexConstraint [ToRange (PrimLit "0")
                                               (PrimLit (show $ size-1))]))
   where (cons, ~[sizeType,valueType]) = fsdSplitTyConApp rep
         isFSVec = cons == fSVecTyCon
         size = transTLNat2Int sizeType


-- | Tuple?
doCustomTR2TM rep | isTuple = do
  -- Create the elements of the record
  fieldTMs <- mapM transTR2TM args
  let elems = zipWith (\fieldId fieldTM -> ElementDec fieldId fieldTM )
                      [tupVHDLIdSuffix n | n <- [1..]] fieldTMs
  -- Create the Type Declaration identifier
      recordId = unsafeVHDLContainerId fieldTMs $
              (tupStrSuffix $ length fieldTMs) ++ "_" ++
              (concatMap fromVHDLId.intersperse (unsafeVHDLBasicId "_")) fieldTMs
  -- Add the default functions for the tuple type to the global results
      funs = genTupleFuns fieldTMs recordId
  mapM_ addSubProgBody funs
  -- Create the record
  return $ Left $ (TypeDec recordId (TDR $ RecordTypeDef elems))
 where (cons, args) = fsdSplitTyConApp rep
       conStr = fsdTyConName cons
       isTuple = (length conStr > 2) && (all (==',') (reverse.tail.reverse.tail $ conStr))


-- | AbstExt?
doCustomTR2TM rep | isAbsExt = do
  -- Create the elements of the record
  valueTM <- transTR2TM valueTR
  let elems = [ElementDec isPresentId booleanTM,
               ElementDec valueId     valueTM  ]

  -- Create the Type Declaration identifier
      recordId = unsafeVHDLContainerId [valueTM] $
                    "abs_ext_" ++ fromVHDLId valueTM
  -- Add the default functions for the vector type to the global results
      funs =  genAbstExtFuns valueTM recordId
  mapM_ addSubProgBody funs
  -- Return the resulting the record
  return $ Left $ (TypeDec recordId (TDR $ RecordTypeDef elems))
 where (cons, ~[valueTR]) = fsdSplitTyConApp rep
       absExtTyCon = fsdTyConOf (undefined :: AbstExt ())
       isAbsExt = cons == absExtTyCon

-- | Finally, it is an Enumerated algebraic type
--   or an unkown custom type (in that case we throw an error)
--
--   NOTE: It would be cleaner to have a different clauses for each case but
--   since we need to access the state to check if it's an enumerated
--   algebraic type, we cannot do it.
doCustomTR2TM rep = do
 -- Get the accumulated Enumerated Algebraic Types
 eTys <- gets (enumTypes.global)
 -- Check if current Type representation can be found in eTys
 let strRep = typeRepQName rep
 let equalsRep (EnumAlgTy name _) = name == strRep
 case (S.toList.(S.filter equalsRep)) eTys of
   -- Found!
   [enumDef] -> liftM Left $ enumAlg2TypeDec enumDef `debug` (">>>>? "++strRep)
   -- Not found, unkown custom type
   _ ->  throwFError $ UnsupportedType rep

-- | Transform an enumerated Algebraic type to a VHDL
--   TypeMark adding its default function to the global results
enumAlg2TypeDec :: EnumAlgTy -- ^ Enumerated type definition
                -> VHDLM TypeDec
enumAlg2TypeDec (EnumAlgTy tn cons) = do
 -- Get the TypeMark
 tMark <- liftEProne $ mkVHDLExtId tn
 -- Get the enumeration literals
 enumLits@(firstLit:_) <- liftEProne $ mapM mkVHDLExtId cons
 -- Add the default functions for the enumeration type
 let funs = genEnumAlgFuns tMark firstLit
 mapM_ addSubProgBody funs
 -- Create the enumeration type
 return (TypeDec tMark (TDE $ EnumTypeDef enumLits))

-- | Translation table for primitive types
primTypeTable :: [(FSDTypeRep, TypeMark)]
primTypeTable = [-- Commented out due to representation overflow
                 -- (typeOf (undefined :: Int64), int64TM)   ,
                 (fsdTypeOf (undefined :: Int32), int32TM)   ,
                 (fsdTypeOf (undefined :: Int16), int16TM)   ,
                 (fsdTypeOf (undefined :: Int8) , int8TM)    ,
                 (fsdTypeOf (undefined :: Bool) , booleanTM) ,
                 (fsdTypeOf (undefined :: Bit)  , std_logicTM)]

---------------------------------------
-- Translating functions and expresions
---------------------------------------

------------------------
-- Translating functions
------------------------


-- | Throw a function error
funErr :: VHDLFunErr -> VHDLM a
funErr err = throwFError $ UntranslatableVHDLFun err

-- | Translate a typed function AST to VHDL
transProcFun2VHDL :: TypedProcFunAST  -- ^ input ast
    -> VHDLM (SubProgBody, VHDLId, [VHDLId], [TypeMark], TypeMark)
    -- ^ Function, Function name, name of inputs, type of inputs, return type
transProcFun2VHDL (TypedProcFunAST fType fEnums fAST) = do
 -- Add the enumerated types associated with the function to the global results
 addEnumTypes fEnums
 -- Check if the procFunAST fullfils the restrictions of the VHDL Backend
 -- FIXME: translate the default arguments
 (fName, fInputPats, fBodyExp, whereDecs) <- checkProcFunAST fAST
 -- Get the function spec and initialize the translation namespace
 (fSpec, fVHDLName, fVHDLPars, argsTM, retTM) <-
  transProcFunSpec fName fType fInputPats
 -- Translate the where declarations and them to the
 -- auxiliary declarations of the function
 transDecs whereDecs
 -- Translate the function's body
 putCurrentFunctionSpec fSpec
 bodySms <- transFunBodyExp2VHDL fBodyExp
 decs <- gets (auxDecs.funTransST.local)
 let  fBody = SubProgBody fSpec decs bodySms
 return (fBody, fVHDLName, fVHDLPars, argsTM, retTM)

-- | Translate a typed function AST to VHDL (only returning the functions body
transProcFun2VHDLBody :: TypedProcFunAST -> VHDLM SubProgBody
transProcFun2VHDLBody tpf = do
 (body, _, _, _, _) <- transProcFun2VHDL tpf
 return body

-- | Translate a list of declarations to a list of process function
--   ASTs
decs2ProcFuns :: [Dec] -> VHDLM [TypedProcFunAST]
decs2ProcFuns [] = return []
decs2ProcFuns decs = do
 (dec, t, name, clauses, restDecs) <- case decs of
   -- A  type signature followed by its function declaration
   SigD n1 t : f@(FunD n2 cls) : xs | n1 == n2 ->
      return (f, t, n1, cls, xs)
   -- A type signature followed by its value declaration
   -- which will be translated to a function
   SigD n1 t : v@(ValD (VarP n2) bdy ds) : xs | n1 == n2 -> do
      return (v, t, n1, [Clause [] bdy ds] , xs)
   -- Otherwise the provided declaration block is not supported
   _ -> funErr $ UnsupportedDecBlock decs
 t' <- maybe (funErr $ PolyDec dec) return (type2FSDTypeRep t)
 let tpf = TypedProcFunAST t' S.empty (ProcFunAST name clauses [])
 restTPFs <- decs2ProcFuns restDecs
 return $ tpf:restTPFs

-- | Tranlate a list of declarations and add them to the auxiliary
--   declarations in the function translation state
transDecs :: [Dec] -> VHDLM ()
transDecs decs = do
  -- Before anything, clear the previous declaration blocks
  -- FIXME: this shouldn't be here
  clearAux
  -- first we tranlsate the declarations to process functions
  tpfs <- decs2ProcFuns decs
  -- Before translating the process functions we add their names to the
  -- name translation table. It is important to note that, since
  -- Template Haskell makes local names unique (e.g. [| let x = 1 in
  -- let x = 2 in x |] is tranlsated to let x_0 = 1 in let x_1 = 2 in x_2),
  -- we don't have to take care of name scopes i.e. we can have a global name
  -- scope.
  mapM_ addDecName tpfs
  -- Translate the declarations to VHDL and add them
  -- to the auxiliary declarations of the function translation
  bodyDecs <- mapM (liftM SPSB . transProcFun2VHDLBody) tpfs
  addDecsToFunTransST bodyDecs
 where addDecName :: TypedProcFunAST -> VHDLM ()
       addDecName (TypedProcFunAST t _ (ProcFunAST n _ _)) = do
          let arity = (length.fst.fsdUnArrowT) t
          vhdlId <- transTHName2VHDL n
          addTransNamePair n arity (genExprFCallN vhdlId arity)
       clearAux = do
          lState <- gets local
          let s = funTransST lState
          modify (\st -> st{local=lState{funTransST=s{auxDecs=[]}}})

-- | Check if a process function AST fulfils the VHDL backend restrictions.
--   It returs the function TH-name its input paterns, its body expression,
--   and the list of theclarations in the where construct.
checkProcFunAST :: ProcFunAST
                -> VHDLM (Name, [Pat], Exp, [Dec])
-- FIXME: translate the default arguments!
checkProcFunAST (ProcFunAST thName [Clause pats (NormalB exp) decs] []) =
 return (thName, pats, exp, decs)
checkProcFunAST (ProcFunAST _ _ (_:_)) =
 intError "ForSyDe.Backend.VHDL.Translate.checkProcFunSpec"
          (UntranslatableVHDLFun $ GeneralErr (Other "default parameters are not yet supported"))
checkProcFunAST (ProcFunAST _ [Clause _ bdy@(GuardedB _) _] _) =
  funErr (FunGuardedBody bdy)
checkProcFunAST (ProcFunAST _ clauses@(_:_) _) =
  funErr (MultipleClauses clauses)
-- cannot happen
checkProcFunAST (ProcFunAST _ [] _) =
 -- FIXME, use a custom error
 intError "ForSyDe.Backend.VHDL.Translate.checkProcFunSpec"
          (UntranslatableVHDLFun $ GeneralErr (Other "inconsistentency"))



-- |  Get the spec of a VHDL function from the Haskell function name, its type
--    and its input patterns. This function also takes care of initalizing the
--    translation namespace.
transProcFunSpec :: TH.Name -- ^ Function name
                 -> FSDTypeRep -- ^ Function type
                 -> [Pat]   -- ^ input patterns
                 -> VHDLM (SubProgSpec, VHDLId, [VHDLId], [TypeMark], TypeMark)
-- ^ translated function spec, function name, inpt parameters, input types
--   and return types
transProcFunSpec fName fType fPats = do
 -- FIXME: translate the default arguments!
 -- Get the input and output types
 let (argsTR, retTR) = fsdUnArrowT fType
 -- Check that the number of patterns equal the function parameter number
     expectedN = length argsTR `debug` ("expected (args): "++ (show (length argsTR)))
     actualN = length fPats `debug` ("actual (patterns): "++ (show (length fPats)))
 when (expectedN /= actualN) (funErr $ InsParamNum fName actualN)
 -- Get a VHDL identifier for each input pattern and
 -- initialize the translation namespace
 fVHDLParIds <- mapM transInputPat2VHDLId fPats
 -- Translate the function name
 fVHDLName <- transTHName2VHDL fName
 -- Translate the types
 argsTM <- mapM transTR2TM argsTR
 retTM <- transTR2TM retTR
 -- Create the spec
 let iface = zipWith (\name typ -> IfaceVarDec  name typ) fVHDLParIds argsTM
     fSpec = Function fVHDLName iface retTM
 -- Finally, return the results
 return (fSpec, fVHDLName, fVHDLParIds, argsTM, retTM)

-- | Translate an input pattern to a VHDLID,
--   making the necessary changes in the translation namespace
transInputPat2VHDLId :: TH.Pat -> VHDLM VHDLId
transInputPat2VHDLId  pat = do
 -- Get the parameter identifier
 id <- case pat of
         -- if we get a variable or and @ patterm, we just translate it to VHDL
         VarP name -> transTHName2VHDL name
         AsP name _ -> transTHName2VHDL name
         -- otherwise, generate a fresh identifier
         _ -> genFreshVHDLId

 -- Prepare the namespace for the pattern
 preparePatNameSpace (NSimple id) pat
 -- Finally return the generated id
 return id


-- | prepare the translation namespace for an input pattern
preparePatNameSpace :: Prefix -- ^ name prefix obtained so far
                    -> Pat    -- ^ pattern
                    -> VHDLM ()
-- NOTE: a good alternative to adding selected names to the
--       translation table would be declaring a variable
--       assignment. It would probably make the generated code more
--       readable but at the same time, it requires knowing the
--       pattern type, and TH's AST is unfortunately not
--       type-annotated which would make things more difficult.

-- variable pattern
preparePatNameSpace prefix (VarP name) =
 addTransNamePair name 0 (\[] -> PrimName prefix)

-- '@' pattern
preparePatNameSpace prefix (AsP name pat) = do
  addTransNamePair name 0 (\[]  -> PrimName prefix)
  preparePatNameSpace prefix pat

-- wildcard pattern
preparePatNameSpace _ WildP = return ()

-- tuple pattern
preparePatNameSpace prefix (TupP pats) = do
  let prepTup n pat = preparePatNameSpace
                          (NSelected (prefix :.: tupVHDLSuffix n)) pat
  zipWithM_ prepTup [1..] pats

-- AbstExt patterns

-- Since we only support one clause per function
-- they are not really useful, but we accept them anyways
-- FIXME: true, they are not useful, but again, since we only support one
--        clause per function they denote a programming error. Should they
--        really be supported?
preparePatNameSpace prefix (ConP name ~[pat]) | isAbstExt name =
  when isPrst (preparePatNameSpace (NSelected (prefix :.: valueSuffix)) pat)
 where isAbstExt name = isPrst || name == 'Abst
       isPrst =  name == 'Prst

-- Unary Constructor patterns
-- We try an enumerated type patterns
-- otherwise we throw an unknown constructor pattern error
preparePatNameSpace _ pat@(ConP name []) = do
 mId <- getEnumConsId name
 case mId of
   -- it is an enumerated data constructor, however, since we only admit
   -- one clause per function there is nothing to do about it
  Just _ -> return ()
  -- it is an unknown data constructor
  Nothing -> funErr $ UnsupportedFunPat pat

-- otherwise the pattern is not supported
preparePatNameSpace _ pat = funErr $ UnsupportedFunPat pat



--------------------------
-- Translating expressions
--------------------------

-- | Throw an expression error
expErr :: Exp -> VHDLExpErr -> VHDLM a
expErr exp err = throwFError $ UntranslatableVHDLExp exp err


-- | Create the unique statement of a VHDL from a TH expression.
transFunBodyExp2VHDL :: TH.Exp -> VHDLM [SeqSm]
transFunBodyExp2VHDL  (CondE condE thenE  elseE)  =
  do condVHDLE  <- transExp2VHDL condE
     thenVHDLSm <- transFunBodyExp2VHDL thenE
     elseVHDLSm <- transFunBodyExp2VHDL elseE
     return [IfSm condVHDLE thenVHDLSm [] (Just $ Else elseVHDLSm)]
transFunBodyExp2VHDL caseE@(CaseE exp matches)  =
  do caseVHDLE  <- transExp2VHDL exp
     caseSmAlts <- mapM (transMatch2VHDLCaseSmAlt caseE) matches
     return [CaseSm caseVHDLE caseSmAlts]
-- A higher order function needs to be treated specially
transFunBodyExp2VHDL e@(AppE _ _) 
   | isHigherOrderFunction e = translateHigherOrderFunctionBody e
-- In other case it is an expression returned directly
transFunBodyExp2VHDL  e =
  do vHDLe <- transExp2VHDL e
     return [ReturnSm $ Just vHDLe]

-- | Translate a case alternative from Haskell to VHDL
transMatch2VHDLCaseSmAlt :: TH.Exp -> TH.Match -> VHDLM CaseSmAlt
-- FIXME: the exp passed (which contains the full case expression for
-- error reporting purposes) should be part of the context once VHDLM
-- is reworked
transMatch2VHDLCaseSmAlt contextExp (Match pat (NormalB matchExp) decs) =
 do transDecs decs
    sm <- transFunBodyExp2VHDL matchExp
    case pat of
     -- FIXME: support pattern matching with tuples, AbsExt,
     -- and enumerated types
     WildP -> return $ CaseSmAlt [Others] sm
     LitP lit -> do vHDLExp <- transExp2VHDL (LitE lit)
                    return $ CaseSmAlt [ChoiceE vHDLExp] sm
     -- FIXME: check! this case introduces new names into scope
     VarP name -> do vHDLExp <- transExp2VHDL (VarE name)
                     return $ CaseSmAlt [ChoiceE vHDLExp] sm
     _ -> expErr contextExp $ UnsupportedCasePat pat
transMatch2VHDLCaseSmAlt contextExp (Match _ bdy@(GuardedB _) _) =
 expErr contextExp $ CaseGuardedBody bdy


-- | Translate a Haskell expression to a VHDL expression
transExp2VHDL :: TH.Exp -> VHDLM VHDL.Expr


-- TypeLevel-package numerical constant aliases
transExp2VHDL (VarE name) | isTypeLevelAlias = do
 let constant = nameBase name
     ([baseSym], val) = splitAt 1 constant
     basePrefix = case baseSym of
       'b' -> "2#"
       'o' -> "8#"
       'h' -> "16#"
       'd' -> ""
       _   -> error "unexpected base symbol"
 return (PrimLit $ basePrefix ++ val)
 where isTypeLevelAlias = (show name =~ aliasPat)
       aliasPat = "^Data\\.TypeLevel\\.Num\\.Aliases\\.(b[0-1]+|o[0-7]+|d[0-9]+|h[0-9A-F]+)$"



-- A FSVec generated with Template Haskell
transExp2VHDL (VarE unsafeFSVecCoerce `AppE` _ `AppE` (ConE con `AppE` ListE exps))
 | show unsafeFSVecCoerce == "Data.Param.FSVec.unsafeFSVecCoerce" &&
   show con == "Data.Param.FSVec.FSVec" = do
    vhdlExps <- mapM transExp2VHDL exps
    return $ Aggregate (map (\e -> ElemAssoc Nothing e) vhdlExps)


-- Is it function/constructor application, a constant
-- or an unkown name.
transExp2VHDL e | isConsOrFun   =
  do -- get the symbol table (name translation table)
     nameTable <- gets (nameTable.funTransST.local)
     case lookup name nameTable of
       -- found name
       Just (arity, transF) ->
            if arity /= numArgs
              then expErr e $ CurryUnsupported arity numArgs
              else do exps <- mapM transExp2VHDL args
                      return $ transF exps
       -- Didn't find the name in the global table
       Nothing -> do
         -- Check if it is a user-defined enumerated data constructor
         mId <- getEnumConsId name
         case mId of
            Just id -> return $ PrimName (NSimple id)
            Nothing -> expErr e $ UnkownIdentifier name
 where (f,args,numArgs) = unApp e
       mName = getName f
       name = fromJust mName
       isConsOrFun = isJust mName
       getName (VarE n) = Just n
       getName (ConE n) = Just n
       getName _        = Nothing



-- Literals
transExp2VHDL  (LitE (IntegerL integer))  = (return.transInteger2VHDL) integer
transExp2VHDL  (LitE (IntPrimL integer))  = (return.transInteger2VHDL) integer

-- Unsupported literal
transExp2VHDL lit@(LitE _) = expErr lit $ UnsupportedLiteral

-- Infix expressions
transExp2VHDL (InfixE (Just argl) f@(VarE _) (Just argr)) =
 transExp2VHDL $ f `AppE` argl `AppE` argr

-- Sections (unsupported)
transExp2VHDL infixExp@(InfixE _ (VarE _) _) = expErr infixExp Section

-- Tuples: e.g. (1,2)
transExp2VHDL (TupE exps) = do
 vExps <- mapM transExp2VHDL exps
 return $ Aggregate $ map (\expr -> ElemAssoc Nothing expr) vExps

-- Let expressions
transExp2VHDL (LetE decs e) = do
 transDecs decs
 transExp2VHDL e

-- Unsupported expressions
transExp2VHDL lamE@(LamE _ _) = expErr lamE  LambdaAbstraction
transExp2VHDL condE@(CondE _ _ _) = expErr condE Conditional
transExp2VHDL caseE@(CaseE _ _) = expErr caseE Case
transExp2VHDL doE@(DoE _) = expErr doE Do
transExp2VHDL compE@(CompE _) = expErr compE ListComprehension
transExp2VHDL arithSeqE@(ArithSeqE _) = expErr arithSeqE ArithSeq
transExp2VHDL listE@(ListE _) = expErr listE List
transExp2VHDL sigE@(SigE _ _) = expErr sigE Signature
transExp2VHDL reConE@(RecConE _ _) = expErr reConE Record
transExp2VHDL recUpE@(RecUpdE _ _) = expErr recUpE Record

-- The rest of expressions are not valid in practice and thus, not supported
-- (e.g. InfixE Nothing (RecConE _ _) _
transExp2VHDL exp = expErr exp Unsupported


-- | Translate an integer to VHDL
transInteger2VHDL :: Integer -> Expr
transInteger2VHDL = PrimLit . show


--------------------
-- Helper Functions
--------------------

-- Translate the TypeRep of a type-level natural (e.g: D1 :* D2) to a number
-- Make sure you don't supply an incorrect TypeRep or the function will break
transTLNat2Int :: FSDTypeRep -> Int
transTLNat2Int tr
  -- Digit
  -- FIXME: Could be made cleaner. It was like this before:
  -- isDigit = (digitToInt.last.tyConName) cons
  -- which was not able to take care of e.g. Data.TypeLevel.Num.Aliases.D10
  | isDigit = (read.reverse.takeWhile (/='D').reverse.fsdTyConName) cons
  -- Connective
  | otherwise = 10 * (transTLNat2Int prefix) + (transTLNat2Int lastDigit)
 where (cons, args@(~[prefix, lastDigit])) = fsdSplitTyConApp tr
       isDigit = null args


-- Tranlate an Int to the TypeRep of a type-level natural (e.g: D1 :* D2)
transInt2TLNat :: Int -> FSDTypeRep
transInt2TLNat n
 | n < 0 = intError fName (Other "negative index")
 | n < 10 = digit n
 | otherwise = fsdTyConApp conTyCon [transInt2TLNat suffix, digit last]
 where fName = "ForSyDe.Backend.VHDL.Translate.transInt2TLNat"
       (suffix, last) = n `divMod` 10
       digit 0 = fsdTypeOf (undefined :: D0)
       digit 1 = fsdTypeOf (undefined :: D1)
       digit 2 = fsdTypeOf (undefined :: D2)
       digit 3 = fsdTypeOf (undefined :: D3)
       digit 4 = fsdTypeOf (undefined :: D4)
       digit 5 = fsdTypeOf (undefined :: D5)
       digit 6 = fsdTypeOf (undefined :: D6)
       digit 7 = fsdTypeOf (undefined :: D7)
       digit 8 = fsdTypeOf (undefined :: D8)
       digit 9 = fsdTypeOf (undefined :: D9)
       -- Just to hush the compiler warnings
       digit _ = undefined
       conTyCon = fsdTyConOf (undefined :: () :* ())

-- Type constructor of FSVec
fSVecTyCon :: FSDTypeCon
fSVecTyCon = fsdTyConOf (undefined :: V.FSVec () ())

-- unApply an expression and obtain the number of arguments found
unApp :: Exp -> (Exp, [Exp], Int)
unApp e = (first, rest, n)
 where (first:rest, n) = unAppAc ([],0) e
       unAppAc (xs,n) (f `AppE` arg) = unAppAc (arg:xs, n+1) f
       unAppAc (xs,n) f = (f:xs,n)



typeRepQName :: FSDTypeRep -> String
typeRepQName rep = mod ++ dot ++ name
 where  tr       = fsdTyRep rep
        tc       = typeRepTyCon tr
        mod      = tyConModule tc
        name     = tyConName tc
        dot      = if mod=="" then "" else "."