1 module FlattenTypes where
4 import Data.Traversable
5 import qualified Data.Foldable as Foldable
6 import qualified Control.Monad.State as State
13 -- | A signal identifier
14 type UnnamedSignal = Int
16 -- | A map of a Haskell value to signal ids
17 type SignalMap sigid = HsValueMap sigid
19 -- | How is a given (single) value in a function's type (ie, argument or
20 -- return value) used?
22 Port -- ^ Use it as a port (input or output)
23 | State Int -- ^ Use it as state (input or output). The int is used to
24 -- match input state to output state.
25 | HighOrder { -- ^ Use it as a high order function input
26 hoName :: String, -- ^ Which function is passed in?
27 hoArgs :: [HsUseMap] -- ^ Which arguments are already applied? This
28 -- ^ map should only contain Port and other
31 deriving (Show, Eq, Ord)
33 -- | Is this HsValueUse a state use?
34 isStateUse :: HsValueUse -> Bool
35 isStateUse (State _) = True
38 -- | A map from a Haskell value to the use of each single value
39 type HsUseMap = HsValueMap HsValueUse
41 -- | Builds a HsUseMap with the same structure has the given HsValueMap in
42 -- which all the Single elements are marked as State, with increasing state
44 useAsState :: HsValueMap a -> HsUseMap
48 -- Traverse the existing map, resulting in a function that maps an initial
49 -- state number to the final state number and the new map
50 PassState f = traverse asState map
51 -- Run this function to get the new map
53 -- This function maps each element to a State with a unique number, by
54 -- incrementing the state count.
55 asState x = PassState (\s -> (s+1, State s))
57 -- | Builds a HsUseMap with the same structure has the given HsValueMap in
58 -- which all the Single elements are marked as Port.
59 useAsPort :: HsValueMap a -> HsUseMap
60 useAsPort map = fmap (\x -> Port) map
62 -- | A Haskell function with a specific signature. The signature defines what
63 -- use the arguments and return value of the function get.
64 data HsFunction = HsFunction {
66 hsFuncArgs :: [HsUseMap],
68 } deriving (Show, Eq, Ord)
70 hasState :: HsFunction -> Bool
72 any (Foldable.any isStateUse) (hsFuncArgs hsfunc)
73 || Foldable.any isStateUse (hsFuncRes hsfunc)
75 -- | A flattened function application
76 data FApp sigid = FApp {
77 appFunc :: HsFunction,
78 appArgs :: [SignalMap sigid],
79 appRes :: SignalMap sigid
82 -- | A conditional signal definition
83 data CondDef sigid = CondDef {
90 -- | How is a given signal used in the resulting VHDL?
92 SigPortIn -- | Use as an input port
93 | SigPortOut -- | Use as an input port
94 | SigInternal -- | Use as an internal signal
95 | SigStateOld Int -- | Use as the current internal state
96 | SigStateNew Int -- | Use as the new internal state
97 | SigSubState -- | Do not use, state variable is used in a subcircuit
99 -- | Is this a port signal use?
100 isPortSigUse :: SigUse -> Bool
101 isPortSigUse SigPortIn = True
102 isPortSigUse SigPortOut = True
103 isPortSigUse _ = False
105 -- | Is this a state signal use? Returns false for substate.
106 isStateSigUse :: SigUse -> Bool
107 isStateSigUse (SigStateOld _) = True
108 isStateSigUse (SigStateNew _) = True
109 isStateSigUse _ = False
111 -- | Is this an internal signal use?
112 isInternalSigUse :: SigUse -> Bool
113 isInternalSigUse SigInternal = True
114 isInternalSigUse _ = False
116 -- | Information on a signal definition
117 data SignalInfo = SignalInfo {
118 sigName :: Maybe String,
123 -- | A flattened function
124 data FlatFunction' sigid = FlatFunction {
125 flat_args :: [SignalMap sigid],
126 flat_res :: SignalMap sigid,
127 flat_apps :: [FApp sigid],
128 flat_conds :: [CondDef sigid],
129 flat_sigs :: [(sigid, SignalInfo)]
132 -- | Lookup a given signal id in a signal map, and return the associated
133 -- SignalInfo. Errors out if the signal was not found.
134 signalInfo :: Eq sigid => [(sigid, SignalInfo)] -> sigid -> SignalInfo
135 signalInfo sigs id = Maybe.fromJust $ lookup id sigs
137 -- | A flat function that does not have its signals named
138 type FlatFunction = FlatFunction' UnnamedSignal
140 -- | A list of binds in effect at a particular point of evaluation
142 CoreBndr, -- ^ The bind name
143 Either -- ^ The bind value which is either
144 (SignalMap UnnamedSignal)
147 HsValueUse, -- ^ or a HighOrder function
148 [UnnamedSignal] -- ^ With these signals already applied to it
152 -- | The state during the flattening of a single function
153 type FlattenState = State.State ([FApp UnnamedSignal], [CondDef UnnamedSignal], [(UnnamedSignal, SignalInfo)], UnnamedSignal)
155 -- | Add an application to the current FlattenState
156 addApp :: (FApp UnnamedSignal) -> FlattenState ()
158 (apps, conds, sigs, n) <- State.get
159 State.put (a:apps, conds, sigs, n)
161 -- | Add a conditional definition to the current FlattenState
162 addCondDef :: (CondDef UnnamedSignal) -> FlattenState ()
164 (apps, conds, sigs, n) <- State.get
165 State.put (apps, c:conds, sigs, n)
167 -- | Generates a new signal id, which is unique within the current flattening.
168 genSignalId :: SigUse -> Type.Type -> FlattenState UnnamedSignal
169 genSignalId use ty = do
170 (apps, conds, sigs, n) <- State.get
171 -- Generate a new numbered but unnamed signal
172 let s = (n, SignalInfo Nothing use ty)
173 State.put (apps, conds, s:sigs, n+1)