[start adding support for top level action declarations
John Meacham <john@repetae.net>**20061120032903] hunk ./FrontEnd/DeclsDepends.hs 40
+getDeclDeps (HsActionDecl _ _ e) = getExpDeps e
hunk ./FrontEnd/DeclsDepends.hs 54
+getLocalDeclDeps (HsActionDecl _sloc _ e) = getExpDeps e
hunk ./FrontEnd/HsParser.y 283
+      | 'data' 'kind' ctype srcloc '=' constrs deriving
+                      {% checkDataHeader $3 `thenP` \(cs,c,t) ->
+                         returnP hsDataDecl { hsDeclKindDecl = True, hsDeclSrcLoc = $4, hsDeclContext = cs, hsDeclName = c, hsDeclArgs = t, hsDeclDerives = $7, hsDeclCons = reverse $6 } }
hunk ./FrontEnd/HsParser.y 295
+      | infixexp srcloc '<-' exp      {% checkPattern $1 `thenP` \p ->
+                                         returnP (HsActionDecl $2 p $4) }
hunk ./FrontEnd/HsParser.y 303
---      | 'foreign' srcloc 'export' mcconv mstring var '::' ctype
---                      {% parseExport $5 $6 >>= \x ->
---                         return (HsForeignExport $2 (FfiExport x Safe $4) $6 $8) }
---      | 'foreign' srcloc 'import' 'primitive' mstring var '::' ctype
---                      { let i = Import (if null $5 then show $6 else $5) nullRequires
---                        in HsForeignDecl $2 (FfiSpec i Safe Primitive) $6 $8 }
---      | 'foreign' srcloc 'import' mcconv msafety mstring var '::' ctype
---                      {% parseImport $6 $7 >>= \x ->
---                         return (HsForeignDecl $2 (FfiSpec x $5 $4) $7 $9) }
hunk ./FrontEnd/HsPretty.hs 271
+ppHsDecl (HsActionDecl _ p e) = ppHsPat p <+> text "<-" <+> ppHsExp e
hunk ./FrontEnd/HsSyn.hs 133
+    srcLoc HsActionDecl { hsDeclSrcLoc = sl } = sl
hunk ./FrontEnd/HsSyn.hs 147
+    hsDeclKindDecl = False,
hunk ./FrontEnd/HsSyn.hs 167
-	 = HsTypeDecl	 { hsDeclSrcLoc :: SrcLoc, hsDeclName :: HsName, hsDeclTArgs :: [HsType], hsDeclType :: HsType }
-	 | HsDataDecl	 {
-            hsDeclSrcLoc :: SrcLoc,
-            hsDeclContext :: HsContext,
-            hsDeclName :: HsName,
-            hsDeclArgs :: [HsName],
-            hsDeclCons :: [HsConDecl],
-            hsDeclHasKind :: Maybe HsKind,
-            {- deriving -} hsDeclDerives :: [HsName]
-            }
-	 | HsNewTypeDecl {
-            hsDeclSrcLoc :: SrcLoc,
-            hsDeclContext :: HsContext,
-            hsDeclName :: HsName,
-            hsDeclArgs :: [HsName],
-            hsDeclCon :: HsConDecl,
-            {- deriving -} hsDeclDerives :: [HsName]
-            }
-	 | HsInfixDecl   { hsDeclSrcLoc :: SrcLoc, hsDeclAssoc :: HsAssoc, hsDeclInt :: !Int, hsDeclNames :: [HsName]  }
-	 | HsClassDecl	 { hsDeclSrcLoc :: SrcLoc, hsDeclQualType :: HsQualType, hsDeclDecls :: [HsDecl] }
-	 | HsInstDecl    { hsDeclSrcLoc :: SrcLoc, hsDeclQualType :: HsQualType, hsDeclDecls :: [HsDecl] }
-	 | HsDefaultDecl SrcLoc HsType
-	 | HsTypeSig	 SrcLoc [HsName] HsQualType
-	 | HsFunBind     [HsMatch]
-	 | HsPatBind	 SrcLoc HsPat HsRhs {-where-} [HsDecl]
-         | HsForeignDecl { hsDeclSrcLoc   :: SrcLoc,
-                           hsDeclForeign  :: FfiSpec,
-                           hsDeclName     :: HsName,
-                           hsDeclQualType :: HsQualType
-                         }
-         | HsForeignExport SrcLoc FfiExport HsName HsQualType
-         | HsPragmaProps SrcLoc String [HsName]
-	 | HsPragmaRules [HsRule]
-         | HsPragmaSpecialize { hsDeclUniq :: (Module,Int), hsDeclSrcLoc :: SrcLoc, hsDeclBool :: Bool, hsDeclName :: HsName, hsDeclType :: HsType }
-         | HsDeclDeriving { hsDeclSrcLoc :: SrcLoc, hsDeclQualType :: HsQualType }
+    = HsTypeDecl	 { hsDeclSrcLoc :: SrcLoc, hsDeclName :: HsName, hsDeclTArgs :: [HsType], hsDeclType :: HsType }
+    | HsDataDecl	 {
+        hsDeclKindDecl :: Bool,
+        hsDeclSrcLoc :: SrcLoc,
+        hsDeclContext :: HsContext,
+        hsDeclName :: HsName,
+        hsDeclArgs :: [HsName],
+        hsDeclCons :: [HsConDecl],
+        hsDeclHasKind :: Maybe HsKind,
+        {- deriving -} hsDeclDerives :: [HsName]
+        }
+    | HsNewTypeDecl {
+        hsDeclSrcLoc :: SrcLoc,
+        hsDeclContext :: HsContext,
+        hsDeclName :: HsName,
+        hsDeclArgs :: [HsName],
+        hsDeclCon :: HsConDecl,
+        {- deriving -} hsDeclDerives :: [HsName]
+        }
+    | HsInfixDecl   { hsDeclSrcLoc :: SrcLoc, hsDeclAssoc :: HsAssoc, hsDeclInt :: !Int, hsDeclNames :: [HsName]  }
+    | HsClassDecl	 { hsDeclSrcLoc :: SrcLoc, hsDeclQualType :: HsQualType, hsDeclDecls :: [HsDecl] }
+    | HsInstDecl    { hsDeclSrcLoc :: SrcLoc, hsDeclQualType :: HsQualType, hsDeclDecls :: [HsDecl] }
+    | HsDefaultDecl SrcLoc HsType
+    | HsTypeSig	 SrcLoc [HsName] HsQualType
+    | HsFunBind     [HsMatch]
+    | HsPatBind	 SrcLoc HsPat HsRhs {-where-} [HsDecl]
+    | HsActionDecl {
+        hsDeclSrcLoc   :: SrcLoc,
+        hsDeclPat      :: HsPat,
+        hsDeclExp      :: HsExp
+        }
+    | HsSpaceDecl {
+        hsDeclSrcLoc   :: SrcLoc,
+        hsDeclName     :: HsName,
+        hsDeclExp      :: HsExp,
+        hsDeclCName    :: Maybe String,
+        hsDeclCount    :: Int,
+        hsDeclQualType :: HsQualType
+        }
+    | HsForeignDecl {
+        hsDeclSrcLoc   :: SrcLoc,
+        hsDeclForeign  :: FfiSpec,
+        hsDeclName     :: HsName,
+        hsDeclQualType :: HsQualType
+        }
+    | HsForeignExport {
+        hsDeclSrcLoc :: SrcLoc,
+        hsDeclFFIExport :: FfiExport,
+        hsDeclName :: HsName,
+        hsDeclQualType ::HsQualType
+        }
+    | HsPragmaProps SrcLoc String [HsName]
+    | HsPragmaRules [HsRule]
+    | HsPragmaSpecialize { hsDeclUniq :: (Module,Int), hsDeclSrcLoc :: SrcLoc, hsDeclBool :: Bool, hsDeclName :: HsName, hsDeclType :: HsType }
+    | HsDeclDeriving { hsDeclSrcLoc :: SrcLoc, hsDeclQualType :: HsQualType }
hunk ./FrontEnd/ParseUtils.hs 402
-doForeignEq = undefined
+doForeignEq srcLoc names ms qt e = undefined
hunk ./FrontEnd/Rename.hs 388
+renameHsDecl (HsActionDecl srcLoc pat e) subTable = do
+    setSrcLoc srcLoc
+    pat <- renameAny pat subTable
+    e <- renameAny e subTable
+    return (HsActionDecl srcLoc pat e)
hunk ./FrontEnd/Rename.hs 545
+instance RenameAny HsExp where
+    renameAny = renameHsExp
hunk ./FrontEnd/Rename.hs 1126
+    f (HsActionDecl srcLoc p _) = tellF [ (toName Val n,srcLoc,[]) | n <- (getHsNamesFromHsPat p) ]
hunk ./FrontEnd/Syn/Traverse.hs 223
+    f (HsActionDecl sl p e) = withSrcLoc sl $ do
+        e <- fn e
+        return $ HsActionDecl sl p e
hunk ./FrontEnd/Tc/Main.hs 630
-{-
-tcDecl d@(HsForeignDecl _ _ _ n _) typ = do
-    s <- lookupName (toName Val n)
-    s `subsumes` typ
-    return (d,mempty)
--}
-
+tcDecl decl@(HsActionDecl srcLoc pat@(HsPVar v) exp) typ = withContext (declDiagnostic decl) $ do
+    typ <- evalType typ
+    (pat',env) <- tcPat pat typ
+    let tio = TCon (Tycon tc_IO (Kfun kindStar kindStar))
+    e' <- tcExpr exp (TAp tio typ)
+    return (decl { hsDeclPat = pat', hsDeclExp = e' }, Map.singleton (toName Val v) typ)
hunk ./FrontEnd/Tc/Main.hs 704
-restricted bs = fopts FO.MonomorphismRestriction && any isSimpleDecl bs where
+restricted bs = any isHsActionDecl bs || (fopts FO.MonomorphismRestriction && any isSimpleDecl bs) where
hunk ./FrontEnd/Tc/Main.hs 871
+    isBindDecl HsActionDecl {} = True
hunk ./FrontEnd/Tc/Module.hs 182
-    let funPatBinds =  [ d | d <- ds, or' [isHsFunBind, isHsPatBind, isHsForeignDecl] d]
+    let funPatBinds =  [ d | d <- ds, or' [isHsFunBind, isHsPatBind, isHsForeignDecl, isHsActionDecl] d]
hunk ./FrontEnd/TypeSyns.hs 138
-
+renameHsDecl decl@HsActionDecl { hsDeclSrcLoc = srcLoc, hsDeclExp = e }  subTable = withSrcLoc srcLoc $ do
+    e <- renameHsExp e subTable
+    return decl { hsDeclExp = e }
hunk ./FrontEnd/Utils.hs 22
+maybeGetDeclName (HsActionDecl sloc (HsPVar name) _) = return (toName Val name)