[major clean ups to Desugar module, remove almost 200 lines of code inherited from hatchet
John Meacham <john@repetae.net>**20090228045244
 Ignore-this: 4fe7a717d45723b21ca6469c3434d11d
] hunk ./FrontEnd/Desugar.hs 1
-{-------------------------------------------------------------------------------
-
-        Copyright:              The Hatchet Team (see file Contributors)
-
-        Module:                 Desugar
-
-        Description:            Desugaring of the abstract syntax.
-
-                                The main tasks implemented by this module are:
-                                        - pattern bindings are converted
-                                          into "simple" pattern bindings
-                                          (x, y, z) = foo
-                                             becomes
-                                          newVal = foo
-                                          x = (\(a, _, _) -> a) newVal
-                                          y = (\(_, a, _) -> a) newVal
-                                          z = (\(_, _, a) -> a) newVal
-                                        - do notation is converted into
-                                          expression form, using (>>) and
-                                          (>>=)
-                                        - type synonyms are removed
-
-        Primary Authors:        Bernie Pope
-
-        Notes:                  See the file License for license information
-
-                                According to the Haskell report a pattern
-                                binding is called "simple" if it consists only
-                                of a single variable - thus we convert all
-                                pattern bindings to simple bindings.
-
--------------------------------------------------------------------------------}
-
--- Type synonyms are no longer handled here. only 'local' desugaring is done.
--- Does this module need to exist?
+-- various desugaring routines
+--
+-- The general desugaring routine creates selectors for data 
+-- constructors with named fields, changes all pattern bindings
+-- into 'simple' pattern bindings, and adds failure cases to lambda
+-- expressions which have failable patterns
hunk ./FrontEnd/Desugar.hs 17
-import Name.VConsts
hunk ./FrontEnd/Desugar.hs 20
-removeSynonymsFromType _ t = t
-removeSynsFromSig _ t = t
-
--- (unique int, list of type synoyms)
-type PatState = (Int, [HsDecl])
+type PatState = Int
hunk ./FrontEnd/Desugar.hs 23
-    n <- readUnique
-    incUnique
+    n <- get
+    put (n + 1)
hunk ./FrontEnd/Desugar.hs 27
-readUnique :: PatSM Int
-readUnique = do
-        state <- readPatSM
-        return (fst state)
-
-readSyns :: PatSM [HsDecl]
-readSyns = do
-        state <- readPatSM
-        return (snd state)
-
-
-incUnique :: PatSM ()
-incUnique = updatePatSM (\(u, s) -> (u + 1, s))
-
hunk ./FrontEnd/Desugar.hs 34
-{------------------------------------------------------------------------------}
-
-readPatSM = get
-updatePatSM = modify
-runPatSM = flip runState
-
-
hunk ./FrontEnd/Desugar.hs 39
-remSynsSig :: HsDecl -> PatSM HsDecl
-remSynsSig sig
-   = do
-        syns <- readSyns
-        let newSig = removeSynsFromSig syns sig
-        return newSig
-
-remSynsType :: HsType -> PatSM HsType
-remSynsType t
-   = do
-        syns <- readSyns
-        let newType = removeSynonymsFromType syns t
-        return newType
hunk ./FrontEnd/Desugar.hs 60
-    (ds', _) = runPatSM (0::Int, undefined) $ dsm (hsModuleDecls m)
+    (ds', _) = runState (dsm (hsModuleDecls m))   (0::Int)
hunk ./FrontEnd/Desugar.hs 64
-desugarHsStmt s = return $ fst $ runPatSM (0::Int, undefined) $ desugarStmt s
-
---desugarHsExp :: Monad m => HsExp -> m HsExp
---desugarHsExp s = return $ fst $ runPatSM (0::Int, undefined) $ desugarExp s
-
+desugarHsStmt s = return $ fst $ runState (desugarStmt s) (0::Int)
hunk ./FrontEnd/Desugar.hs 67
-desugarDecl (HsForeignDecl a b c qt) = do
-    qt <- remSynsQualType qt
-    return [HsForeignDecl a b c qt]
-desugarDecl (HsForeignExport a b c qt) = do
-    qt <- remSynsQualType qt
-    return [HsForeignExport a b c qt]
hunk ./FrontEnd/Desugar.hs 94
-    newQualType <- remSynsQualType qualtype
hunk ./FrontEnd/Desugar.hs 95
-    return [HsInstDecl sloc newQualType (concat newDecls)]
-
-desugarDecl sig@(HsTypeSig _sloc _names _qualType) = do
-    newSig <- remSynsSig sig
-    return [newSig]
-
+    return [HsInstDecl sloc qualtype (concat newDecls)]
hunk ./FrontEnd/Desugar.hs 98
-        --newConDecls <- mapM remSynsFromCondecl condecls
-        newConDecls <- return condecls
-        ds <- deriveInstances sloc name args newConDecls derives
-        ss <- createSelectors sloc newConDecls
-        return $ dl:(ds ++ ss)
+        ss <- createSelectors sloc condecls
+        return $ dl:ss
hunk ./FrontEnd/Desugar.hs 102
-        --newConDecl <- remSynsFromCondecl condecl
-        newConDecl <- return condecl
-        ds <- deriveInstances sloc name args [newConDecl] derives
-        ss <- createSelectors sloc [newConDecl]
-        return $ dl:(ds ++ ss)
+        ss <- createSelectors sloc [condecl]
+        return $ dl:ss
hunk ./FrontEnd/Desugar.hs 107
-
-
hunk ./FrontEnd/Desugar.hs 118
-
hunk ./FrontEnd/Desugar.hs 121
-deriveInstances :: Monad m => SrcLoc -> HsName -> [HsName] -> [HsConDecl] -> [HsName] -> m [HsDecl]
-deriveInstances sloc name args cons ds = return []
hunk ./FrontEnd/Desugar.hs 124
-desugarMatch (HsMatch sloc funName pats rhs wheres)
-   = do
+desugarMatch (HsMatch sloc funName pats rhs wheres) = do
hunk ./FrontEnd/Desugar.hs 173
-
hunk ./FrontEnd/Desugar.hs 174
-desugarRhs (HsUnGuardedRhs e)
-   = do
-        newE <- desugarExp e
-        return (HsUnGuardedRhs newE)
-
-desugarRhs (HsGuardedRhss gRhss)
-   = do
-        newRhss <- mapM desugarGRhs gRhss
-        return (HsGuardedRhss newRhss)
-
-desugarGRhs :: HsGuardedRhs -> PatSM (HsGuardedRhs)
-desugarGRhs (HsGuardedRhs sloc e1 e2)
-   = do
-        newE1 <- desugarExp e1
-        newE2 <- desugarExp e2
-        return (HsGuardedRhs sloc newE1 newE2)
-
-
+desugarRhs  = traverseHsRhsHsExp desugarExp 
hunk ./FrontEnd/Desugar.hs 213
-desugarExp (HsExpTypeSig sloc e qualType) = do
-        e' <- desugarExp e
-        newQualType <- remSynsQualType qualType
-        return (HsExpTypeSig sloc e' newQualType)
hunk ./FrontEnd/Desugar.hs 215
-
-
hunk ./FrontEnd/Desugar.hs 216
-
hunk ./FrontEnd/Desugar.hs 217
-        newGAlts <- desugarGAlts gAlts
+        newGAlts <- desugarRhs gAlts
hunk ./FrontEnd/Desugar.hs 221
-desugarGAlts :: (HsRhs) -> PatSM (HsRhs)
-
-desugarGAlts (HsUnGuardedRhs e) = do
-        newE <- desugarExp e
-        return (HsUnGuardedRhs newE)
-
-desugarGAlts (HsGuardedRhss gAlts) = do
-        newGAlts <- mapM desugarGuardedAlt gAlts
-        return (HsGuardedRhss newGAlts)
-
-desugarGuardedAlt :: (HsGuardedRhs) -> PatSM (HsGuardedRhs)
-
-desugarGuardedAlt (HsGuardedRhs sloc e1 e2) = do
-        newE1 <- desugarExp e1
-        newE2 <- desugarExp e2
-        return (HsGuardedRhs sloc newE1 newE2)
-
hunk ./FrontEnd/Desugar.hs 225
-
hunk ./FrontEnd/Desugar.hs 228
-
hunk ./FrontEnd/Desugar.hs 233
-remSynsQualType :: HsQualType -> PatSM HsQualType
-remSynsQualType qualtype
-   = case qualtype of
-        HsQualType cntxt t
-           -> do
-                 newT <- remSynsType t
-                 return (HsQualType cntxt newT)
-
---------------------------------------------------------------------------------
-
--- desugar the do-notation
-
--- flatten out do notation into an expression
--- involving ">>" and ">>="
--- TODO -  THIS IS BROKEN
-
-
-
hunk ./FrontEnd/Desugar.hs 263
---    f_bind = nameName $ toUnqualified (func_bind sFuncNames)
---    f_bind_ = nameName $ toUnqualified (func_bind_ sFuncNames)
---    f_fail = nameName $ toUnqualified v_fail
hunk ./FrontEnd/Desugar.hs 266
-patVar = HsVar newPatVarName