Scoper.hs 23.5 KB
Newer Older
1
{-# LANGUAGE ScopedTypeVariables #-}
2
{-# LANGUAGE FlexibleInstances #-}
3 4 5 6 7 8 9
{- sv2v
 - Author: Zachary Snow <zach@zachjs.com>
 -
 - Standardized scope traversal utilities
 -
 - This module provides a series of "scopers" which track the scope of blocks,
 - generate loops, tasks, and functions, and provides the ability to insert and
10 11
 - lookup elements in a scope-aware way. It also provides the ability to check
 - whether the current node is within a procedural context.
12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28
 -
 - The interfaces take in a mappers for each of: Decl, ModuleItem, GenItem, and
 - Stmt. Note that Function, Task, Always, Initial, and Final are NOT passed
 - through the ModuleItem mapper as those constructs only provide Stmts and
 - Decls. For the same reason, Decl ModuleItems are not passed through the
 - ModuleItem mapper.
 -
 - All of the mappers should not recursively traverse any of the items captured
 - by any of the other mappers. Scope resolution enforces data declaration
 - ordering.
 -}

module Convert.Scoper
    ( Scoper
    , ScoperT
    , evalScoper
    , evalScoperT
29
    , runScoper
30
    , runScoperT
31
    , partScoper
32 33 34 35
    , scopeModuleItem
    , scopeModuleItems
    , scopePart
    , scopeModule
36 37 38
    , accessesToExpr
    , replaceInType
    , replaceInExpr
39 40
    , scopeExpr
    , scopeType
41 42
    , scopeExprWithScopes
    , scopeTypeWithScopes
43
    , insertElem
44
    , removeElem
45
    , injectItem
46
    , injectTopItem
47
    , injectDecl
48 49
    , lookupElem
    , lookupElemM
50 51
    , localAccesses
    , localAccessesM
52
    , Access(..)
53
    , ScopeKey
54
    , Scopes
55
    , extractMapping
56
    , embedScopes
57 58
    , withinProcedure
    , withinProcedureM
59 60
    , procedureLoc
    , procedureLocM
61 62
    , scopedError
    , scopedErrorM
63 64
    , isLoopVar
    , isLoopVarM
65 66
    , loopVarDepth
    , loopVarDepthM
67 68
    , lookupLocalIdent
    , lookupLocalIdentM
69
    , Replacements
70
    , LookupResult
71 72
    ) where

Zachary Snow committed
73
import Control.Monad (join, when)
74
import Control.Monad.State.Strict
75
import Data.List (findIndices, intercalate, isPrefixOf, partition)
Zachary Snow committed
76
import Data.Maybe (isNothing)
77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108
import qualified Data.Map.Strict as Map

import Convert.Traverse
import Language.SystemVerilog.AST

-- user monad aliases
type Scoper a = State (Scopes a)
type ScoperT a m = StateT (Scopes a) m

-- one tier of scope construction
data Tier = Tier
    { tierName :: Identifier
    , tierIndex :: Identifier
    } deriving (Eq, Show)

-- one layer of scope inspection
data Access = Access
    { accessName :: Identifier
    , accessIndex :: Expr
    } deriving (Eq, Show)

type Mapping a = Map.Map Identifier (Entry a)

data Entry a = Entry
    { eElement :: Maybe a
    , eIndex :: Identifier
    , eMapping :: Mapping a
    } deriving Show

data Scopes a = Scopes
    { sCurrent :: [Tier]
    , sMapping :: Mapping a
109
    , sProcedureLoc :: [Access]
110
    , sInjectedItems :: [(Bool, ModuleItem)]
111
    , sInjectedDecls :: [Decl]
112
    , sLatestTrace :: String
113 114
    } deriving Show

115 116 117 118 119 120
extractMapping :: Scopes a -> Map.Map Identifier a
extractMapping =
    Map.mapMaybe eElement .
    eMapping . snd .
    Map.findMin . sMapping

121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137
embedScopes :: Monad m => (Scopes a -> b -> c) -> b -> ScoperT a m c
embedScopes func x = do
    scopes <- get
    return $ func scopes x

setScope :: [Tier] -> Entry a -> Mapping a -> Mapping a
setScope [] _ = error "setScope invariant violated"
setScope [Tier name _] newEntry =
    Map.insert name newEntry
setScope (Tier name _ : tiers) newEntry =
    Map.adjust adjustment name
    where
        adjustment entry =
            entry { eMapping = setScope tiers newEntry (eMapping entry) }

enterScope :: Monad m => Identifier -> Identifier -> ScoperT a m ()
enterScope name index = do
138 139
    s <- get
    let current' = sCurrent s ++ [Tier name index]
140
    let existingResult = lookupLocalIdent s name
141 142
    let existingElement = fmap thd3 existingResult
    let entry = Entry existingElement index Map.empty
143 144
    let mapping' = setScope current' entry $ sMapping s
    put $ s { sCurrent = current', sMapping = mapping'}
145 146
    where thd3 (_, _, c) = c

147 148
exitScope :: Monad m => ScoperT a m ()
exitScope = modify' $ \s -> s { sCurrent = init $ sCurrent s }
149 150

enterProcedure :: Monad m => ScoperT a m ()
151
enterProcedure = modify' $ \s -> s { sProcedureLoc = map toAccess (sCurrent s) }
152 153

exitProcedure :: Monad m => ScoperT a m ()
154
exitProcedure = modify' $ \s -> s { sProcedureLoc = [] }
155 156 157 158 159 160 161 162 163 164 165

exprToAccesses :: [Access] -> Expr -> Maybe [Access]
exprToAccesses accesses (Ident x) =
    Just $ Access x Nil : accesses
exprToAccesses accesses (Bit (Ident x) y) =
    Just $ Access x y : accesses
exprToAccesses accesses (Bit (Dot e x) y) =
    exprToAccesses (Access x y : accesses) e
exprToAccesses accesses (Dot e x) =
    exprToAccesses (Access x Nil : accesses) e
exprToAccesses _ _ = Nothing
166

167 168 169 170 171 172 173 174 175 176 177 178 179
accessesToExpr :: [Access] -> Expr
accessesToExpr accesses =
    foldl accessToExpr (Ident topName) rest
    where Access topName Nil : rest = accesses

accessToExpr :: Expr -> Access -> Expr
accessToExpr e (Access x Nil) = Dot e x
accessToExpr e (Access x i) = Bit (Dot e x) i

replaceInType :: Replacements -> Type -> Type
replaceInType replacements =
    if Map.null replacements
        then id
180 181 182 183 184
        else replaceInType' replacements

replaceInType' :: Replacements -> Type -> Type
replaceInType' replacements =
    traverseNestedTypes $ traverseTypeExprs $ replaceInExpr' replacements
185 186 187 188 189 190 191 192 193 194 195

replaceInExpr :: Replacements -> Expr -> Expr
replaceInExpr replacements =
    if Map.null replacements
        then id
        else replaceInExpr' replacements

replaceInExpr' :: Replacements -> Expr -> Expr
replaceInExpr' replacements (Ident x) =
    Map.findWithDefault (Ident x) x replacements
replaceInExpr' replacements other =
196 197
    traverseExprTypes (replaceInType' replacements) $
    traverseSinglyNestedExprs (replaceInExpr' replacements) other
198

199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214
-- rewrite an expression so that any identifiers it contains unambiguously refer
-- refer to currently visible declarations so it can be substituted elsewhere
scopeExpr :: Monad m => Expr -> ScoperT a m Expr
scopeExpr expr = do
    expr' <- traverseSinglyNestedExprsM scopeExpr expr
                >>= traverseExprTypesM scopeType
    details <- lookupElemM expr'
    case details of
        Just (accesses, _, _) -> return $ accessesToExpr accesses
        _ -> return expr'
scopeType :: Monad m => Type -> ScoperT a m Type
scopeType = traverseNestedTypesM $ traverseTypeExprsM scopeExpr

{-# INLINABLE scopeExpr #-}
{-# INLINABLE scopeType #-}

215 216 217 218 219 220
scopeExprWithScopes :: Scopes a -> Expr -> Expr
scopeExprWithScopes scopes = flip evalState scopes . scopeExpr

scopeTypeWithScopes :: Scopes a -> Type -> Type
scopeTypeWithScopes scopes = flip evalState scopes . scopeType

221 222 223 224 225 226 227 228 229 230 231 232 233 234 235
class ScopePath k where
    toTiers :: Scopes a -> k -> [Tier]

instance ScopePath Identifier where
    toTiers scopes name = sCurrent scopes ++ [Tier name ""]

instance ScopePath [Access] where
    toTiers _ = map toTier
        where
            toTier :: Access -> Tier
            toTier (Access x Nil) = Tier x ""
            toTier (Access x iy) = Tier x y
                where Ident y = iy

insertElem :: Monad m => ScopePath k => k -> a -> ScoperT a m ()
236 237 238 239 240 241 242
insertElem key = setElem key . Just

removeElem :: Monad m => ScopePath k => k -> ScoperT a m ()
removeElem key = setElem key Nothing

setElem :: Monad m => ScopePath k => k -> Maybe a -> ScoperT a m ()
setElem key maybeElement = do
243 244
    s <- get
    let mapping = sMapping s
245
    let entry = Entry maybeElement "" Map.empty
246
    let mapping' = setScope (toTiers s key) entry mapping
247 248 249 250
    put $ s { sMapping = mapping' }

injectItem :: Monad m => ModuleItem -> ScoperT a m ()
injectItem item =
251 252 253 254 255
    modify' $ \s -> s { sInjectedItems = (True, item) : sInjectedItems s }

injectTopItem :: Monad m => ModuleItem -> ScoperT a m ()
injectTopItem item =
    modify' $ \s -> s { sInjectedItems = (False, item) : sInjectedItems s }
256 257 258 259 260 261 262

injectDecl :: Monad m => Decl -> ScoperT a m ()
injectDecl decl =
    modify' $ \s -> s { sInjectedDecls = decl : sInjectedDecls s }

consumeInjectedItems :: Monad m => ScoperT a m [ModuleItem]
consumeInjectedItems = do
263 264 265 266
    -- only pull out top items if in the top scope
    inTopLevelScope <- gets $ (== 1) . length . sCurrent
    let op = if inTopLevelScope then const True else fst
    (injected, remaining) <- gets $ partition op . sInjectedItems
267
    when (not $ null injected) $
268 269
        modify' $ \s -> s { sInjectedItems = remaining }
    return $ reverse $ map snd $ injected
270 271 272 273 274 275 276

consumeInjectedDecls :: Monad m => ScoperT a m [Decl]
consumeInjectedDecls = do
    injected <- gets sInjectedDecls
    when (not $ null injected) $
        modify' $ \s -> s { sInjectedDecls = [] }
    return $ reverse injected
277 278 279

type Replacements = Map.Map Identifier Expr

Zachary Snow committed
280 281 282 283 284 285 286 287 288 289 290
-- lookup accesses by direct match (no search)
directResolve :: Mapping a -> [Access] -> Maybe (Replacements, a)
directResolve _ [] = Nothing
directResolve mapping [Access x Nil] = do
    Entry maybeElement _ _ <- Map.lookup x mapping
    fmap (Map.empty, ) maybeElement
directResolve _ [_] = Nothing
directResolve mapping (Access x Nil : rest) = do
    Entry _ "" subMapping <- Map.lookup x mapping
    directResolve subMapping rest
directResolve mapping (Access x e : rest) = do
291
    Entry _ index@(_ : _) subMapping <- Map.lookup x mapping
Zachary Snow committed
292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311
    (replacements, element) <- directResolve subMapping rest
    let replacements' = Map.insert index e replacements
    Just (replacements', element)

-- lookup accesses given a current scope prefix
resolveInScope :: Mapping a -> [Tier] -> [Access] -> LookupResult a
resolveInScope mapping [] accesses = do
    (replacements, element) <- directResolve mapping accesses
    Just (accesses, replacements, element)
resolveInScope mapping (Tier x y : rest) accesses = do
    Entry _ _ subMapping <- Map.lookup x mapping
    let deep = resolveInScope subMapping rest accesses
    let side = resolveInScope subMapping [] accesses
    let chosen = if isNothing deep then side else deep
    (accesses', replacements, element) <- chosen
    if null y
        then Just (Access x Nil : accesses', replacements, element)
        else do
            let replacements' = Map.insert y (Ident y) replacements
            Just (Access x (Ident y) : accesses', replacements', element)
312 313 314

type LookupResult a = Maybe ([Access], Replacements, a)

315 316 317 318
class ScopeKey k where
    lookupElem :: Scopes a -> k -> LookupResult a
    lookupElemM :: Monad m => k -> ScoperT a m (LookupResult a)
    lookupElemM = embedScopes lookupElem
319

320
instance ScopeKey Expr where
321
    lookupElem scopes = join . fmap (lookupAccesses scopes) . exprToAccesses []
322

323 324
instance ScopeKey LHS where
    lookupElem scopes = lookupElem scopes . lhsToExpr
325

326 327
instance ScopeKey Identifier where
    lookupElem scopes ident = lookupAccesses scopes [Access ident Nil]
328 329 330

lookupAccesses :: Scopes a -> [Access] -> LookupResult a
lookupAccesses scopes accesses = do
Zachary Snow committed
331 332 333
    let deep = resolveInScope (sMapping scopes) (sCurrent scopes) accesses
    let side = resolveInScope (sMapping scopes) [] accesses
    if isNothing deep then side else deep
334

335 336 337 338 339 340 341
localAccesses :: Scopes a -> Identifier -> [Access]
localAccesses scopes ident =
    foldr ((:) . toAccess) [Access ident Nil] (sCurrent scopes)

localAccessesM :: Monad m => Identifier -> ScoperT a m [Access]
localAccessesM = embedScopes localAccesses

342 343 344 345
lookupLocalIdent :: Scopes a -> Identifier -> LookupResult a
lookupLocalIdent scopes ident = do
    (replacements, element) <- directResolve (sMapping scopes) accesses
    Just (accesses, replacements, element)
346
    where accesses = localAccesses scopes ident
347 348 349 350

toAccess :: Tier -> Access
toAccess (Tier x "") = Access x Nil
toAccess (Tier x y) = Access x (Ident y)
351 352 353 354

lookupLocalIdentM :: Monad m => Identifier -> ScoperT a m (LookupResult a)
lookupLocalIdentM = embedScopes lookupLocalIdent

355
withinProcedureM :: Monad m => ScoperT a m Bool
356
withinProcedureM = gets withinProcedure
357 358

withinProcedure :: Scopes a -> Bool
359 360 361 362 363 364 365
withinProcedure = not . null . sProcedureLoc

procedureLocM :: Monad m => ScoperT a m [Access]
procedureLocM = gets procedureLoc

procedureLoc :: Scopes a -> [Access]
procedureLoc = sProcedureLoc
366

367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386
debugLocation :: Scopes a -> String
debugLocation s =
    hierarchy ++
    if null latestTrace
        then " (use -v to get approximate source location)"
        else ", near " ++ latestTrace
    where
        hierarchy = intercalate "." $ map tierToStr $ sCurrent s
        latestTrace = sLatestTrace s
        tierToStr :: Tier -> String
        tierToStr (Tier "" _) = "<unnamed_block>"
        tierToStr (Tier x "") = x
        tierToStr (Tier x y) = x ++ '[' : y ++ "]"

scopedErrorM :: Monad m => String -> ScoperT a m x
scopedErrorM msg = get >>= flip scopedError msg

scopedError :: Scopes a -> String -> x
scopedError scopes = error . (++ ", within scope " ++ debugLocation scopes)

387 388 389 390 391 392 393
isLoopVar :: Scopes a -> Identifier -> Bool
isLoopVar scopes x = any matches $ sCurrent scopes
    where matches = (== x) . tierIndex

isLoopVarM :: Monad m => Identifier -> ScoperT a m Bool
isLoopVarM = embedScopes isLoopVar

394 395 396 397 398 399 400 401 402 403
loopVarDepth :: Scopes a -> Identifier -> Maybe Int
loopVarDepth scopes x =
    case findIndices matches $ sCurrent scopes of
        [] -> Nothing
        indices -> Just $ last indices
    where matches = (== x) . tierIndex

loopVarDepthM :: Monad m => Identifier -> ScoperT a m (Maybe Int)
loopVarDepthM = embedScopes loopVarDepth

404 405 406
scopeModuleItems
    :: Monad m
    => MapperM (ScoperT a m) ModuleItem
407
    -> Identifier
408 409 410 411 412
    -> MapperM (ScoperT a m) [ModuleItem]
scopeModuleItems moduleItemMapper topName items = do
    enterScope topName ""
    items' <- mapM moduleItemMapper items
    exitScope
413 414
    return items'

415 416 417 418 419 420 421
scopeModule :: Monad m
    => MapperM (ScoperT a m) ModuleItem
    -> MapperM (ScoperT a m) Description
scopeModule moduleItemMapper description
    | Part _ _ Module _ _ _ _ <- description =
        scopePart moduleItemMapper description
    | otherwise = return description
422

423 424 425 426 427 428 429 430
scopePart :: Monad m
    => MapperM (ScoperT a m) ModuleItem
    -> MapperM (ScoperT a m) Description
scopePart moduleItemMapper description
    | Part attrs extern kw liftetime name ports items <- description =
        scopeModuleItems moduleItemMapper name items >>=
        return . Part attrs extern kw liftetime name ports
    | otherwise = return description
431

432 433 434 435 436 437 438 439 440 441 442
evalScoper :: Scoper a x -> x
evalScoper = flip evalState initialState

evalScoperT :: Monad m => ScoperT a m x -> m x
evalScoperT = flip evalStateT initialState

runScoper :: Scoper a x -> (x, Scopes a)
runScoper = flip runState initialState

runScoperT :: Monad m => ScoperT a m x -> m (x, Scopes a)
runScoperT = flip runStateT initialState
443

444
initialState :: Scopes a
445 446 447 448
initialState = Scopes [] Map.empty [] [] [] ""

tracePrefix :: String
tracePrefix = "Trace: "
449 450

scopeModuleItem
451 452 453 454 455
    :: forall a m. Monad m
    => MapperM (ScoperT a m) Decl
    -> MapperM (ScoperT a m) ModuleItem
    -> MapperM (ScoperT a m) GenItem
    -> MapperM (ScoperT a m) Stmt
456
    -> MapperM (ScoperT a m) ModuleItem
457
scopeModuleItem declMapperRaw moduleItemMapper genItemMapper stmtMapperRaw =
458 459
    wrappedModuleItemMapper
    where
460 461 462
        fullStmtMapper :: Stmt -> ScoperT a m Stmt
        fullStmtMapper (Block kw name decls stmts) = do
            enterScope name ""
463
            decls' <- fmap concat $ mapM declMapper' decls
464
            stmts' <- mapM fullStmtMapper $ filter (/= Null) stmts
465
            exitScope
466 467
            return $ Block kw name decls' stmts'
        -- TODO: Do we need to support the various procedural loops?
468 469 470 471 472 473 474
        fullStmtMapper stmt = do
            stmt' <- stmtMapper stmt
            injected <- consumeInjectedDecls
            if null injected
                then traverseSinglyNestedStmtsM fullStmtMapper stmt'
                else fullStmtMapper $ Block Seq "" injected [stmt']

475 476 477 478 479 480 481 482 483 484 485 486 487 488 489
        declMapper :: Decl -> ScoperT a m Decl
        declMapper decl@(CommentDecl c) =
            consumeComment c >> return decl
        declMapper decl = declMapperRaw decl

        stmtMapper :: Stmt -> ScoperT a m Stmt
        stmtMapper stmt@(CommentStmt c) =
            consumeComment c >> return stmt
        stmtMapper stmt = stmtMapperRaw stmt

        consumeComment :: String -> ScoperT a m ()
        consumeComment c =
            when (tracePrefix `isPrefixOf` c) $
                modify' $ \s -> s { sLatestTrace = drop (length tracePrefix) c }

490 491 492 493 494 495 496 497 498 499
        -- converts a decl and adds decls injected during conversion
        declMapper' :: Decl -> ScoperT a m [Decl]
        declMapper' decl = do
            decl' <- declMapper decl
            injected <- consumeInjectedDecls
            if null injected
                then return [decl']
                else do
                    injected' <- mapM declMapper injected
                    return $ injected' ++ [decl']
500 501 502 503 504 505 506 507 508

        mapTFDecls :: [Decl] -> ScoperT a m [Decl]
        mapTFDecls = mapTFDecls' 0
            where
                mapTFDecls' :: Int -> [Decl] -> ScoperT a m [Decl]
                mapTFDecls' _ [] = return []
                mapTFDecls' idx (decl : decls) =
                    case argIdxDecl decl of
                        Nothing -> do
509
                            decl' <- declMapper' decl
510
                            decls' <- mapTFDecls' idx decls
511
                            return $ decl' ++ decls'
512 513
                        Just declFunc -> do
                            _ <- declMapper $ declFunc idx
514
                            decl' <- declMapper' decl
515
                            decls' <- mapTFDecls' (idx + 1) decls
516
                            return $ decl' ++ decls'
517 518 519 520 521 522

                argIdxDecl :: Decl -> Maybe (Int -> Decl)
                argIdxDecl (Variable d t _ a e) =
                    if d == Local
                        then Nothing
                        else Just $ \i -> Variable d t (show i) a e
523
                argIdxDecl Net{} = Nothing
524 525 526 527
                argIdxDecl Param{} = Nothing
                argIdxDecl ParamType{} = Nothing
                argIdxDecl CommentDecl{} = Nothing

528 529 530
        redirectTFDecl :: Type -> Identifier -> ScoperT a m (Type, Identifier)
        redirectTFDecl typ ident = do
            res <- declMapper $ Variable Local typ ident [] Nil
531 532 533 534 535
            (newType, newName, newRanges) <-
                return $ case res of
                    Variable Local t x r Nil -> (t, x, r)
                    Net Local TWire DefaultStrength t x r Nil -> (t, x, r)
                    _ -> error "redirectTFDecl invariant violated"
536 537 538 539 540
            return $ if null newRanges
                then (newType, newName)
                else
                    let (tf, rs2) = typeRanges newType
                    in (tf $ newRanges ++ rs2, newName)
541

542 543 544
        wrappedModuleItemMapper :: ModuleItem -> ScoperT a m ModuleItem
        wrappedModuleItemMapper item = do
            item' <- fullModuleItemMapper item
545
            injected <- consumeInjectedItems
546 547 548 549 550
            if null injected
                then return item'
                else do
                    injected' <- mapM fullModuleItemMapper injected
                    return $ Generate $ map GenModuleItem $ injected' ++ [item']
551 552
        fullModuleItemMapper :: ModuleItem -> ScoperT a m ModuleItem
        fullModuleItemMapper (MIPackageItem (Function ml t x decls stmts)) = do
553
            (t', x') <- redirectTFDecl t x
554
            enterProcedure
555
            enterScope x' ""
556 557
            decls' <- mapTFDecls decls
            stmts' <- mapM fullStmtMapper stmts
558
            exitScope
559
            exitProcedure
560 561 562
            return $ MIPackageItem $ Function ml t' x' decls' stmts'
        fullModuleItemMapper (MIPackageItem (Task ml x decls stmts)) = do
            (_, x') <- redirectTFDecl (Implicit Unspecified []) x
563
            enterProcedure
564
            enterScope x' ""
565 566
            decls' <- mapTFDecls decls
            stmts' <- mapM fullStmtMapper stmts
567
            exitScope
568
            exitProcedure
569
            return $ MIPackageItem $ Task ml x' decls' stmts'
570 571
        fullModuleItemMapper (MIPackageItem (Decl decl)) =
            declMapper decl >>= return . MIPackageItem . Decl
572 573 574 575 576 577 578 579
        fullModuleItemMapper (MIPackageItem item@DPIImport{}) = do
            let DPIImport spec prop alias typ name decls = item
            (typ', name') <- redirectTFDecl typ name
            decls' <- mapM declMapper decls
            let item' = DPIImport spec prop alias typ' name' decls'
            return $ MIPackageItem item'
        fullModuleItemMapper (MIPackageItem (DPIExport spec alias kw name)) =
            return $ MIPackageItem $ DPIExport spec alias kw name
580 581 582 583 584 585 586 587 588 589 590 591 592 593 594
        fullModuleItemMapper (AlwaysC kw stmt) = do
            enterProcedure
            stmt' <- fullStmtMapper stmt
            exitProcedure
            return $ AlwaysC kw stmt'
        fullModuleItemMapper (Initial stmt) = do
            enterProcedure
            stmt' <- fullStmtMapper stmt
            exitProcedure
            return $ Initial stmt'
        fullModuleItemMapper (Final stmt) = do
            enterProcedure
            stmt' <- fullStmtMapper stmt
            exitProcedure
            return $ Final stmt'
595
        fullModuleItemMapper (Generate genItems) =
596
            fullGenItemBlockMapper genItems >>= return . Generate
597 598 599 600 601
        fullModuleItemMapper (MIAttr attr item) =
            fullModuleItemMapper item >>= return . MIAttr attr
        fullModuleItemMapper item = moduleItemMapper item

        fullGenItemMapper :: GenItem -> ScoperT a m GenItem
602 603
        fullGenItemMapper genItem = do
            genItem' <- genItemMapper genItem
604
            injected <- consumeInjectedItems
605 606 607 608 609 610 611 612 613 614 615 616
            genItem'' <- scopeGenItemMapper genItem'
            mapM_ injectItem injected -- defer until enclosing block
            return genItem''

        -- akin to fullGenItemMapper, but for lists of generate items, and
        -- allowing module items to be injected in the middle of the list
        fullGenItemBlockMapper :: [GenItem] -> ScoperT a m [GenItem]
        fullGenItemBlockMapper = fmap concat . mapM genblkStep
        genblkStep :: GenItem -> ScoperT a m [GenItem]
        genblkStep genItem = do
            genItem' <- fullGenItemMapper genItem
            injected <- consumeInjectedItems
617
            if null injected
618
                then return [genItem']
619 620
                else do
                    injected' <- mapM fullModuleItemMapper injected
621 622 623
                    return $ map GenModuleItem injected' ++ [genItem']

        -- enters and exits generate block scopes as appropriate
624
        scopeGenItemMapper :: GenItem -> ScoperT a m GenItem
625
        scopeGenItemMapper (GenFor _ _ _ GenNull) = return GenNull
626
        scopeGenItemMapper (GenFor (index, a) b c genItem) = do
627 628 629 630 631
            let GenBlock name genItems = genItem
            enterScope name index
            genItems' <- fullGenItemBlockMapper genItems
            exitScope
            let genItem' = GenBlock name genItems'
632
            return $ GenFor (index, a) b c genItem'
633
        scopeGenItemMapper (GenIf cond thenItem elseItem) = do
634 635
            thenItem' <- fullGenItemMapper thenItem
            elseItem' <- fullGenItemMapper elseItem
636
            return $ GenIf cond thenItem' elseItem'
637 638
        scopeGenItemMapper (GenBlock name genItems) = do
            enterScope name ""
639
            genItems' <- fullGenItemBlockMapper genItems
640
            exitScope
641 642
            return $ GenBlock name genItems'
        scopeGenItemMapper (GenModuleItem moduleItem) =
643
            wrappedModuleItemMapper moduleItem >>= return . GenModuleItem
644
        scopeGenItemMapper genItem@GenCase{} =
645
            traverseSinglyNestedGenItemsM fullGenItemMapper genItem
646
        scopeGenItemMapper GenNull = return GenNull
647

648 649 650 651 652
partScoper
    :: MapperM (Scoper a) Decl
    -> MapperM (Scoper a) ModuleItem
    -> MapperM (Scoper a) GenItem
    -> MapperM (Scoper a) Stmt
653 654 655 656
    -> Mapper Description
partScoper declMapper moduleItemMapper genItemMapper stmtMapper =
    evalScoper . scopePart scoper
    where scoper = scopeModuleItem
657
            declMapper moduleItemMapper genItemMapper stmtMapper