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

* git://github.com/darchon/clash:
  Keys for typemap can now deal with vector lengths based on type operators

Conflicts:
	Generate.hs
	VHDLTools.hs

diff --cc Generate.hs
index 6b19bb5d729806ee0eb18e8f3a9faaa2e269ee93,dfd9fad8bbfaed867db25a8d368493387cae7c57..b3045def5bfcee16e869fac00e08e603e7335e15
--- 1/Generate.hs
--- 2/Generate.hs
+++ b/Generate.hs
@@@ -72,16 -71,16 +72,16 @@@ genOperator1' op _ f [arg] = return $ o
  
  -- | Generate a function call from the destination binder, function name and a
  -- list of expressions (its arguments)
- genFCall :: BuiltinBuilder 
- genFCall = genExprArgs $ genExprRes genFCall'
- genFCall' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
- genFCall' (Left res) f args = do
+ genFCall :: Bool -> BuiltinBuilder 
+ genFCall switch = genExprArgs $ genExprRes (genFCall' switch)
+ genFCall' :: Bool -> Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
+ genFCall' switch (Left res) f args = do
    let fname = varToString f
-   let el_ty = (tfvec_elem . Var.varType) res
+   let el_ty = if switch then (Var.varType res) else ((tfvec_elem . Var.varType) res)
 -  id <- vectorFunId el_ty fname
 +  id <- MonadState.lift vsType $ vectorFunId el_ty fname
    return $ AST.PrimFCall $ AST.FCall (AST.NSimple id)  $
               map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
- genFCall' (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
+ genFCall' _ (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
  
  -- | Generate a generate statement for the builtin function "map"
  genMap :: BuiltinBuilder

diff --cc VHDLTools.hs
index 5deaf45effbf579d6b5ce03f782c93e8b1c16712,cb4ea741645619d98d37f953930167f39162ab45..d560a7472bfada0303841dc0184312446109fe94
--- 1/VHDLTools.hs
--- 2/VHDLTools.hs
+++ b/VHDLTools.hs
@@@ -263,46 -262,33 +263,47 @@@ builtin_types 
    ]
  
  -- 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
 +  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
          (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
+   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
 -      newty_maybe <- (construct_vhdl_ty msg ty)
 +      newty_maybe <- (construct_vhdl_ty ty)
        case newty_maybe of
 -        Just (ty_id, ty_def) -> do
 +        Right (ty_id, ty_def) -> do
            -- TODO: Check name uniqueness
-           modA vsTypes (Map.insert (OrdType ty) (ty_id, ty_def))
+           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)
@@@ -368,28 -351,22 +369,28 @@@ mk_vector_ty ty = d
    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 (OrdType vec_ty) types_map
++      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 (OrdType vec_ty) (vec_id, (Left vec_def)))
++          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)
@@@ -418,3 -395,41 +420,41 @@@ getFieldLabels ty = d
  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 -> VHDLSession HType
+ 
 -mkTyConHType :: TyCon.TyCon -> [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
+         (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 $ 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
+               elem_htype <- mkHType (tfvec_elem ty)
+               return $ VecType (tfvec_len ty) elem_htype
+             otherwise -> do
+               mkTyConHType tycon args
+         Nothing -> return $ StdType $ OrdType ty
+ 
+ -- FIXME: Do we really need to do this here again?
 -    subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
++mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession HType
+ mkTyConHType tycon args =
+   case TyCon.tyConDataCons tycon of
+     -- Not an algebraic type
+     [] -> error $ "\nVHDLTools.mkHType: 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
+       elem_htys <- mapM mkHType real_arg_tys
+       return $ ADTType (nameToString (TyCon.tyConName tycon)) elem_htys
+     dcs -> error $ "\nVHDLTools.mkHType: Only single constructor datatypes supported: " ++ pprString tycon
+   where
+     tyvars = TyCon.tyConTyVars tycon
++    subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)

diff --cc VHDLTypes.hs
Simple merge