X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=VHDLTools.hs;h=e4aad6f497a685c1b6d6dbd0e732bb98ac0f456c;hb=65d99830e416463d66f97581ece93da49f746778;hp=09796399b8e24576435e0155a6621cacba35f559;hpb=87f5213db3cfaa65ad805d0ee1c41434e2bed096;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git a/VHDLTools.hs b/VHDLTools.hs
index 0979639..e4aad6f 100644
--- a/VHDLTools.hs
+++ b/VHDLTools.hs
@@ -2,6 +2,7 @@ module VHDLTools where
 
 -- Standard modules
 import qualified Maybe
+import qualified Data.Either as Either
 import qualified Data.List as List
 import qualified Data.Map as Map
 import qualified Control.Monad as Monad
@@ -157,8 +158,8 @@ exprToVHDLExpr = varToVHDLExpr . exprToVar
 altconToVHDLExpr :: CoreSyn.AltCon -> AST.Expr
 altconToVHDLExpr (DataAlt dc) = dataconToVHDLExpr dc
 
-altconToVHDLExpr (LitAlt _) = error "VHDL.conToVHDLExpr Literals not support in case alternatives yet"
-altconToVHDLExpr DEFAULT = error "VHDL.conToVHDLExpr DEFAULT alternative should not occur here!"
+altconToVHDLExpr (LitAlt _) = error "\nVHDL.conToVHDLExpr: Literals not support in case alternatives yet"
+altconToVHDLExpr DEFAULT = error "\nVHDL.conToVHDLExpr: DEFAULT alternative should not occur here!"
 
 -- Turn a datacon (without arguments!) into a VHDL expression.
 dataconToVHDLExpr :: DataCon.DataCon -> AST.Expr
@@ -262,71 +263,95 @@ builtin_types =
   ]
 
 -- Translate a Haskell type to a VHDL type, generating a new type if needed.
-vhdl_ty :: Type.Type -> VHDLSession AST.TypeMark
-vhdl_ty ty = do
+-- Returns an error value, using the given message, when no type could be
+-- created.
+vhdl_ty :: String -> Type.Type -> TypeSession AST.TypeMark
+vhdl_ty msg ty = do
+  tm_either <- vhdl_ty_either ty
+  case tm_either of
+    Right tm -> return tm
+    Left err -> error $ msg ++ "\n" ++ err
+
+-- Translate a Haskell type to a VHDL type, generating a new type if needed.
+-- Returns either an error message or the resulting type.
+vhdl_ty_either :: Type.Type -> TypeSession (Either String AST.TypeMark)
+vhdl_ty_either ty = do
   typemap <- getA vsTypes
-  let builtin_ty = do -- See if this is a tycon and lookup its name
-        (tycon, args) <- Type.splitTyConApp_maybe ty
-        let name = Name.getOccString (TyCon.tyConName tycon)
-        Map.lookup name builtin_types
-  -- If not a builtin type, try the custom types
-  let existing_ty = (fmap fst) $ Map.lookup (OrdType ty) typemap
-  case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
-    -- Found a type, return it
-    Just t -> return t
-    -- No type yet, try to construct it
-    Nothing -> do
-      newty_maybe <- (construct_vhdl_ty ty)
-      case newty_maybe of
-        Just (ty_id, ty_def) -> do
-          -- TODO: Check name uniqueness
-          modA vsTypes (Map.insert (OrdType ty) (ty_id, ty_def))
-          return ty_id
-        Nothing -> error $ "Unsupported Haskell type: " ++ pprString ty
-
--- Construct a new VHDL type for the given Haskell type.
-construct_vhdl_ty :: Type.Type -> VHDLSession (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
+  htype_either <- mkHType ty
+  case htype_either of
+    -- No errors
+    Right htype -> do
+      let builtin_ty = do -- See if this is a tycon and lookup its name
+            (tycon, args) <- Type.splitTyConApp_maybe ty
+            let name = Name.getOccString (TyCon.tyConName tycon)
+            Map.lookup name builtin_types
+      -- If not a builtin type, try the custom types
+      let existing_ty = (fmap fst) $ Map.lookup htype typemap
+      case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
+        -- Found a type, return it
+        Just t -> return (Right t)
+        -- No type yet, try to construct it
+        Nothing -> do
+          newty_maybe <- (construct_vhdl_ty ty)
+          case newty_maybe of
+            Right (ty_id, ty_def) -> do
+              -- TODO: Check name uniqueness
+              modA vsTypes (Map.insert htype (ty_id, ty_def))
+              modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)]) 
+              return (Right ty_id)
+            Left err -> return $ Left $
+              "VHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n"
+              ++ err
+    -- Error when constructing htype
+    Left err -> return $ Left err 
+
+-- Construct a new VHDL type for the given Haskell type. Returns an error
+-- message or the resulting typemark and typedef.
+construct_vhdl_ty :: Type.Type -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
 construct_vhdl_ty ty = do
   case Type.splitTyConApp_maybe ty of
     Just (tycon, args) -> do
       let name = Name.getOccString (TyCon.tyConName tycon)
       case name of
