1-- | 2-- Module : Cryptol.ModuleSystem.Renamer 3-- Copyright : (c) 2013-2016 Galois, Inc. 4-- License : BSD3 5-- Maintainer : cryptol@galois.com 6-- Stability : provisional 7-- Portability : portable 8 9{-# LANGUAGE DeriveAnyClass #-} 10{-# LANGUAGE DeriveGeneric #-} 11{-# LANGUAGE FlexibleContexts #-} 12{-# LANGUAGE FlexibleInstances #-} 13{-# LANGUAGE MultiWayIf #-} 14{-# LANGUAGE PatternGuards #-} 15{-# LANGUAGE RecordWildCards #-} 16{-# LANGUAGE ViewPatterns #-} 17{-# LANGUAGE OverloadedStrings #-} 18module Cryptol.ModuleSystem.Renamer ( 19 NamingEnv(), shadowing 20 , BindsNames(..), InModule(..), namingEnv' 21 , checkNamingEnv 22 , shadowNames 23 , Rename(..), runRenamer, RenameM() 24 , RenamerError(..) 25 , RenamerWarning(..) 26 , renameVar 27 , renameType 28 , renameModule 29 ) where 30 31import Cryptol.ModuleSystem.Name 32import Cryptol.ModuleSystem.NamingEnv 33import Cryptol.ModuleSystem.Exports 34import Cryptol.Parser.AST 35import Cryptol.Parser.Position 36import Cryptol.Parser.Selector(ppNestedSels,selName) 37import Cryptol.Utils.Panic (panic) 38import Cryptol.Utils.PP 39import Cryptol.Utils.RecordMap 40 41import Data.List(find) 42import qualified Data.Foldable as F 43import Data.Map.Strict ( Map ) 44import qualified Data.Map.Strict as Map 45import qualified Data.Sequence as Seq 46import qualified Data.Semigroup as S 47import Data.Set (Set) 48import qualified Data.Set as Set 49import MonadLib hiding (mapM, mapM_) 50 51import GHC.Generics (Generic) 52import Control.DeepSeq 53 54import Prelude () 55import Prelude.Compat 56 57-- Errors ---------------------------------------------------------------------- 58 59data RenamerError 60 = MultipleSyms (Located PName) [Name] NameDisp 61 -- ^ Multiple imported symbols contain this name 62 63 | UnboundExpr (Located PName) NameDisp 64 -- ^ Expression name is not bound to any definition 65 66 | UnboundType (Located PName) NameDisp 67 -- ^ Type name is not bound to any definition 68 69 | OverlappingSyms [Name] NameDisp 70 -- ^ An environment has produced multiple overlapping symbols 71 72 | ExpectedValue (Located PName) NameDisp 73 -- ^ When a value is expected from the naming environment, but one or more 74 -- types exist instead. 75 76 | ExpectedType (Located PName) NameDisp 77 -- ^ When a type is missing from the naming environment, but one or more 78 -- values exist with the same name. 79 80 | FixityError (Located Name) Fixity (Located Name) Fixity NameDisp 81 -- ^ When the fixity of two operators conflict 82 83 | InvalidConstraint (Type PName) NameDisp 84 -- ^ When it's not possible to produce a Prop from a Type. 85 86 | MalformedBuiltin (Type PName) PName NameDisp 87 -- ^ When a builtin type/type-function is used incorrectly. 88 89 | BoundReservedType PName (Maybe Range) Doc NameDisp 90 -- ^ When a builtin type is named in a binder. 91 92 | OverlappingRecordUpdate (Located [Selector]) (Located [Selector]) NameDisp 93 -- ^ When record updates overlap (e.g., @{ r | x = e1, x.y = e2 }@) 94 deriving (Show, Generic, NFData) 95 96instance PP RenamerError where 97 ppPrec _ e = case e of 98 99 MultipleSyms lqn qns disp -> fixNameDisp disp $ 100 hang (text "[error] at" <+> pp (srcRange lqn)) 101 4 $ (text "Multiple definitions for symbol:" <+> pp (thing lqn)) 102 $$ vcat (map ppLocName qns) 103 104 UnboundExpr lqn disp -> fixNameDisp disp $ 105 hang (text "[error] at" <+> pp (srcRange lqn)) 106 4 (text "Value not in scope:" <+> pp (thing lqn)) 107 108 UnboundType lqn disp -> fixNameDisp disp $ 109 hang (text "[error] at" <+> pp (srcRange lqn)) 110 4 (text "Type not in scope:" <+> pp (thing lqn)) 111 112 OverlappingSyms qns disp -> fixNameDisp disp $ 113 hang (text "[error]") 114 4 $ text "Overlapping symbols defined:" 115 $$ vcat (map ppLocName qns) 116 117 ExpectedValue lqn disp -> fixNameDisp disp $ 118 hang (text "[error] at" <+> pp (srcRange lqn)) 119 4 (fsep [ text "Expected a value named", quotes (pp (thing lqn)) 120 , text "but found a type instead" 121 , text "Did you mean `(" <.> pp (thing lqn) <.> text")?" ]) 122 123 ExpectedType lqn disp -> fixNameDisp disp $ 124 hang (text "[error] at" <+> pp (srcRange lqn)) 125 4 (fsep [ text "Expected a type named", quotes (pp (thing lqn)) 126 , text "but found a value instead" ]) 127 128 FixityError o1 f1 o2 f2 disp -> fixNameDisp disp $ 129 hang (text "[error] at" <+> pp (srcRange o1) <+> text "and" <+> pp (srcRange o2)) 130 4 (fsep [ text "The fixities of" 131 , nest 2 $ vcat 132 [ "•" <+> pp (thing o1) <+> parens (pp f1) 133 , "•" <+> pp (thing o2) <+> parens (pp f2) ] 134 , text "are not compatible." 135 , text "You may use explicit parentheses to disambiguate." ]) 136 137 InvalidConstraint ty disp -> fixNameDisp disp $ 138 hang (text "[error]" <+> maybe empty (\r -> text "at" <+> pp r) (getLoc ty)) 139 4 (fsep [ pp ty, text "is not a valid constraint" ]) 140 141 MalformedBuiltin ty pn disp -> fixNameDisp disp $ 142 hang (text "[error]" <+> maybe empty (\r -> text "at" <+> pp r) (getLoc ty)) 143 4 (fsep [ text "invalid use of built-in type", pp pn 144 , text "in type", pp ty ]) 145 146 BoundReservedType n loc src disp -> fixNameDisp disp $ 147 hang (text "[error]" <+> maybe empty (\r -> text "at" <+> pp r) loc) 148 4 (fsep [ text "built-in type", quotes (pp n), text "shadowed in", src ]) 149 150 OverlappingRecordUpdate xs ys disp -> fixNameDisp disp $ 151 hang "[error] Overlapping record updates:" 152 4 (vcat [ ppLab xs, ppLab ys ]) 153 where 154 ppLab as = ppNestedSels (thing as) <+> "at" <+> pp (srcRange as) 155 156-- Warnings -------------------------------------------------------------------- 157 158data RenamerWarning 159 = SymbolShadowed Name [Name] NameDisp 160 161 | UnusedName Name NameDisp 162 deriving (Show, Generic, NFData) 163 164instance PP RenamerWarning where 165 ppPrec _ (SymbolShadowed new originals disp) = fixNameDisp disp $ 166 hang (text "[warning] at" <+> loc) 167 4 $ fsep [ text "This binding for" <+> backticks sym 168 , text "shadows the existing binding" <.> plural <+> 169 text "at" ] 170 $$ vcat (map (pp . nameLoc) originals) 171 172 where 173 plural | length originals > 1 = char 's' 174 | otherwise = empty 175 176 loc = pp (nameLoc new) 177 sym = pp new 178 179 ppPrec _ (UnusedName x disp) = fixNameDisp disp $ 180 hang (text "[warning] at" <+> pp (nameLoc x)) 181 4 (text "Unused name:" <+> pp x) 182 183 184data RenamerWarnings = RenamerWarnings 185 { renWarnNameDisp :: !NameDisp 186 , renWarnShadow :: Map Name (Set Name) 187 , renWarnUnused :: Set Name 188 } 189 190noRenamerWarnings :: RenamerWarnings 191noRenamerWarnings = RenamerWarnings 192 { renWarnNameDisp = mempty 193 , renWarnShadow = Map.empty 194 , renWarnUnused = Set.empty 195 } 196 197addRenamerWarning :: RenamerWarning -> RenamerWarnings -> RenamerWarnings 198addRenamerWarning w ws = 199 case w of 200 SymbolShadowed x xs d -> 201 ws { renWarnNameDisp = renWarnNameDisp ws <> d 202 , renWarnShadow = Map.insertWith Set.union x (Set.fromList xs) 203 (renWarnShadow ws) 204 } 205 UnusedName x d -> 206 ws { renWarnNameDisp = renWarnNameDisp ws <> d 207 , renWarnUnused = Set.insert x (renWarnUnused ws) 208 } 209 210listRenamerWarnings :: RenamerWarnings -> [RenamerWarning] 211listRenamerWarnings ws = 212 [ mk (UnusedName x) | x <- Set.toList (renWarnUnused ws) ] ++ 213 [ mk (SymbolShadowed x (Set.toList xs)) 214 | (x,xs) <- Map.toList (renWarnShadow ws) ] 215 where 216 mk f = f (renWarnNameDisp ws) 217 218 219-- Renaming Monad -------------------------------------------------------------- 220 221data RO = RO 222 { roLoc :: Range 223 , roMod :: !ModName 224 , roNames :: NamingEnv 225 , roDisp :: !NameDisp 226 } 227 228data RW = RW 229 { rwWarnings :: !RenamerWarnings 230 , rwErrors :: !(Seq.Seq RenamerError) 231 , rwSupply :: !Supply 232 , rwNameUseCount :: !(Map Name Int) 233 -- ^ How many times did we refer to each name. 234 -- Used to generate warnings for unused definitions. 235 } 236 237 238 239newtype RenameM a = RenameM 240 { unRenameM :: ReaderT RO (StateT RW Lift) a } 241 242instance S.Semigroup a => S.Semigroup (RenameM a) where 243 {-# INLINE (<>) #-} 244 a <> b = 245 do x <- a 246 y <- b 247 return (x S.<> y) 248 249instance (S.Semigroup a, Monoid a) => Monoid (RenameM a) where 250 {-# INLINE mempty #-} 251 mempty = return mempty 252 253 {-# INLINE mappend #-} 254 mappend = (S.<>) 255 256instance Functor RenameM where 257 {-# INLINE fmap #-} 258 fmap f m = RenameM (fmap f (unRenameM m)) 259 260instance Applicative RenameM where 261 {-# INLINE pure #-} 262 pure x = RenameM (pure x) 263 264 {-# INLINE (<*>) #-} 265 l <*> r = RenameM (unRenameM l <*> unRenameM r) 266 267instance Monad RenameM where 268 {-# INLINE return #-} 269 return x = RenameM (return x) 270 271 {-# INLINE (>>=) #-} 272 m >>= k = RenameM (unRenameM m >>= unRenameM . k) 273 274instance FreshM RenameM where 275 liftSupply f = RenameM $ sets $ \ RW { .. } -> 276 let (a,s') = f rwSupply 277 rw' = RW { rwSupply = s', .. } 278 in a `seq` rw' `seq` (a, rw') 279 280runRenamer :: Supply -> ModName -> NamingEnv -> RenameM a 281 -> (Either [RenamerError] (a,Supply),[RenamerWarning]) 282runRenamer s ns env m = (res, listRenamerWarnings warns) 283 where 284 warns = foldr addRenamerWarning (rwWarnings rw) 285 (warnUnused ns env ro rw) 286 287 (a,rw) = runM (unRenameM m) ro 288 RW { rwErrors = Seq.empty 289 , rwWarnings = noRenamerWarnings 290 , rwSupply = s 291 , rwNameUseCount = Map.empty 292 } 293 294 ro = RO { roLoc = emptyRange 295 , roNames = env 296 , roMod = ns 297 , roDisp = neverQualifyMod ns `mappend` toNameDisp env 298 } 299 300 res | Seq.null (rwErrors rw) = Right (a,rwSupply rw) 301 | otherwise = Left (F.toList (rwErrors rw)) 302 303-- | Record an error. XXX: use a better name 304record :: (NameDisp -> RenamerError) -> RenameM () 305record f = RenameM $ 306 do RO { .. } <- ask 307 RW { .. } <- get 308 set RW { rwErrors = rwErrors Seq.|> f roDisp, .. } 309 310-- | Get the source range for wahtever we are currently renaming. 311curLoc :: RenameM Range 312curLoc = RenameM (roLoc `fmap` ask) 313 314-- | Annotate something with the current range. 315located :: a -> RenameM (Located a) 316located thing = 317 do srcRange <- curLoc 318 return Located { .. } 319 320-- | Do the given computation using the source code range from `loc` if any. 321withLoc :: HasLoc loc => loc -> RenameM a -> RenameM a 322withLoc loc m = RenameM $ case getLoc loc of 323 324 Just range -> do 325 ro <- ask 326 local ro { roLoc = range } (unRenameM m) 327 328 Nothing -> unRenameM m 329 330-- | Retrieve the name of the current module. 331getNS :: RenameM ModName 332getNS = RenameM (roMod `fmap` ask) 333 334-- | Shadow the current naming environment with some more names. 335shadowNames :: BindsNames env => env -> RenameM a -> RenameM a 336shadowNames = shadowNames' CheckAll 337 338data EnvCheck = CheckAll -- ^ Check for overlap and shadowing 339 | CheckOverlap -- ^ Only check for overlap 340 | CheckNone -- ^ Don't check the environment 341 deriving (Eq,Show) 342 343-- | Shadow the current naming environment with some more names. 344shadowNames' :: BindsNames env => EnvCheck -> env -> RenameM a -> RenameM a 345shadowNames' check names m = do 346 do env <- liftSupply (namingEnv' names) 347 RenameM $ 348 do ro <- ask 349 env' <- sets (checkEnv (roDisp ro) check env (roNames ro)) 350 let ro' = ro { roNames = env' `shadowing` roNames ro } 351 local ro' (unRenameM m) 352 353shadowNamesNS :: BindsNames (InModule env) => env -> RenameM a -> RenameM a 354shadowNamesNS names m = 355 do ns <- getNS 356 shadowNames (InModule ns names) m 357 358 359-- | Generate warnings when the left environment shadows things defined in 360-- the right. Additionally, generate errors when two names overlap in the 361-- left environment. 362checkEnv :: NameDisp -> EnvCheck -> NamingEnv -> NamingEnv -> RW -> (NamingEnv,RW) 363checkEnv disp check l r rw 364 | check == CheckNone = (l',rw) 365 | otherwise = (l',rw'') 366 367 where 368 369 l' = l { neExprs = es, neTypes = ts } 370 371 (rw',es) = Map.mapAccumWithKey (step neExprs) rw (neExprs l) 372 (rw'',ts) = Map.mapAccumWithKey (step neTypes) rw' (neTypes l) 373 374 step prj acc k ns = (acc', [head ns]) 375 where 376 acc' = acc 377 { rwWarnings = 378 if check == CheckAll 379 then case Map.lookup k (prj r) of 380 Nothing -> rwWarnings acc 381 Just os -> addRenamerWarning 382 (SymbolShadowed (head ns) os disp) 383 (rwWarnings acc) 384 385 else rwWarnings acc 386 , rwErrors = rwErrors acc Seq.>< containsOverlap disp ns 387 } 388 389-- | Check the RHS of a single name rewrite for conflicting sources. 390containsOverlap :: NameDisp -> [Name] -> Seq.Seq RenamerError 391containsOverlap _ [_] = Seq.empty 392containsOverlap _ [] = panic "Renamer" ["Invalid naming environment"] 393containsOverlap disp ns = Seq.singleton (OverlappingSyms ns disp) 394 395-- | Throw errors for any names that overlap in a rewrite environment. 396checkNamingEnv :: NamingEnv -> ([RenamerError],[RenamerWarning]) 397checkNamingEnv env = (F.toList out, []) 398 where 399 out = Map.foldr check outTys (neExprs env) 400 outTys = Map.foldr check mempty (neTypes env) 401 402 disp = toNameDisp env 403 404 check ns acc = containsOverlap disp ns Seq.>< acc 405 406recordUse :: Name -> RenameM () 407recordUse x = RenameM $ sets_ $ \rw -> 408 rw { rwNameUseCount = Map.insertWith (+) x 1 (rwNameUseCount rw) } 409 410 411warnUnused :: ModName -> NamingEnv -> RO -> RW -> [RenamerWarning] 412warnUnused m0 env ro rw = 413 map warn 414 $ Map.keys 415 $ Map.filterWithKey keep 416 $ rwNameUseCount rw 417 where 418 warn x = UnusedName x (roDisp ro) 419 keep k n = n == 1 && isLocal k 420 oldNames = fst (visibleNames env) 421 isLocal nm = case nameInfo nm of 422 Declared m sys -> sys == UserName && 423 m == m0 && nm `Set.notMember` oldNames 424 Parameter -> True 425 426-- Renaming -------------------------------------------------------------------- 427 428class Rename f where 429 rename :: f PName -> RenameM (f Name) 430 431renameModule :: Module PName -> RenameM (NamingEnv,Module Name) 432renameModule m = 433 do env <- liftSupply (namingEnv' m) 434 -- NOTE: we explicitly hide shadowing errors here, by using shadowNames' 435 decls' <- shadowNames' CheckOverlap env (traverse rename (mDecls m)) 436 let m1 = m { mDecls = decls' } 437 exports = modExports m1 438 mapM_ recordUse (eTypes exports) 439 return (env,m1) 440 441instance Rename TopDecl where 442 rename td = case td of 443 Decl d -> Decl <$> traverse rename d 444 DPrimType d -> DPrimType <$> traverse rename d 445 TDNewtype n -> TDNewtype <$> traverse rename n 446 Include n -> return (Include n) 447 DParameterFun f -> DParameterFun <$> rename f 448 DParameterType f -> DParameterType <$> rename f 449 450 DParameterConstraint d -> DParameterConstraint <$> mapM renameLocated d 451 452renameLocated :: Rename f => Located (f PName) -> RenameM (Located (f Name)) 453renameLocated x = 454 do y <- rename (thing x) 455 return x { thing = y } 456 457instance Rename PrimType where 458 rename pt = 459 do x <- rnLocated renameType (primTName pt) 460 let (as,ps) = primTCts pt 461 (_,cts) <- renameQual as ps $ \as' ps' -> pure (as',ps') 462 pure pt { primTCts = cts, primTName = x } 463 464instance Rename ParameterType where 465 rename a = 466 do n' <- rnLocated renameType (ptName a) 467 return a { ptName = n' } 468 469instance Rename ParameterFun where 470 rename a = 471 do n' <- rnLocated renameVar (pfName a) 472 sig' <- renameSchema (pfSchema a) 473 return a { pfName = n', pfSchema = snd sig' } 474 475rnLocated :: (a -> RenameM b) -> Located a -> RenameM (Located b) 476rnLocated f loc = withLoc loc $ 477 do a' <- f (thing loc) 478 return loc { thing = a' } 479 480instance Rename Decl where 481 rename d = case d of 482 DSignature ns sig -> DSignature <$> traverse (rnLocated renameVar) ns 483 <*> rename sig 484 DPragma ns p -> DPragma <$> traverse (rnLocated renameVar) ns 485 <*> pure p 486 DBind b -> DBind <$> rename b 487 488 -- XXX we probably shouldn't see these at this point... 489 DPatBind pat e -> do (pe,pat') <- renamePat pat 490 shadowNames pe (DPatBind pat' <$> rename e) 491 492 DType syn -> DType <$> rename syn 493 DProp syn -> DProp <$> rename syn 494 DLocated d' r -> withLoc r 495 $ DLocated <$> rename d' <*> pure r 496 DFixity{} -> panic "Renamer" ["Unexpected fixity declaration" 497 , show d] 498 499instance Rename Newtype where 500 rename n = do 501 name' <- rnLocated renameType (nName n) 502 shadowNames (nParams n) $ 503 do ps' <- traverse rename (nParams n) 504 body' <- traverse (traverse rename) (nBody n) 505 return Newtype { nName = name' 506 , nParams = ps' 507 , nBody = body' } 508 509renameVar :: PName -> RenameM Name 510renameVar qn = do 511 ro <- RenameM ask 512 case Map.lookup qn (neExprs (roNames ro)) of 513 Just [n] -> return n 514 Just [] -> panic "Renamer" ["Invalid expression renaming environment"] 515 Just syms -> 516 do n <- located qn 517 record (MultipleSyms n syms) 518 return (head syms) 519 520 -- This is an unbound value. Record an error and invent a bogus real name 521 -- for it. 522 Nothing -> 523 do n <- located qn 524 525 case Map.lookup qn (neTypes (roNames ro)) of 526 -- types existed with the name of the value expected 527 Just _ -> record (ExpectedValue n) 528 529 -- the value is just missing 530 Nothing -> record (UnboundExpr n) 531 532 mkFakeName qn 533 534-- | Produce a name if one exists. Note that this includes situations where 535-- overlap exists, as it's just a query about anything being in scope. In the 536-- event that overlap does exist, an error will be recorded. 537typeExists :: PName -> RenameM (Maybe Name) 538typeExists pn = 539 do ro <- RenameM ask 540 case Map.lookup pn (neTypes (roNames ro)) of 541 Just [n] -> recordUse n >> return (Just n) 542 Just [] -> panic "Renamer" ["Invalid type renaming environment"] 543 Just syms -> do n <- located pn 544 mapM_ recordUse syms 545 record (MultipleSyms n syms) 546 return (Just (head syms)) 547 Nothing -> return Nothing 548 549renameType :: PName -> RenameM Name 550renameType pn = 551 do mb <- typeExists pn 552 case mb of 553 Just n -> return n 554 555 -- This is an unbound value. Record an error and invent a bogus real name 556 -- for it. 557 Nothing -> 558 do ro <- RenameM ask 559 let n = Located { srcRange = roLoc ro, thing = pn } 560 561 case Map.lookup pn (neExprs (roNames ro)) of 562 563 -- values exist with the same name, so throw a different error 564 Just _ -> record (ExpectedType n) 565 566 -- no terms with the same name, so the type is just unbound 567 Nothing -> record (UnboundType n) 568 569 mkFakeName pn 570 571-- | Assuming an error has been recorded already, construct a fake name that's 572-- not expected to make it out of the renamer. 573mkFakeName :: PName -> RenameM Name 574mkFakeName pn = 575 do ro <- RenameM ask 576 liftSupply (mkParameter (getIdent pn) (roLoc ro)) 577 578-- | Rename a schema, assuming that none of its type variables are already in 579-- scope. 580instance Rename Schema where 581 rename s = snd `fmap` renameSchema s 582 583-- | Rename a schema, assuming that the type variables have already been brought 584-- into scope. 585renameSchema :: Schema PName -> RenameM (NamingEnv,Schema Name) 586renameSchema (Forall ps p ty loc) = 587 renameQual ps p $ \ps' p' -> 588 do ty' <- rename ty 589 pure (Forall ps' p' ty' loc) 590 591-- | Rename a qualified thing. 592renameQual :: [TParam PName] -> [Prop PName] -> 593 ([TParam Name] -> [Prop Name] -> RenameM a) -> 594 RenameM (NamingEnv, a) 595renameQual as ps k = 596 do env <- liftSupply (namingEnv' as) 597 res <- shadowNames env $ do as' <- traverse rename as 598 ps' <- traverse rename ps 599 k as' ps' 600 pure (env,res) 601 602instance Rename TParam where 603 rename TParam { .. } = 604 do n <- renameType tpName 605 return TParam { tpName = n, .. } 606 607instance Rename Prop where 608 rename (CType t) = CType <$> rename t 609 610 611instance Rename Type where 612 rename ty0 = 613 case ty0 of 614 TFun a b -> TFun <$> rename a <*> rename b 615 TSeq n a -> TSeq <$> rename n <*> rename a 616 TBit -> return TBit 617 TNum c -> return (TNum c) 618 TChar c -> return (TChar c) 619 TUser qn ps -> TUser <$> renameType qn <*> traverse rename ps 620 TTyApp fs -> TTyApp <$> traverse (traverse rename) fs 621 TRecord fs -> TRecord <$> traverse (traverse rename) fs 622 TTuple fs -> TTuple <$> traverse rename fs 623 TWild -> return TWild 624 TLocated t' r -> withLoc r (TLocated <$> rename t' <*> pure r) 625 TParens t' -> TParens <$> rename t' 626 TInfix a o _ b -> do o' <- renameTypeOp o 627 a' <- rename a 628 b' <- rename b 629 mkTInfix a' o' b' 630 631mkTInfix :: Type Name -> (Located Name, Fixity) -> Type Name -> RenameM (Type Name) 632 633mkTInfix t@(TInfix x o1 f1 y) op@(o2,f2) z = 634 case compareFixity f1 f2 of 635 FCLeft -> return (TInfix t o2 f2 z) 636 FCRight -> do r <- mkTInfix y op z 637 return (TInfix x o1 f1 r) 638 FCError -> do record (FixityError o1 f1 o2 f2) 639 return (TInfix t o2 f2 z) 640 641mkTInfix (TLocated t' _) op z = 642 mkTInfix t' op z 643 644mkTInfix t (o,f) z = 645 return (TInfix t o f z) 646 647 648-- | Rename a binding. 649instance Rename Bind where 650 rename b = do 651 n' <- rnLocated renameVar (bName b) 652 mbSig <- traverse renameSchema (bSignature b) 653 shadowNames (fst `fmap` mbSig) $ 654 do (patEnv,pats') <- renamePats (bParams b) 655 -- NOTE: renamePats will generate warnings, so we don't need to trigger 656 -- them again here. 657 e' <- shadowNames' CheckNone patEnv (rnLocated rename (bDef b)) 658 return b { bName = n' 659 , bParams = pats' 660 , bDef = e' 661 , bSignature = snd `fmap` mbSig 662 , bPragmas = bPragmas b 663 } 664 665instance Rename BindDef where 666 rename DPrim = return DPrim 667 rename (DExpr e) = DExpr <$> rename e 668 669-- NOTE: this only renames types within the pattern. 670instance Rename Pattern where 671 rename p = case p of 672 PVar lv -> PVar <$> rnLocated renameVar lv 673 PWild -> pure PWild 674 PTuple ps -> PTuple <$> traverse rename ps 675 PRecord nps -> PRecord <$> traverse (traverse rename) nps 676 PList elems -> PList <$> traverse rename elems 677 PTyped p' t -> PTyped <$> rename p' <*> rename t 678 PSplit l r -> PSplit <$> rename l <*> rename r 679 PLocated p' loc -> withLoc loc 680 $ PLocated <$> rename p' <*> pure loc 681 682-- | Note that after this point the @->@ updates have an explicit function 683-- and there are no more nested updates. 684instance Rename UpdField where 685 rename (UpdField h ls e) = 686 -- The plan: 687 -- x = e ~~~> x = e 688 -- x -> e ~~~> x -> \x -> e 689 -- x.y = e ~~~> x -> { _ | y = e } 690 -- x.y -> e ~~~> x -> { _ | y -> e } 691 case ls of 692 l : more -> 693 case more of 694 [] -> case h of 695 UpdSet -> UpdField UpdSet [l] <$> rename e 696 UpdFun -> UpdField UpdFun [l] <$> rename (EFun emptyFunDesc [PVar p] e) 697 where 698 p = UnQual . selName <$> last ls 699 _ -> UpdField UpdFun [l] <$> rename (EUpd Nothing [ UpdField h more e]) 700 [] -> panic "rename@UpdField" [ "Empty label list." ] 701 702 703instance Rename FunDesc where 704 rename (FunDesc nm offset) = 705 do nm' <- traverse renameVar nm 706 pure (FunDesc nm' offset) 707 708instance Rename Expr where 709 rename expr = case expr of 710 EVar n -> EVar <$> renameVar n 711 ELit l -> return (ELit l) 712 ENeg e -> ENeg <$> rename e 713 EComplement e -> EComplement 714 <$> rename e 715 EGenerate e -> EGenerate 716 <$> rename e 717 ETuple es -> ETuple <$> traverse rename es 718 ERecord fs -> ERecord <$> traverse (traverse rename) fs 719 ESel e' s -> ESel <$> rename e' <*> pure s 720 EUpd mb fs -> do checkLabels fs 721 EUpd <$> traverse rename mb <*> traverse rename fs 722 EList es -> EList <$> traverse rename es 723 EFromTo s n e t -> EFromTo <$> rename s 724 <*> traverse rename n 725 <*> rename e 726 <*> traverse rename t 727 EFromToLessThan s e t -> 728 EFromToLessThan <$> rename s 729 <*> rename e 730 <*> traverse rename t 731 EInfFrom a b -> EInfFrom<$> rename a <*> traverse rename b 732 EComp e' bs -> do arms' <- traverse renameArm bs 733 let (envs,bs') = unzip arms' 734 -- NOTE: renameArm will generate shadowing warnings; we only 735 -- need to check for repeated names across multiple arms 736 shadowNames' CheckOverlap envs (EComp <$> rename e' <*> pure bs') 737 EApp f x -> EApp <$> rename f <*> rename x 738 EAppT f ti -> EAppT <$> rename f <*> traverse rename ti 739 EIf b t f -> EIf <$> rename b <*> rename t <*> rename f 740 EWhere e' ds -> do ns <- getNS 741 shadowNames (map (InModule ns) ds) $ 742 EWhere <$> rename e' <*> traverse rename ds 743 ETyped e' ty -> ETyped <$> rename e' <*> rename ty 744 ETypeVal ty -> ETypeVal<$> rename ty 745 EFun desc ps e' -> do desc' <- rename desc 746 (env,ps') <- renamePats ps 747 -- NOTE: renamePats will generate warnings, so we don't 748 -- need to duplicate them here 749 shadowNames' CheckNone env (EFun desc' ps' <$> rename e') 750 ELocated e' r -> withLoc r 751 $ ELocated <$> rename e' <*> pure r 752 753 ESplit e -> ESplit <$> rename e 754 EParens p -> EParens <$> rename p 755 EInfix x y _ z -> do op <- renameOp y 756 x' <- rename x 757 z' <- rename z 758 mkEInfix x' op z' 759 760 761checkLabels :: [UpdField PName] -> RenameM () 762checkLabels = foldM_ check [] . map labs 763 where 764 labs (UpdField _ ls _) = ls 765 766 check done l = 767 do case find (overlap l) done of 768 Just l' -> record (OverlappingRecordUpdate (reLoc l) (reLoc l')) 769 Nothing -> pure () 770 pure (l : done) 771 772 overlap xs ys = 773 case (xs,ys) of 774 ([],_) -> True 775 (_, []) -> True 776 (x : xs', y : ys') -> same x y && overlap xs' ys' 777 778 same x y = 779 case (thing x, thing y) of 780 (TupleSel a _, TupleSel b _) -> a == b 781 (ListSel a _, ListSel b _) -> a == b 782 (RecordSel a _, RecordSel b _) -> a == b 783 _ -> False 784 785 reLoc xs = (head xs) { thing = map thing xs } 786 787 788mkEInfix :: Expr Name -- ^ May contain infix expressions 789 -> (Located Name,Fixity) -- ^ The operator to use 790 -> Expr Name -- ^ Will not contain infix expressions 791 -> RenameM (Expr Name) 792 793mkEInfix e@(EInfix x o1 f1 y) op@(o2,f2) z = 794 case compareFixity f1 f2 of 795 FCLeft -> return (EInfix e o2 f2 z) 796 797 FCRight -> do r <- mkEInfix y op z 798 return (EInfix x o1 f1 r) 799 800 FCError -> do record (FixityError o1 f1 o2 f2) 801 return (EInfix e o2 f2 z) 802 803mkEInfix (ELocated e' _) op z = 804 mkEInfix e' op z 805 806mkEInfix e (o,f) z = 807 return (EInfix e o f z) 808 809 810renameOp :: Located PName -> RenameM (Located Name, Fixity) 811renameOp ln = 812 withLoc ln $ 813 do n <- renameVar (thing ln) 814 fixity <- lookupFixity n 815 return (ln { thing = n }, fixity) 816 817renameTypeOp :: Located PName -> RenameM (Located Name, Fixity) 818renameTypeOp ln = 819 withLoc ln $ 820 do n <- renameType (thing ln) 821 fixity <- lookupFixity n 822 return (ln { thing = n }, fixity) 823 824lookupFixity :: Name -> RenameM Fixity 825lookupFixity n = 826 case nameFixity n of 827 Just fixity -> return fixity 828 Nothing -> return defaultFixity -- FIXME: should we raise an error instead? 829 830instance Rename TypeInst where 831 rename ti = case ti of 832 NamedInst nty -> NamedInst <$> traverse rename nty 833 PosInst ty -> PosInst <$> rename ty 834 835renameArm :: [Match PName] -> RenameM (NamingEnv,[Match Name]) 836 837renameArm (m:ms) = 838 do (me,m') <- renameMatch m 839 -- NOTE: renameMatch will generate warnings, so we don't 840 -- need to duplicate them here 841 shadowNames' CheckNone me $ 842 do (env,rest) <- renameArm ms 843 844 -- NOTE: the inner environment shadows the outer one, for examples 845 -- like this: 846 -- 847 -- [ x | x <- xs, let x = 10 ] 848 return (env `shadowing` me, m':rest) 849 850renameArm [] = 851 return (mempty,[]) 852 853-- | The name environment generated by a single match. 854renameMatch :: Match PName -> RenameM (NamingEnv,Match Name) 855 856renameMatch (Match p e) = 857 do (pe,p') <- renamePat p 858 e' <- rename e 859 return (pe,Match p' e') 860 861renameMatch (MatchLet b) = 862 do ns <- getNS 863 be <- liftSupply (namingEnv' (InModule ns b)) 864 b' <- shadowNames be (rename b) 865 return (be,MatchLet b') 866 867-- | Rename patterns, and collect the new environment that they introduce. 868renamePat :: Pattern PName -> RenameM (NamingEnv, Pattern Name) 869renamePat p = 870 do pe <- patternEnv p 871 p' <- shadowNames pe (rename p) 872 return (pe, p') 873 874 875 876-- | Rename patterns, and collect the new environment that they introduce. 877renamePats :: [Pattern PName] -> RenameM (NamingEnv,[Pattern Name]) 878renamePats = loop 879 where 880 loop ps = case ps of 881 882 p:rest -> do 883 pe <- patternEnv p 884 shadowNames pe $ 885 do p' <- rename p 886 (env',rest') <- loop rest 887 return (pe `mappend` env', p':rest') 888 889 [] -> return (mempty, []) 890 891patternEnv :: Pattern PName -> RenameM NamingEnv 892patternEnv = go 893 where 894 go (PVar Located { .. }) = 895 do n <- liftSupply (mkParameter (getIdent thing) srcRange) 896 return (singletonE thing n) 897 898 go PWild = return mempty 899 go (PTuple ps) = bindVars ps 900 go (PRecord fs) = bindVars (fmap snd (recordElements fs)) 901 go (PList ps) = foldMap go ps 902 go (PTyped p ty) = go p `mappend` typeEnv ty 903 go (PSplit a b) = go a `mappend` go b 904 go (PLocated p loc) = withLoc loc (go p) 905 906 bindVars [] = return mempty 907 bindVars (p:ps) = 908 do env <- go p 909 shadowNames env $ 910 do rest <- bindVars ps 911 return (env `mappend` rest) 912 913 914 typeEnv (TFun a b) = bindTypes [a,b] 915 typeEnv (TSeq a b) = bindTypes [a,b] 916 917 typeEnv TBit = return mempty 918 typeEnv TNum{} = return mempty 919 typeEnv TChar{} = return mempty 920 921 typeEnv (TUser pn ps) = 922 do mb <- typeExists pn 923 case mb of 924 925 -- The type is already bound, don't introduce anything. 926 Just _ -> bindTypes ps 927 928 Nothing 929 930 -- The type isn't bound, and has no parameters, so it names a portion 931 -- of the type of the pattern. 932 | null ps -> 933 do loc <- curLoc 934 n <- liftSupply (mkParameter (getIdent pn) loc) 935 return (singletonT pn n) 936 937 -- This references a type synonym that's not in scope. Record an 938 -- error and continue with a made up name. 939 | otherwise -> 940 do loc <- curLoc 941 record (UnboundType (Located loc pn)) 942 n <- liftSupply (mkParameter (getIdent pn) loc) 943 return (singletonT pn n) 944 945 typeEnv (TRecord fs) = bindTypes (map snd (recordElements fs)) 946 typeEnv (TTyApp fs) = bindTypes (map value fs) 947 typeEnv (TTuple ts) = bindTypes ts 948 typeEnv TWild = return mempty 949 typeEnv (TLocated ty loc) = withLoc loc (typeEnv ty) 950 typeEnv (TParens ty) = typeEnv ty 951 typeEnv (TInfix a _ _ b) = bindTypes [a,b] 952 953 bindTypes [] = return mempty 954 bindTypes (t:ts) = 955 do env' <- typeEnv t 956 shadowNames env' $ 957 do res <- bindTypes ts 958 return (env' `mappend` res) 959 960 961instance Rename Match where 962 rename m = case m of 963 Match p e -> Match <$> rename p <*> rename e 964 MatchLet b -> shadowNamesNS b (MatchLet <$> rename b) 965 966instance Rename TySyn where 967 rename (TySyn n f ps ty) = 968 shadowNames ps $ TySyn <$> rnLocated renameType n 969 <*> pure f 970 <*> traverse rename ps 971 <*> rename ty 972 973instance Rename PropSyn where 974 rename (PropSyn n f ps cs) = 975 shadowNames ps $ PropSyn <$> rnLocated renameType n 976 <*> pure f 977 <*> traverse rename ps 978 <*> traverse rename cs 979