X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=VHDL.hs;h=418ac181fc95a4c6e0bb43f83410a463de7623b6;hb=29ee33754fc52a1a46fd44aba98a4dce8c81ce58;hp=63537c7e6f58c1a1de605ab291185a2bbdfbfdcc;hpb=a045ea0bb646279dc138c887682f16b51eb8476b;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git a/VHDL.hs b/VHDL.hs
index 63537c7..418ac18 100644
--- a/VHDL.hs
+++ b/VHDL.hs
@@ -11,6 +11,7 @@ import qualified Control.Monad as Monad
 import qualified Control.Arrow as Arrow
 import qualified Data.Traversable as Traversable
 import qualified Data.Monoid as Monoid
+import Data.Accessor
 
 import qualified Type
 import qualified TysWiredIn
@@ -43,9 +44,9 @@ createEntity ::
                     ---  Entity for builtin functions.
 
 createEntity hsfunc fdata = 
-  case flatFunc fdata of
+  case fdata ^. fdFlatFunc of
     -- Skip (builtin) functions without a FlatFunction
-    Nothing -> funcEntity fdata
+    Nothing -> fdata ^. fdEntity
     -- Create an entity for all other functions
     Just flatfunc ->
       let 
@@ -124,36 +125,36 @@ mkEntityId hsfunc =
 
 -- | Create an architecture for a given function
 createArchitecture ::
-  HsFunction        -- | The function signature
-  -> FuncData       -- | The function data collected so far
-  -> VHDLState ()
+  FuncMap           -- ^ The functions in the current session
+  -> HsFunction     -- ^ The function signature
+  -> FuncData       -- ^ The function data collected so far
+  -> Maybe AST.ArchBody -- ^ The architecture for this function
 
-createArchitecture hsfunc fdata = 
-  let func = flatFunc fdata in
-  case func of
+createArchitecture funcs hsfunc fdata = 
+  case fdata ^. fdFlatFunc of
     -- Skip (builtin) functions without a FlatFunction
-    Nothing -> do return ()
+    Nothing -> fdata ^. fdArch
     -- Create an architecture for all other functions
-    Just flatfunc -> do
-      let sigs = flat_sigs flatfunc
-      let args = flat_args flatfunc
-      let res  = flat_res  flatfunc
-      let defs = flat_defs flatfunc
-      let entity_id = Maybe.fromMaybe
+    Just flatfunc ->
+      let
+        sigs = flat_sigs flatfunc
+        args = flat_args flatfunc
+        res  = flat_res  flatfunc
+        defs = flat_defs flatfunc
+        entity_id = Maybe.fromMaybe
                       (error $ "Building architecture without an entity? This should not happen!")
                       (getEntityId fdata)
-      -- Create signal declarations for all signals that are not in args and
-      -- res
-      let (ty_decls, sig_decs)  = Arrow.second Maybe.catMaybes $ Traversable.traverse (mkSigDec . snd) sigs
-      -- TODO: Unique ty_decls
-      -- TODO: Store ty_decls somewhere
-      -- Create concurrent statements for all signal definitions
-      funcs <- getFuncMap
-      let statements = zipWith (mkConcSm funcs sigs) defs [0..]
-      let procs = map mkStateProcSm (makeStatePairs flatfunc)
-      let procs' = map AST.CSPSm procs
-      let arch = AST.ArchBody (mkVHDLId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
-      setArchitecture hsfunc arch
+        -- Create signal declarations for all signals that are not in args and
+        -- res
+        (ty_decls, sig_decs)  = Arrow.second Maybe.catMaybes $ Traversable.traverse (mkSigDec . snd) sigs
+        -- TODO: Unique ty_decls
+        -- TODO: Store ty_decls somewhere
+        -- Create concurrent statements for all signal definitions
+        statements = zipWith (mkConcSm funcs sigs) defs [0..]
+        procs = map mkStateProcSm (makeStatePairs flatfunc)
+        procs' = map AST.CSPSm procs
+      in
+        Just $ AST.ArchBody (mkVHDLId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
 
 -- | Looks up all pairs of old state, new state signals, together with
 --   the state id they represent.
@@ -218,7 +219,7 @@ mkConcSm funcs sigs (FApp hsfunc args res) num =
         fdata_maybe
     entity = Maybe.fromMaybe
         (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' without entity declaration? This should not happen!")
-        (funcEntity fdata)
+        (fdata ^. fdEntity)
     entity_id = ent_id entity
     label = (AST.fromVHDLId entity_id) ++ "_" ++ (show num)
     -- Add a clk port if we have state
@@ -307,7 +308,7 @@ mkAssocElem Nothing _ = Nothing
 -- | Extracts the generated entity id from the given funcdata
 getEntityId :: FuncData -> Maybe AST.VHDLId
 getEntityId fdata =
-  case funcEntity fdata of
+  case fdata ^. fdEntity of
     Nothing -> Nothing
     Just e  -> case ent_decl e of
       Nothing -> Nothing
@@ -318,13 +319,13 @@ getLibraryUnits ::
   -> [AST.LibraryUnit]  -- | The entity, architecture and optional package for the function
 
 getLibraryUnits fdata =
-  case funcEntity fdata of 
+  case fdata ^. fdEntity of 
     Nothing -> []
     Just ent -> 
       case ent_decl ent of
       Nothing -> []
       Just decl ->
-        case funcArch fdata of
+        case fdata ^. fdArch of
           Nothing -> []
           Just arch ->
               [AST.LUEntity decl, AST.LUArch arch]