-        "TFVec" -> do
-          res <- mk_vector_ty (tfvec_len ty) (tfvec_elem ty)
-          return $ Just $ (Arrow.second Right) res
+        "TFVec" -> mk_vector_ty ty
         -- "SizedWord" -> do
         --   res <- mk_vector_ty (sized_word_len ty) ty
         --   return $ Just $ (Arrow.second Left) res
-        "RangedWord" -> do 
-          res <- mk_natural_ty 0 (ranged_word_bound ty)
-          return $ Just $ (Arrow.second Right) res
+        "RangedWord" -> mk_natural_ty 0 (ranged_word_bound ty)
         -- Create a custom type from this tycon
         otherwise -> mk_tycon_ty tycon args
-    Nothing -> return $ Nothing
+    Nothing -> return (Left $ "VHDLTools.construct_vhdl_ty: Cannot create type for non-tycon type: " ++ pprString ty ++ "\n")
 
 -- | Create VHDL type for a custom tycon
-mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> VHDLSession (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
+mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
 mk_tycon_ty tycon args =
   case TyCon.tyConDataCons tycon of
     -- Not an algebraic type
-    [] -> error $ "Only custom algebraic types are supported: " ++ pprString tycon
+    [] -> return (Left $ "VHDLTools.mk_tycon_ty: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n")
     [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 elem_names = concat $ map prettyShow elem_tys
-      let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon) ++ elem_names
-      let ty_def = AST.TDR $ AST.RecordTypeDef elems
-      return $ Just (ty_id, Left ty_def)
-    dcs -> error $ "Only single constructor datatypes supported: " ++ pprString tycon
+      elem_tys_either <- mapM vhdl_ty_either real_arg_tys
+      case Either.partitionEithers elem_tys_either of
+        -- No errors in element types
+        ([], elem_tys) -> do
+          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 elem_names = concat $ map prettyShow elem_tys
+          let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon) ++ elem_names
+          let ty_def = AST.TDR $ AST.RecordTypeDef elems
+          return $ Right (ty_id, Left ty_def)
+        -- There were errors in element types
+        (errors, _) -> return $ Left $
+          "VHDLTools.mk_tycon_ty: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
+          ++ (concat errors)
+    dcs -> return $ Left $ "VHDLTools.mk_tycon_ty: Only single constructor datatypes supported: " ++ pprString tycon ++ "\n"
   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
@@ -338,46 +363,140 @@ mk_tycon_ty tycon args =
 
 -- | Create a VHDL vector type
 mk_vector_ty ::
