Merge git://github.com/darchon/clash into cλash

[matthijs/master-project/cλash.git] / VHDLTools.hs

diff --git a/VHDLTools.hs b/VHDLTools.hs
index cb4ea741645619d98d37f953930167f39162ab45..d560a7472bfada0303841dc0184312446109fe94 100644 (file)
--- a/VHDLTools.hs
+++ b/VHDLTools.hs
@@ -2,6 +2,7 @@ module VHDLTools where
 
 -- Standard modules
 import qualified Maybe
 
 -- 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
 import qualified Data.List as List
 import qualified Data.Map as Map
 import qualified Control.Monad as Monad


@@ -262,8 +263,19 @@ builtin_types =
   ]
 
 -- Translate a Haskell type to a VHDL type, generating a new type if needed.
   ]
 
 -- Translate a Haskell type to a VHDL type, generating a new type if needed.

-vhdl_ty :: String -> Type.Type -> VHDLSession AST.TypeMark
+-- 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
 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
   htype <- mkHType ty
   let builtin_ty = do -- See if this is a tycon and lookup its name
   typemap <- getA vsTypes
   htype <- mkHType ty
   let builtin_ty = do -- See if this is a tycon and lookup its name


@@ -274,62 +286,67 @@ vhdl_ty msg ty = do
   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
   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 t
+    Just t -> return (Right t)

     -- No type yet, try to construct it
     Nothing -> do
     -- No type yet, try to construct it
     Nothing -> do

-      newty_maybe <- (construct_vhdl_ty msg ty)
+      newty_maybe <- (construct_vhdl_ty ty)

       case newty_maybe of
       case newty_maybe of

-        Just (ty_id, ty_def) -> do
+        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)]) 
           -- TODO: Check name uniqueness
           modA vsTypes (Map.insert htype (ty_id, ty_def))
           modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)]) 

-          return ty_id
-        Nothing -> error $ msg ++ "\nVHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n"
-
--- Construct a new VHDL type for the given Haskell type.
-construct_vhdl_ty :: String -> Type.Type -> VHDLSession (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
-construct_vhdl_ty msg ty = do
+          return (Right ty_id)
+        Left err -> return $ Left $
+          "VHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n"
+          ++ 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
   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 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
         -- "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
         -- Create a custom type from this tycon

-        otherwise -> mk_tycon_ty msg tycon args
-    Nothing -> return $ Nothing
+        otherwise -> mk_tycon_ty tycon args
+    Nothing -> return (Left $ "VHDLTools.construct_vhdl_ty: Cannot create type for non-tycon type: " ++ pprString ty ++ "\n")

 
 -- | Create VHDL type for a custom tycon
 
 -- | Create VHDL type for a custom tycon

-mk_tycon_ty :: String -> TyCon.TyCon -> [Type.Type] -> VHDLSession (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
-mk_tycon_ty msg tycon args =
+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
   case TyCon.tyConDataCons tycon of
     -- Not an algebraic type

-    [] -> error $ "\nVHDLTools.mk_tycon_ty: 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
     [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

-      let error_msg = msg ++ "\nVHDLTools.mk_tycon_ty: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for one of the arguments."
-      elem_tys <- mapM (vhdl_ty error_msg) 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 $ "\nVHDLTools.mk_tycon_ty: 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
   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


@@ -342,7 +359,8 @@ mk_tycon_ty msg tycon args =
 -- | Create a VHDL vector type
 mk_vector_ty ::
   Type.Type -- ^ The Haskell type of the Vector
 -- | Create a VHDL vector type
 mk_vector_ty ::
   Type.Type -- ^ The Haskell type of the Vector

-  -> 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_vector_ty ty = do
   types_map <- getA vsTypes
 
 mk_vector_ty ty = do
   types_map <- getA vsTypes


@@ -351,36 +369,43 @@ mk_vector_ty ty = do
   let vec_ty = Type.mkAppTy nvec nvec_el
   let len = tfvec_len ty
   let el_ty = tfvec_elem ty
   let vec_ty = Type.mkAppTy nvec nvec_el
   let len = tfvec_len ty
   let el_ty = tfvec_elem ty

-  let error_msg = "\nVHDLTools.mk_vector_ty: Can not construct vectortype for elementtype: " ++ pprString el_ty 
-  el_ty_tm <- vhdl_ty error_msg 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 (StdType $ OrdType vec_ty) 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 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 (ty_id, ty_def)
+  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)
 
 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)
 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.
 
 -- 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)
   let error_msg = "\nVHDLTools.getFieldLabels: Can not get field labels, because: " ++ pprString ty ++ "can not be generated." 
 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." 


@@ -396,7 +421,7 @@ 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
 
 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 -> VHDLSession HType
+mkHType :: Type.Type -> TypeSession 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
 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


@@ -419,7 +444,7 @@ mkHType ty = do
         Nothing -> return $ StdType $ OrdType ty
 
 -- FIXME: Do we really need to do this here again?
         Nothing -> return $ StdType $ OrdType ty
 
 -- FIXME: Do we really need to do this here again?

-mkTyConHType :: TyCon.TyCon -> [Type.Type] -> VHDLSession HType
+mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession HType

 mkTyConHType tycon args =
   case TyCon.tyConDataCons tycon of
     -- Not an algebraic type
 mkTyConHType tycon args =
   case TyCon.tyConDataCons tycon of
     -- Not an algebraic type


@@ -432,4 +457,4 @@ mkTyConHType tycon args =
     dcs -> error $ "\nVHDLTools.mkHType: Only single constructor datatypes supported: " ++ pprString tycon
   where
     tyvars = TyCon.tyConTyVars tycon
     dcs -> error $ "\nVHDLTools.mkHType: Only single constructor datatypes supported: " ++ pprString tycon
   where
     tyvars = TyCon.tyConTyVars tycon

-    subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
\ No newline at end of file
+    subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)