2 -- Functions to generate VHDL from FlatFunctions
6 import Data.Traversable
7 import qualified Data.Foldable as Foldable
12 import qualified TyCon
13 import Outputable ( showSDoc, ppr )
15 import qualified ForSyDe.Backend.VHDL.AST as AST
19 import TranslatorTypes
21 -- | Create an entity for a given function
23 HsFunction -- | The function signature
24 -> FuncData -- | The function data collected so far
25 -> FuncData -- | The modified function data
27 createEntity hsfunc fdata =
28 let func = flatFunc fdata in
30 -- Skip (builtin) functions without a FlatFunction
32 -- Create an entity for all other functions
36 sigs = flat_sigs flatfunc
37 args = flat_args flatfunc
38 res = flat_res flatfunc
39 args' = map (fmap (mkMap sigs)) args
40 res' = fmap (mkMap sigs) res
41 ent_decl' = createEntityAST hsfunc args' res'
42 entity' = Entity args' res' (Just ent_decl')
44 fdata { funcEntity = Just entity' }
46 mkMap :: Eq id => [(id, SignalInfo)] -> id -> (AST.VHDLId, AST.TypeMark)
48 (mkVHDLId nm, vhdl_ty ty)
50 info = Maybe.fromMaybe
51 (error $ "Signal not found in the name map? This should not happen!")
54 (error $ "Signal not named? This should not happen!")
58 -- | Create the VHDL AST for an entity
60 HsFunction -- | The signature of the function we're working with
61 -> [VHDLSignalMap] -- | The entity's arguments
62 -> VHDLSignalMap -- | The entity's result
63 -> AST.EntityDec -- | The entity with the ent_decl filled in as well
65 createEntityAST hsfunc args res =
66 AST.EntityDec vhdl_id ports
68 vhdl_id = mkEntityId hsfunc
69 ports = concatMap (mapToPorts AST.In) args
70 ++ mapToPorts AST.Out res
71 mapToPorts :: AST.Mode -> VHDLSignalMap -> [AST.IfaceSigDec]
73 map (mkIfaceSigDec mode) (Foldable.toList m)
75 -- | Create a port declaration
77 AST.Mode -- | The mode for the port (In / Out)
78 -> (AST.VHDLId, AST.TypeMark) -- | The id and type for the port
79 -> AST.IfaceSigDec -- | The resulting port declaration
81 mkIfaceSigDec mode (id, ty) = AST.IfaceSigDec id mode ty
83 -- | Generate a VHDL entity name for the given hsfunc
85 -- TODO: This doesn't work for functions with multiple signatures!
86 mkVHDLId $ hsFuncName hsfunc
88 -- | Create an architecture for a given function
90 HsFunction -- | The function signature
91 -> FuncData -- | The function data collected so far
92 -> FuncData -- | The modified function data
94 createArchitecture hsfunc fdata =
95 let func = flatFunc fdata in
97 -- Skip (builtin) functions without a FlatFunction
99 -- Create an architecture for all other functions
102 sigs = flat_sigs flatfunc
103 args = flat_args flatfunc
104 res = flat_res flatfunc
105 entity_id = Maybe.fromMaybe
106 (error $ "Building architecture without an entity? This should not happen!")
108 -- Create signal declarations for all signals that are not in args and
110 sig_decs = [mkSigDec info | (id, info) <- sigs, (all (id `Foldable.notElem`) (res:args)) ]
111 arch = AST.ArchBody (mkVHDLId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) []
113 fdata { funcArch = Just arch }
115 mkSigDec :: SignalInfo -> AST.SigDec
117 AST.SigDec (mkVHDLId name) (vhdl_ty ty) Nothing
119 name = Maybe.fromMaybe
120 (error $ "Unnamed signal? This should not happen!")
124 -- | Extracts the generated entity id from the given funcdata
125 getEntityId :: FuncData -> Maybe AST.VHDLId
127 case funcEntity fdata of
129 Just e -> case ent_decl e of
131 Just (AST.EntityDec id _) -> Just id
134 (HsFunction, FuncData) -- | A function from the session
135 -> [AST.LibraryUnit] -- | The library units it generates
137 getLibraryUnits (hsfunc, fdata) =
138 case funcEntity fdata of
140 Just ent -> case ent_decl ent of
142 Just decl -> [AST.LUEntity decl]
144 case funcArch fdata of
146 Just arch -> [AST.LUArch arch]
148 -- | The VHDL Bit type
149 bit_ty :: AST.TypeMark
150 bit_ty = AST.unsafeVHDLBasicId "Bit"
152 -- Translate a Haskell type to a VHDL type
153 vhdl_ty :: Type.Type -> AST.TypeMark
154 vhdl_ty ty = Maybe.fromMaybe
155 (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty))
158 -- Translate a Haskell type to a VHDL type
159 vhdl_ty_maybe :: Type.Type -> Maybe AST.TypeMark
161 case Type.splitTyConApp_maybe ty of
162 Just (tycon, args) ->
163 let name = TyCon.tyConName tycon in
164 -- TODO: Do something more robust than string matching
165 case Name.getOccString name of
171 mkVHDLId :: String -> AST.VHDLId
172 mkVHDLId = AST.unsafeVHDLBasicId