-  Int -- ^ The length of the vector
-  -> Type.Type -- ^ The Haskell element type of the Vector
-  -> VHDLSession (AST.TypeMark, AST.SubtypeIn) -- The typemark created.
-
-mk_vector_ty len el_ty = do
-  elem_types_map <- getA vsElemTypes
-  el_ty_tm <- vhdl_ty el_ty
-  let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId el_ty_tm) ++ "-0_to_" ++ (show len)
-  let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
-  let existing_elem_ty = (fmap fst) $ Map.lookup (OrdType el_ty) elem_types_map
-  case existing_elem_ty of
-    Just t -> do
-      let ty_def = AST.SubtypeIn t (Just range)
-      return (ty_id, ty_def)
-    Nothing -> do
-      let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm)
-      let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] el_ty_tm
-      modA vsElemTypes (Map.insert (OrdType el_ty) (vec_id, vec_def))
-      --modA vsTypeFuns (Map.insert (OrdType el_ty) (genUnconsVectorFuns el_ty_tm vec_id)) 
-      let ty_def = AST.SubtypeIn vec_id (Just range)
-      return (ty_id, ty_def)
+  Type.Type -- ^ The Haskell type of the Vector
+  -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
+      -- ^ An error message or The typemark created.
+
+mk_vector_ty ty = do
+  types_map <- getA vsTypes
+  let (nvec_l, nvec_el) = Type.splitAppTy ty
+  let (nvec, leng) = Type.splitAppTy nvec_l
+  let vec_ty = Type.mkAppTy nvec nvec_el
+  let len = tfvec_len ty
+  let el_ty = tfvec_elem ty
+  el_ty_tm_either <- vhdl_ty_either el_ty
+  case el_ty_tm_either of
+    -- Could create element type
+    Right el_ty_tm -> do
+      let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId el_ty_tm) ++ "-0_to_" ++ (show len)
+      let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
+      let existing_elem_ty = (fmap fst) $ Map.lookup (StdType $ OrdType vec_ty) types_map
+      case existing_elem_ty of
+        Just t -> do
+          let ty_def = AST.SubtypeIn t (Just range)
+          return (Right (ty_id, Right ty_def))
+        Nothing -> do
+          let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm)
+          let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] el_ty_tm
+          modA vsTypes (Map.insert (StdType $ OrdType vec_ty) (vec_id, (Left vec_def)))
+          modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Left vec_def))]) 
+          let ty_def = AST.SubtypeIn vec_id (Just range)
+          return (Right (ty_id, Right ty_def))
+    -- Could not create element type
+    Left err -> return $ Left $ 
+      "VHDLTools.mk_vector_ty: Can not construct vectortype for elementtype: " ++ pprString el_ty  ++ "\n"
+      ++ err
 
 mk_natural_ty ::
   Int -- ^ The minimum bound (> 0)
   -> Int -- ^ The maximum bound (> minimum bound)
-  -> VHDLSession (AST.TypeMark, AST.SubtypeIn) -- The typemark created.
+  -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
+      -- ^ An error message or The typemark created.
 mk_natural_ty min_bound max_bound = do
   let ty_id = mkVHDLExtId $ "nat_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
   let range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit $ (show min_bound)) (AST.PrimLit $ (show max_bound))
   let ty_def = AST.SubtypeIn naturalTM (Just range)
