--- | Look up a signal in the signal name map
-lookupSigName :: [(SignalId, SignalInfo)] -> SignalId -> String
-lookupSigName sigs sig = name
- where
- info = Maybe.fromMaybe
- (error $ "Unknown signal " ++ (show sig) ++ " used? This should not happen!")
- (lookup sig sigs)
- name = Maybe.fromMaybe
- (error $ "Unnamed signal " ++ (show sig) ++ " used? This should not happen!")
- (sigName info)
-
--- | Create an VHDL port -> signal association
-mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem
-mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLExtId signal)))
-mkAssocElem Nothing _ = Nothing
-
--- | The VHDL Bit type
-bit_ty :: AST.TypeMark
-bit_ty = AST.unsafeVHDLBasicId "Bit"
-
--- | The VHDL Boolean type
-bool_ty :: AST.TypeMark
-bool_ty = AST.unsafeVHDLBasicId "Boolean"
-
--- | The VHDL std_logic
-std_logic_ty :: AST.TypeMark
-std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
-
--- Translate a Haskell type to a VHDL type
-vhdl_ty :: Type.Type -> VHDLState AST.TypeMark
-vhdl_ty 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
- let new_ty = do
- -- Use the Maybe Monad for failing when one of these fails
- (tycon, args) <- Type.splitTyConApp_maybe ty
- let name = Name.getOccString (TyCon.tyConName tycon)
- case name of
- "TFVec" -> Just $ mk_vector_ty (tfvec_len ty) ty
- "SizedWord" -> Just $ mk_vector_ty (sized_word_len ty) ty
- otherwise -> Nothing
- -- Return new_ty when a new type was successfully created
- Maybe.fromMaybe
- (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty))
- new_ty
-
--- | Create a VHDL vector type
-mk_vector_ty ::
- Int -- ^ The length of the vector
- -> Type.Type -- ^ The Haskell type to create a VHDL type for
- -> VHDLState AST.TypeMark -- The typemark created.
-
-mk_vector_ty len ty = do
- -- Assume there is a single type argument
- let ty_id = mkVHDLExtId $ "vector_" ++ (show len)
- -- TODO: Use el_ty
- let range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
- let ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty
- let ty_dec = AST.TypeDec ty_id ty_def
- -- TODO: Check name uniqueness
- --State.modify (Map.insert (OrdType ty) (ty_id, ty_dec))
- modA vsTypes (Map.insert (OrdType ty) (ty_id, ty_dec))
- modA vsTypeFuns (Map.insert (OrdType ty) (genUnconsVectorFuns std_logic_ty ty_id))
- return ty_id
-
-
-builtin_types =
- Map.fromList [
- ("Bit", std_logic_ty),
- ("Bool", bool_ty) -- TysWiredIn.boolTy
- ]
-
--- Shortcut for
--- Can only contain alphanumerics and underscores. The supplied string must be
--- a valid basic id, otherwise an error value is returned. This function is
--- not meant to be passed identifiers from a source file, use mkVHDLExtId for
--- that.
-mkVHDLBasicId :: String -> AST.VHDLId
-mkVHDLBasicId s =
- AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
- where
- -- Strip invalid characters.
- strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
- -- Strip leading numbers and underscores
- strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
- -- Strip multiple adjacent underscores
- strip_multiscore = concat . map (\cs ->
- case cs of
- ('_':_) -> "_"
- _ -> cs
- ) . List.group
-
--- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
--- different characters than basic ids, but can never be used to refer to
--- basic ids.
--- Use extended Ids for any values that are taken from the source file.
-mkVHDLExtId :: String -> AST.VHDLId
-mkVHDLExtId s =
- AST.unsafeVHDLExtId $ strip_invalid s
- where
- -- Allowed characters, taken from ForSyde's mkVHDLExtId
- allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
- strip_invalid = filter (`elem` allowed)
-
--- Creates a VHDL Id from a binder
-bndrToVHDLId ::
- CoreSyn.CoreBndr
- -> AST.VHDLId
-
-bndrToVHDLId = mkVHDLExtId . OccName.occNameString . Name.nameOccName . Var.varName
-
--- Extracts the binder name as a String
-bndrToString ::
- CoreSyn.CoreBndr
- -> String
-
-bndrToString = OccName.occNameString . Name.nameOccName . Var.varName
-
--- | 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
-data BuiltIn = BuiltIn String [(String, AST.TypeMark)] (String, AST.TypeMark)
-
--- | Translate a list of concise representation of builtin functions to a
--- SignatureMap
-mkBuiltins :: [BuiltIn] -> SignatureMap
-mkBuiltins = Map.fromList . map (\(BuiltIn name args res) ->
- (name,
- Entity (VHDL.mkVHDLBasicId name) (map toVHDLSignalMapElement args) (toVHDLSignalMapElement res))
- )
-
-builtin_hsfuncs = Map.keys builtin_funcs
-builtin_funcs = mkBuiltins
- [
- BuiltIn "hwxor" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
- BuiltIn "hwand" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
- BuiltIn "hwor" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
- BuiltIn "hwnot" [("a", VHDL.bit_ty)] ("o", VHDL.bit_ty)
- ]
-
--- | Map a port specification of a builtin function to a VHDL Signal to put in
--- a VHDLSignalMap
-toVHDLSignalMapElement :: (String, AST.TypeMark) -> VHDLSignalMapElement
-toVHDLSignalMapElement (name, ty) = Just (mkVHDLBasicId name, ty)
+mkConcSm (bndr, app@(CoreSyn.App _ _))= do
+ let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
+ let valargs = get_val_args (Var.varType f) args
+ genApplication (Left bndr) f (map Left valargs)
+
+-- A single alt case must be a selector. This means thee scrutinee is a simple
+-- variable, the alternative is a dataalt with a single non-wild binder that
+-- is also returned.
+mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) =
+ case alt of
+ (DataAlt dc, bndrs, (Var sel_bndr)) -> do
+ case List.elemIndex sel_bndr bndrs of
+ Just i -> do
+ labels <- MonadState.lift vsType $ getFieldLabels (Id.idType scrut)
+ let label = labels!!i
+ let sel_name = mkSelectedName (varToVHDLName scrut) label
+ let sel_expr = AST.PrimName sel_name
+ return [mkUncondAssign (Left bndr) sel_expr]
+ Nothing -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
+
+ _ -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
+
+-- Multiple case alt are be conditional assignments and have only wild
+-- 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, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) = do
+ scrut' <- MonadState.lift vsType $ varToVHDLExpr scrut
+ let cond_expr = scrut' AST.:=: (altconToVHDLExpr con)
+ true_expr <- MonadState.lift vsType $ varToVHDLExpr true
+ false_expr <- MonadState.lift vsType $ varToVHDLExpr false
+ return [mkCondAssign (Left bndr) cond_expr true_expr false_expr]
+
+mkConcSm (_, (Case (Var _) _ _ alts)) = error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives"
+mkConcSm (_, Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement has does not have a simple variable as scrutinee"
+mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr