Don't prefix package name in _types package in VHDL

changelog/2021-11-11T11_29_26+01_00_unqualify_package_body_vhdl.md

@@ -0,0 +1 @@
+CHANGED: Types defined in the package head are no longer qualified in the package body when rendering VHDL [#1996](https://github.com/clash-lang/clash-compiler/issues/1996).

clash-lib/src/Clash/Backend/VHDL.hs

@@ -96,6 +96,8 @@ data VHDLState =
   -- ^ Files to be stored: (filename, contents). These files are generated
   -- during the execution of 'genNetlist'.
   , _idSeen    :: IdentifierSet
+  , _tyPkgCtx :: Bool
+  -- ^ Are we in the context of generating the @_types@ package?
   , _intWidth  :: Int
   -- ^ Int/Word/Integer bit-width
   , _hdlsyn    :: HdlSyn
@@ -126,6 +128,7 @@ instance Backend VHDLState where
     , _dataFiles=[]
     , _memoryDataFiles=[]
     , _idSeen=Id.emptyIdentifierSet esc lw VHDL
+    , _tyPkgCtx=False
     , _intWidth=w
     , _hdlsyn=hdlsyn_
     , _undefValue=undefVal
@@ -390,15 +393,16 @@ genVHDL nm sp seen c = do
 -- | Generate a VHDL package containing type definitions for the given HWTypes
 mkTyPackage_ :: ModName -> [HWType] -> VHDLM [(String,Doc)]
 mkTyPackage_ modName (map filterTransparent -> hwtys) = do
-    { syn <- Ap hdlSyn
+    { Ap (tyPkgCtx .= True)
+    ; syn <- Ap hdlSyn
     ; enums <- Ap renderEnums
     ; let usedTys     = concatMap mkUsedTys hwtys
     ; let normTys0    = nub (map mkVecZ (hwtys ++ usedTys))
     ; let sortedTys0  = topSortHWTys normTys0
           packageDec  = vcat $ mapM tyDec (nubBy eqTypM sortedTys0)
           (funDecs,funBodies) = unzip . mapMaybe (funDec enums syn) $ nubBy eqTypM (normaliseType enums <$> sortedTys0)
 
-    ; (:[]) <$> (TextS.unpack (modName `TextS.append` "_types"),) <$>
+    ; pkg <- (:[]) <$> (TextS.unpack (modName `TextS.append` "_types"),) <$>
       "library IEEE;" <> line <>
       "use IEEE.STD_LOGIC_1164.ALL;" <> line <>
       "use IEEE.NUMERIC_STD.ALL;" <> line <> line <>
@@ -407,6 +411,8 @@ mkTyPackage_ modName (map filterTransparent -> hwtys) = do
                     vcat (sequence funDecs)
                   ) <> line <>
       "end" <> semi <> packageBodyDec funBodies
+    ; Ap (tyPkgCtx .= False)
+    ; return pkg
     }
   where
     packageBodyDec :: [VHDLM Doc] -> VHDLM Doc
@@ -682,13 +688,13 @@ funDec _ _ (Unsigned _) = Just
   )
 
 funDec _ _ t@(Product _ labels elTys) = Just
-  ( "function" <+> "toSLV" <+> parens ("p :" <+> sizedQualTyName t) <+> "return std_logic_vector" <> semi <> line <>
-    "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> sizedQualTyName t <> semi
-  , "function" <+> "toSLV" <+> parens ("p :" <+> sizedQualTyName t) <+> "return std_logic_vector" <+> "is" <> line <>
+  ( "function" <+> "toSLV" <+> parens ("p :" <+> sizedTyName t) <+> "return std_logic_vector" <> semi <> line <>
+    "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> sizedTyName t <> semi
+  , "function" <+> "toSLV" <+> parens ("p :" <+> sizedTyName t) <+> "return std_logic_vector" <+> "is" <> line <>
     "begin" <> line <>
     indent 2 ("return" <+> parens (hcat (punctuate " & " elTyToSLV)) <> semi) <> line <>
     "end" <> semi <> line <>
-    "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> sizedQualTyName t <+> "is" <> line <>
+    "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> sizedTyName t <+> "is" <> line <>
       "alias islv : std_logic_vector(0 to slv'length - 1) is slv;" <> line <>
     "begin" <> line <>
     indent 2 ("return" <+> parens (hcat (punctuate "," elTyFromSLV)) <> semi) <> line <>
@@ -1063,8 +1069,12 @@ qualTyName (filterTransparent -> hwty) = case hwty of
 
   -- Custom types:
   _ -> do
+    pkgCtx <- Ap (use tyPkgCtx)
     modName <- Ap (use modNm)
-    pretty modName <> "_types." <> tyName hwty
+
+    if pkgCtx
+      then tyName hwty
+      else pretty modName <> "_types." <> tyName hwty
 
 -- | Generates a unique name for a given type. This action will cache its
 -- results, thus returning the same answer for the same @HWType@ argument.

tests/Main.hs

@@ -548,6 +548,7 @@ runClashTest = defaultMain $ clashTestRoot
             hdlTargets=[VHDL]
           , expectClashFail=Just (NoTestExitCode, "NOT:WARNING")
           }
+        , outputTest "T1996" def{hdlTargets=[VHDL]}
         ] <>
         if compiledWith == Cabal then
           -- This tests fails without environment files present, which are only

tests/shouldwork/Issues/T1996.hs

@@ -0,0 +1,25 @@
+module T1996 where
+
+import qualified Prelude as P
+import           Data.List (isInfixOf)
+import           System.Environment (getArgs)
+import           System.FilePath ((</>), takeDirectory)
+
+import           Clash.Prelude
+
+topEntity :: (Int, Int) -> (Int, Int)
+topEntity = id
+
+assertNotIn :: String -> String -> IO ()
+assertNotIn needle haystack
+  | needle `isInfixOf` haystack =
+      P.error $ P.concat [ "Did not expect:\n\n  ", needle
+                         , "\n\nIn:\n\n", haystack ]
+  | otherwise = return ()
+
+mainVHDL :: IO ()
+mainVHDL = do
+  [topDir] <- getArgs
+  content  <- readFile (topDir </> show 'topEntity </> "T1996_topEntity_types.vhdl")
+
+  assertNotIn "T1996_topEntity_types." content