packages feed

AsyncRattus 0.1.0.1 → 0.1.0.2

raw patch · 13 files changed

+41/−409 lines, 13 filesdep +ghc-bootdep +textPVP ok

version bump matches the API change (PVP)

Dependencies added: ghc-boot, text

API changes (from Hackage documentation)

Files

AsyncRattus.cabal view
@@ -1,6 +1,6 @@ cabal-version:       1.18 name:                AsyncRattus-version:             0.1.0.1+version:             0.1.0.2 category:            FRP synopsis:            An asynchronous modal FRP language description:@@ -160,6 +160,7 @@   build-depends:       base >=4.16 && <5,                        containers >= 0.6.5 && < 0.8,                        ghc >= 9.2 && < 9.9,+                       ghc-boot >= 9.2 && < 9.9,                        hashtables >= 1.3.1 && < 1.4,                        simple-affine-space >= 0.2.1 && < 0.3,                        transformers >= 0.5.6 && < 0.7@@ -182,6 +183,6 @@   main-is:             WellTyped.hs   hs-source-dirs:      test   default-language:    Haskell2010-  build-depends:       AsyncRattus, base, containers+  build-depends:       AsyncRattus, base, containers, text   ghc-options:         -fplugin=AsyncRattus.Plugin
CHANGELOG.md view
@@ -1,5 +1,9 @@ # 0.1.0.1 +Make Integer and Text stable types++# 0.1.0.1+ Compatibility with GHC 9.8  # 0.1
docs/paper.pdf view

binary file changed (387094 → 395625 bytes)

