module ForSyDe.Backend.VHDL.Translate where
import ForSyDe.Backend.VHDL.AST
import qualified ForSyDe.Backend.VHDL.AST as VHDL
import ForSyDe.Backend.VHDL.Constants
import ForSyDe.Backend.VHDL.Generate
import ForSyDe.Backend.VHDL.Traverse.VHDLM
import ForSyDe.Ids
import ForSyDe.AbsentExt
import ForSyDe.Signal
import ForSyDe.Bit hiding (not)
import qualified ForSyDe.Bit as B
import ForSyDe.ForSyDeErr
import ForSyDe.System.SysDef
import ForSyDe.Process.ProcFun
import ForSyDe.Process.ProcVal
import ForSyDe.Process.ProcType
import Data.Typeable.TypeRepLib (unArrowT)
import Language.Haskell.TH.TypeLib (type2TypeRep)
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 qualified Data.Param.FSVec as V
import Text.Regex.Posix ((=~))
import Data.TypeLevel.Num.Reps
transSysDef2Ent :: SysLogic
-> SysDefVal
-> VHDLM EntityDec
transSysDef2Ent logic sysDefVal = do
entId <- transSysId2VHDL (sid sysDefVal)
inDecs <- mapM (uncurry $ transPort2IfaceSigDec In) (iIface sysDefVal)
outDecs <- mapM (uncurry $ transPort2IfaceSigDec Out) (oIface sysDefVal)
let implicitDecs = if logic == Sequential then
[IfaceSigDec resetId In std_logicTM,
IfaceSigDec clockId In std_logicTM]
else []
return $ EntityDec entId (implicitDecs ++ inDecs ++ outDecs)
transZipWithN2Block :: Label
-> [VHDLId]
-> Loc
-> TypedProcFunAST
-> VHDLId
-> VHDLM (BlockSm, SigDec)
transZipWithN2Block vPid ins loc ast out = do
(f,fName , inFPars, inFTypes, retFType) <-
withProcFunC ((name.tpast) ast) loc $ transProcFun2VHDL ast
let inPars = map (\n -> unsafeIdAppend vPid ("_in" ++ show n)) [1..length ins]
outPar = unsafeIdAppend vPid "_out"
inDecs = zipWith (\par typ -> IfaceSigDec par In typ) inPars inFTypes
outDec = IfaceSigDec outPar Out retFType
iface = inDecs ++ [outDec]
pMap = genPMap (inPars ++ [outPar]) (ins ++ [out])
outAssign = genFCallAssign out fName inFPars ins
return (BlockSm vPid iface pMap [BDISPB f] [CSSASm outAssign],
SigDec out retFType Nothing)
transZipWithx2Block :: Label
-> [VHDLId]
-> Loc
-> TypedProcFunAST
-> VHDLId
-> VHDLM (BlockSm, SigDec)
transZipWithx2Block vPid ins loc ast out = do
(f, fName, [inFPar], [inFType], retFType) <-
withProcFunC ((name.tpast) ast) loc $ transProcFun2VHDL ast
let [[_,suffix]] = (fromVHDLId inFType) =~ "^fsvec_[0-9]*_(.*)$"
inType = unsafeVHDLBasicId $ suffix
inPars = map (\n -> unsafeIdAppend vPid ("_in" ++ show n)) [1..length ins]
outPar = unsafeIdAppend vPid "_out"
inDecs = map (\par -> IfaceSigDec par In inType) inPars
outDec = IfaceSigDec outPar Out retFType
iface = inDecs ++ [outDec]
pMap = genPMap (inPars ++ [outPar]) (ins ++ [out])
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)
transUnzipNSY2Block :: Label
-> VHDLId
-> [VHDLId]
-> [TypeRep]
-> VHDLM (BlockSm, [SigDec])
transUnzipNSY2Block vPid inSig outSigs outTRTypes = do
let inPar = unsafeIdAppend vPid "_in"
outPars = map (\n -> unsafeIdAppend vPid ("_out" ++ show n))
[1..length outSigs]
nOuts = length outSigs
tupTyCon = mkTyCon $ '(':replicate (nOuts1) ','++")"
inTRType = tupTyCon `mkTyConApp` 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
pMap = genPMap (inPar : outPars) (inSig : outSigs)
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)
transUnzipxSY2Block :: Label
-> VHDLId
-> [VHDLId]
-> TypeRep
-> Int
-> VHDLM (BlockSm, [SigDec])
transUnzipxSY2Block vPid inSig outSigs elemTR vSize = do
let inPar = unsafeIdAppend vPid "_in"
outPars = map (\n -> unsafeIdAppend vPid ("_out" ++ show n))
[1..length outSigs]
inTRType = fSVecTyCon `mkTyConApp` [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
pMap = genPMap (inPar : outPars) (inSig : outSigs)
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)
transDelay2Block :: Label
-> VHDLId
-> ProcValAST
-> VHDLId
-> VHDLM (BlockSm, SigDec)
transDelay2Block vPid inS (ProcValAST exp tr enums) outS = do
addEnumTypes enums
initTR <- transTR2TM tr
initExp <- withProcValC exp $ withInitFunTransST $ (transExp2VHDL exp)
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)
transSysIns2CompIns :: SysLogic
-> Label
-> [VHDLId]
-> [(VHDLId, TypeRep)]
-> SysId
-> [PortId]
-> [PortId]
-> 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
decs <- mapM (\(name,typ) -> transVHDLName2SigDec name typ Nothing) typedOuts
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)
transVHDLName2SigDec :: SimpleName
-> TypeRep
-> Maybe TH.Exp
-> VHDLM SigDec
transVHDLName2SigDec vId tr mExp = do
tm <- transTR2TM tr
mVExp <- DT.mapM (\e -> withInitFunTransST (transExp2VHDL e)) mExp
return $ SigDec vId tm mVExp
transVHDLId2IfaceSigDec :: Mode -> VHDLId -> TypeRep -> VHDLM IfaceSigDec
transVHDLId2IfaceSigDec m vid trep = do
tm <- transTR2TM trep
return $ IfaceSigDec vid m tm
transPort2IfaceSigDec :: Mode -> PortId -> TypeRep -> VHDLM IfaceSigDec
transPort2IfaceSigDec m pid trep = do
sid <- transPortId2VHDL pid
transVHDLId2IfaceSigDec m sid trep
transTHName2VHDL :: TH.Name -> VHDLM VHDLId
transTHName2VHDL = transPortId2VHDL . tyconUQname . pprint
transSysId2VHDL :: SysId -> VHDLM VHDLId
transSysId2VHDL = transPortId2VHDL
transProcId2VHDL :: ProcId -> VHDLM VHDLId
transProcId2VHDL = transPortId2VHDL
transPortId2VHDL :: PortId -> VHDLM VHDLId
transPortId2VHDL str = liftEProne $ mkVHDLExtId str
transTR2TM :: TypeRep -> VHDLM TypeMark
transTR2TM rep
| isSignal = transTR2TM nestedTR
| isJust mPrimitiveTM = return $ fromJust mPrimitiveTM
| otherwise = customTR2TM rep
where (isSignal, nestedTR) = let (tc,~[tr]) = splitTyConApp rep
in (tc == signalTyCon, tr)
signalTyCon = (typeRepTyCon.typeOf) (undefined :: Signal ())
mPrimitiveTM = lookup rep primTypeTable
customTR2TM :: TypeRep -> VHDLM TypeMark
customTR2TM rep = do
mTranslated <- lookupCustomType rep
case mTranslated of
Nothing -> do
e <- doCustomTR2TM rep
addCustomType rep e
case e of
Left (TypeDec id _) -> return id
Right (SubtypeDec id _) -> return id
Just tm -> return tm
doCustomTR2TM :: TypeRep -> VHDLM (Either TypeDec SubtypeDec)
doCustomTR2TM rep | isFSVec = do
valTM <- transTR2TM valueType
let vectorId = unsafeVHDLContainerId [valTM] ("fsvec_"++ fromVHDLId valTM)
vecs <- gets (transUnconsFSVecs.global)
when (not $ elem valueType vecs) $ do
when (valueType /= typeOf (undefined :: Bit))
(addTypeDec $ TypeDec vectorId (TDA (UnconsArrayDef [fsvec_indexTM] valTM)))
let funs = genUnconsVectorFuns valTM vectorId
mapM_ addSubProgBody funs
addUnconsFSVec valueType
let subvectorId = unsafeVHDLBasicId ("fsvec_" ++ show size ++ "_" ++
fromVHDLId valTM)
return $ Right $
SubtypeDec subvectorId (SubtypeIn vectorId
(Just $ IndexConstraint [ToRange (PrimLit "0")
(PrimLit (show $ size1))]))
where (cons, ~[sizeType,valueType]) = splitTyConApp rep
isFSVec = cons == fSVecTyCon
size = transTLNat2Int sizeType
doCustomTR2TM rep | isTuple = do
fieldTMs <- mapM transTR2TM args
let elems = zipWith (\fieldId fieldTM -> ElementDec fieldId fieldTM )
[tupVHDLIdSuffix n | n <- [1..]] fieldTMs
recordId = unsafeVHDLContainerId fieldTMs $
(tupStrSuffix $ length fieldTMs) ++ "_" ++
(concatMap fromVHDLId.intersperse (unsafeVHDLBasicId "_")) fieldTMs
funs = genTupleFuns fieldTMs recordId
mapM_ addSubProgBody funs
return $ Left $ (TypeDec recordId (TDR $ RecordTypeDef elems))
where (cons, args) = splitTyConApp rep
conStr = tyConString cons
isTuple = (length conStr > 2) && (all (==',') (reverse.tail.reverse.tail $ conStr))
doCustomTR2TM rep | isAbsExt = do
valueTM <- transTR2TM valueTR
let elems = [ElementDec isPresentId booleanTM,
ElementDec valueId valueTM ]
recordId = unsafeVHDLContainerId [valueTM] $
"abs_ext_" ++ fromVHDLId valueTM
funs = genAbstExtFuns valueTM recordId
mapM_ addSubProgBody funs
return $ Left $ (TypeDec recordId (TDR $ RecordTypeDef elems))
where (cons, ~[valueTR]) = splitTyConApp rep
absExtTyCon = (typeRepTyCon.typeOf) (undefined :: AbstExt ())
isAbsExt = cons == absExtTyCon
doCustomTR2TM rep = do
eTys <- gets (enumTypes.global)
let equalsRep (EnumAlgTy name _) = name == (tyConString.typeRepTyCon) rep
case (S.toList.(S.filter equalsRep)) eTys of
[enumDef] -> liftM Left $ enumAlg2TypeDec enumDef
_ -> throwFError $ UnsupportedType rep
enumAlg2TypeDec :: EnumAlgTy
-> VHDLM TypeDec
enumAlg2TypeDec (EnumAlgTy tn cons) = do
tMark <- liftEProne $ mkVHDLExtId tn
enumLits@(firstLit:_) <- liftEProne $ mapM mkVHDLExtId cons
let funs = genEnumAlgFuns tMark firstLit
mapM_ addSubProgBody funs
return (TypeDec tMark (TDE $ EnumTypeDef enumLits))
primTypeTable :: [(TypeRep, TypeMark)]
primTypeTable = [
(typeOf (undefined :: Int32), int32TM) ,
(typeOf (undefined :: Int16), int16TM) ,
(typeOf (undefined :: Int8) , int8TM) ,
(typeOf (undefined :: Bool) , booleanTM) ,
(typeOf (undefined :: Bit) , std_logicTM)]
funErr :: VHDLFunErr -> VHDLM a
funErr err = throwFError $ UntranslatableVHDLFun err
transProcFun2VHDL :: TypedProcFunAST
-> VHDLM (SubProgBody, VHDLId, [VHDLId], [TypeMark], TypeMark)
transProcFun2VHDL (TypedProcFunAST fType fEnums fAST) = do
addEnumTypes fEnums
(fName, fInputPats, fBodyExp, whereDecs) <- checkProcFunAST fAST
(fSpec, fVHDLName, fVHDLPars, argsTM, retTM) <-
transProcFunSpec fName fType fInputPats
transDecs whereDecs
bodySm <- transFunBodyExp2VHDL fBodyExp
decs <- gets (auxDecs.funTransST.local)
let fBody = SubProgBody fSpec decs [bodySm]
return (fBody, fVHDLName, fVHDLPars, argsTM, retTM)
transProcFun2VHDLBody :: TypedProcFunAST -> VHDLM SubProgBody
transProcFun2VHDLBody tpf = do
(body, _, _, _, _) <- transProcFun2VHDL tpf
return body
decs2ProcFuns :: [Dec] -> VHDLM [TypedProcFunAST]
decs2ProcFuns [] = return []
decs2ProcFuns decs = do
(dec, t, name, clauses, restDecs) <- case decs of
SigD n1 t : f@(FunD n2 cls) : xs | n1 == n2 ->
return (f, t, n1, cls, xs)
SigD n1 t : v@(ValD (VarP n2) bdy ds) : xs | n1 == n2 -> do
return (v, t, n1, [Clause [] bdy ds] , xs)
_ -> funErr $ UnsupportedDecBlock decs
t' <- maybe (funErr $ PolyDec dec) return (type2TypeRep t)
let tpf = TypedProcFunAST t' S.empty (ProcFunAST name clauses [])
restTPFs <- decs2ProcFuns restDecs
return $ tpf:restTPFs
transDecs :: [Dec] -> VHDLM ()
transDecs decs = do
clearAux
tpfs <- decs2ProcFuns decs
mapM_ addDecName tpfs
bodyDecs <- mapM (liftM SPSB . transProcFun2VHDLBody) tpfs
addDecsToFunTransST bodyDecs
where addDecName :: TypedProcFunAST -> VHDLM ()
addDecName (TypedProcFunAST t _ (ProcFunAST n _ _)) = do
let arity = (length.fst.unArrowT) 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=[]}}})
checkProcFunAST :: ProcFunAST
-> VHDLM (Name, [Pat], Exp, [Dec])
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)
checkProcFunAST (ProcFunAST _ [] _) =
intError "ForSyDe.Backend.VHDL.Translate.checkProcFunSpec"
(UntranslatableVHDLFun $ GeneralErr (Other "inconsistentency"))
transProcFunSpec :: TH.Name
-> TypeRep
-> [Pat]
-> VHDLM (SubProgSpec, VHDLId, [VHDLId], [TypeMark], TypeMark)
transProcFunSpec fName fType fPats = do
let (argsTR, retTR) = unArrowT fType
expectedN = length argsTR
actualN = length fPats
when (expectedN /= actualN) (funErr $ InsParamNum fName actualN)
fVHDLParIds <- mapM transInputPat2VHDLId fPats
fVHDLName <- transTHName2VHDL fName
argsTM <- mapM transTR2TM argsTR
retTM <- transTR2TM retTR
let iface = zipWith (\name typ -> IfaceVarDec name typ) fVHDLParIds argsTM
fSpec = Function fVHDLName iface retTM
return (fSpec, fVHDLName, fVHDLParIds, argsTM, retTM)
transInputPat2VHDLId :: TH.Pat -> VHDLM VHDLId
transInputPat2VHDLId pat = do
id <- case pat of
VarP name -> transTHName2VHDL name
AsP name _ -> transTHName2VHDL name
_ -> genFreshVHDLId
preparePatNameSpace (NSimple id) pat
return id
preparePatNameSpace :: Prefix
-> Pat
-> VHDLM ()
preparePatNameSpace prefix (VarP name) =
addTransNamePair name 0 (\[] -> PrimName prefix)
preparePatNameSpace prefix (AsP name pat) = do
addTransNamePair name 0 (\[] -> PrimName prefix)
preparePatNameSpace prefix pat
preparePatNameSpace _ WildP = return ()
preparePatNameSpace prefix (TupP pats) = do
let prepTup n pat = preparePatNameSpace
(NSelected (prefix :.: tupVHDLSuffix n)) pat
zipWithM_ prepTup [1..] pats
preparePatNameSpace prefix (ConP name ~[pat]) | isAbstExt name =
when isPrst (preparePatNameSpace (NSelected (prefix :.: valueSuffix)) pat)
where isAbstExt name = isPrst || name == 'Abst
isPrst = name == 'Prst
preparePatNameSpace _ pat@(ConP name []) = do
mId <- getEnumConsId name
case mId of
Just _ -> return ()
Nothing -> funErr $ UnsupportedFunPat pat
preparePatNameSpace _ pat = funErr $ UnsupportedFunPat pat
expErr :: Exp -> VHDLExpErr -> VHDLM a
expErr exp err = throwFError $ UntranslatableVHDLExp exp err
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)
transFunBodyExp2VHDL e =
do vHDLe <- transExp2VHDL e
return (ReturnSm $ Just vHDLe)
transMatch2VHDLCaseSmAlt :: TH.Exp -> TH.Match -> VHDLM CaseSmAlt
transMatch2VHDLCaseSmAlt contextExp (Match pat (NormalB matchExp) decs) =
do transDecs decs
sm <- transFunBodyExp2VHDL matchExp
case pat of
WildP -> return $ CaseSmAlt [Others] [sm]
LitP lit -> do vHDLExp <- transExp2VHDL (LitE lit)
return $ CaseSmAlt [ChoiceE vHDLExp] [sm]
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
transExp2VHDL :: TH.Exp -> VHDLM VHDL.Expr
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]+)$"
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)
transExp2VHDL e | isConsOrFun =
do
nameTable <- gets (nameTable.funTransST.local)
case lookup name nameTable of
Just (arity, transF) ->
if arity /= numArgs
then expErr e $ CurryUnsupported arity numArgs
else do exps <- mapM transExp2VHDL args
return $ transF exps
Nothing -> do
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
transExp2VHDL (LitE (IntegerL integer)) = (return.transInteger2VHDL) integer
transExp2VHDL (LitE (IntPrimL integer)) = (return.transInteger2VHDL) integer
transExp2VHDL lit@(LitE _) = expErr lit $ UnsupportedLiteral
transExp2VHDL (InfixE (Just argl) f@(VarE _) (Just argr)) =
transExp2VHDL $ f `AppE` argl `AppE` argr
transExp2VHDL infixExp@(InfixE _ (VarE _) _) = expErr infixExp Section
transExp2VHDL (TupE exps) = do
vExps <- mapM transExp2VHDL exps
return $ Aggregate $ map (\expr -> ElemAssoc Nothing expr) vExps
transExp2VHDL (LetE decs e) = do
transDecs decs
transExp2VHDL e
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
transExp2VHDL exp = expErr exp Unsupported
transInteger2VHDL :: Integer -> Expr
transInteger2VHDL = PrimLit . show
transTLNat2Int :: TypeRep -> Int
transTLNat2Int tr
| isDigit = (read.reverse.takeWhile (/='D').reverse.tyConString) cons
| otherwise = 10 * (transTLNat2Int prefix) + (transTLNat2Int lastDigit)
where (cons, args@(~[prefix, lastDigit])) = splitTyConApp tr
isDigit = null args
transInt2TLNat :: Int -> TypeRep
transInt2TLNat n
| n < 0 = intError fName (Other "negative index")
| n < 10 = digit n
| otherwise = mkTyConApp conTyCon [transInt2TLNat suffix, digit last]
where fName = "ForSyDe.Backend.VHDL.Translate.transInt2TLNat"
(suffix, last) = n `divMod` 10
digit 0 = typeOf (undefined :: D0)
digit 1 = typeOf (undefined :: D1)
digit 2 = typeOf (undefined :: D2)
digit 3 = typeOf (undefined :: D3)
digit 4 = typeOf (undefined :: D4)
digit 5 = typeOf (undefined :: D5)
digit 6 = typeOf (undefined :: D6)
digit 7 = typeOf (undefined :: D7)
digit 8 = typeOf (undefined :: D8)
digit 9 = typeOf (undefined :: D9)
digit _ = undefined
conTyCon = (typeRepTyCon.typeOf) (undefined :: () :* ())
fSVecTyCon :: TyCon
fSVecTyCon =(typeRepTyCon.typeOf) (undefined :: V.FSVec () ())
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)