X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=VHDL.hs;h=f145385e6c19f932a089d6bae4b62eb8ef0b7952;hb=2fa8431a83031128428caa8f833a3396de34536f;hp=dad3aec2623867ec0c958a3810ac9ca5ff35ce34;hpb=e03f02c419b4365d498c25dfbc861215394046df;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git a/VHDL.hs b/VHDL.hs
index dad3aec..f145385 100644
--- a/VHDL.hs
+++ b/VHDL.hs
@@ -458,9 +458,39 @@ construct_vhdl_ty ty = do
         "SizedWord" -> do
           res <- mk_vector_ty (sized_word_len ty) ty
           return $ Just res
-        otherwise -> return Nothing
+        -- Create a custom type from this tycon
+        otherwise -> mk_tycon_ty tycon args
     Nothing -> return $ Nothing
 
+-- | Create VHDL type for a custom tycon
+mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> VHDLState (Maybe (AST.TypeMark, AST.TypeDef))
+mk_tycon_ty tycon args =
+  case TyCon.tyConDataCons tycon of
+    -- Not an algebraic type
+    [] -> error $ "Only custom algebraic types are supported: " ++  (showSDoc $ ppr tycon)
+    [dc] -> do
+      let arg_tys = DataCon.dataConRepArgTys dc
+      -- TODO: CoreSubst docs say each Subs can be applied only once. Is this a
+      -- violation? Or does it only mean not to apply it again to the same
+      -- subject?
+      let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
+      elem_tys <- mapM vhdl_ty real_arg_tys
+      let elems = zipWith AST.ElementDec recordlabels elem_tys
+      -- For a single construct datatype, build a record with one field for
+      -- each argument.
+      -- TODO: Add argument type ids to this, to ensure uniqueness
+      -- TODO: Special handling for tuples?
+      let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon)
+      let ty_def = AST.TDR $ AST.RecordTypeDef elems
+      return $ Just (ty_id, ty_def)
+    dcs -> error $ "Only single constructor datatypes supported: " ++  (showSDoc $ ppr tycon)
+  where
+    -- Create a subst that instantiates all types passed to the tycon
+    -- TODO: I'm not 100% sure that this is the right way to do this. It seems
+    -- to work so far, though..
+    tyvars = TyCon.tyConTyVars tycon
+    subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
+
 -- | Create a VHDL vector type
 mk_vector_ty ::
   Int -- ^ The length of the vector
@@ -529,6 +559,10 @@ bndrToString ::
 
 bndrToString = OccName.occNameString . Name.nameOccName . Var.varName
 
+-- Extracts the string version of the name
+nameToString :: Name.Name -> String
+nameToString = OccName.occNameString . Name.nameOccName
+
 -- | A consise representation of a (set of) ports on a builtin function
 --type PortMap = HsValueMap (String, AST.TypeMark)
 -- | A consise representation of a builtin function
@@ -551,6 +585,8 @@ builtin_funcs = mkBuiltins
     BuiltIn "hwnot" [("a", VHDL.bit_ty)] ("o", VHDL.bit_ty)
   ]
 
+recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
+
 -- | Map a port specification of a builtin function to a VHDL Signal to put in
 --   a VHDLSignalMap
 toVHDLSignalMapElement :: (String, AST.TypeMark) -> VHDLSignalMapElement