src/AsyncRattus/Plugin.hs view
@@ -24,13 +24,8 @@ import qualified Data.Set as Set import Data.Set (Set) -#if __GLASGOW_HASKELL__ >= 900 import GHC.Plugins import GHC.Tc.Types-#else-import GhcPlugins-import TcRnTypes-#endif  -- | Use this to enable Asynchronous Rattus' plugin, either by supplying the option -- @-fplugin=AsyncRattus.Plugin@ directly to GHC, or by including the@@ -153,14 +148,7 @@  annotationsOn :: (Data a) => ModGuts -> CoreBndr -> CoreM [a] annotationsOn guts bndr = do-#if __GLASGOW_HASKELL__ >= 900   (_,anns)  <- getAnnotations deserializeWithData guts   return $     lookupWithDefaultUFM anns [] (varName bndr) ++     getModuleAnnotations guts-#else    -  anns <- getAnnotations deserializeWithData guts-  return $-    lookupWithDefaultUFM anns [] (varUnique bndr) ++-    getModuleAnnotations guts-#endif
src/AsyncRattus/Plugin/CheckClockCompatibility.hs view
@@ -8,15 +8,8 @@ module AsyncRattus.Plugin.CheckClockCompatibility   (checkExpr, CheckExpr (..)) where -#if __GLASGOW_HASKELL__ >= 902 import GHC.Types.Tickish-#endif--#if __GLASGOW_HASKELL__ >= 900 import GHC.Plugins-#else-import GhcPlugins-#endif  import AsyncRattus.Plugin.Utils import qualified AsyncRattus.Plugin.PrimExpr as Prim
src/AsyncRattus/Plugin/Dependency.hs view
@@ -11,35 +11,20 @@  module AsyncRattus.Plugin.Dependency (dependency, HasBV (..),printBinds) where -#if __GLASGOW_HASKELL__ >= 900+ import GHC.Plugins import GHC.Data.Bag import GHC.Hs.Type-#else-import GhcPlugins-import Bag-#if __GLASGOW_HASKELL__ >= 810-import GHC.Hs.Types-#else-import HsTypes-#endif-#endif -#if __GLASGOW_HASKELL__ >= 810+ import GHC.Hs.Extension import GHC.Hs.Expr import GHC.Hs.Pat import GHC.Hs.Binds-#else -import HsExtension-import HsExpr-import HsPat-import HsBinds-#endif  #if __GLASGOW_HASKELL__ >= 904 import GHC.Parser.Annotation-#elif __GLASGOW_HASKELL__ >= 902+#else import Language.Haskell.Syntax.Extension import GHC.Parser.Annotation #endif@@ -99,10 +84,7 @@   getBV (PatBind {pat_lhs = pat}) = getBV pat   getBV (VarBind {var_id = v}) = Set.singleton v   getBV PatSynBind{} = Set.empty-#if __GLASGOW_HASKELL__ < 900-  getBV (XHsBindsLR e) = getBV e-  getBV (AbsBinds {abs_exports = es}) = Set.fromList (map abe_poly es)-#elif __GLASGOW_HASKELL__ < 904+#if __GLASGOW_HASKELL__ < 904   getBV (AbsBinds {abs_exports = es}) = Set.fromList (map abe_poly es) #else   getBV (XHsBindsLR (AbsBinds {abs_exports = es})) = Set.fromList (map abe_poly es)@@ -120,19 +102,15 @@ getRecFieldRhs = hsRecFieldArg #endif -#if __GLASGOW_HASKELL__ >= 902 getConBV (PrefixCon _ ps) = getBV ps-#else-getConBV (PrefixCon ps) = getBV ps-#endif getConBV (InfixCon p p') = getBV p `Set.union` getBV p' getConBV (RecCon (HsRecFields {rec_flds = fs})) = foldl run Set.empty fs       where run s (L _ f) = getBV (getRecFieldRhs f) `Set.union` s -#if __GLASGOW_HASKELL__ >= 900 && __GLASGOW_HASKELL__ < 904+#if __GLASGOW_HASKELL__ < 904 instance HasBV CoPat where   getBV CoPat {co_pat_inner = p} = getBV p-#elif __GLASGOW_HASKELL__ >= 904+#else instance HasBV XXPatGhcTc where   getBV CoPat {co_pat_inner = p} = getBV p   getBV (ExpansionPat _ p) = getBV p@@ -175,27 +153,11 @@ #else   getBV (ParPat _ p) = getBV p #endif-#if __GLASGOW_HASKELL__ >= 900   getBV (ConPat {pat_args = con}) = getConBV con-#else-  getBV (ConPatIn (L _ v) con) = Set.insert v (getConBV con)-  getBV (ConPatOut {pat_args = con}) = getConBV con-  getBV (CoPat _ _ p _) = getBV p-#endif-#if __GLASGOW_HASKELL__ >= 808   getBV (SigPat _ p _) = getBV p-#else-  getBV (SigPat _ p)   = getBV p-#endif -#if __GLASGOW_HASKELL__ >= 904--#elif __GLASGOW_HASKELL__ >= 810-instance HasBV NoExtCon where-#else-instance HasBV NoExt where-#endif #if __GLASGOW_HASKELL__ < 904+instance HasBV NoExtCon where   getBV _ = Set.empty #endif @@ -221,44 +183,26 @@  instance HasFV a => HasFV (MatchGroup GhcTc a) where   getFV MG {mg_alts = alts} = getFV alts-#if __GLASGOW_HASKELL__ < 900-  getFV (XMatchGroup e) = getFV e-#endif    instance HasFV a => HasFV (Match GhcTc a) where   getFV Match {m_grhss = rhss} = getFV rhss-#if __GLASGOW_HASKELL__ < 900-  getFV (XMatch e) = getFV e-#endif  instance HasFV (HsTupArg GhcTc) where   getFV (Present _ e) = getFV e   getFV Missing {} = Set.empty-#if __GLASGOW_HASKELL__ < 900-  getFV (XTupArg e) = getFV e-#endif  instance HasFV a => HasFV (GRHS GhcTc a) where   getFV (GRHS _ g b) = getFV g `Set.union` getFV b-#if __GLASGOW_HASKELL__ < 900-  getFV (XGRHS e) = getFV e-#endif  instance HasFV a => HasFV (GRHSs GhcTc a) where   getFV GRHSs {grhssGRHSs = rhs, grhssLocalBinds = lbs} =     getFV rhs `Set.union` getFV lbs-#if __GLASGOW_HASKELL__ < 900-  getFV (XGRHSs e) = getFV e-#endif   instance HasFV (HsLocalBindsLR GhcTc GhcTc) where   getFV (HsValBinds _ bs) = getFV bs   getFV (HsIPBinds _ bs) = getFV bs   getFV EmptyLocalBinds {} = Set.empty-#if __GLASGOW_HASKELL__ < 900-  getFV (XHsLocalBindsLR e) = getFV e-#endif    instance HasFV (HsValBindsLR GhcTc GhcTc) where   getFV (ValBinds _ b _) = getFV b@@ -277,70 +221,38 @@ #else   getFV (XHsBindsLR AbsBinds {abs_binds = bs}) = getFV bs #endif-#if __GLASGOW_HASKELL__ < 900-  getFV (XHsBindsLR e) = getFV e-#endif  instance HasFV (IPBind GhcTc) where   getFV (IPBind _ _ e) = getFV e-#if __GLASGOW_HASKELL__ < 900-  getFV (XIPBind e) = getFV e-#endif  instance HasFV (HsIPBinds GhcTc) where   getFV (IPBinds _ bs) = getFV bs-#if __GLASGOW_HASKELL__ < 900-  getFV (XHsIPBinds e) = getFV e-#endif    instance HasFV (ApplicativeArg GhcTc) where-#if __GLASGOW_HASKELL__ >= 810   getFV ApplicativeArgOne { arg_expr = e }     = getFV e   getFV ApplicativeArgMany {app_stmts = es, final_expr = e} = getFV es `Set.union` getFV e-#else-  getFV (ApplicativeArgOne _ _ e _) = getFV e-  getFV (ApplicativeArgMany _ es e _) = getFV es `Set.union` getFV e-#endif-#if __GLASGOW_HASKELL__ < 900-  getFV (XApplicativeArg e) = getFV e-#endif  instance HasFV (ParStmtBlock GhcTc GhcTc) where   getFV (ParStmtBlock _ es _ _) = getFV es-#if __GLASGOW_HASKELL__ < 900-  getFV (XParStmtBlock e) = getFV e-#endif    instance HasFV a => HasFV (StmtLR GhcTc GhcTc a) where   getFV (LastStmt _ e _ _) = getFV e-#if __GLASGOW_HASKELL__ >= 900   getFV (BindStmt _ _ e) = getFV e-#else-  getFV (BindStmt _ _ e _ _) = getFV e-#endif   getFV (ApplicativeStmt _ args _) = foldMap (getFV . snd) args   getFV (BodyStmt _ e _ _) = getFV e   getFV (LetStmt _ bs) = getFV bs   getFV (ParStmt _ stms e _) = getFV stms `Set.union` getFV e   getFV TransStmt{} = Set.empty -- TODO   getFV RecStmt{} = Set.empty -- TODO-#if __GLASGOW_HASKELL__ < 900-  getFV (XStmtLR e) = getFV e-#endif -#if __GLASGOW_HASKELL__ >= 902+ instance HasFV (HsRecFields GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))) where-#else-instance HasFV (HsRecordBinds GhcTc) where-#endif   getFV HsRecFields{rec_flds = fs} = getFV fs  #if __GLASGOW_HASKELL__ >= 904 instance HasFV (HsFieldBind o (GenLocated SrcSpanAnnA (HsExpr GhcTc))) where-#elif __GLASGOW_HASKELL__ >= 902-instance HasFV (HsRecField' o (GenLocated SrcSpanAnnA (HsExpr GhcTc))) where #else-instance HasFV (HsRecField' o (LHsExpr GhcTc)) where+instance HasFV (HsRecField' o (GenLocated SrcSpanAnnA (HsExpr GhcTc))) where #endif   getFV rf  = getFV (getRecFieldRhs rf) @@ -376,10 +288,8 @@ #endif #if __GLASGOW_HASKELL__ >= 904   getFV (HsCmdLamCase _ _ mg) = getFV mg-#elif __GLASGOW_HASKELL__ >= 900-  getFV (HsCmdLamCase _ mg) = getFV mg #else-  getFV (HsCmdWrap _ _ cmd) = getFV cmd+  getFV (HsCmdLamCase _ mg) = getFV mg #endif   getFV (XCmd e) = getFV e @@ -396,9 +306,6 @@  instance HasFV (HsCmdTop GhcTc) where   getFV (HsCmdTop _ cmd) = getFV cmd-#if __GLASGOW_HASKELL__ < 900-  getFV (XCmdTop e) = getFV e-#endif  instance HasFV (HsExpr GhcTc) where   getFV (HsVar _ v) = getFV v@@ -418,13 +325,9 @@   getFV (HsCase _ e mg) = getFV e  `Set.union` getFV mg   getFV (HsMultiIf _ es) = getFV es   getFV (HsDo _ _ e) = getFV e-#if __GLASGOW_HASKELL__ >= 902   getFV HsProjection {} = Set.empty   getFV HsGetField {gf_expr = e} = getFV e   getFV (ExplicitList _ es) = getFV es-#else-  getFV (ExplicitList _ _ es) = getFV es-#endif   getFV (RecordUpd {rupd_expr = e, rupd_flds = fs}) = getFV e `Set.union` getFV fs   getFV (RecordCon {rcon_flds = fs}) = getFV fs   getFV (ArithSeq _ _ e) = getFV e@@ -460,36 +363,14 @@ #if __GLASGOW_HASKELL__ >= 906   getFV (HsAppType _ e _ _) = getFV e   getFV (ExprWithTySig _ e _) = getFV e  -#elif __GLASGOW_HASKELL__ >= 808+#else   getFV (HsAppType _ e _) = getFV e   getFV (ExprWithTySig _ e _) = getFV e  -#else-  getFV (ExprWithTySig _ e)   = getFV e-  getFV (HsAppType _ e)   = getFV e #endif--#if __GLASGOW_HASKELL__ >= 900   getFV (HsIf _ e1 e2 e3) = getFV e1 `Set.union` getFV e2 `Set.union` getFV e3   getFV (HsPragE _ _ e) = getFV e-#else-  getFV (HsIf _ _ e1 e2 e3) = getFV e1 `Set.union` getFV e2 `Set.union` getFV e3-  getFV (HsSCC _ _ _ e) = getFV e-  getFV (HsCoreAnn _ _ _ e) = getFV e-  getFV (HsTickPragma _ _ _ _ e) = getFV e-  getFV (HsWrap _ _ e) = getFV e-#endif -#if __GLASGOW_HASKELL__ < 810  -  getFV (HsArrApp _ e1 e2 _ _) = getFV e1 `Set.union` getFV e2-  getFV (HsArrForm _ e _ cmd) = getFV e `Set.union` getFV cmd-  getFV EWildPat {} = Set.empty-  getFV (EAsPat _ e1 e2) = getFV e1 `Set.union` getFV e2-  getFV (EViewPat _ e1 e2) = getFV e1 `Set.union` getFV e2-  getFV (ELazyPat _ e) = getFV e-#endif --#if __GLASGOW_HASKELL__ >= 900 instance HasFV XXExprGhcTc where   getFV (WrapExpr e) = getFV e   getFV (ExpansionExpr (HsExpanded _e1 e2)) = getFV e2@@ -502,10 +383,3 @@  instance HasFV (e GhcTc) => HasFV (HsWrap e) where   getFV (HsWrap _ e) = getFV e-#elif __GLASGOW_HASKELL__ >= 810-instance HasFV NoExtCon where-  getFV _ = Set.empty-#else-instance HasFV NoExt where-  getFV _ = Set.empty-#endif
src/AsyncRattus/Plugin/PrimExpr.hs view
@@ -90,7 +90,6 @@ isPrimExpr :: Expr Var -> Maybe PrimInfo isPrimExpr expr = isPrimExpr' expr >>= validatePartialPrimInfo --- App (App (App (App f type) arg) Type2) arg2 isPrimExpr' :: Expr Var -> Maybe PartialPrimInfo isPrimExpr' (App e (Type t)) = case mPPI of   Just pPI@(PartialPrimInfo {typeArgs = tArgs}) -> Just pPI {typeArgs = t : tArgs}
src/AsyncRattus/Plugin/ScopeCheck.hs view
@@ -25,33 +25,15 @@  import Prelude hiding ((<>)) -#if __GLASGOW_HASKELL__ >= 902 import GHC.Parser.Annotation-#endif--#if __GLASGOW_HASKELL__ >= 900 import GHC.Plugins import GHC.Tc.Types import GHC.Data.Bag import GHC.Tc.Types.Evidence-#else-import GhcPlugins-import TcRnTypes-import TcEvidence-import Bag-#endif--#if __GLASGOW_HASKELL__ >= 810 import GHC.Hs.Extension import GHC.Hs.Expr import GHC.Hs.Pat import GHC.Hs.Binds-#else -import HsExtension-import HsExpr-import HsPat-import HsBinds-#endif  import Data.Graph import qualified Data.Set as Set@@ -182,7 +164,7 @@   -#if __GLASGOW_HASKELL__ >= 902+ getLocAnn' :: SrcSpanAnn' b -> SrcSpan getLocAnn' = locA @@ -190,15 +172,7 @@ updateLoc :: SrcSpanAnn' b -> (GetCtxt => a) -> (GetCtxt => a) updateLoc src = modifyCtxt (\c -> c {srcLoc = getLocAnn' src}) -#else-getLocAnn' :: SrcSpan -> SrcSpan-getLocAnn' s = s --updateLoc :: SrcSpan -> (GetCtxt => a) -> (GetCtxt => a)-updateLoc src = modifyCtxt (\c -> c {srcLoc = src})-#endif- -- | Check all definitions in the given module. If Scope errors are -- found, the current execution is halted with 'exitFailure'. checkAll :: TcGblEnv -> TcM ()@@ -240,12 +214,8 @@ instance Scope a => Scope (GenLocated SrcSpan a) where   check (L l x) =  (\c -> c {srcLoc = l}) `modifyCtxt` check x --#if __GLASGOW_HASKELL__ >= 902 instance Scope a => Scope (GenLocated (SrcSpanAnn' b) a) where   check (L l x) =  updateLoc l $ check x-#endif-    instance Scope a => Scope (Bag a) where   check bs = fmap and (mapM check (bagToList bs))@@ -256,38 +226,22 @@  instance Scope (Match GhcTc (GenLocated SrcAnno (HsExpr GhcTc))) where   check Match{m_pats=ps,m_grhss=rhs} = addVars (getBV ps) `modifyCtxt` check rhs-#if __GLASGOW_HASKELL__ < 900-  check XMatch{} = return True-#endif  instance Scope (Match GhcTc (GenLocated SrcAnno (HsCmd GhcTc))) where   check Match{m_pats=ps,m_grhss=rhs} = addVars (getBV ps) `modifyCtxt` check rhs-#if __GLASGOW_HASKELL__ < 900-  check XMatch{} = return True-#endif   instance Scope (MatchGroup GhcTc (GenLocated SrcAnno (HsExpr GhcTc))) where   check MG {mg_alts = alts} = check alts-#if __GLASGOW_HASKELL__ < 900-  check XMatchGroup {} = return True-#endif   instance Scope (MatchGroup GhcTc (GenLocated SrcAnno (HsCmd GhcTc))) where   check MG {mg_alts = alts} = check alts-#if __GLASGOW_HASKELL__ < 900-  check XMatchGroup {} = return True-#endif   instance Scope a => ScopeBind (StmtLR GhcTc GhcTc a) where   checkBind (LastStmt _ b _ _) =  ( , Set.empty) <$> check b-#if __GLASGOW_HASKELL__ >= 900   checkBind (BindStmt _ p b) = do-#else-  checkBind (BindStmt _ p b _ _) = do-#endif     let vs = getBV p     let c' = addVars vs ?ctxt     r <- setCtxt c' (check b)@@ -298,9 +252,6 @@   checkBind TransStmt{} = notSupported "monad comprehensions"   checkBind ApplicativeStmt{} = notSupported "applicative do notation"   checkBind RecStmt{} = notSupported "recursive do notation"-#if __GLASGOW_HASKELL__ < 900-  checkBind XStmtLR {} = return (True,Set.empty)-#endif  instance ScopeBind a => ScopeBind [a] where   checkBind [] = return (True,Set.empty)@@ -312,19 +263,14 @@ instance ScopeBind a => ScopeBind (GenLocated SrcSpan a) where   checkBind (L l x) =  (\c -> c {srcLoc = l}) `modifyCtxt` checkBind x -#if __GLASGOW_HASKELL__ >= 902 instance ScopeBind a => ScopeBind (GenLocated (SrcSpanAnn' b) a) where   checkBind (L l x) =  updateLoc l $ checkBind x-#endif  instance Scope a => Scope (GRHS GhcTc a) where   check (GRHS _ gs b) = do     (r, vs) <- checkBind gs     r' <- addVars vs `modifyCtxt`  (check b)     return (r && r')-#if __GLASGOW_HASKELL__ < 900-  check XGRHS{} = return True-#endif  checkRec :: GetCtxt => LHsBindLR GhcTc GhcTc -> CheckM Bool checkRec b =  liftM2 (&&) (checkPatBind b) (check b)@@ -365,11 +311,7 @@                    }            -#if __GLASGOW_HASKELL__ >= 902 instance ScopeBind (SCC (GenLocated SrcSpanAnnA (HsBindLR  GhcTc GhcTc), Set Var)) where-#else-instance ScopeBind (SCC (LHsBindLR GhcTc GhcTc, Set Var)) where-#endif   checkBind (AcyclicSCC (b,vs)) = (, vs) <$> check b   checkBind (CyclicSCC bs) = checkRecursiveBinds (map fst bs) (foldMap snd bs)   @@ -399,11 +341,7 @@   -- Check nested bindings-#if __GLASGOW_HASKELL__ >= 902 instance ScopeBind (RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))) where-#else-instance ScopeBind (RecFlag, LHsBinds GhcTc) where-#endif   checkBind (NonRecursive, bs)  = checkBind $ bagToList bs   checkBind (Recursive, bs) = checkRecursiveBinds bs' (foldMap getAllBV bs')     where bs' = bagToList bs@@ -413,33 +351,20 @@   checkBind (HsValBinds _ bs) = checkBind bs   checkBind HsIPBinds {} = notSupported "implicit parameters"   checkBind EmptyLocalBinds{} = return (True,Set.empty)-#if __GLASGOW_HASKELL__ < 900-  checkBind XHsLocalBindsLR{} = return (True,Set.empty)-#endif -#if __GLASGOW_HASKELL__ >= 902 type SrcAnno = SrcSpanAnnA-#else-type SrcAnno = SrcSpan-#endif    instance Scope (GRHSs GhcTc (GenLocated SrcAnno (HsExpr GhcTc))) where   check GRHSs{grhssGRHSs = rhs, grhssLocalBinds = lbinds} = do     (l,vs) <- checkBind lbinds     r <- addVars vs `modifyCtxt` (check rhs)     return (r && l)-#if __GLASGOW_HASKELL__ < 900-  check XGRHSs{} = return True-#endif  instance Scope (GRHSs GhcTc (GenLocated SrcAnno (HsCmd GhcTc))) where   check GRHSs{grhssGRHSs = rhs, grhssLocalBinds = lbinds} = do     (l,vs) <- checkBind lbinds     r <- addVars vs `modifyCtxt` (check rhs)     return (r && l)-#if __GLASGOW_HASKELL__ < 900-  check XGRHSs{} = return True-#endif  instance Show Var where   show v = getOccString v@@ -571,13 +496,9 @@   check (NegApp _ e _) = check e   check (ExplicitSum _ _ _ e) = check e   check (HsMultiIf _ e) = check e-#if __GLASGOW_HASKELL__ >= 902   check (ExplicitList _ e) = check e   check HsProjection {} = return True   check HsGetField {gf_expr = e} = check e-#else-  check (ExplicitList _ _ e) = check e-#endif   check RecordUpd { rupd_expr = e, rupd_flds = fs} = (&&) <$> check e <*> check fs   check RecordCon { rcon_flds = f} = check f   check (ArithSeq _ _ e) = check e@@ -594,35 +515,13 @@ #if __GLASGOW_HASKELL__ >= 906   check (HsAppType _ e _ _) = check e   check (ExprWithTySig _ e _) = check e-#elif __GLASGOW_HASKELL__ >= 808+#else   check (HsAppType _ e _) = check e   check (ExprWithTySig _ e _) = check e-#else-  check (HsAppType _ e)  = check e-  check (ExprWithTySig _ e) = check e #endif--#if __GLASGOW_HASKELL__ >= 900   check (HsPragE _ _ e) = check e   check (HsIf _ e1 e2 e3) = and <$> mapM check [e1,e2,e3]-#else-  check (HsSCC _ _ _ e) = check e-  check (HsCoreAnn _ _ _ e) = check e-  check (HsTickPragma _ _ _ _ e) = check e-  check (HsWrap _ _ e) = check e-  check (HsIf _ _ e1 e2 e3) = and <$> mapM check [e1,e2,e3]-#endif-#if __GLASGOW_HASKELL__ < 810-  check HsArrApp{} = impossible-  check HsArrForm{} = impossible-  check EWildPat{} = impossible-  check EAsPat{} = impossible-  check EViewPat{} = impossible-  check ELazyPat{} = impossible -impossible :: GetCtxt => TcM Bool-impossible = printMessageCheck SevError "This syntax should never occur after typechecking"-#endif  instance (Scope a, Scope b) => Scope (Either a b) where   check (Left x) = check x@@ -636,7 +535,6 @@ #endif  -#if __GLASGOW_HASKELL__ >= 900 instance Scope XXExprGhcTc where   check (WrapExpr (HsWrap _ e)) = check e   check (ExpansionExpr (HsExpanded _ e)) = check e@@ -645,19 +543,9 @@   check (HsTick _ e) = check e   check (HsBinTick _ _ e) = check e #endif-#elif __GLASGOW_HASKELL__ >= 810-instance Scope NoExtCon where-  check _ = return True-#else-instance Scope NoExt where-  check _ = return True-#endif  instance Scope (HsCmdTop GhcTc) where   check (HsCmdTop _ e) = check e-#if __GLASGOW_HASKELL__ < 900-  check XCmdTop{} = return True-#endif    instance Scope (HsCmd GhcTc) where   check (HsCmdArrApp _ e1 e2 _ _) = (&&) <$> check e1 <*> check e2@@ -671,9 +559,7 @@   check (HsCmdLet _ _ bs _ e) = do #else   check (HsCmdPar _ e) = check e-#if __GLASGOW_HASKELL__ >= 900   check (HsCmdLamCase _ e) = check e-#endif   check (HsCmdLet _ bs e) = do #endif     (l,vs) <- checkBind bs@@ -682,12 +568,7 @@    check (HsCmdCase _ e1 e2) = (&&) <$> check e1 <*> check e2   check (HsCmdIf _ _ e1 e2 e3) = (&&) <$> ((&&) <$> check e1 <*> check e2) <*> check e3-#if __GLASGOW_HASKELL__ >= 900   check (XCmd (HsWrap _ e)) = check e-#else-  check (HsCmdWrap _ _ e) = check e-  check XCmd{} = return True-#endif   instance Scope (ArithSeqInfo GhcTc) where@@ -712,9 +593,6 @@ instance Scope (HsTupArg GhcTc) where   check (Present _ e) = check e   check Missing{} = return True-#if __GLASGOW_HASKELL__ < 900-  check XTupArg{} = return True-#endif  instance Scope (HsBindLR GhcTc GhcTc) where #if __GLASGOW_HASKELL__ >= 904@@ -726,11 +604,7 @@       where mod c = c { stableTypes= stableTypes c `Set.union`                         Set.fromList (mapMaybe (isStableConstr . varType) ev)}   check FunBind{fun_matches= matches, fun_id = L _ v,-#if __GLASGOW_HASKELL__ >= 900                 fun_ext = wrapper} =-#else-                fun_co_fn = wrapper} =-#endif       mod `modifyCtxt` check matches     where mod c = c { stableTypes= stableTypes c `Set.union`                       Set.fromList (stableConstrFromWrapper' wrapper)  `Set.union`@@ -738,9 +612,6 @@   check PatBind{pat_lhs = lhs, pat_rhs=rhs} = addVars (getBV lhs) `modifyCtxt` check rhs   check VarBind{var_rhs = rhs} = check rhs   check PatSynBind {} = return True -- pattern synonyms are not supported-#if __GLASGOW_HASKELL__ < 900-  check XHsBindsLR {} = return True-#endif   -- | Checks whether the given type is a type constraint of the form@@ -778,11 +649,7 @@ -- of type variables @[a1,...,am]@ for which there is a constraint -- @Stable ai@ among @C1, ... Cn@. extractStableConstr :: Type -> [TyVar]-#if __GLASGOW_HASKELL__ >= 900 extractStableConstr  = mapMaybe isStableConstr . map irrelevantMult . fst . splitFunTys . snd . splitForAllTys'-#else-extractStableConstr  = mapMaybe isStableConstr . fst . splitFunTys . snd . splitForAllTys'-#endif   getSCCLoc :: SCC (LHsBindLR  GhcTc GhcTc, Set Var) -> SrcSpan@@ -914,22 +781,13 @@   isPrimExpr' (HsVar _ (L _ v)) = fmap (,v) (isPrim v) #if __GLASGOW_HASKELL__ >= 906   isPrimExpr' (HsAppType _ e _ _) = isPrimExpr e-#elif __GLASGOW_HASKELL__ >= 808-  isPrimExpr' (HsAppType _ e _) = isPrimExpr e #else-  isPrimExpr' (HsAppType _ e)   = isPrimExpr e+  isPrimExpr' (HsAppType _ e _) = isPrimExpr e #endif -#if __GLASGOW_HASKELL__ < 900-  isPrimExpr' (HsSCC _ _ _ e) = isPrimExpr e-  isPrimExpr' (HsCoreAnn _ _ _ e) = isPrimExpr e-  isPrimExpr' (HsTickPragma _ _ _ _ e) = isPrimExpr e-  isPrimExpr' (HsWrap _ _ e) = isPrimExpr' e-#else   isPrimExpr' (XExpr (WrapExpr (HsWrap _ e))) = isPrimExpr' e   isPrimExpr' (XExpr (ExpansionExpr (HsExpanded _ e))) = isPrimExpr' e   isPrimExpr' (HsPragE _ _ e) = isPrimExpr e-#endif #if __GLASGOW_HASKELL__ < 904   isPrimExpr' (HsTick _ _ e) = isPrimExpr e   isPrimExpr' (HsBinTick _ _ _ e) = isPrimExpr e
src/AsyncRattus/Plugin/StableSolver.hs view
@@ -12,7 +12,6 @@  import Prelude hiding ((<>)) -#if __GLASGOW_HASKELL__ >= 900 import GHC.Plugins   (Type, Var, CommandLineOption,tyConSingleDataCon,    mkCoreConApps,getTyVar_maybe)@@ -20,21 +19,7 @@ import GHC.Tc.Types.Evidence import GHC.Core.Class import GHC.Tc.Types-#else-import GhcPlugins-  (Type, Var, CommandLineOption,tyConSingleDataCon,-   mkCoreConApps,getTyVar_maybe)-import CoreSyn-import TcEvidence-import Class-import TcRnTypes-#endif--#if __GLASGOW_HASKELL__ >= 900 import GHC.Tc.Types.Constraint-#elif __GLASGOW_HASKELL__ >= 810-import Constraint-#endif  import Data.Set (Set) import qualified Data.Set as Set
src/AsyncRattus/Plugin/Strictify.hs view
@@ -5,15 +5,8 @@ import Prelude hiding ((<>)) import AsyncRattus.Plugin.Utils -#if __GLASGOW_HASKELL__ >= 900 import GHC.Plugins-#else-import GhcPlugins-#endif--#if __GLASGOW_HASKELL__ >= 902 import GHC.Types.Tickish-#endif  data SCxt = SCxt {srcSpan :: SrcSpan, checkStrictData :: Bool}
src/AsyncRattus/Plugin/Utils.hs view
@@ -48,20 +48,10 @@ #else import Data.IORef (readIORef) #endif  -#if __GLASGOW_HASKELL__ >= 902- import GHC.Utils.Logger-#endif--#if __GLASGOW_HASKELL__ >= 900 import GHC.Plugins import GHC.Utils.Error import GHC.Utils.Monad-#else-import GhcPlugins-import ErrUtils-import MonadUtils-#endif   import GHC.Types.Name.Cache (NameCache(nsNames), lookupOrigNameCache, OrigNameCache)@@ -101,14 +91,9 @@ repSplitAppTys = splitAppTysNoView #endif  -#if __GLASGOW_HASKELL__ >= 902+ printMessage :: (HasDynFlags m, MonadIO m, HasLogger m) =>                 Severity -> SrcSpan -> SDoc -> m ()-#else-printMessage :: (HasDynFlags m, MonadIO m) =>-                Severity -> SrcSpan -> MsgDoc -> m ()-#endif- printMessage sev loc doc = do #if __GLASGOW_HASKELL__ >= 908   logger <- getLogger@@ -122,27 +107,14 @@   logger <- getLogger   liftIO $ putLogMsg logger (logFlags logger)     (MCDiagnostic sev (if sev == SevError then ErrorWithoutFlag else WarningWithoutFlag)) loc doc-#elif __GLASGOW_HASKELL__ >= 902+#else    dflags <- getDynFlags    logger <- getLogger    liftIO $ putLogMsg logger dflags NoReason sev loc doc-#elif __GLASGOW_HASKELL__ >= 900  -  dflags <- getDynFlags-  liftIO $ putLogMsg dflags NoReason sev loc doc-#else-  dflags <- getDynFlags-  let sty = case sev of-              SevError   -> defaultErrStyle dflags-              SevWarning -> defaultErrStyle dflags-              SevDump    -> defaultDumpStyle dflags-              _          -> defaultUserStyle dflags-  liftIO $ putLogMsg dflags NoReason sev loc sty doc #endif -#if __GLASGOW_HASKELL__ >= 902 instance Ord FastString where    compare = uniqCompareFS-#endif  {- ******************************************************@@ -282,6 +254,8 @@       case getNameModule con of         Nothing -> False         Just (name,mod)+          | mod == "GHC.Num.Integer" && name == "Integer" -> True+          | mod == "Data.Text.Internal" && name == "Text" -> True           -- If it's a Rattus type constructor check if it's a box           | isRattModule mod && name == "Box" -> True             -- If its a built-in type check the set of stable built-in types@@ -293,8 +267,7 @@             case algTyConRhs con of               DataTyCon {data_cons = cons, is_enum = enum}                 | enum -> True-                | and $ concatMap (map isSrcStrict'-                                   . dataConSrcBangs) $ cons ->+                | all hasStrictArgs cons ->                   and  (map check cons)                 | otherwise -> False                 where check con = case dataConInstSig con args of@@ -308,12 +281,8 @@ isStrict :: Type -> Bool isStrict t = isStrictRec 0 Set.empty t -#if __GLASGOW_HASKELL__ >= 902 splitForAllTys' :: Type -> ([TyCoVar], Type) splitForAllTys' = splitForAllTyCoVars-#else-splitForAllTys' = splitForAllTys-#endif  -- | Check whether the given type is stable. This check may use -- 'Stable' constraints from the context.@@ -349,7 +318,7 @@             case algTyConRhs con of               DataTyCon {data_cons = cons, is_enum = enum}                 | enum -> True-                | and $ (map (areSrcStrict args)) $ cons ->+                | all hasStrictArgs cons ->                   and  (map check cons)                 | otherwise -> False                 where check con = case dataConInstSig con args of@@ -363,16 +332,8 @@   -areSrcStrict :: [Type] -> DataCon -> Bool-areSrcStrict args con = and (zipWith check tys (dataConSrcBangs con))-  where (_, _,tys) = dataConInstSig con args-        check _ b = isSrcStrict' b--isSrcStrict' :: HsSrcBang -> Bool-isSrcStrict' (HsSrcBang _ _ SrcStrict) = True-isSrcStrict' (HsSrcBang _ SrcUnpack _) = True-isSrcStrict' _ =  False-+hasStrictArgs :: DataCon -> Bool+hasStrictArgs con = all isBanged (dataConImplBangs con)  userFunction :: Var -> Bool userFunction v@@ -392,48 +353,26 @@     _ -> False  mkSysLocalFromVar :: MonadUnique m => FastString -> Var -> m Id-#if __GLASGOW_HASKELL__ >= 900- mkSysLocalFromVar lit v = mkSysLocalM lit (varMult v) (varType v)-#else-mkSysLocalFromVar lit v = mkSysLocalM lit (varType v)-#endif   mkSysLocalFromExpr :: MonadUnique m => FastString -> CoreExpr -> m Id-#if __GLASGOW_HASKELL__ >= 900 mkSysLocalFromExpr lit e = mkSysLocalM lit oneDataConTy (exprType e)-#else-mkSysLocalFromExpr lit e = mkSysLocalM lit (exprType e)-#endif     fromRealSrcSpan :: RealSrcSpan -> SrcSpan #if __GLASGOW_HASKELL__ >= 904 fromRealSrcSpan span = RealSrcSpan span Strict.Nothing-#elif __GLASGOW_HASKELL__ >= 900-fromRealSrcSpan span = RealSrcSpan span Nothing #else-fromRealSrcSpan span = RealSrcSpan span+fromRealSrcSpan span = RealSrcSpan span Nothing #endif -#if __GLASGOW_HASKELL__ >= 900 instance Ord SrcSpan where   compare (RealSrcSpan s _) (RealSrcSpan t _) = compare s t   compare RealSrcSpan{} _ = LT   compare _ _ = GT-#endif  noLocationInfo :: SrcSpan-#if __GLASGOW_HASKELL__ >= 900 noLocationInfo = UnhelpfulSpan UnhelpfulNoLocationInfo-#else         -noLocationInfo = UnhelpfulSpan "<no location info>"-#endif -#if __GLASGOW_HASKELL__ >= 902 mkAlt c args e = Alt c args e getAlt (Alt c args e) = (c, args, e)-#else-mkAlt c args e = (c, args, e)-getAlt alt = alt-#endif
src/AsyncRattus/Signal.hs view
@@ -162,12 +162,6 @@ const :: a -> Sig a const x = x ::: never --- | Construct a signal by repeatedly applying a function to a given--- start element. That is, @unfold (box f) x@ will produce the signal--- @x ::: f x ::: f (f x) ::: ...@--- unfold :: Stable a => Box (a -> a) -> a -> Sig a--- unfold f x = x ::: delay (unfold f (unbox f x))- -- | Similar to Haskell's 'scanl'. -- -- > scan (box f) x (v1 ::: v2 ::: v3 ::: ... ) == (x `f` v1) ::: ((x `f` v1) `f` v2) ::: ...@@ -178,7 +172,7 @@ scan f acc (a ::: as) = acc' ::: delay (scan f acc' (adv as))   where acc' = unbox f acc a --- Like 'scan', but uses a delayed signal.+-- | Like 'scan', but uses a delayed signal. scanAwait :: (Stable b) => Box (b -> a -> b) -> b -> O (Sig a) -> Sig b scanAwait f acc as = acc ::: delay (scan f acc (adv as)) @@ -348,12 +342,8 @@     map p (scan f acc as) = scanMap f p acc as ;    "zip/map" forall xs ys f.-    map f (zip xs ys) = let f' = unbox f in zipWith (box (\ x y -> f' (x :* y))) xs ys-#-}-+    map f (zip xs ys) = let f' = unbox f in zipWith (box (\ x y -> f' (x :* y))) xs ys; -#if __GLASGOW_HASKELL__ >= 808-{-# RULES   "scan/scan" forall f g b c as.     scan g c (scan f b as) =       let f' = unbox f; g' = unbox g in@@ -365,4 +355,4 @@       scanMap (box (\ (b:*c) a -> let b' = f' (p' b) a in (b':* g' c b'))) (box snd') (b:*c) as ;  #-}-#endif+
test/WellTyped.hs view
@@ -7,6 +7,7 @@ import AsyncRattus import AsyncRattus.Signal import Data.Set as Set+import Data.Text   @@ -121,6 +122,13 @@  advUnderLambda :: O Int -> O (a -> Int) advUnderLambda y = delay (\_ -> adv y)+++stableText :: Text -> Sig Text -> Sig Text+stableText = scan (box append) ++stableInteger :: Integer -> Sig Integer -> Sig Integer+stableInteger = scan (box (+))    dblAdv :: O (O a) -> O (O a)