Rattus 0.5 → 0.5.0.1
raw patch · 9 files changed
+192/−34 lines, 9 filesdep ~ghcPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: ghc
API changes (from Hackage documentation)
Files
- CHANGELOG.md +5/−0
- Rattus.cabal +2/−2
- docs/paper.pdf binary
- src/Rattus/Plugin/CheckSingleTick.hs +7/−1
- src/Rattus/Plugin/Dependency.hs +29/−1
- src/Rattus/Plugin/ScopeCheck.hs +95/−17
- src/Rattus/Plugin/SingleTick.hs +3/−3
- src/Rattus/Plugin/Strictify.hs +7/−3
- src/Rattus/Plugin/Utils.hs +44/−7
CHANGELOG.md view
@@ -1,3 +1,8 @@+0.5.0.1+---++Compatibility with GHC 9.2.1+ 0.5 ---
Rattus.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.18 name: Rattus-version: 0.5+version: 0.5.0.1 category: FRP synopsis: A modal FRP language description:@@ -155,7 +155,7 @@ Rattus.Plugin.Utils Rattus.Plugin.Dependency Rattus.Plugin.StableSolver- build-depends: base >=4.12 && <5, containers, ghc >= 8.6 && < 9.1, ghc-prim, simple-affine-space, transformers+ build-depends: base >=4.12 && <5, containers, ghc >= 8.6 && < 9.3, ghc-prim, simple-affine-space, transformers hs-source-dirs: src default-language: Haskell2010 ghc-options: -W
docs/paper.pdf view
binary file changed (736708 → 326270 bytes)
src/Rattus/Plugin/CheckSingleTick.hs view
@@ -8,6 +8,11 @@ module Rattus.Plugin.CheckSingleTick (checkExpr, CheckExpr (..)) where +#if __GLASGOW_HASKELL__ >= 902+import GHC.Types.Tickish+#endif++ #if __GLASGOW_HASKELL__ >= 900 import GHC.Plugins #else@@ -206,7 +211,8 @@ Nothing -> typeError c v (text "can only advance under delay") _ -> liftM2 (<|>) (checkExpr' c e1) (checkExpr' c e2) checkExpr' c (Case e v _ alts) =- liftM2 (<|>) (checkExpr' c e) (liftM (foldl' (<|>) Nothing) (mapM (\ (_,vs,e)-> checkExpr' (addVars vs c') e) alts))+ liftM2 (<|>) (checkExpr' c e) (liftM (foldl' (<|>) Nothing)+ (mapM ((\ (_,vs,e)-> checkExpr' (addVars vs c') e) . getAlt) alts)) where c' = addVars [v] c checkExpr' c (Lam v e) | isTyVar v || (not $ tcIsLiftedTypeKind $ typeKind $ varType v) = do
src/Rattus/Plugin/Dependency.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-} -- | This module is used to perform a dependency analysis of top-level -- function definitions, i.e. to find out which defintions are@@ -36,6 +37,12 @@ import HsBinds #endif +#if __GLASGOW_HASKELL__ >= 902+import Language.Haskell.Syntax.Extension+import GHC.Parser.Annotation+#endif++ import Data.Set (Set) import qualified Data.Set as Set import Data.Graph@@ -98,7 +105,11 @@ +#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 (hsRecFieldArg f) `Set.union` s@@ -277,10 +288,19 @@ 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__ >= 902+instance HasFV (HsRecField' o (GenLocated SrcSpanAnnA (HsExpr GhcTc))) where+#else instance HasFV (HsRecField' o (LHsExpr GhcTc)) where+#endif getFV HsRecField {hsRecFieldArg = arg} = getFV arg instance HasFV (ArithSeqInfo GhcTc) where@@ -341,9 +361,17 @@ getFV (HsMultiIf _ es) = getFV es getFV (HsLet _ bs e) = getFV bs `Set.union` getFV e 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+ getFV (RecordUpd {rupd_expr = e, rupd_flds = fs}) =+ getFV e `Set.union` either getFV getFV fs+#else getFV (ExplicitList _ _ es) = getFV es- getFV (RecordCon {rcon_flds = fs}) = getFV fs getFV (RecordUpd {rupd_expr = e, rupd_flds = fs}) = getFV e `Set.union` getFV fs+#endif+ getFV (RecordCon {rcon_flds = fs}) = getFV fs getFV (ArithSeq _ _ e) = getFV e getFV (HsBracket _ e) = getFV e getFV HsRnBracketOut {} = Set.empty
src/Rattus/Plugin/ScopeCheck.hs view
@@ -23,6 +23,10 @@ import Prelude hiding ((<>)) +#if __GLASGOW_HASKELL__ >= 902+import GHC.Parser.Annotation+#endif+ #if __GLASGOW_HASKELL__ >= 900 import GHC.Plugins import GHC.Tc.Types@@ -175,6 +179,26 @@ let ?ctxt = newc in a ++#if __GLASGOW_HASKELL__ >= 902+getLocAnn' :: SrcSpanAnn' b -> SrcSpan+getLocAnn' = locA+++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 ()@@ -212,30 +236,51 @@ in Rattus `elem` anns || (not (NotRattus `elem` anns) && Rattus `elem` annsMod) + instance Scope a => Scope (GenLocated SrcSpan a) where check (L l x) = (\c -> c {srcLoc = l}) `modifyCtxt` check x -instance Scope (LHsBinds GhcTc) where+#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)) instance Scope a => Scope [a] where check ls = fmap and (mapM check ls) -instance Scope a => Scope (Match GhcTc a) where+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 a => Scope (MatchGroup GhcTc a) where+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@@ -267,6 +312,10 @@ 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@@ -281,7 +330,7 @@ checkRec b = liftM2 (&&) (checkPatBind b) (check b) checkPatBind :: GetCtxt => LHsBindLR GhcTc GhcTc -> TcM Bool-checkPatBind (L l b) = (\c -> c {srcLoc = l}) `modifyCtxt` checkPatBind' b+checkPatBind (L l b) = updateLoc l $ checkPatBind' b checkPatBind' :: GetCtxt => HsBindLR GhcTc GhcTc -> TcM Bool checkPatBind' PatBind{} = do@@ -302,7 +351,7 @@ Just reason | res -> (printMessage' SevWarning (recReason reason <> " can cause time leaks")) >> return (res, vs) _ -> return (res, vs)- where check' b@(L l _) = fc l `modifyCtxt` checkRec b+ where check' b@(L l _) = fc (getLocAnn' l) `modifyCtxt` checkRec b fc l c = let ctxHid = either (const $ current c) (Set.union (current c) . Set.unions) (earlier c) in c {current = Set.empty,@@ -319,8 +368,11 @@ recReason StableArr = "recursive definitions nested under arr" -+#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) @@ -346,7 +398,11 @@ -- 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@@ -359,8 +415,14 @@ #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 a => Scope (GRHSs GhcTc a) where+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)@@ -368,7 +430,16 @@ #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 @@ -460,9 +531,16 @@ 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 RecordUpd { rupd_expr = e, rupd_flds = fs} = (&&) <$> check e <*> either check check fs+ check HsProjection {} = return True+ check HsGetField {gf_expr = e} = check e+#else check (ExplicitList _ _ e) = check e- check RecordCon { rcon_flds = f} = check f check RecordUpd { rupd_expr = e, rupd_flds = fs} = (&&) <$> check e <*> check fs+#endif+ check RecordCon { rcon_flds = f} = check f check (ArithSeq _ _ e) = check e check HsBracket{} = notSupported "MetaHaskell" check HsRnBracketOut{} = notSupported "MetaHaskell"@@ -549,10 +627,10 @@ check (FromTo e1 e2) = (&&) <$> check e1 <*> check e2 check (FromThenTo e1 e2 e3) = (&&) <$> ((&&) <$> check e1 <*> check e2) <*> check e3 -instance Scope (HsRecordBinds GhcTc) where+instance Scope a => Scope (HsRecFields GhcTc a) where check HsRecFields {rec_flds = fs} = check fs -instance Scope (HsRecField' a (LHsExpr GhcTc)) where+instance Scope b => Scope (HsRecField' a b) where check HsRecField{hsRecFieldArg = a} = check a instance Scope (HsTupArg GhcTc) where@@ -611,15 +689,15 @@ -- @Stable ai@ among @C1, ... Cn@. extractStableConstr :: Type -> [TyVar] #if __GLASGOW_HASKELL__ >= 900-extractStableConstr = mapMaybe isStableConstr . map irrelevantMult . fst . splitFunTys . snd . splitForAllTys+extractStableConstr = mapMaybe isStableConstr . map irrelevantMult . fst . splitFunTys . snd . splitForAllTys' #else-extractStableConstr = mapMaybe isStableConstr . fst . splitFunTys . snd . splitForAllTys+extractStableConstr = mapMaybe isStableConstr . fst . splitFunTys . snd . splitForAllTys' #endif getSCCLoc :: SCC (LHsBindLR GhcTc GhcTc, Set Var) -> SrcSpan-getSCCLoc (AcyclicSCC (L l _ ,_)) = l-getSCCLoc (CyclicSCC ((L l _,_ ) : _)) = l+getSCCLoc (AcyclicSCC (L l _ ,_)) = getLocAnn' l+getSCCLoc (CyclicSCC ((L l _,_ ) : _)) = getLocAnn' l getSCCLoc _ = noLocationInfo @@ -667,7 +745,7 @@ checkSCC errm (CyclicSCC bs) = (fmap and (mapM check' bs')) where bs' = map fst bs vs = foldMap snd bs- check' b@(L l _) = setCtxt (emptyCtxt errm (Just (vs,l))) (checkRec b)+ check' b@(L l _) = setCtxt (emptyCtxt errm (Just (vs,getLocAnn' l))) (checkRec b) -- | Stabilizes the given context, i.e. remove all non-stable types -- and any tick. This is performed on checking 'box', 'arr' and
src/Rattus/Plugin/SingleTick.hs view
@@ -32,7 +32,7 @@ return (Let (NonRec b e1') e2') toSingleTick (Case e b ty alts) = do e' <- toSingleTick e- alts' <- mapM (\ (c,bs,f) -> fmap (\ x ->(c,bs,x)) (toSingleTick f)) alts+ alts' <- mapM ((\ (c,bs,f) -> fmap (\ x -> mkAlt c bs x) (toSingleTick f)) . getAlt) alts return (Case e' b ty alts') toSingleTick (Cast e c) = do e' <- toSingleTick e@@ -108,7 +108,7 @@ return (foldLets advs' (Lam x e')) extractAdv (Case e b ty alts) = do e' <- extractAdv e- alts' <- mapM (\ (c,bs,f) -> fmap (\ x ->(c,bs,x)) (extractAdv f)) alts+ alts' <- mapM ((\ (c,bs,f) -> fmap (\ x -> mkAlt c bs x) (extractAdv f)) . getAlt) alts return (Case e' b ty alts') extractAdv (Cast e c) = do e' <- extractAdv e@@ -152,7 +152,7 @@ return (Lam x e') extractAdv' (Case e b ty alts) = do e' <- extractAdv' e- alts' <- mapM (\ (c,bs,f) -> fmap (\ x ->(c,bs,x)) (extractAdv' f)) alts+ alts' <- mapM ((\ (c,bs,f) -> fmap (\ x -> mkAlt c bs x) (extractAdv' f)) . getAlt) alts return (Case e' b ty alts') extractAdv' (Cast e c) = do e' <- extractAdv' e
src/Rattus/Plugin/Strictify.hs view
@@ -11,6 +11,10 @@ import GhcPlugins #endif +#if __GLASGOW_HASKELL__ >= 902+import GHC.Types.Tickish+#endif+ data SCxt = SCxt {srcSpan :: SrcSpan, checkStrictData :: Bool} -- | Transforms all functions into strict functions. If the@@ -21,10 +25,10 @@ strictifyExpr ss (Let (NonRec b e1) e2) = do e1' <- strictifyExpr ss e1 e2' <- strictifyExpr ss e2- return (Case e1' b (exprType e2) [(DEFAULT, [], e2')])+ return (Case e1' b (exprType e2) [mkAlt DEFAULT [] e2' ]) strictifyExpr ss (Case e b t alts) = do e' <- strictifyExpr ss e- alts' <- mapM (\(c,args,e) -> fmap (\e' -> (c,args,e')) (strictifyExpr ss e)) alts+ alts' <- mapM ((\(c,args,e) -> fmap (\e' -> mkAlt c args e' ) (strictifyExpr ss e)) . getAlt) alts return (Case e' b t alts') strictifyExpr ss (Let (Rec es) e) = do es' <- mapM (\ (b,e) -> strictifyExpr ss e >>= \e'-> return (b,e')) es@@ -35,7 +39,7 @@ = do e' <- strictifyExpr ss e b' <- mkSysLocalFromVar (fsLit "strict") b- return (Lam b' (Case (varToCoreExpr b') b (exprType e) [(DEFAULT,[],e')]))+ return (Lam b' (Case (varToCoreExpr b') b (exprType e) [mkAlt DEFAULT [] e' ])) | otherwise = do e' <- strictifyExpr ss e return (Lam b e')
src/Rattus/Plugin/Utils.hs view
@@ -17,8 +17,14 @@ mkSysLocalFromVar, mkSysLocalFromExpr, fromRealSrcSpan,- noLocationInfo)+ noLocationInfo,+ mkAlt,+ getAlt,+ splitForAllTys') where+#if __GLASGOW_HASKELL__ >= 902+import GHC.Utils.Logger+#endif #if __GLASGOW_HASKELL__ >= 900 import GHC.Plugins@@ -44,12 +50,20 @@ isType _ = False -+#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__ >= 900 +#if __GLASGOW_HASKELL__ >= 902 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@@ -61,7 +75,10 @@ liftIO $ putLogMsg dflags NoReason sev loc sty doc #endif -+#if __GLASGOW_HASKELL__ >= 902+instance Ord FastString where+ compare = uniqCompareFS+#endif rattModules :: Set FastString rattModules = Set.fromList ["Rattus.Internal","Rattus.Primitives"@@ -85,7 +102,10 @@ ghcStableTypes :: Set FastString ghcStableTypes = Set.fromList ["Int","Bool","Float","Double","Char", "IO"] +isGhcStableType :: FastString -> Bool+isGhcStableType = (`Set.member` ghcStableTypes) + newtype TypeCmp = TC Type instance Eq TypeCmp where@@ -150,7 +170,7 @@ -- 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- | isGhcModule mod -> name `Set.member` ghcStableTypes+ | isGhcModule mod -> isGhcStableType name {- deal with type synonyms (does not seem to be necessary (??)) | Just (subst,ty,[]) <- expandSynTyCon_maybe con args -> isStableRec c (d+1) pr' (substTy (extendTvSubstList emptySubst subst) ty) -}@@ -173,6 +193,13 @@ 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. @@ -184,7 +211,7 @@ isStrictRec _ pr t | Set.member (TC t) pr = True isStrictRec d pr t = do let pr' = Set.insert (TC t) pr- let (_,t') = splitForAllTys t+ let (_,t') = splitForAllTys' t let (c, tys) = repSplitAppTys t' if isJust (getTyVar_maybe c) then and (map (isStrictRec (d+1) pr') tys) else case splitTyConApp_maybe t' of@@ -196,7 +223,7 @@ -- If it's a Rattus type constructor check if it's a box | isRattModule mod && (name == "Box" || name == "O") -> True -- If its a built-in type check the set of stable built-in types- | isGhcModule mod -> name `Set.member` ghcStableTypes+ | isGhcModule mod -> isGhcStableType name {- deal with type synonyms (does not seem to be necessary (??)) | Just (subst,ty,[]) <- expandSynTyCon_maybe con args -> isStrictRec c (d+1) pr' (substTy (extendTvSubstList emptySubst subst) ty) -}@@ -273,4 +300,14 @@ 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