[attach a location to irrefutable patterns. improve Located datatype, clean up code
John Meacham <john@repetae.net>**20061213043909] hunk ./E/FromHs.hs 41
-import FrontEnd.Desugar(patVarNames)
+import FrontEnd.Syn.Traverse(getNamesFromHsPat)
hunk ./E/FromHs.hs 647
-    f (HsPIrrPat p) = f p >>= \ (p',fe) -> case p' of
+    f (HsPIrrPat (Located ss p)) = f p >>= \ (p',fe) -> case p' of
hunk ./E/FromHs.hs 653
-                fe <- convertMatches [bv] [([p],const (EVar v))] (EError "Irrefutable pattern match failed" (getType v))
+                fe <- convertMatches [bv] [([p],const (EVar v))] (EError (show ss ++ ": Irrefutable pattern match failed") (getType v))
hunk ./E/FromHs.hs 655
-            zs <- mapM f (patVarNames p)
+            zs <- mapM f (getNamesFromHsPat p)
hunk ./FrontEnd/Desugar.hs 37
-module FrontEnd.Desugar (doToExp, desugarHsModule, desugarHsStmt, patVarNames) where
+module FrontEnd.Desugar (doToExp, desugarHsModule, desugarHsStmt) where
hunk ./FrontEnd/Desugar.hs 239
-getPatSelFuns sloc pat = [(varName, HsParen (HsLambda sloc [HsPVar newPatVarName] (kase (replaceVarNamesInPat varName pat)))) | varName <- patVarNames pat] where
+getPatSelFuns sloc pat = [(varName, HsParen (HsLambda sloc [HsPVar newPatVarName] (kase (replaceVarNamesInPat varName pat)))) | varName <- getNamesFromHsPat pat] where
hunk ./FrontEnd/Desugar.hs 245
---getPatSelFuns sloc pat = [(varName, HsParen (HsLambda sloc [replaceVarNamesInPat varName pat] (HsVar newPatVarName))) | varName <- patVarNames pat]
--- returns the names of variables bound in a pattern
--- XXX bjpop: do as patterns work properly?
-patVarNames :: HsPat -> [HsName]
-patVarNames (HsPVar name) = [name]
-patVarNames (HsPLit _) = []
-patVarNames (HsPNeg pat) = patVarNames pat
-patVarNames (HsPInfixApp pat1 conName pat2) = patVarNames pat1 ++ patVarNames pat2
-patVarNames (HsPApp conName pats) = concatMap patVarNames pats
-patVarNames (HsPTuple pats) = concatMap patVarNames pats
-patVarNames (HsPUnboxedTuple pats) = concatMap patVarNames pats
-patVarNames (HsPList pats) = concatMap patVarNames pats
-patVarNames (HsPParen pat) = patVarNames pat
-patVarNames (HsPRec _ _) = error "patVarNames (HsPRec _ _): not implemented "
-patVarNames (HsPAsPat asName pat) = asName : patVarNames pat
-patVarNames HsPWildCard = []
-patVarNames (HsPIrrPat pat) = patVarNames pat
-patVarNames e = error $ "patVarNames: " ++ show e
-
hunk ./FrontEnd/Desugar.hs 249
-
-replaceVarNamesInPat name1 (HsPVar name2)
-   | name1 == name2 = HsPVar $ newPatVarName
-   | otherwise = HsPWildCard
-replaceVarNamesInPat _ p@(HsPLit _) = p
-replaceVarNamesInPat name (HsPNeg pat)
-   = HsPNeg $ replaceVarNamesInPat name pat
-replaceVarNamesInPat name (HsPInfixApp pat1 conName pat2)
-   = HsPInfixApp (replaceVarNamesInPat name pat1) conName (replaceVarNamesInPat name pat2)
-replaceVarNamesInPat name (HsPApp conName pats)
-   = HsPApp conName (map (replaceVarNamesInPat name) pats)
-replaceVarNamesInPat name (HsPTuple pats)
-   = HsPTuple (map (replaceVarNamesInPat name) pats)
-replaceVarNamesInPat name (HsPUnboxedTuple pats)
-   = HsPUnboxedTuple (map (replaceVarNamesInPat name) pats)
-replaceVarNamesInPat name (HsPList pats)
-   = HsPList (map (replaceVarNamesInPat name) pats)
-replaceVarNamesInPat name (HsPParen pat)
-   = HsPParen (replaceVarNamesInPat name pat)
-replaceVarNamesInPat name (HsPRec _ _)
-   = error  "replaceVarNamesInPat name (HsPRec _ _): not implemented"
-replaceVarNamesInPat name (HsPAsPat asName pat)
-   | name == asName = HsPAsPat newPatVarName (replaceVarNamesInPat name pat)
-   | otherwise = replaceVarNamesInPat name pat
-replaceVarNamesInPat name HsPWildCard = HsPWildCard
-replaceVarNamesInPat name (HsPIrrPat pat)
-   = HsPIrrPat $ replaceVarNamesInPat name pat
-replaceVarNamesInPat name p = error $ "replaceVarNamesInPat: " ++ show (name,p)
+replaceVarNamesInPat name p = f name p where
+    f name1 (HsPVar name2)
+       | name1 == name2 = HsPVar $ newPatVarName
+       | otherwise = HsPWildCard
+    f _ p@(HsPLit _) = p
+    f name (HsPNeg pat) = HsPNeg $ f name pat
+    f name (HsPInfixApp pat1 conName pat2) = HsPInfixApp (f name pat1) conName (f name pat2)
+    f name (HsPApp conName pats) = HsPApp conName (map (f name) pats)
+    f name (HsPTuple pats) = HsPTuple (map (f name) pats)
+    f name (HsPUnboxedTuple pats) = HsPUnboxedTuple (map (f name) pats)
+    f name (HsPList pats) = HsPList (map (f name) pats)
+    f name (HsPParen pat) = HsPParen (f name pat)
+    f name (HsPRec _ _) = error  "f name (HsPRec _ _): not implemented"
+    f name (HsPAsPat asName pat)
+       | name == asName = HsPAsPat newPatVarName (f name pat)
+       | otherwise = f name pat
+    f name HsPWildCard = HsPWildCard
+    f name (HsPIrrPat pat) = HsPIrrPat $ fmap (f name) pat
+    f name p = error $ "f: " ++ show (name,p)
hunk ./FrontEnd/HsParser.y 657
-      | '~' aexp1                     { HsIrrPat $2 }
+      | '~' srcloc aexp1 srcloc       { HsIrrPat $ located ($2,$4) $3 }
hunk ./FrontEnd/HsPretty.hs 29
+import FrontEnd.SrcLoc(Located(..))
hunk ./FrontEnd/HsPretty.hs 527
-ppHsExp (HsAsPat name (HsIrrPat exp)) =
+ppHsExp (HsAsPat name (HsIrrPat (Located _ exp))) =
hunk ./FrontEnd/HsPretty.hs 531
-ppHsExp (HsIrrPat exp) = char '~' <> ppHsExp exp
+ppHsExp (HsIrrPat (Located _ exp)) = char '~' <> ppHsExp exp
hunk ./FrontEnd/HsPretty.hs 566
-ppHsPat (HsPAsPat name (HsPIrrPat pat)) =
+ppHsPat (HsPAsPat name (HsPIrrPat (Located _ pat))) =
hunk ./FrontEnd/HsPretty.hs 570
-ppHsPat	(HsPIrrPat pat) = char '~' <> ppHsPat pat
+ppHsPat	(HsPIrrPat (Located _ pat)) = char '~' <> ppHsPat pat
hunk ./FrontEnd/HsSyn.hs 340
+type LHsExp = Located HsExp
+
hunk ./FrontEnd/HsSyn.hs 371
-	| HsIrrPat HsExp		-- ditto
+	| HsIrrPat { hsExpLExp :: LHsExp }
hunk ./FrontEnd/HsSyn.hs 375
+type LHsPat = Located HsPat
+
hunk ./FrontEnd/HsSyn.hs 390
-	| HsPIrrPat HsPat
+	| HsPIrrPat { hsPatLPat :: LHsPat }
hunk ./FrontEnd/Infix.hs 238
-    HsPIrrPat p -> tf $ HsPIrrPat (pp p)
+    HsPIrrPat p -> tf $ HsPIrrPat (fmap pp p)
hunk ./FrontEnd/Infix.hs 308
-    HsIrrPat e1            -> (HsIrrPat (processExp' e1), terminalFixity)
+    HsIrrPat e1            -> (HsIrrPat (fmap processExp' e1), terminalFixity)
hunk ./FrontEnd/ParseUtils.hs 42
+import Data.FunctorM
hunk ./FrontEnd/ParseUtils.hs 121
+
hunk ./FrontEnd/ParseUtils.hs 152
-	HsIrrPat e	   -> do
-			      p <- checkPat e []
+	HsIrrPat e         -> do
+			      p <- fmapM checkPattern e
hunk ./FrontEnd/Rename.hs 353
---renameHsDecl (HsNewTypeDecl srcLoc hsContext hsName hsNames1 hsConDecl hsNames2) subTable = do
---    setSrcLoc srcLoc
---    subTable' <- updateSubTableWithHsNames subTable hsNames1
---    hsContext' <- renameHsContext hsContext subTable'
---    -- don't need to rename the hsName (it is a constructor)
---    hsNames1' <- renameHsNames hsNames1 subTable'
---    hsConDecl' <- renameHsConDecl hsConDecl subTable'
---    -- don't need to rename the hsNames2 as it is just a list of TypeClasses
---    hsNames2' <- mapM (`renameTypeHsName` subTable') hsNames2
---    return (HsNewTypeDecl srcLoc hsContext' hsName hsNames1' hsConDecl' hsNames2')
--- here, we have to create a separate subTable (called the typeSigSubTable) to be passed down
--- because the part that renames the hsQualType in the type signatures needs a subTable with
--- _only_ the class's QualType in it.
--- Yes this is complicated and nasty. It is due mainly to the fact that some (but not all of
--- the type variables in the type sigs of the class's member functions must be renamed and
--- the new variables are used on the fly and not declared in an orderly manner.
hunk ./FrontEnd/Rename.hs 857
--- XXX I'm not 100% sure that this works
-{-
-renameHsFieldUpdate (HsFieldBind hsName) subTable
-  = do
-      hsName' <- renameHsName hsName subTable  -- do i need to rename this name?
-      return (HsFieldBind hsName')
--}
hunk ./FrontEnd/Rename.hs 890
---renameTypeHsName hsName subTable  = case hsIdentString (hsNameIdent hsName) of
---    xs@(x:_) | isUpper x -> do
---        t <- gets typeSubTable
---        renameHsName hsName t
---    _ -> renameHsName hsName subTable
-
hunk ./FrontEnd/Rename.hs 1004
-    let hsNamesAndASrcLocs = zip (getHsNamesFromHsPat hsPat) (repeat srcLoc)
+    let hsNamesAndASrcLocs = zip (getNamesFromHsPat hsPat) (repeat srcLoc)
hunk ./FrontEnd/Rename.hs 1096
-    f (HsPatBind srcLoc p _ _) = tellF [ (toName Val n,srcLoc,[]) | n <- (getHsNamesFromHsPat p) ]
-    f (HsActionDecl srcLoc p _) = tellF [ (toName Val n,srcLoc,[]) | n <- (getHsNamesFromHsPat p) ]
+    f (HsPatBind srcLoc p _ _) = tellF [ (toName Val n,srcLoc,[]) | n <- (getNamesFromHsPat p) ]
+    f (HsActionDecl srcLoc p _) = tellF [ (toName Val n,srcLoc,[]) | n <- (getNamesFromHsPat p) ]
hunk ./FrontEnd/Rename.hs 1125
-{-
-collectDefsHsModule :: HsModule -> [(Bool,HsName,SrcLoc,[HsName])]
-collectDefsHsModule m = map g $ snd $ runWriter (mapM_ f (hsModuleDecls m)) where
-    g (b,n,sl,ns) = (b,mod n, sl, map mod ns)
-    mod = qualifyName (hsModuleName m)
-    f (HsForeignDecl a _ _ n _)  = tell [(False,n,a,[])]
-    f (HsFunBind [])  = return ()
-    f (HsFunBind (HsMatch a n _ _ _:_))  = tell [(False,n,a,[])]
-    f (HsPatBind srcLoc p _ _) = tell [ (False,n,srcLoc,[]) | n <- (getHsNamesFromHsPat p) ]
-    f (HsTypeDecl sl n _ _) = tell [(True,n,sl,[])]
-    f (HsDataDecl sl _ n _ cs _) = tell $ (True,n,sl,fsts cs'):[ (False,n,sl,[]) | (n,sl) <- cs'] where
-        cs' = concatMap namesHsConDecl cs
-    f (HsNewTypeDecl sl _ n _ c _) =  tell $ (True,n,sl,fsts cs'):[ (False,n,sl,[]) | (n,sl) <- cs'] where
-        cs' = namesHsConDecl c
-    f cd@(HsClassDecl sl _ ds) = tell $ (True,z,sl,fsts cs):[ (False,n,a,[]) | (n,a) <- cs]  where
-        Just z = maybeGetDeclName cd
-        cs = fst (mconcatMap namesHsDeclTS ds)
-    f _ = return ()
-
--- | Collect all names which are defined in a given module.
-namesHsModule ::
-    HsModule   -- ^ Module to collect names from.
-    -> ([(HsName, SrcLoc)],[(HsName, SrcLoc)])  -- ^ (value-like names,type-like names)
-namesHsModule m = mconcatMap namesHsDecl (hsModuleDecls m)
--}
hunk ./FrontEnd/Rename.hs 1129
-namesHsDecl (HsPatBind srcLoc p _ _) = (map (rtup srcLoc) (getHsNamesFromHsPat p),[])
+namesHsDecl (HsPatBind srcLoc p _ _) = (map (rtup srcLoc) (getNamesFromHsPat p),[])
hunk ./FrontEnd/Rename.hs 1148
-getHsNamesFromHsPat :: HsPat -> [HsName]
-getHsNamesFromHsPat p = execWriter (getNamesFromPat p)
-getNamesFromPat (HsPVar hsName) = tell [hsName]
-getNamesFromPat (HsPAsPat hsName hsPat) = do
-    tell [hsName]
-    getNamesFromPat hsPat
-getNamesFromPat p = traverseHsPat_ getNamesFromPat p
hunk ./FrontEnd/Rename.hs 1151
-  = zip (getHsNamesFromHsPat hsPat) (repeat srcLoc)
+  = zip (getNamesFromHsPat hsPat) (repeat srcLoc)
hunk ./FrontEnd/SrcLoc.hs 5
+import Control.Monad
+import Data.FunctorM
hunk ./FrontEnd/SrcLoc.hs 49
-data Located x = Located SrcSpan x
-    deriving(Ord,Show,Data,Typeable,Eq)
+instance HasLocation (SrcLoc,SrcLoc) where
+    srcSpan (x,y) = SrcSpan x y
hunk ./FrontEnd/SrcLoc.hs 55
+data Located x = Located SrcSpan x
+    deriving(Ord,Show,Data,Typeable,Eq)
+
+fromLocated :: Located x -> x
+fromLocated (Located _ x) = x
+
+instance Functor Located where
+    fmap f (Located l x) = Located l (f x)
+instance FunctorM Located where
+    fmapM f (Located l x) = Located l `liftM` f x
+
+
+located ss x = Located (srcSpan ss) x
+
hunk ./FrontEnd/Syn/Traverse.hs 99
-        hsExp' <- fn hsExp
+        hsExp' <- fnl hsExp
hunk ./FrontEnd/Syn/Traverse.hs 111
+    fnl (Located l e) = Located l `liftM` fn e
hunk ./FrontEnd/Syn/Traverse.hs 202
-          hsPat' <- fn hsPat
+          hsPat' <- fnl hsPat
hunk ./FrontEnd/Syn/Traverse.hs 211
+    fnl (Located l e) = Located l `liftM` fn e
hunk ./FrontEnd/Syn/Traverse.hs 244
+getNamesFromHsPat :: HsPat -> [HsName]
+getNamesFromHsPat p = execWriter (getNamesFromPat p) where
+    getNamesFromPat (HsPVar hsName) = tell [hsName]
+    getNamesFromPat (HsPAsPat hsName hsPat) = do
+        tell [hsName]
+        getNamesFromPat hsPat
+    getNamesFromPat p = traverseHsPat_ getNamesFromPat p
hunk ./FrontEnd/Tc/Main.hs 430
-tiPat (HsPIrrPat p) typ = do
+tiPat (HsPIrrPat (Located l p)) typ = do
hunk ./FrontEnd/Tc/Main.hs 432
-    return (HsPIrrPat p,ns)
+    return (HsPIrrPat (Located l p),ns)
hunk ./FrontEnd/TypeSyns.hs 259
-    subTable' <- updateSubTableWithHsPats subTable hsPats srcLoc FunPat
+    subTable' <- updateSubTableWithHsPats subTable hsPats srcLoc
hunk ./FrontEnd/TypeSyns.hs 261
-    subTable'' <- updateSubTableWithHsDecls subTable' hsDecls WhereFun
+    subTable'' <- updateSubTableWithHsDecls subTable' hsDecls
hunk ./FrontEnd/TypeSyns.hs 288
-    subTable' <- updateSubTableWithHsPats subTable hsPats srcLoc LamPat
+    subTable' <- updateSubTableWithHsPats subTable hsPats srcLoc
hunk ./FrontEnd/TypeSyns.hs 293
-    subTable' <- updateSubTableWithHsDecls subTable hsDecls LetFun
+    subTable' <- updateSubTableWithHsDecls subTable hsDecls
hunk ./FrontEnd/TypeSyns.hs 330
-    subTable' <- updateSubTableWithHsPats subTable [hsPat] srcLoc CasePat
+    subTable' <- updateSubTableWithHsPats subTable [hsPat] srcLoc
hunk ./FrontEnd/TypeSyns.hs 332
-    subTable'' <- updateSubTableWithHsDecls subTable' hsDecls WhereFun
+    subTable'' <- updateSubTableWithHsDecls subTable' hsDecls
hunk ./FrontEnd/TypeSyns.hs 425
-clobberHsNamesAndUpdateIdentTable :: [(HsName,SrcLoc)] -> SubTable -> Binding -> ScopeSM (SubTable)
-clobberHsNamesAndUpdateIdentTable ((hsName,srcLoc):hsNamesAndASrcLocs) subTable binding = do
+clobberHsNamesAndUpdateIdentTable :: [(HsName,SrcLoc)] -> SubTable ->  ScopeSM (SubTable)
+clobberHsNamesAndUpdateIdentTable ((hsName,srcLoc):hsNamesAndASrcLocs) subTable  = do
hunk ./FrontEnd/TypeSyns.hs 428
-      subTable'' <- clobberHsNamesAndUpdateIdentTable hsNamesAndASrcLocs subTable' binding
+      subTable'' <- clobberHsNamesAndUpdateIdentTable hsNamesAndASrcLocs subTable'
hunk ./FrontEnd/TypeSyns.hs 430
-clobberHsNamesAndUpdateIdentTable [] subTable _binding = return (subTable)
+clobberHsNamesAndUpdateIdentTable [] subTable  = return (subTable)
hunk ./FrontEnd/TypeSyns.hs 465
-updateSubTableWithHsDecls :: SubTable -> [HsDecl] -> Binding -> ScopeSM (SubTable)
-updateSubTableWithHsDecls subTable [] _binding = return subTable
-updateSubTableWithHsDecls subTable (hsDecl:hsDecls) binding = do
+updateSubTableWithHsDecls :: SubTable -> [HsDecl] ->  ScopeSM (SubTable)
+updateSubTableWithHsDecls subTable []  = return subTable
+updateSubTableWithHsDecls subTable (hsDecl:hsDecls) = do
hunk ./FrontEnd/TypeSyns.hs 469
-    subTable'  <- clobberHsNamesAndUpdateIdentTable hsNamesAndASrcLocs subTable binding
-    subTable'' <- updateSubTableWithHsDecls subTable' hsDecls binding
+    subTable'  <- clobberHsNamesAndUpdateIdentTable hsNamesAndASrcLocs subTable
+    subTable'' <- updateSubTableWithHsDecls subTable' hsDecls
hunk ./FrontEnd/TypeSyns.hs 473
-updateSubTableWithHsPats :: SubTable -> [HsPat] -> SrcLoc -> Binding -> ScopeSM (SubTable)
-updateSubTableWithHsPats subTable (hsPat:hsPats) srcLoc binding = do
-    let hsNamesAndASrcLocs = zip (getHsNamesFromHsPat hsPat) (repeat srcLoc)
-    subTable'  <- clobberHsNamesAndUpdateIdentTable hsNamesAndASrcLocs subTable binding
-    subTable'' <- updateSubTableWithHsPats subTable' hsPats srcLoc binding
+updateSubTableWithHsPats :: SubTable -> [HsPat] -> SrcLoc -> ScopeSM (SubTable)
+updateSubTableWithHsPats subTable (hsPat:hsPats) srcLoc  = do
+    let hsNamesAndASrcLocs = zip (getNamesFromHsPat hsPat) (repeat srcLoc)
+    subTable'  <- clobberHsNamesAndUpdateIdentTable hsNamesAndASrcLocs subTable
+    subTable'' <- updateSubTableWithHsPats subTable' hsPats srcLoc
hunk ./FrontEnd/TypeSyns.hs 479
-updateSubTableWithHsPats subTable [] _srcLoc _binding = do return (subTable)
+updateSubTableWithHsPats subTable [] _srcLoc = do return (subTable)
hunk ./FrontEnd/TypeSyns.hs 487
-    subTable' <- clobberHsNamesAndUpdateIdentTable hsNamesAndASrcLocs subTable GenPat
+    subTable' <- clobberHsNamesAndUpdateIdentTable hsNamesAndASrcLocs subTable
hunk ./FrontEnd/TypeSyns.hs 527
-
-getHsNamesFromHsPat :: HsPat -> [HsName]
-getHsNamesFromHsPat (HsPVar hsName) = [hsName]
-getHsNamesFromHsPat (HsPLit _hsName) = []
-getHsNamesFromHsPat (HsPNeg hsPat) = getHsNamesFromHsPat hsPat
--- _hsName can be ignored as it is a Constructor (e.g. in (x:xs) we only want to know what's in scope; that is x and xs)
-getHsNamesFromHsPat (HsPInfixApp hsPat1 _hsName hsPat2) = getHsNamesFromHsPat hsPat1 ++ getHsNamesFromHsPat hsPat2
-getHsNamesFromHsPat (HsPApp _hsName hsPats) = concat (map getHsNamesFromHsPat hsPats)
-getHsNamesFromHsPat (HsPTuple hsPats) = concat (map getHsNamesFromHsPat hsPats)
-getHsNamesFromHsPat (HsPUnboxedTuple hsPats) = concat (map getHsNamesFromHsPat hsPats)
-getHsNamesFromHsPat (HsPList hsPats) = concat (map getHsNamesFromHsPat hsPats)
-getHsNamesFromHsPat (HsPParen hsPat) = getHsNamesFromHsPat hsPat
-getHsNamesFromHsPat (HsPRec _hsName hsPatFields) = concat $ map getHsNamesFromHsPatField hsPatFields -- hsName can be ignored as it is a Constructor
-getHsNamesFromHsPat (HsPAsPat hsName hsPat) = hsName:(getHsNamesFromHsPat hsPat)
-getHsNamesFromHsPat (HsPWildCard) = []
-getHsNamesFromHsPat (HsPIrrPat hsPat) = getHsNamesFromHsPat hsPat
-
--- the hsName can be ignored as it is the field name and must already be in scope
-getHsNamesFromHsPatField :: HsPatField -> [HsName]
-{-
-getHsNamesFromHsPatField (HsPFieldPun _hsName)
-  = []
-  -}
-getHsNamesFromHsPatField (HsPFieldPat _hsName hsPat) = getHsNamesFromHsPat hsPat
-
hunk ./FrontEnd/TypeSyns.hs 528
-getHsNamesAndASrcLocsFromHsStmt (HsGenerator srcLoc hsPat _hsExp) = zip (getHsNamesFromHsPat hsPat) (repeat srcLoc)
+getHsNamesAndASrcLocsFromHsStmt (HsGenerator srcLoc hsPat _hsExp) = zip (getNamesFromHsPat hsPat) (repeat srcLoc)
hunk ./FrontEnd/TypeSyns.hs 551
-data Binding
-   = WhereFun           -- function binding in a where clause
-   | LetFun             -- function binding in a let expression (used to include topbinds too)
-   | LamPat             -- pattern binding in a lambda expression
-   | CasePat            -- pattern binding in a case expression
-   | GenPat             -- pattern binding in a generator statement
-   | FunPat             -- pattern binding in a function declaration