sv2v-0.0.12: src/Convert/Package.hs
{- sv2v
- Author: Zachary Snow <zach@zachjs.com>
-
- Conversion for packages and global declarations
-
- This conversion first makes a best-effort pass at resolving any simple
- declaration ordering issues in the input. Many conversions require that
- declarations precede their first usage.
-
- The main phase elaborates packages and resolves imported identifiers. An
- identifier (perhaps implicitly) referring to `P::X` is rewritten to `P_X`.
- This conversion assumes such renaming will not cause conflicts. The full
- semantics of imports and exports are followed.
-
- Finally, because Verilog doesn't allow declarations to exist outside of
- modules, declarations within packages and in the global scope are injected
- into modules and interfaces as needed.
-}
module Convert.Package
( convert
, inject
, prefixItems
) where
import Control.Monad (when, (>=>))
import Control.Monad.State.Strict
import Control.Monad.Writer.Strict
import Data.Functor ((<&>))
import Data.List (insert, intercalate, isPrefixOf)
import Data.Maybe (mapMaybe)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Convert.ResolveBindings (resolveBindings)
import Convert.Scoper
import Convert.Traverse
import Language.SystemVerilog.AST
type Packages = Map.Map Identifier Package
type Classes = Map.Map Identifier Class
type Package = (IdentStateMap, [PackageItem])
type Class = ([Decl], [PackageItem])
type Idents = Set.Set Identifier
type PIs = Map.Map Identifier PackageItem
convert :: [AST] -> [AST]
convert files =
map (traverseDescriptions $ convertDescription pis) files'
where
(files', packages') = convertPackages files
pis = Map.fromList $
concatMap (concatMap (toPackageItems . makeLocal) . snd) $
filter (not . Map.null . fst) $
Map.elems packages'
toPackageItems :: PackageItem -> [(Identifier, PackageItem)]
toPackageItems item = map (, item) (piNames item)
-- convert a parameter to a localparam
makeLocal :: PackageItem -> PackageItem
makeLocal (Decl (Param _ t x e)) = Decl $ Param Localparam t x e
makeLocal (Decl (ParamType _ x t)) = Decl $ ParamType Localparam x t
makeLocal other = other
-- utility for inserting package items into a set of module items as needed
inject :: [PackageItem] -> [ModuleItem] -> [ModuleItem]
inject packageItems items =
addItems localPIs Set.empty (map addUsedPIs items)
where
localPIs = Map.fromList $ concatMap toPIElem packageItems
toPIElem :: PackageItem -> [(Identifier, PackageItem)]
toPIElem item = map (, item) (piNames item)
-- utility for appling a prefix to all of the top level items in a module
prefixItems :: Identifier -> [ModuleItem] -> [ModuleItem]
prefixItems prefix items =
snd $ evalState (processItems "" prefix items) initialState
where initialState = PK [] Map.empty Map.empty Set.empty
-- collect packages and global package items
collectPackageM :: Description -> Writer (Packages, Classes, [PackageItem]) ()
collectPackageM (PackageItem item) =
when (not $ null $ piNames item) $
tell (Map.empty, Map.empty, [item])
collectPackageM (Package _ name items) =
tell (Map.singleton name (Map.empty, items), Map.empty, [])
collectPackageM (Class _ name decls items) =
tell (Map.empty, Map.singleton name (decls, map unpackClassItem items), [])
where
unpackClassItem :: ClassItem -> PackageItem
unpackClassItem item@(_, Task{}) = checkTF item
unpackClassItem item@(_, Function{}) = checkTF item
unpackClassItem item = checkNonTF item
checkTF :: ClassItem -> PackageItem
checkTF (QStatic, item) = item
checkTF (_, item) =
error $ "unsupported declaration of non-static method " ++ itemName
where [itemName] = piNames item
checkNonTF :: ClassItem -> PackageItem
checkNonTF (QNone, item) = item
checkNonTF (qualifier, _) =
error $ "unexpected qualifier " ++ show qualifier
++ " on a class item which is not a task or a function"
collectPackageM _ = return ()
-- elaborate all packages and their usages
convertPackages :: [AST] -> ([AST], Packages)
convertPackages files =
(files', packages')
where
(files', PK [] packages' _ _) = runState op initialState
initialState = PK [] packages classes conflicts
op = mapM (traverseDescriptionsM traverseDescriptionM) files
packages = Map.insert "" (Map.empty, globalItems) realPackages
(realPackages, classes, globalItems) =
execWriter $ mapM (collectDescriptionsM collectPackageM) files
prefixes = Set.union (Map.keysSet classes) (Map.keysSet realPackages)
conflicts =
if Set.null prefixes
then Set.empty
else execWriter $ mapM (collectIdentConflicts prefixes) files
-- write down identifiers that might conflict with the generated names for
-- injected package items
collectIdentConflicts :: Idents -> AST -> Writer Idents ()
collectIdentConflicts prefixes =
mapM_ $ collectModuleItemsM collectModuleItem
where
collectModuleItem =
evalScoperT . scoper >=>
collectify traverseIdentsM ident
scoper = scopeModuleItem collectDecl return return return
collectDecl decl = do
case decl of
Variable _ _ x _ _ -> lift $ ident x
Net _ _ _ _ x _ _ -> lift $ ident x
Param _ _ x _ -> lift $ ident x
ParamType _ x _ -> lift $ ident x
CommentDecl{} -> return ()
return decl
ident = collectIdent prefixes
-- write down identifiers that have a package name as a prefix
collectIdent :: Idents -> Identifier -> Writer Idents ()
collectIdent prefixes ident =
case Set.lookupLE ident prefixes of
Just prefix -> when (prefix `isPrefixOf` ident) found
where found = tell $ Set.singleton ident
Nothing -> return ()
data PK = PK
{ pkStack :: [Identifier]
, pkPackages :: Packages
, pkClasses :: Classes
, pkConflicts :: Idents
}
type PackagesState = State PK
traverseDescriptionM :: Description -> PackagesState Description
traverseDescriptionM (PackageItem item) = do
return $ PackageItem $ case piNames item of
[] -> item
idents -> Decl $ CommentDecl $ "removed " ++ show idents
traverseDescriptionM (Package _ name _) =
return $ PackageItem $ Decl $ CommentDecl $ "removed package " ++ show name
traverseDescriptionM (Class _ name _ _) =
return $ PackageItem $ Decl $ CommentDecl $ "removed class " ++ show name
traverseDescriptionM (Part attrs extern kw liftetime name ports items) = do
(_, items') <- processItems name "" items
return $ Part attrs extern kw liftetime name ports items'
data IdentState
= Available [Identifier]
| Imported Identifier
| Declared
deriving Eq
isImported :: IdentState -> Bool
isImported Imported{} = True
isImported _ = False
isDeclared :: IdentState -> Bool
isDeclared Declared{} = True
isDeclared _ = False
type IdentStateMap = Map.Map Identifier IdentState
type Scope = ScoperT IdentState PackagesState
-- produce the partial mapping for a particular export and ensure its validity
resolveExport
:: IdentStateMap -> Identifier -> Identifier -> PackagesState IdentStateMap
resolveExport mapping "" "" =
return $ Map.filter isImported mapping
resolveExport mapping pkg "" =
fmap (Map.mapMaybeWithKey checkExport . fst) (findPackage pkg)
where
checkExport :: Identifier -> IdentState -> Maybe IdentState
checkExport ident exportedIdentState =
if localIdentState == expectedIdentState
then localIdentState
else Nothing
where
localIdentState = Map.lookup ident mapping
expectedIdentState = Just $ Imported $
toRootPackage pkg exportedIdentState
resolveExport mapping pkg ident =
case Map.lookup ident mapping of
Just (Imported importedPkg) -> do
exportedPkg <- resolveRootPackage pkg ident
if importedPkg == exportedPkg
then return $ Map.singleton ident $ Imported importedPkg
else error $ "export of " ++ pkg ++ "::" ++ ident
++ " differs from import of " ++ importedPkg
++ "::" ++ ident
_ -> error $ "export of " ++ pkg ++ "::" ++ ident
++ ", but " ++ ident ++ " was never imported"
-- lookup the state of the identifier only within the current scope
lookupLocalIdentState :: Identifier -> Scope (Maybe IdentState)
lookupLocalIdentState =
fmap (fmap thd3) . lookupLocalIdentM
where thd3 (_, _, c) = c
-- make a particular identifier within a package available for import
wildcardImport :: Identifier -> Identifier -> Scope ()
wildcardImport pkg ident = do
rootPkg <- lift $ resolveRootPackage pkg ident
maybeIdentState <- lookupLocalIdentState ident
insertElem ident $
case maybeIdentState of
Nothing -> Available [rootPkg]
Just Declared -> Declared
Just (Imported existingRootPkg) -> Imported existingRootPkg
Just (Available rootPkgs) ->
if elem rootPkg rootPkgs
then Available rootPkgs
else Available $ insert rootPkg rootPkgs
-- make all exported identifiers within a package available for import
wildcardImports :: Identifier -> Scope ()
wildcardImports pkg = do
(exports, _) <- lift $ findPackage pkg
_ <- mapM (wildcardImport pkg) (Map.keys exports)
return ()
-- resolve and store an explicit (non-wildcard) import
explicitImport :: Identifier -> Identifier -> Scope ()
explicitImport pkg ident = do
rootPkg <- lift $ resolveRootPackage pkg ident
maybeIdentState <- lookupLocalIdentState ident
insertElem ident $
case maybeIdentState of
Nothing -> Imported rootPkg
Just Declared ->
error $ "import of " ++ pkg ++ "::" ++ ident
++ " conflicts with prior declaration of " ++ ident
Just Available{} -> Imported rootPkg
Just (Imported otherPkg) ->
if otherPkg == rootPkg
then Imported rootPkg
else error $ "import of " ++ pkg ++ "::" ++ ident
++ " conflicts with prior import of "
++ otherPkg ++ "::" ++ ident
pattern PatternTag :: Char
pattern PatternTag = '*'
-- main logic responsible for translating packages, resolving imports and
-- exports, and rewriting identifiers referring to package declarations
processItems :: Identifier -> Identifier -> [ModuleItem]
-> PackagesState (IdentStateMap, [ModuleItem])
processItems topName packageName moduleItems = do
(moduleItems', scopes) <- runScoperT $ scopeModuleItems scoper
topName (reorderItems moduleItems)
let rawIdents = extractMapping scopes
externalIdentMaps <- mapM (resolveExportMI rawIdents) moduleItems
let externalIdents = Map.unions externalIdentMaps
let declaredIdents = Map.filter isDeclared rawIdents
let exports = Map.union declaredIdents externalIdents
let exports' = if null packageName
then rawIdents
else exports
seq exports return (exports', moduleItems')
where
scoper = scopeModuleItem
traverseDeclM traverseModuleItemM traverseGenItemM traverseStmtM
-- produces partial mappings of exported identifiers, while also
-- checking the validity of the exports
resolveExportMI :: IdentStateMap -> ModuleItem -> PackagesState IdentStateMap
resolveExportMI mapping (MIPackageItem item@(Export pkg ident)) =
if null packageName
then error $ "invalid " ++ (init $ show item)
++ " outside of package"
else resolveExport mapping pkg ident
resolveExportMI _ _ = return Map.empty
-- declare an identifier, prefixing it if within a package
prefixIdent :: Identifier -> Scope Identifier
prefixIdent x = do
inProcedure <- withinProcedureM
maybeIdentState <- lookupLocalIdentState x
case maybeIdentState of
Just (Imported rootPkg) -> error $ "declaration of " ++ x
++ " conflicts with prior import of " ++ rootPkg
++ "::" ++ x
_ -> do
insertElem x Declared
if inProcedure || null packageName
then return x
else lift $ makeIdent packageName x
-- check the global scope for declarations or imports
resolveGlobalIdent :: Identifier -> Scope Identifier
resolveGlobalIdent x = do
(exports, _) <- lift $ findPackage ""
case Map.lookup x exports of
Nothing -> return x
Just identState -> do
-- inject the exact state outside of the module scope,
-- allowing wildcard imports to be handled correctly
insertElem [Access x Nil] identState
resolveIdent x
-- remap an identifier if needed based on declarations, explicit
-- imports, or names available for import
resolveIdent :: Identifier -> Scope Identifier
resolveIdent x = do
details <- lookupElemM x
case details of
Nothing ->
-- only missing identifiers within parts should be looked up
-- in the global scope
if null packageName && not (null topName)
then resolveGlobalIdent x
else return x
Just ([_, _], _, Declared) ->
if null packageName
then return x
else lift $ makeIdent packageName x
Just (_, _, Declared) -> return x
Just (_, _, Imported rootPkg) ->
lift $ makeIdent rootPkg x
Just (accesses, _, Available [rootPkg]) -> do
insertElem accesses $ Imported rootPkg
lift $ makeIdent rootPkg x
Just (_, _, Available rootPkgs) ->
error $ "identifier " ++ show x
++ " ambiguously refers to the definitions in any of "
++ intercalate ", " rootPkgs
traversePackageItemM :: PackageItem -> Scope PackageItem
traversePackageItemM orig@(Import pkg ident) = do
if null ident
then wildcardImports pkg
else explicitImport pkg ident
return $ Decl $ CommentDecl $ "removed " ++ show orig
traversePackageItemM orig@(Export pkg ident) = do
() <- when (not (null pkg || null ident)) $ do
localName <- resolveIdent ident
rootPkg <- lift $ resolveRootPackage pkg ident
localName `seq` rootPkg `seq` return ()
return $ Decl $ CommentDecl $ "removed " ++ show orig
traversePackageItemM other = return other
traverseDeclM :: Decl -> Scope Decl
traverseDeclM decl = do
decl' <- traverseDeclNodesM traverseTypeM traverseExprM decl
case decl' of
Variable d t x a e -> declHelp x $ \x' -> Variable d t x' a e
Net d n s t x a e -> declHelp x $ \x' -> Net d n s t x' a e
Param p t x e -> declHelp x $ \x' -> Param p t x' e
ParamType p x t ->
-- make this typename available for use in patterns
prefixIdent (PatternTag : x) >>
declHelp x (\x' -> ParamType p x' t)
CommentDecl c -> return $ CommentDecl c
where declHelp x f = prefixIdent x >>= return . f
traverseRangeM :: Range -> Scope Range
traverseRangeM = mapBothM traverseExprM
traverseEnumItemM :: (Identifier, Expr) -> Scope (Identifier, Expr)
traverseEnumItemM (x, e) = do
x' <- prefixIdent x
e' <- traverseExprM e
return (x', e')
traverseTypeM :: Type -> Scope Type
traverseTypeM (CSAlias p b x rs) = do
x' <- resolveCSIdent' p b x
rs' <- mapM traverseRangeM rs
return $ Alias x' rs'
traverseTypeM (PSAlias p x rs) = do
x' <- resolvePSIdent' p x
rs' <- mapM traverseRangeM rs
return $ Alias x' rs'
traverseTypeM (Alias x rs) = do
rs' <- mapM traverseRangeM rs
x' <- resolveIdent x
return $ Alias x' rs'
traverseTypeM (Enum t enumItems rs) = do
t' <- traverseTypeM t
enumItems' <- mapM traverseEnumItemM enumItems
rs' <- mapM traverseRangeM rs
return $ Enum t' enumItems' rs'
traverseTypeM other =
traverseSinglyNestedTypesM traverseTypeM other
>>= traverseTypeExprsM traverseExprM
traverseExprM :: Expr -> Scope Expr
traverseExprM (CSIdent p b x) = do
x' <- resolveCSIdent' p b x
return $ Ident x'
traverseExprM (PSIdent p x) = do
x' <- resolvePSIdent' p x
return $ Ident x'
traverseExprM (Ident x) = resolveIdent x >>= return . Ident
traverseExprM (Pattern items) = do
keys' <- mapM keyMapper keys
vals' <- mapM traverseExprM vals
return $ Pattern $ zip keys' vals'
where (keys, vals) = unzip items
traverseExprM other =
traverseSinglyNestedExprsM traverseExprM other
>>= traverseExprTypesM traverseTypeM
-- equivalent to the special case in traverseExprIdentsM
keyMapper (Left t) =
traverseTypeM t <&> Left
keyMapper (Right (Ident x)) = do
tagged' <- traverseExprM $ Ident $ PatternTag : x
let Ident x' = tagged'
return $ Right $ Ident $ filter (/= PatternTag) x'
keyMapper (Right e) =
traverseExprM e <&> Right
traverseLHSM :: LHS -> Scope LHS
traverseLHSM (LHSIdent x) = resolveIdent x >>= return . LHSIdent
traverseLHSM other = traverseSinglyNestedLHSsM traverseLHSM other
traverseGenItemM = traverseGenItemExprsM traverseExprM
traverseModuleItemM (MIPackageItem item) = do
item' <- traversePackageItemM item
return $ MIPackageItem item'
traverseModuleItemM other =
traverseModuleItemM' other
traverseModuleItemM' =
traverseTypesM traverseTypeM >=>
traverseExprsM traverseExprM >=>
traverseLHSsM traverseLHSM
traverseStmtM =
traverseStmtExprsM traverseExprM >=>
traverseStmtLHSsM traverseLHSM
traverseParamBindingM :: ParamBinding -> Scope ParamBinding
traverseParamBindingM (x, Left t) =
traverseTypeM t >>= return . (x, ) . Left
traverseParamBindingM (x, Right e) =
traverseExprM e >>= return . (x, ) . Right
-- wrapper allowing explicit reference to local package items
resolvePSIdent' :: Identifier -> Identifier -> Scope Identifier
resolvePSIdent' p x = do
if p /= packageName then
lift $ resolvePSIdent p x
else do
details <- lookupElemM $ Dot (Ident p) x
case details of
Just ([_, _], _, Declared) ->
lift $ makeIdent p x
Just ([_, _], _, Imported rootPkg) ->
lift $ makeIdent rootPkg x
_ -> error $ "package " ++ show p ++ " references"
++ " undeclared local \"" ++ p ++ "::" ++ x ++ "\""
-- wrapper resolving parameters and locally injecting the necessary
-- class items into modules and interfaces
resolveCSIdent'
:: Identifier -> [ParamBinding] -> Identifier -> Scope Identifier
resolveCSIdent' p b x = do
scopeKeys <- bindingsScopeKeys b
b' <- mapM traverseParamBindingM b
x' <- lift $ resolveCSIdent p b' scopeKeys x
let rootPkg = take (length x' - length x - 1) x'
when (null packageName) (classScopeInject rootPkg x')
return x'
-- inject the given class item and its dependencies into the local scope
classScopeInject :: Identifier -> Identifier -> Scope ()
classScopeInject rootPkg fullName = do
packages <- lift $ gets pkPackages
let (_, packageItems) = packages Map.! rootPkg
let localPIs = Map.fromList $ concatMap toPIElem packageItems
mapM_ injectIfMissing $
addItems localPIs Set.empty
[(Generate [], Set.singleton fullName)]
where
injectIfMissing :: ModuleItem -> Scope ()
injectIfMissing (Generate []) = return ()
injectIfMissing moduleItem = do
let MIPackageItem packageItem = moduleItem
let itemName : _ = piNames packageItem
details <- lookupElemM itemName
when (details == Nothing) $ do
accesses <- procedureLocM
let accesses' = accesses ++ [Access itemName Nil]
if null accesses
then insertElem itemName Declared
else insertElem accesses' Declared
injectItem moduleItem
toPIElem :: PackageItem -> [(Identifier, PackageItem)]
toPIElem item = map (, makeLocal item) (piNames item)
-- locate a package by name, processing its contents if necessary
findPackage :: Identifier -> PackagesState Package
findPackage packageName = do
PK { pkStack = stack, pkPackages = packages } <- get
let maybePackage = Map.lookup packageName packages
assertMsg (maybePackage /= Nothing) $
"could not find package " ++ show packageName
-- because this conversion doesn't enforce declaration ordering of packages,
-- it must check for dependency loops to avoid infinite recursion
let first : rest = reverse $ packageName : stack
assertMsg (not $ elem packageName stack) $
"package dependency loop: " ++ show first ++ " depends on "
++ intercalate ", which depends on " (map show rest)
let Just package@(exports, _) = maybePackage
if Map.null exports
then do
-- process and resolve this package
modify' $ \pk -> pk { pkStack = packageName : pkStack pk }
package' <- processPackage packageName $ snd package
pk <- get
let stack' = tail $ pkStack pk
let packages' = Map.insert packageName package' $ pkPackages pk
put $ pk { pkStack = stack', pkPackages = packages' }
return package'
else return package
-- helper for elaborating a package when it is first referenced
processPackage :: Identifier -> [PackageItem] -> PackagesState Package
processPackage packageName packageItems = do
(exports, moduleItems') <- processItems packageName packageName wrapped
let packageItems' = map unwrap moduleItems'
let package' = (exports, packageItems')
return package'
where
wrapped = map wrap packageItems
wrap :: PackageItem -> ModuleItem
wrap = MIPackageItem
unwrap :: ModuleItem -> PackageItem
unwrap packageItem = item
where MIPackageItem item = packageItem
-- resolve a package scoped identifier to its unique global name
resolvePSIdent :: Identifier -> Identifier -> PackagesState Identifier
resolvePSIdent packageName itemName = do
classes <- gets pkClasses
case Map.lookup packageName classes of
Nothing -> do
rootPkg <- resolveRootPackage packageName itemName
makeIdent rootPkg itemName
Just ([], _) -> resolveCSIdent packageName [] Set.empty itemName
Just _ -> error $ "reference to " ++ show itemName
++ " in parameterized class " ++ show packageName
++ " requires explicit #()"
-- determines the root package contained the given package scoped identifier
resolveRootPackage :: Identifier -> Identifier -> PackagesState Identifier
resolveRootPackage packageName itemName = do
(exports, _) <- findPackage packageName
let maybeIdentState = Map.lookup itemName exports
assertMsg (maybeIdentState /= Nothing) $
"could not find " ++ show itemName ++ " in package " ++ show packageName
let Just identState = maybeIdentState
return $ toRootPackage packageName identState
-- collect hashes of accessed resolved scopes in class parameters
bindingsScopeKeys :: [ParamBinding] -> Scope Idents
bindingsScopeKeys =
execWriterT . mapM (traverseTypeOrExprIdentsM identMapper) . map snd
where
identMapper :: Identifier -> WriterT Idents Scope Identifier
identMapper x = do
details <- lift $ lookupElemM x
case details of
Nothing -> return ()
Just (accesses, _, _) ->
tell $ Set.singleton $ shortHash accesses
return x
traverseTypeOrExprIdentsM mapper (Left t) =
traverseTypeIdentsM mapper t >>= return . Left
traverseTypeOrExprIdentsM mapper (Right e) =
traverseExprIdentsM mapper e >>= return . Right
-- resolve a class scoped identifier to its unique global name
resolveCSIdent :: Identifier -> [ParamBinding] -> Idents -> Identifier -> PackagesState Identifier
resolveCSIdent className paramBindings scopeKeys itemName = do
-- find the specified class
classes <- gets pkClasses
let maybeClass = Map.lookup className classes
assertMsg (maybeClass /= Nothing) $
"could not find class " ++ show className
let Just (classParams, classItems) = maybeClass
-- resolve the provided parameters
let resolveMsg = "parameters in class specialization of " ++ show className
let paramNames = mapMaybe extractParameterName classParams
let paramBindings' = resolveBindings resolveMsg paramNames paramBindings
-- generate a unique name for this synthetic package
let packageName = className ++ '_' : shortHash (scopeKeys, paramBindings')
-- process the synthetic package and inject the given parameters
(exports, classItems') <- processPackage packageName $
map Decl classParams ++ classItems
let overrider = overrideParam packageName paramBindings'
let classItems'' = map overrider classItems'
-- add the synthetic package to the state
let package = (exports, classItems'')
packages' <- gets $ Map.insert packageName package . pkPackages
modify' $ \pk -> pk { pkPackages = packages' }
-- ensure the item actually exists
let maybeIdentState = Map.lookup itemName exports
assertMsg (maybeIdentState /= Nothing) $
"could not find " ++ show itemName ++ " in class " ++ show className
makeIdent packageName itemName
where
extractParameterName :: Decl -> Maybe Identifier
extractParameterName (Param Parameter _ x _) = Just x
extractParameterName (ParamType Parameter x _) = Just x
extractParameterName _ = Nothing
-- replace default parameter values with the given overrides
overrideParam :: Identifier -> [ParamBinding] -> PackageItem -> PackageItem
overrideParam packageName bindings (Decl (Param Parameter t x e)) =
Decl $ Param Parameter t x $
case lookup x' bindings of
Just (Right e') -> e'
Just (Left t') ->
error $ "cannot override parameter " ++ show x'
++ " in class " ++ show className
++ " with type " ++ show t'
Nothing ->
if e == Nil
then error $ "required parameter " ++ show x'
++ " in class " ++ show className
++ " has not been provided"
else e
where x' = drop (1 + length packageName) x
overrideParam packageName bindings (Decl (ParamType Parameter x t)) =
Decl $ ParamType Parameter x $
case lookup x' bindings of
Just (Left t') -> t'
Just (Right e') ->
case exprToType e' of
Just t' -> t'
Nothing ->
error $ "cannot override type parameter "
++ show x' ++ " in class " ++ show className
++ " with expression " ++ show e'
Nothing ->
if t == UnknownType
then error $ "required type parameter " ++ show x'
++ " in class " ++ show className
++ " has not been provided"
else t
where x' = drop (1 + length packageName) x
overrideParam _ _ other = other
-- construct a new identifier for a package scoped identifier
makeIdent :: Identifier -> Identifier -> PackagesState Identifier
makeIdent x y = do
conflicts <- gets pkConflicts
return $ uniqueIdent conflicts $ x ++ '_' : y
-- prepend underscores until the name is unique
uniqueIdent :: Idents -> Identifier -> Identifier
uniqueIdent conflicts ident =
if Set.member ident conflicts
then uniqueIdent conflicts $ '_' : ident
else ident
-- errors with the given message when the check is false
assertMsg :: Monad m => Bool -> String -> m ()
assertMsg check msg = when (not check) $ error msg
-- helper for taking an ident which is either declared or exported form a
-- package and determine its true root source package
toRootPackage :: Identifier -> IdentState -> Identifier
toRootPackage sourcePackage identState =
if identState == Declared
then sourcePackage
else rootPackage
where Imported rootPackage = identState
-- nests packages items missing from modules
convertDescription :: PIs -> Description -> Description
convertDescription pis orig@Part{} =
if Map.null pis
then orig
else Part attrs extern kw lifetime name ports items'
where
Part attrs extern kw lifetime name ports items = orig
items' = addItems pis Set.empty $ map addUsedPIs $
foldr breakGenerate [] items -- ensure decls are visible
convertDescription _ other = other
-- attempt to fix simple declaration order issues
reorderItems :: [ModuleItem] -> [ModuleItem]
reorderItems items =
addItems localPIs Set.empty $ map addUsedPIs $
map (traverseGenItems $ traverseNestedGenItems reorderGenItem) items
where
localPIs = Map.fromList $ concat $ mapMaybe toPIElem items
toPIElem :: ModuleItem -> Maybe [(Identifier, PackageItem)]
toPIElem (MIPackageItem item) = Just $ map (, item) (piNames item)
toPIElem _ = Nothing
-- attempt to declaration order issues within generate blocks
reorderGenItem :: GenItem -> GenItem
reorderGenItem (GenBlock name genItems) =
GenBlock name $ map unwrap $ reorderItems $ map wrap genItems
where
wrap :: GenItem -> ModuleItem
wrap (GenModuleItem item) = item
wrap item = Generate [item]
unwrap :: ModuleItem -> GenItem
unwrap (Generate [item]) = item
unwrap item = GenModuleItem item
reorderGenItem item = item
-- iteratively inserts missing package items exactly where they are needed
addItems :: PIs -> Idents -> [(ModuleItem, Idents)] -> [ModuleItem]
addItems pis existingPIs ((item, usedPIs) : items) =
if not $ forceKeep || Set.disjoint existingPIs thisPI then
-- this item was re-imported earlier in the module
addItems pis existingPIs items
else if Map.null itemsToAdd then
-- this item has no additional dependencies
item : addItems pis (Set.union existingPIs thisPI) items
else
-- this item has at least one un-met dependency
addItems remainingPIs existingPIs
(addUsedPIs chosenItem : (item, usedPIs) : items)
where
thisPI = case item of
MIPackageItem packageItem ->
Set.fromList $ piNames packageItem
Instance _ _ x _ _ -> Set.singleton x
_ -> Set.empty
forceKeep = case item of
Instance{} -> True
_ -> False
neededPIs = Set.difference (Set.difference usedPIs existingPIs) thisPI
itemsToAdd = Map.restrictKeys pis neededPIs
(chosenName, chosenPI) = Map.findMin itemsToAdd
chosenItem = MIPackageItem chosenPI
remainingPIs = Map.delete chosenName pis
addItems _ _ [] = []
-- augment a module item with the set of identifiers it uses
addUsedPIs :: ModuleItem -> (ModuleItem, Idents)
addUsedPIs item =
(item, usedPIs)
where
usedPIs = execWriter $ evalScoperT $ scoper item
scoper = scopeModuleItem writeDeclIdents writeModuleItemIdents
writeGenItemIdents writeStmtIdents
type IdentWriter = ScoperT () (Writer Idents)
writeDeclIdents :: Decl -> IdentWriter Decl
writeDeclIdents decl = do
case decl of
Variable _ _ x _ _ -> insertElem x ()
Net _ _ _ _ x _ _ -> insertElem x ()
Param _ _ x _ -> insertElem x ()
ParamType _ x _ -> insertElem x ()
CommentDecl{} -> return ()
traverseDeclIdentsM writeIdent decl
writeModuleItemIdents :: ModuleItem -> IdentWriter ModuleItem
writeModuleItemIdents = traverseIdentsM writeIdent
writeGenItemIdents :: GenItem -> IdentWriter GenItem
writeGenItemIdents =
traverseGenItemExprsM $ traverseExprIdentsM writeIdent
writeStmtIdents :: Stmt -> IdentWriter Stmt
writeStmtIdents = traverseStmtIdentsM writeIdent
writeIdent :: Identifier -> IdentWriter Identifier
writeIdent x = do
details <- lookupElemM x
when (details == Nothing) $ tell (Set.singleton x)
return x
-- visits all identifiers in a module item
traverseIdentsM :: Monad m => MapperM m Identifier -> MapperM m ModuleItem
traverseIdentsM identMapper = traverseNodesM
(traverseExprIdentsM identMapper)
(traverseDeclIdentsM identMapper)
(traverseTypeIdentsM identMapper)
(traverseLHSIdentsM identMapper)
(traverseStmtIdentsM identMapper)
-- visits all identifiers in an expression
traverseExprIdentsM :: Monad m => MapperM m Identifier -> MapperM m Expr
traverseExprIdentsM identMapper = exprMapper
where
exprMapper (Ident x) = identMapper x >>= return . Ident
exprMapper (Pattern items) = do
keys' <- mapM keyMapper keys
vals' <- mapM exprMapper vals
return $ Pattern $ zip keys' vals'
where (keys, vals) = unzip items
exprMapper other =
traverseExprTypesM (traverseTypeIdentsM identMapper) other >>=
traverseSinglyNestedExprsM exprMapper
-- Don't reorder or inject a pattern key unless it refers to a known
-- typename. TODO: This prevents referring to expressions in packages in
-- pattern keys, though this probably isn't common.
keyMapper (Left t) =
traverseTypeIdentsM identMapper t <&> Left
keyMapper (Right (Ident x)) =
identMapper (PatternTag : x)
<&> filter (/= PatternTag) <&> Ident <&> Right
keyMapper (Right e) =
exprMapper e <&> Right
-- visits all identifiers in a type
traverseTypeIdentsM :: Monad m => MapperM m Identifier -> MapperM m Type
traverseTypeIdentsM identMapper = fullMapper
where
fullMapper = typeMapper
>=> traverseTypeExprsM (traverseExprIdentsM identMapper)
>=> traverseSinglyNestedTypesM fullMapper
typeMapper (Alias x t) = identMapper x >>= return . flip Alias t
typeMapper other = return other
-- visits all identifiers in an LHS
traverseLHSIdentsM :: Monad m => MapperM m Identifier -> MapperM m LHS
traverseLHSIdentsM identMapper = fullMapper
where
fullMapper = lhsMapper
>=> traverseLHSExprsM (traverseExprIdentsM identMapper)
>=> traverseSinglyNestedLHSsM fullMapper
lhsMapper (LHSIdent x) = identMapper x >>= return . LHSIdent
lhsMapper other = return other
-- visits all identifiers in a statement
traverseStmtIdentsM :: Monad m => MapperM m Identifier -> MapperM m Stmt
traverseStmtIdentsM identMapper =
traverseStmtExprsM (traverseExprIdentsM identMapper) >=>
traverseStmtLHSsM (traverseLHSIdentsM identMapper)
-- visits all identifiers in a declaration
traverseDeclIdentsM :: Monad m => MapperM m Identifier -> MapperM m Decl
traverseDeclIdentsM identMapper = traverseDeclNodesM
(traverseTypeIdentsM identMapper)
(traverseExprIdentsM identMapper)
-- returns any names defined by a package item
piNames :: PackageItem -> [Identifier]
piNames (Decl (ParamType _ ident (Enum _ enumItems _))) =
ident : map fst enumItems
piNames (Function _ _ ident _ _) = [ident]
piNames (Task _ ident _ _) = [ident]
piNames (Decl (Variable _ _ ident _ _)) = [ident]
piNames (Decl (Net _ _ _ _ ident _ _)) = [ident]
piNames (Decl (Param _ _ ident _)) = [ident]
piNames (Decl (ParamType _ ident _)) = [ident, PatternTag : ident]
piNames (Decl (CommentDecl _)) = []
piNames item@DPIImport{} = [show item]
piNames item@DPIExport{} = [show item]
piNames item@Import{} = [show item]
piNames item@Export{} = [show item]
piNames (Directive _) = []