From 4583b2b6d86da12e795f199f2951b193efed613f Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Wed, 9 Jun 2010 22:30:13 +0200 Subject: [PATCH] Add support for multiple-constructor datatypes with fields. MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit This is the naïve implementation that will not try to use the same storage space for fields from different constructors, so it might quickly become inefficient with bigger datatypes. For simple types like the Maybe type, this should be fine. The support is not quite working yet, for some reason these new types are not marked as representable. This is cause because the type substitution in mkTyConHType does not work for some reason, so the field type of the Just constructor in (for example) a Maybe Bool type stays "a" instead of "Bool". --- clash/CLasH/Translator/TranslatorTypes.hs | 8 +- clash/CLasH/VHDL/Generate.hs | 86 ++++++++---- clash/CLasH/VHDL/VHDLTools.hs | 159 ++++++++++++++-------- 3 files changed, 170 insertions(+), 83 deletions(-) diff --git a/clash/CLasH/Translator/TranslatorTypes.hs b/clash/CLasH/Translator/TranslatorTypes.hs index eabb004..c158158 100644 --- a/clash/CLasH/Translator/TranslatorTypes.hs +++ b/clash/CLasH/Translator/TranslatorTypes.hs @@ -45,8 +45,14 @@ instance Eq OrdType where instance Ord OrdType where compare (OrdType a) (OrdType b) = Type.tcCmpType a b -data HType = AggrType String [HType] | +data HType = AggrType String (Maybe (String, HType)) [[(String, HType)]] | + -- ^ A type containing multiple fields. Arguments: Type + -- name, an optional EnumType for the constructors (if > 1) + -- and a list containing a list of fields (name, htype) for + -- each constructor. EnumType String [String] | + -- ^ A type containing no fields and multiple constructors. + -- Arguments: Type name, a list of possible values. VecType Int HType | UVecType HType | SizedWType Int | diff --git a/clash/CLasH/VHDL/Generate.hs b/clash/CLasH/VHDL/Generate.hs index 3d31529..c9febe3 100644 --- a/clash/CLasH/VHDL/Generate.hs +++ b/clash/CLasH/VHDL/Generate.hs @@ -251,7 +251,7 @@ mkConcSm (bndr, expr@(CoreSyn.Case (CoreSyn.Var scrut) b ty [alt])) then do bndrs' <- Monad.filterM hasNonEmptyType bndrs case List.elemIndex sel_bndr bndrs' of - Just i -> do + Just sel_i -> do htypeScrt <- MonadState.lift tsType $ mkHTypeEither (Var.varType scrut) htypeBndr <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr) case htypeScrt == htypeBndr of @@ -261,9 +261,10 @@ mkConcSm (bndr, expr@(CoreSyn.Case (CoreSyn.Var scrut) b ty [alt])) return ([mkUncondAssign (Left bndr) sel_expr], []) otherwise -> case htypeScrt of - Right (AggrType _ _) -> do - labels <- MonadState.lift tsType $ getFieldLabels (Id.idType scrut) - let label = labels!!i + Right htype@(AggrType _ _ _) -> do + let dc_i = datacon_index (Id.idType scrut) dc + let labels = getFieldLabels htype dc_i + let label = labels!!sel_i let sel_name = mkSelectedName (varToVHDLName scrut) label let sel_expr = AST.PrimName sel_name return ([mkUncondAssign (Left bndr) sel_expr], []) @@ -282,13 +283,34 @@ mkConcSm (bndr, expr@(CoreSyn.Case (CoreSyn.Var scrut) b ty [alt])) -- binders in the alts and only variables in the case values and a variable -- for a scrutinee. We check the constructor of the second alt, since the -- first is the default case, if there is any. -mkConcSm (bndr, (CoreSyn.Case (CoreSyn.Var scrut) _ _ (alt:alts))) = do - scrut' <- MonadState.lift tsType $ varToVHDLExpr scrut - -- Omit first condition, which is the default - altcons <- MonadState.lift tsType $ mapM (altconToVHDLExpr . (\(con,_,_) -> con)) alts - let cond_exprs = map (\x -> scrut' AST.:=: x) altcons +mkConcSm (bndr, expr@(CoreSyn.Case (CoreSyn.Var scrut) _ _ alts)) = do + htype <- MonadState.lift tsType $ mkHType ("\nVHDL.mkConcSm: Unrepresentable scrutinee type? Expression: " ++ pprString expr) scrut + -- Turn the scrutinee into a VHDLExpr + scrut_expr <- MonadState.lift tsType $ varToVHDLExpr scrut + (enums, cmp) <- case htype of + EnumType _ enums -> do + -- Enumeration type, compare with the scrutinee directly + return (map stringToVHDLExpr enums, scrut_expr) + AggrType _ (Just (name, EnumType _ enums)) _ -> do + -- Extract the enumeration field from the aggregation + let sel_name = mkSelectedName (varToVHDLName scrut) (mkVHDLBasicId name) + let sel_expr = AST.PrimName sel_name + return (map stringToVHDLExpr enums, sel_expr) + (BuiltinType "Bit") -> do + let enums = [AST.PrimLit "'1'", AST.PrimLit "'0'"] + return (enums, scrut_expr) + (BuiltinType "Bool") -> do + let enums = [AST.PrimLit "true", AST.PrimLit "false"] + return (enums, scrut_expr) + _ -> error $ "\nSelector case on weird scrutinee: " ++ pprString scrut ++ " scrutinee type: " ++ pprString (Id.idType scrut) + -- Omit first condition, which is the default. Look up each altcon in + -- the enums list from the HType to find the actual enum value names. + let altcons = map (\(CoreSyn.DataAlt dc, _, _) -> enums!!(datacon_index scrut dc)) (tail alts) + -- Compare the (constructor field of the) scrutinee with each of the + -- alternatives. + let cond_exprs = map (\x -> cmp AST.:=: x) altcons -- Rotate expressions to the left, so that the expression related to the default case is the last - exprs <- MonadState.lift tsType $ mapM (varToVHDLExpr . (\(_,_,CoreSyn.Var expr) -> expr)) (alts ++ [alt]) + exprs <- MonadState.lift tsType $ mapM (varToVHDLExpr . (\(_,_,CoreSyn.Var expr) -> expr)) ((tail alts) ++ [head alts]) return ([mkAltsAssign (Left bndr) cond_exprs exprs], []) mkConcSm (_, CoreSyn.Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement does not have a simple variable as scrutinee" @@ -725,6 +747,7 @@ genZip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Va genZip' (Left res) f args@[arg1, arg2] = do { -- Setup the generate scheme ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res + ; res_htype <- MonadState.lift tsType $ mkHType "\nGenerate.genZip: Invalid result type" (tfvec_elem (Var.varType res)) -- TODO: Use something better than varToString ; let { label = mkVHDLExtId ("zipVector" ++ (varToString res)) ; n_id = mkVHDLBasicId "n" @@ -734,8 +757,8 @@ genZip' (Left res) f args@[arg1, arg2] = do { ; resname' = mkIndexedName (varToVHDLName res) n_expr ; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr ; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr - } ; - ; labels <- MonadState.lift tsType $ getFieldLabels (tfvec_elem (Var.varType res)) + ; labels = getFieldLabels res_htype 0 + } ; let { resnameA = mkSelectedName resname' (labels!!0) ; resnameB = mkSelectedName resname' (labels!!1) ; resA_assign = mkUncondAssign (Right resnameA) argexpr1 @@ -750,8 +773,10 @@ genFst :: BuiltinBuilder genFst = genNoInsts $ genVarArgs genFst' genFst' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm] genFst' (Left res) f args@[arg] = do { - ; labels <- MonadState.lift tsType $ getFieldLabels (Var.varType arg) - ; let { argexpr' = varToVHDLName arg + ; arg_htype <- MonadState.lift tsType $ mkHType "\nGenerate.genFst: Invalid argument type" (Var.varType arg) + ; let { + ; labels = getFieldLabels arg_htype 0 + ; argexpr' = varToVHDLName arg ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (labels!!0) ; assign = mkUncondAssign (Left res) argexprA } ; @@ -764,8 +789,10 @@ genSnd :: BuiltinBuilder genSnd = genNoInsts $ genVarArgs genSnd' genSnd' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm] genSnd' (Left res) f args@[arg] = do { - ; labels <- MonadState.lift tsType $ getFieldLabels (Var.varType arg) - ; let { argexpr' = varToVHDLName arg + ; arg_htype <- MonadState.lift tsType $ mkHType "\nGenerate.genSnd: Invalid argument type" (Var.varType arg) + ; let { + ; labels = getFieldLabels arg_htype 0 + ; argexpr' = varToVHDLName arg ; argexprB = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (labels!!1) ; assign = mkUncondAssign (Left res) argexprB } ; @@ -785,9 +812,11 @@ genUnzip' (Left res) f args@[arg] = do -- resulting VHDL, making the the unzip no longer required. case htype of -- A normal vector containing two-tuples - VecType _ (AggrType _ [_, _]) -> do { + VecType _ (AggrType _ _ [_, _]) -> do { -- Setup the generate scheme ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg + ; arg_htype <- MonadState.lift tsType $ mkHType "\nGenerate.genUnzip: Invalid argument type" (Var.varType arg) + ; res_htype <- MonadState.lift tsType $ mkHType "\nGenerate.genUnzip: Invalid result type" (Var.varType res) -- TODO: Use something better than varToString ; let { label = mkVHDLExtId ("unzipVector" ++ (varToString res)) ; n_id = mkVHDLBasicId "n" @@ -796,9 +825,9 @@ genUnzip' (Left res) f args@[arg] = do ; genScheme = AST.ForGn n_id range ; resname' = varToVHDLName res ; argexpr' = mkIndexedName (varToVHDLName arg) n_expr + ; reslabels = getFieldLabels res_htype 0 + ; arglabels = getFieldLabels arg_htype 0 } ; - ; reslabels <- MonadState.lift tsType $ getFieldLabels (Var.varType res) - ; arglabels <- MonadState.lift tsType $ getFieldLabels (tfvec_elem (Var.varType arg)) ; let { resnameA = mkIndexedName (mkSelectedName resname' (reslabels!!0)) n_expr ; resnameB = mkIndexedName (mkSelectedName resname' (reslabels!!1)) n_expr ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!0) @@ -811,9 +840,9 @@ genUnzip' (Left res) f args@[arg] = do } -- Both elements of the tuple were state, so they've disappeared. No -- need to do anything - VecType _ (AggrType _ []) -> return [] + VecType _ (AggrType _ _ []) -> return [] -- A vector containing aggregates with more than two elements? - VecType _ (AggrType _ _) -> error $ "Unzipping a value that is not a vector of two-tuples? Value: " ++ pprString arg ++ "\nType: " ++ pprString (Var.varType arg) + VecType _ (AggrType _ _ _) -> error $ "Unzipping a value that is not a vector of two-tuples? Value: " ++ pprString arg ++ "\nType: " ++ pprString (Var.varType arg) -- One of the elements of the tuple was state, so there won't be a -- tuple (record) in the VHDL output. We can just do a plain -- assignment, then. @@ -997,9 +1026,11 @@ genSplit = genNoInsts $ genVarArgs genSplit' genSplit' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm] genSplit' (Left res) f args@[vecIn] = do { - ; labels <- MonadState.lift tsType $ getFieldLabels (Var.varType res) ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vecIn - ; let { block_label = mkVHDLExtId ("split" ++ (varToString vecIn)) + ; res_htype <- MonadState.lift tsType $ mkHType "\nGenerate.genSplit': Invalid result type" (Var.varType res) + ; let { + ; labels = getFieldLabels res_htype 0 + ; block_label = mkVHDLExtId ("split" ++ (varToString vecIn)) ; halflen = round ((fromIntegral len) / 2) ; rangeL = vecSlice (AST.PrimLit "0") (AST.PrimLit $ show (halflen - 1)) ; rangeR = vecSlice (AST.PrimLit $ show halflen) (AST.PrimLit $ show (len - 1)) @@ -1039,16 +1070,17 @@ genApplication dst f args = do -- It's a datacon. Create a record from its arguments. Left bndr -> do -- We have the bndr, so we can get at the type - htype <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr) + htype_either <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr) let argsNostate = filter (\x -> not (either hasStateType (\x -> False) x)) args case argsNostate of [arg] -> do [arg'] <- argsToVHDLExprs [arg] return ([mkUncondAssign dst arg'], []) otherwise -> - case htype of - Right (AggrType _ _) -> do - labels <- MonadState.lift tsType $ getFieldLabels (Var.varType bndr) + case htype_either of + Right htype@(AggrType _ _ _) -> do + let dc_i = datacon_index (Var.varType bndr) dc + let labels = getFieldLabels htype dc_i args' <- argsToVHDLExprs argsNostate return (zipWith mkassign labels args', []) where diff --git a/clash/CLasH/VHDL/VHDLTools.hs b/clash/CLasH/VHDL/VHDLTools.hs index 7677369..639452b 100644 --- a/clash/CLasH/VHDL/VHDLTools.hs +++ b/clash/CLasH/VHDL/VHDLTools.hs @@ -356,42 +356,62 @@ mkTyConHType tycon args = case TyCon.tyConDataCons tycon of -- Not an algebraic type [] -> return $ Left $ "VHDLTools.mkTyConHType: Only custom algebraic types are supported: " ++ pprString tycon - [dc] -> do - let arg_tys = DataCon.dataConRepArgTys dc - let real_arg_tys = map (CoreSubst.substTy subst) arg_tys - let real_arg_tys_nostate = filter (\x -> not (isStateType x)) real_arg_tys - elem_htys_either <- mapM mkHTypeEither real_arg_tys_nostate - case Either.partitionEithers elem_htys_either of - ([], [elem_hty]) -> - return $ Right elem_hty - -- No errors in element types - ([], elem_htys) -> - return $ Right $ AggrType (nameToString (TyCon.tyConName tycon)) elem_htys - -- There were errors in element types - (errors, _) -> return $ Left $ - "\nVHDLTools.mkTyConHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n" - ++ (concat errors) dcs -> do - let arg_tys = concatMap DataCon.dataConRepArgTys dcs - let real_arg_tys = map (CoreSubst.substTy subst) arg_tys - case real_arg_tys of - [] -> - return $ Right $ EnumType (nameToString (TyCon.tyConName tycon)) (map (nameToString . DataCon.dataConName) dcs) - xs -> return $ Left $ - "VHDLTools.mkTyConHType: Only enum-like constructor datatypes supported: " ++ pprString dcs ++ "\n" + let arg_tyss = map DataCon.dataConRepArgTys dcs + let enum_ty = EnumType name (map (nameToString . DataCon.dataConName) dcs) + case (concat arg_tyss) of + -- No arguments, this is just an enumeration type + [] -> return (Right enum_ty) + -- At least one argument, this becomes an aggregate type + _ -> do + -- Resolve any type arguments to this type + let real_arg_tyss = map (map (CoreSubst.substTy subst)) arg_tyss + -- Remove any state type fields + let real_arg_tyss_nostate = map (filter (\x -> not (isStateType x))) real_arg_tyss + elem_htyss_either <- mapM (mapM mkHTypeEither) real_arg_tyss_nostate + let (errors, elem_htyss) = unzip (map Either.partitionEithers elem_htyss_either) + case errors of + [] -> case (dcs, concat elem_htyss) of + -- A single constructor with a single (non-state) field? + ([dc], [elem_hty]) -> return $ Right elem_hty + -- If we get here, then all of the argument types were state + -- types (we check for enumeration types at the top). Not + -- sure how to handle this, so error out for now. + (_, []) -> error $ "ADT with only State elements (or something like that?) Dunno how to handle this yet. Tycon: " ++ pprString tycon ++ " Arguments: " ++ pprString args + -- A full ADT (with multiple fields and one or multiple + -- constructors). + (_, elem_htys) -> do + let (_, fieldss) = List.mapAccumL (List.mapAccumL label_field) labels elem_htyss + -- Only put in an enumeration as part of the aggregation + -- when there are multiple datacons + let enum_ty_part = case dcs of + [dc] -> Nothing + _ -> Just ("constructor", enum_ty) + -- Create the AggrType HType + return $ Right $ AggrType name enum_ty_part fieldss + -- There were errors in element types + errors -> return $ Left $ + "\nVHDLTools.mkTyConHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n" + ++ (concat $ concat errors) where + name = (nameToString (TyCon.tyConName tycon)) tyvars = TyCon.tyConTyVars tycon subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args) + -- Label a field by taking the first available label and returning + -- the rest. + label_field :: [String] -> HType -> ([String], (String, HType)) + label_field (l:ls) htype = (ls, (l, htype)) + labels = map (:[]) ['A'..'Z'] --- Translate a Haskell type to a VHDL type, generating a new type if needed. --- Returns an error value, using the given message, when no type could be --- created. Returns Nothing when the type is valid, but empty. vhdlTy :: (TypedThing t, Outputable.Outputable t) => String -> t -> TypeSession (Maybe AST.TypeMark) vhdlTy msg ty = do htype <- mkHType msg ty vhdlTyMaybe htype +-- | Translate a Haskell type to a VHDL type, generating a new type if needed. +-- Returns an error value, using the given message, when no type could be +-- created. Returns Nothing when the type is valid, but empty. vhdlTyMaybe :: HType -> TypeSession (Maybe AST.TypeMark) vhdlTyMaybe htype = do typemap <- MonadState.get tsTypes @@ -429,17 +449,45 @@ construct_vhdl_ty htype = mkTyconTy :: HType -> TypeSession TypeMapRec mkTyconTy htype = case htype of - (AggrType tycon args) -> do - elemTysMaybe <- mapM vhdlTyMaybe args - case Maybe.catMaybes elemTysMaybe of - [] -> -- No non-empty members + (AggrType name enum_field_maybe fieldss) -> do + let (labelss, elem_htypess) = unzip (map unzip fieldss) + elemTyMaybess <- mapM (mapM vhdlTyMaybe) elem_htypess + let elem_tyss = map Maybe.catMaybes elemTyMaybess + case concat elem_tyss of + [] -> -- No non-empty fields return Nothing - elem_tys -> do - let elems = zipWith AST.ElementDec recordlabels elem_tys - let elem_names = concatMap prettyShow elem_tys - let ty_id = mkVHDLExtId $ tycon ++ elem_names - let ty_def = AST.TDR $ AST.RecordTypeDef elems - let tupshow = mkTupleShow elem_tys ty_id + _ -> do + let reclabelss = map (map mkVHDLBasicId) labelss + let elemss = zipWith (zipWith AST.ElementDec) reclabelss elem_tyss + let elem_names = concatMap (concatMap prettyShow) elem_tyss + let ty_id = mkVHDLExtId $ name ++ elem_names + -- Find out if we need to add an extra field at the start of + -- the record type containing the constructor (only needed + -- when there's more than one constructor). + enum_ty_maybe <- case enum_field_maybe of + Nothing -> return Nothing + Just (_, enum_htype) -> do + enum_ty_maybe' <- vhdlTyMaybe enum_htype + case enum_ty_maybe' of + Nothing -> error $ "Couldn't translate enumeration type part of AggrType: " ++ show htype + -- Note that the first Just means the type is + -- translateable, while the second Just means that there + -- is a enum_ty at all (e.g., there's multiple + -- constructors). + Just enum_ty -> return $ Just enum_ty + -- Create an record field declaration for the first + -- constructor field, if needed. + enum_dec_maybe <- case enum_field_maybe of + Nothing -> return $ Nothing + Just (enum_name, enum_htype) -> do + enum_vhdl_ty_maybe <- vhdlTyMaybe enum_htype + let enum_vhdl_ty = Maybe.fromMaybe (error $ "\nVHDLTools.mkTyconTy: Enumeration field should not have empty type: " ++ show enum_htype) enum_vhdl_ty_maybe + return $ Just $ AST.ElementDec (mkVHDLBasicId enum_name) enum_vhdl_ty + -- Turn the maybe into a list, so we can prepend it. + let enum_decs = Maybe.maybeToList enum_dec_maybe + let enum_tys = Maybe.maybeToList enum_ty_maybe + let ty_def = AST.TDR $ AST.RecordTypeDef (enum_decs ++ concat elemss) + let tupshow = mkTupleShow (enum_tys ++ concat elem_tyss) ty_id MonadState.modify tsTypeFuns $ Map.insert (htype, showIdString) (showId, tupshow) return $ Just (ty_id, Just $ Left ty_def) (EnumType tycon dcs) -> do @@ -450,9 +498,6 @@ mkTyconTy htype = MonadState.modify tsTypeFuns $ Map.insert (htype, showIdString) (showId, enumShow) return $ Just (ty_id, Just $ Left ty_def) otherwise -> error $ "\nVHDLTools.mkTyconTy: Called for HType that is neiter a AggrType or EnumType: " ++ show htype - where - -- Generate a bunch of labels for fields of a record - recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z'] -- | Create a VHDL vector type mkVectorTy :: @@ -515,23 +560,27 @@ mkSignedTy size = do let ty_def = AST.SubtypeIn signedTM (Just range) return (Just (ty_id, Just $ Right ty_def)) --- Finds the field labels for VHDL type generated for the given Core type, --- which must result in a record type. -getFieldLabels :: Type.Type -> TypeSession [AST.VHDLId] -getFieldLabels ty = do - -- Ensure that the type is generated (but throw away it's VHDLId) - let error_msg = "\nVHDLTools.getFieldLabels: Can not get field labels, because: " ++ pprString ty ++ "can not be generated." - vhdlTy error_msg ty - -- Get the types map, lookup and unpack the VHDL TypeDef - types <- MonadState.get tsTypes - -- Assume the type for which we want labels is really translatable - htype <- mkHType error_msg ty - case Map.lookup htype types of - Nothing -> error $ "\nVHDLTools.getFieldLabels: Type not found? This should not happen!\nLooking for type: " ++ (pprString ty) ++ "\nhtype: " ++ (show htype) - Just Nothing -> return [] -- The type is empty - Just (Just (_, Just (Left (AST.TDR (AST.RecordTypeDef elems))))) -> return $ map (\(AST.ElementDec id _) -> id) elems - Just (Just (_, Just vty)) -> error $ "\nVHDLTools.getFieldLabels: Type not a record type? This should not happen!\nLooking for type: " ++ pprString (ty) ++ "\nhtype: " ++ (show htype) ++ "\nFound type: " ++ (show vty) - +-- Finds the field labels and types for aggregation HType. Returns an +-- error on other types. +getFields :: + HType -- ^ The HType to get fields for + -> Int -- ^ The constructor to get fields for (e.g., 0 + -- for the first constructor, etc.) + -> [(String, HType)] -- ^ A list of fields, with their name and type +getFields htype dc_i = case htype of + (AggrType name _ fieldss) + | dc_i >= 0 && dc_i < length fieldss -> fieldss!!dc_i + | otherwise -> error $ "Invalid constructor index: " ++ (show dc_i) ++ ". No such constructor in HType: " ++ (show htype) + _ -> error $ "Can't get fields from non-aggregate HType: " ++ show htype + +-- Finds the field labels for an aggregation type, as VHDLIds. +getFieldLabels :: + HType -- ^ The HType to get field labels for + -> Int -- ^ The constructor to get fields for (e.g., 0 + -- for the first constructor, etc.) + -> [AST.VHDLId] -- ^ The labels +getFieldLabels htype dc_i = ((map mkVHDLBasicId) . (map fst)) (getFields htype dc_i) + mktydecl :: (AST.VHDLId, Maybe (Either AST.TypeDef AST.SubtypeIn)) -> Maybe AST.PackageDecItem mytydecl (_, Nothing) = Nothing mktydecl (ty_id, Just (Left ty_def)) = Just $ AST.PDITD $ AST.TypeDec ty_id ty_def -- 2.30.2