Remove createEntity from the VHDLState monad.

[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
 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
 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
 
 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
   
 -- | 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 = 
 
 createEntity hsfunc fdata = 

-  let func = flatFunc fdata in
-  case func of
+  case flatFunc fdata of

     -- Skip (builtin) functions without a FlatFunction
     -- Skip (builtin) functions without a FlatFunction

-    Nothing -> do return ()
+    Nothing -> Nothing

     -- Create an entity for all other functions
     Just flatfunc ->
       let 
     -- 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' 
           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)] 
   where
     mkMap :: 
       [(SignalId, SignalInfo)] 


@@ -305,20 +302,19 @@ getEntityId fdata =
       Just (AST.EntityDec id _) -> Just id
 
 getLibraryUnits ::
       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 
   case funcEntity fdata of 

-    Nothing -> Nothing
+    Nothing -> []

     Just ent -> 
       case ent_decl ent of
     Just ent -> 
       case ent_decl ent of

-      Nothing -> Nothing
+      Nothing -> []

       Just decl ->
         case funcArch fdata of
       Just decl ->
         case funcArch fdata of

-          Nothing -> Nothing
+          Nothing -> []

           Just arch ->
           Just arch ->

-            Just $

               [AST.LUEntity decl, AST.LUArch arch]
               ++ (Maybe.maybeToList (fmap AST.LUPackageDec $ ent_pkg_decl ent))
 
               [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 = 
 -- Shortcut
 mkVHDLId :: String -> AST.VHDLId
 mkVHDLId s = 

-  AST.unsafeVHDLBasicId s'
+  AST.unsafeVHDLBasicId $ (strip_multiscore . strip_invalid) s

   where
     -- Strip invalid characters.
   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