Add a getFuncMap accessor for VHDLState.

[matthijs/master-project/cλash.git] / VHDL.hs

diff --git a/VHDL.hs b/VHDL.hs
index f5ab7cd25cd23046d6e95887036c6f50d3e51331..6f3705e421d6f0d55b16faef97054ac3f3462367 100644 (file)
--- a/VHDL.hs
+++ b/VHDL.hs
@@ -4,6 +4,7 @@
 module VHDL where
 
 import qualified Data.Foldable as Foldable
+import qualified Data.List as List
 import qualified Maybe
 import qualified Control.Monad as Monad
 import qualified Control.Arrow as Arrow
@@ -24,28 +25,25 @@ import FlattenTypes
 import TranslatorTypes
 import Pretty
 
-getDesignFiles :: VHDLState [AST.DesignFile]
-getDesignFiles = do
-  -- Extract the library units generated from all the functions in the
-  -- session.
-  funcs <- getFuncs
-  let units = Maybe.mapMaybe getLibraryUnits funcs
-  let context = [
-        AST.Library $ mkVHDLId "IEEE",
-        AST.Use $ (AST.NSimple $ mkVHDLId "IEEE.std_logic_1164") AST.:.: AST.All]
-  return $ map (AST.DesignFile context) units
+getDesignFiles :: [FuncData] -> [AST.DesignFile]
+getDesignFiles funcs =
+  map (AST.DesignFile context) units
+  where
+    units = filter (not.null) $ map getLibraryUnits funcs
+    context = [
+      AST.Library $ mkVHDLId "IEEE",
+      AST.Use $ (AST.NSimple $ mkVHDLId "IEEE.std_logic_1164") AST.:.: AST.All]
   
 -- | Create an entity for a given function
 createEntity ::
   HsFunction        -- | The function signature
   -> FuncData       -- | The function data collected so far
-  -> VHDLState ()
+  -> Maybe Entity   -- | The resulting entity
 
 createEntity hsfunc fdata = 
-  let func = flatFunc fdata in
-  case func of
+  case flatFunc fdata of
     -- Skip (builtin) functions without a FlatFunction
-    Nothing -> do return ()
+    Nothing -> Nothing
     -- Create an entity for all other functions
     Just flatfunc ->
       let 
@@ -61,9 +59,8 @@ createEntity hsfunc fdata =
           then Nothing
           else Just $ AST.PackageDec pkg_id (map AST.PDITD $ ty_decls ++ ty_decls')
         AST.EntityDec entity_id _ = ent_decl' 
-        entity' = Entity entity_id args' res' (Just ent_decl') pkg_decl
-      in do
-        setEntity hsfunc entity'
+      in 
+        Just $ Entity entity_id args' res' (Just ent_decl') pkg_decl
   where
     mkMap :: 
       [(SignalId, SignalInfo)] 
@@ -305,20 +302,19 @@ getEntityId fdata =
       Just (AST.EntityDec id _) -> Just id
 
 getLibraryUnits ::
-  (HsFunction, FuncData)      -- | A function from the session
-  -> Maybe [AST.LibraryUnit]  -- | The entity, architecture and optional package for the function
+  FuncData                    -- | A function from the session
+  -> [AST.LibraryUnit]  -- | The entity, architecture and optional package for the function
 
-getLibraryUnits (hsfunc, fdata) =
+getLibraryUnits fdata =
   case funcEntity fdata of 
-    Nothing -> Nothing
+    Nothing -> []
     Just ent -> 
       case ent_decl ent of
-      Nothing -> Nothing
+      Nothing -> []
       Just decl ->
         case funcArch fdata of
-          Nothing -> Nothing
+          Nothing -> []
           Just arch ->
-            Just $
               [AST.LUEntity decl, AST.LUArch arch]
               ++ (Maybe.maybeToList (fmap AST.LUPackageDec $ ent_pkg_decl ent))
 
@@ -371,7 +367,13 @@ vhdl_ty_maybe ty =
 -- Shortcut
 mkVHDLId :: String -> AST.VHDLId
 mkVHDLId s = 
-  AST.unsafeVHDLBasicId s'
+  AST.unsafeVHDLBasicId $ (strip_multiscore . strip_invalid) s
   where
     -- Strip invalid characters.
-    s' = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.") s
+    strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
+    -- Strip multiple adjacent underscores
+    strip_multiscore = concat . map (\cs -> 
+        case cs of 
+          ('_':_) -> "_"
+          _ -> cs
+      ) . List.group