-  return (ty_id, ty_def)
+  return (Right (ty_id, 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 -> VHDLSession [AST.VHDLId]
+getFieldLabels :: Type.Type -> TypeSession [AST.VHDLId]
 getFieldLabels ty = do
   -- Ensure that the type is generated (but throw away it's VHDLId)
-  vhdl_ty ty
+  let error_msg = "\nVHDLTools.getFieldLabels: Can not get field labels, because: " ++ pprString ty ++ "can not be generated." 
+  vhdl_ty error_msg ty
   -- Get the types map, lookup and unpack the VHDL TypeDef
   types <- getA vsTypes
-  case Map.lookup (OrdType ty) types of
+  -- Assume the type for which we want labels is really translatable
+  Right htype <- mkHType ty
+  case Map.lookup htype types of
     Just (_, Left (AST.TDR (AST.RecordTypeDef elems))) -> return $ map (\(AST.ElementDec id _) -> id) elems
-    _ -> error $ "VHDL.getFieldLabels Type not found or not a record type? This should not happen! Type: " ++ (show ty)
+    _ -> error $ "\nVHDL.getFieldLabels: Type not found or not a record type? This should not happen! Type: " ++ (show ty)
+    
+mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem
+mktydecl (ty_id, Left ty_def) = AST.PDITD $ AST.TypeDec ty_id ty_def
+mktydecl (ty_id, Right ty_def) = AST.PDISD $ AST.SubtypeDec ty_id ty_def
+
+mkHType :: Type.Type -> TypeSession (Either String HType)
+mkHType ty = do
+  -- FIXME: Do we really need to do this here again?
+  let builtin_ty = do -- See if this is a tycon and lookup its name
+        (tycon, args) <- Type.splitTyConApp_maybe ty
+        let name = Name.getOccString (TyCon.tyConName tycon)
+        Map.lookup name builtin_types
+  case builtin_ty of
+    Just typ -> 
+      return $ Right $ BuiltinType $ prettyShow typ
+    Nothing ->
+      case Type.splitTyConApp_maybe ty of
+        Just (tycon, args) -> do
+          let name = Name.getOccString (TyCon.tyConName tycon)
+          case name of
+            "TFVec" -> do
+              let el_ty = tfvec_elem ty
+              elem_htype_either <- mkHType el_ty
+              case elem_htype_either of
+                -- Could create element type
+                Right elem_htype -> do
+                  len <- vec_len ty
+                  return $ Right $ VecType len elem_htype
+                -- Could not create element type
+                Left err -> return $ Left $ 
+                  "VHDLTools.mkHType: Can not construct vectortype for elementtype: " ++ pprString el_ty  ++ "\n"
+                  ++ err
+            otherwise -> do
+              mkTyConHType tycon args
+        Nothing -> return $ Right $ StdType $ OrdType ty
+
+-- FIXME: Do we really need to do this here again?
+mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String HType)
+mkTyConHType tycon args =
+  case TyCon.tyConDataCons tycon of
+    -- Not an algebraic type
+    [] -> return $ Left $ "VHDLTools.mkHType: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n"
+    [dc] -> do
+      let arg_tys = DataCon.dataConRepArgTys dc
+      let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
+      elem_htys_either <- mapM mkHType real_arg_tys
+      case Either.partitionEithers elem_htys_either of
+        -- No errors in element types
+        ([], elem_htys) -> do
+          return $ Right $ ADTType (nameToString (TyCon.tyConName tycon)) elem_htys
+        -- There were errors in element types
+        (errors, _) -> return $ Left $
+          "VHDLTools.mkHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
+          ++ (concat errors)
+    dcs -> return $ Left $ "VHDLTools.mkHType: Only single constructor datatypes supported: " ++ pprString tycon ++ "\n"
+  where
+    tyvars = TyCon.tyConTyVars tycon
+    subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
+
+-- Is the given type representable at runtime?
+isReprType :: Type.Type -> TypeSession Bool
+isReprType ty = do
+  ty_either <- vhdl_ty_either ty
+  return $ case ty_either of
+    Left _ -> False
+    Right _ -> True
+
+vec_len :: Type.Type -> TypeSession Int
+vec_len ty = do
+  veclens <- getA vsTfpInts
+  let len_ty = tfvec_len_ty ty
+  let existing_len = Map.lookup (OrdType len_ty) veclens
+  case existing_len of
+    Just len -> return len
+    Nothing -> do
+      let new_len = tfvec_len ty
+      modA vsTfpInts (Map.insert (OrdType len_ty) (new_len))
+      return new_len
\ No newline at end of file