[add FrontEnd.Syn.Traverse, make Desugar use it.
John Meacham <john@repetae.net>**20060408004000] adddir ./FrontEnd/Syn
hunk ./FrontEnd/Desugar.hs 49
+import FrontEnd.Syn.Traverse
hunk ./FrontEnd/Desugar.hs 51
+import FrontEnd.SrcLoc
hunk ./FrontEnd/Desugar.hs 78
---newtype PatSM a = PatSM (PatState -> (a, PatState))  -- The monadic type
-
hunk ./FrontEnd/Desugar.hs 80
---instance Monad PatSM where
---  -- defines state propagation
---  PatSM c1 >>= fc2         =  PatSM (\s0 -> let (r,s1) = c1 s0
---                                                PatSM c2 = fc2 r in
---                                                c2 s1)
---  return k                  =  PatSM (\s -> (k,s))
---
--- -- extracts the state from the monad
---readPatSM                  :: PatSM PatState
---readPatSM                  =  PatSM (\s -> (s,s))
---
--- -- updates the state of the monad
---updatePatSM                :: (PatState -> PatState) -> PatSM ()  -- alters the state
---updatePatSM f              =  PatSM (\s -> ((), f s))
---
----- run a computation in the PatSM monad
---runPatSM                   :: PatState -> PatSM a -> (a, PatState)
---runPatSM s0 (PatSM c)     =  c s0
+instance MonadSrcLoc PatSM where
+instance MonadSetSrcLoc PatSM where
+    withSrcLoc _ a = a
+
hunk ./FrontEnd/Desugar.hs 141
---desugarTidyModule :: [HsDecl] -> TidyModule -> TidyModule
---desugarTidyModule importSyns tidy
---   = newTidy
---   where
---   (newTidy, _) = runPatSM (0::Int, synonyms) $ desugarTidyModuleM tidy
---   synonyms = tidyTyDecls tidy ++ importSyns
---
---desugarTidyModuleM :: TidyModule -> PatSM TidyModule
---desugarTidyModuleM tidy
---   = do let oldTyDecls    = tidyTyDecls tidy
---            oldDataDecls  = tidyDataDecls tidy
---            oldInFixDecls = tidyInFixDecls tidy
---            oldNewTyDecls = tidyNewTyDecls tidy
---            oldClassDecls = tidyClassDecls tidy
---            oldInstDecls  = tidyInstDecls tidy
---            oldDefs       = tidyDefDecls tidy
---            oldTySigs     = tidyTySigs tidy
---            oldFunBinds   = tidyFunBinds tidy
---            oldPatBinds   = tidyPatBinds tidy
---        newTyDecls    <- mapM desugarDecl oldTyDecls
---        newDataDecls  <- mapM desugarDecl oldDataDecls
---        newInFixDecls <- mapM desugarDecl oldInFixDecls
---        newNewTyDecls <- mapM desugarDecl oldNewTyDecls
---        newClassDecls <- mapM desugarDecl oldClassDecls
---        newInstDecls  <- mapM desugarDecl oldInstDecls
---        newDefs       <- mapM desugarDecl oldDefs
---        newTySigs     <- mapM desugarDecl oldTySigs
---        newFunBinds   <- mapM desugarDecl oldFunBinds
---        newPatBinds   <- mapM desugarDecl oldPatBinds
---        return tidy{tidyTyDecls    = concat newTyDecls, --[],  -- return the empty list of synonyms, we don't need them anymore
---                    tidyDataDecls  = concat newDataDecls,
---                    tidyInFixDecls = concat newInFixDecls,
---                    tidyNewTyDecls = concat newNewTyDecls,
---                    tidyClassDecls = concat newClassDecls,
---                    tidyInstDecls  = concat newInstDecls,
---                    tidyDefDecls   = concat newDefs,
---                    tidyTySigs     = concat newTySigs,
---                    tidyFunBinds   = concat newFunBinds,
---                    tidyPatBinds   = concat newPatBinds}
---
-
-
hunk ./FrontEnd/Desugar.hs 156
--- constructor and tuple pattern bindings must be changed
--- XXX bjpop: what about nested parenthesised patterns that just bind
--- variables?
-
hunk ./FrontEnd/Desugar.hs 216
-{-
-
-remSynsFromCondecl :: HsConDecl -> PatSM HsConDecl
-remSynsFromCondecl (HsConDecl sloc name bangTypes)
-   = do
-        newBangTypes <- mapM remSynsFromBangType bangTypes
-        return (HsConDecl sloc name newBangTypes)
-remSynsFromCondecl rd@(HsRecDecl _ _ _) = return rd
---   = error $ "remSynsFromCondecl (HsRecDecl _ _ _) not implemented"
-
-remSynsFromBangType :: HsBangType -> PatSM HsBangType
-remSynsFromBangType (HsBangedTy t) = do
-    newType <- remSynsType t
-    return (HsBangedTy newType)
-remSynsFromBangType (HsUnBangedTy t) = do
-    newType <- remSynsType t
-    return (HsUnBangedTy newType)
--}
-
hunk ./FrontEnd/Desugar.hs 318
-
-desugarExp e@HsVar {} = return e
-
-desugarExp e@HsCon {} = return e
-
-desugarExp e@HsLit {} = return e
-
-desugarExp (HsInfixApp e1 e2 e3)
-   = do
-        newE1 <- desugarExp e1
-        newE2 <- desugarExp e2
-        newE3 <- desugarExp e3
-        return (HsInfixApp newE1 newE2 newE3)
-
-desugarExp (HsApp e1 e2)
-   = do
-        newE1 <- desugarExp e1
-        newE2 <- desugarExp e2
-        return (HsApp newE1 newE2)
-
-desugarExp (HsNegApp e)
-   = do
-        newE <- desugarExp e
-        return (HsNegApp newE)
-
hunk ./FrontEnd/Desugar.hs 322
-
hunk ./FrontEnd/Desugar.hs 341
-
-
-
-desugarExp (HsLet decls e)
-   = do
+desugarExp (HsLet decls e) = do
hunk ./FrontEnd/Desugar.hs 345
-
-desugarExp (HsIf e1 e2 e3)
-   = do
-        newE1 <- desugarExp e1
-        newE2 <- desugarExp e2
-        newE3 <- desugarExp e3
-        return (HsIf newE1 newE2 newE3)
-
-desugarExp (HsCase e alts)
-   = do
+desugarExp (HsCase e alts) = do
hunk ./FrontEnd/Desugar.hs 349
-
-desugarExp (HsDo stmts)
-   = do
+desugarExp (HsDo stmts) = do
hunk ./FrontEnd/Desugar.hs 352
-
-desugarExp (HsTuple exps)
-   = do
-        newExps <- mapM desugarExp exps
-        return (HsTuple newExps)
-
-desugarExp (HsList exps)
-   = do
-        newExps <- mapM desugarExp exps
-        return (HsList newExps)
-
-desugarExp (HsParen e)
-   = do
-        newE <- desugarExp e
-        return (HsParen newE)
-
-desugarExp (HsLeftSection e1 e2)
-   = do
-        newE1 <- desugarExp e1
-        newE2 <- desugarExp e2
-        return (HsLeftSection newE1 newE2)
-
-desugarExp (HsRightSection e1 e2) = do
-        newE1 <- desugarExp e1
-        newE2 <- desugarExp e2
-        return (HsRightSection newE1 newE2)
-        --let nv = (nameName $ toName Val "rsection@")
-        --return (HsLambda bogusASrcLoc [HsPVar nv ] (HsApp (HsRightSection newE1 newE2) (HsVar nv)))
-
-desugarExp (HsRecConstr n fus) = do
-    fus' <- mapM desugarFU fus
-    return $ HsRecConstr n fus'
---   = error "desugarExp (HsRecConstr _ _): not implemented"
-
-desugarExp (HsRecUpdate e fus) = do
-    fus' <- mapM desugarFU fus
-    e' <- desugarExp e
-    return $ HsRecUpdate e' fus'
---   = error "desugarExp (HsRecUpdate _ _): not implemented"
-
-desugarExp (HsEnumFrom e) = do
-        newE <- desugarExp e
-        return (HsEnumFrom newE)
-
-desugarExp (HsEnumFromTo e1 e2) = do
-        newE1 <- desugarExp e1
-        newE2 <- desugarExp e2
-        return (HsEnumFromTo newE1 newE2)
-
-desugarExp (HsEnumFromThen e1 e2) = do
-        newE1 <- desugarExp e1
-        newE2 <- desugarExp e2
-        return (HsEnumFromThen newE1 newE2)
-
-desugarExp (HsEnumFromThenTo e1 e2 e3) = do
-        newE1 <- desugarExp e1
-        newE2 <- desugarExp e2
-        newE3 <- desugarExp e3
-        return (HsEnumFromThenTo newE1 newE2 newE3)
-
hunk ./FrontEnd/Desugar.hs 356
-
--- e :: t  ---> let {v :: t, v = e} in e
-
-{-
-desugarExp (HsExpTypeSig sloc e qualType)
-   = do
-        newE <- desugarExp e
-        newQualType <- remSynsQualType qualType
-        return (HsExpTypeSig sloc newE newQualType)
--}
-
hunk ./FrontEnd/Desugar.hs 360
+desugarExp e = traverseHsExp desugarExp e
hunk ./FrontEnd/Desugar.hs 363
-desugarExp (HsAsPat name e) = do
-        newE <- desugarExp e
-        return (HsAsPat name e)
-
-desugarExp (HsWildCard x)
-   = return (HsWildCard x)
-
-desugarExp (HsIrrPat e) = do
-        newE <- desugarExp e
-        return (HsIrrPat newE)
-
-desugarFU (HsFieldUpdate n e) = do
-    e' <- desugarExp e
-    return $ HsFieldUpdate n e'
hunk ./FrontEnd/Desugar.hs 366
-desugarAlt (HsAlt sloc pat gAlts wheres)
-   = do
+desugarAlt (HsAlt sloc pat gAlts wheres) = do
hunk ./FrontEnd/Desugar.hs 373
-desugarGAlts (HsUnGuardedRhs e)
-   = do
+desugarGAlts (HsUnGuardedRhs e) = do
hunk ./FrontEnd/Desugar.hs 377
-desugarGAlts (HsGuardedRhss gAlts)
-   = do
+desugarGAlts (HsGuardedRhss gAlts) = do
hunk ./FrontEnd/Desugar.hs 383
-desugarGuardedAlt (HsGuardedRhs sloc e1 e2)
-   = do
+desugarGuardedAlt (HsGuardedRhs sloc e1 e2) = do
hunk ./FrontEnd/Desugar.hs 389
-desugarStmt (HsGenerator srcLoc pat e)
-   = do
+desugarStmt (HsGenerator srcLoc pat e) = do
hunk ./FrontEnd/Desugar.hs 393
-desugarStmt (HsQualifier e)
-   = do
+desugarStmt (HsQualifier e) = do
hunk ./FrontEnd/Desugar.hs 397
-desugarStmt (HsLetStmt decls)
-   = do
+desugarStmt (HsLetStmt decls) = do
addfile ./FrontEnd/Syn/Traverse.hs
hunk ./FrontEnd/Syn/Traverse.hs 1
+module FrontEnd.Syn.Traverse where
+
+import HsSyn
+import Control.Monad.Identity
+import FrontEnd.SrcLoc
+
+
+
+traverseHsExp :: MonadSetSrcLoc m => (HsExp -> m HsExp) -> HsExp -> m HsExp
+traverseHsExp fn e = f e where
+    fns = mapM fn
+    f (HsAsPat n e) = do
+        e' <- fn e
+        return $ HsAsPat n e'
+    f e@HsVar {} = return e
+    f e@HsCon {} = return e
+    f e@HsLit {} = return e
+    f (HsInfixApp hsExp1 hsExp2 hsExp3) = do
+        hsExp1' <- fn hsExp1
+        hsExp2' <- fn hsExp2
+        hsExp3' <- fn hsExp3
+        return (HsInfixApp hsExp1' hsExp2' hsExp3')
+    f (HsApp hsExp1 hsExp2)  = do
+        hsExp1' <- fn hsExp1
+        hsExp2' <- fn hsExp2
+        return (HsApp hsExp1' hsExp2')
+    f (HsNegApp hsExp)  = do
+        hsExp' <- fn hsExp
+        return (HsNegApp hsExp')
+    f (HsLambda srcLoc hsPats hsExp) = withSrcLoc srcLoc $ do
+        hsExp' <- fn hsExp
+        return (HsLambda srcLoc hsPats hsExp')
+    f (HsIf hsExp1 hsExp2 hsExp3)  = do
+        hsExp1' <- fn hsExp1
+        hsExp2' <- fn hsExp2
+        hsExp3' <- fn hsExp3
+        return (HsIf hsExp1' hsExp2' hsExp3')
+    f (HsTuple hsExps)  = do
+        hsExps' <- fns hsExps
+        return (HsTuple hsExps')
+    f (HsList hsExps)  = do
+        hsExps' <- fns hsExps
+        return (HsList hsExps')
+    f (HsParen hsExp)  = do
+        hsExp' <- fn hsExp
+        return (HsParen hsExp')
+    f (HsLeftSection hsExp1 hsExp2)  = do
+        hsExp1' <- fn hsExp1
+        hsExp2' <- fn hsExp2
+        return (HsLeftSection hsExp1' hsExp2')
+    f (HsRightSection hsExp1 hsExp2)  = do
+        hsExp1' <- fn hsExp1
+        hsExp2' <- fn hsExp2
+        return (HsRightSection hsExp1' hsExp2')
+    f (HsEnumFrom hsExp)  = do
+        hsExp' <- fn hsExp
+        return (HsEnumFrom hsExp')
+    f (HsEnumFromTo hsExp1 hsExp2)  = do
+        hsExp1' <- fn hsExp1
+        hsExp2' <- fn hsExp2
+        return (HsEnumFromTo hsExp1' hsExp2')
+    f (HsEnumFromThen hsExp1 hsExp2)  = do
+        hsExp1' <- fn hsExp1
+        hsExp2' <- fn hsExp2
+        return (HsEnumFromThen hsExp1' hsExp2')
+    f (HsEnumFromThenTo hsExp1 hsExp2 hsExp3)  = do
+        hsExp1' <- fn hsExp1
+        hsExp2' <- fn hsExp2
+        hsExp3' <- fn hsExp3
+        return (HsEnumFromThenTo hsExp1' hsExp2' hsExp3')
+    f (HsExpTypeSig srcLoc hsExp hsQualType)  = withSrcLoc srcLoc $ do
+        hsExp' <- fn hsExp
+        return (HsExpTypeSig srcLoc hsExp' hsQualType)
+    f (HsAsPat hsName hsExp)  = do
+        hsExp' <- fn hsExp
+        return (HsAsPat hsName hsExp')
+    f (HsWildCard x) = do return (HsWildCard x)
+    f (HsIrrPat hsExp)  = do
+        hsExp' <- fn hsExp
+        return (HsIrrPat hsExp')
+    f (HsRecConstr n fus) = do
+        fus' <- mapM fFieldUpdate fus
+        return $ HsRecConstr n fus'
+    f (HsRecUpdate e fus) = do
+        fus' <- mapM fFieldUpdate fus
+        e' <- fn e
+        return $ HsRecUpdate e' fus'
+    fFieldUpdate (HsFieldUpdate n e) = do
+        e' <- fn e
+        return $ HsFieldUpdate n e'
+
+    {-
+-- not done
+    f (HsRecUpdate hsExp hsFieldUpdates)  = do
+        hsExp' <- fn hsExp
+        hsFieldUpdates' <- renameHsFieldUpdates hsFieldUpdates
+        return (HsRecUpdate hsExp' hsFieldUpdates')
+    fn (HsRecConstr hsName hsFieldUpdates)  = do
+        hsName' <- renameHsName hsName   -- do I need to change this name?
+        hsFieldUpdates' <- renameHsFieldUpdates hsFieldUpdates
+        return (HsRecConstr hsName' hsFieldUpdates')
+--    fn (HsCase hsExp hsAlts)  = do
+--        hsExp' <- fn hsExp
+--        hsAlts' <- renameHsAlts hsAlts
+--        return (HsCase hsExp' hsAlts')
+--    fn (HsDo hsStmts)  = do
+--        let e = doToExp hsStmts
+--        fn e
+        --(hsStmts',_) <- renameHsStmts hsStmts
+        --return (doToExp hsStmts')
+    fn (HsListComp hsExp hsStmts)  = do
+        (hsStmts',') <- renameHsStmts hsStmts
+        hsExp' <- fn hsExp '
+        return (HsListComp hsExp' hsStmts')
+    fn (HsLet hsDecls hsExp)  = do
+        ' <- updateSubTableWithHsDecls  hsDecls LetFun
+        hsDecls' <- renameHsDecls hsDecls '
+        hsExp' <- fn hsExp '
+        return (HsLet hsDecls' hsExp')
+
+-}