packages feed

Rattus 0.5.0.1 → 0.5.1

raw patch · 12 files changed

+355/−98 lines, 12 filesdep ~ghcPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: ghc

API changes (from Hackage documentation)

+ Rattus: AllowRecursion :: Rattus
+ Rattus.Event: combine :: Box (a -> a -> a) -> Str a -> Event (Str a) -> Str a
+ Rattus.Event: dswitchTrans :: (Str a -> Str b) -> O (Event (Str a -> Str b)) -> Str a -> Str b
+ Rattus.Plugin: AllowRecursion :: Rattus
+ Rattus.Plugin.Annotation: AllowRecursion :: Rattus
+ Rattus.Plugin.Annotation: instance GHC.Classes.Ord Rattus.Plugin.Annotation.Rattus
+ Rattus.Strict: init' :: List a -> List a
+ Rattus.Strict: listDelay :: List (O a) -> O (List a)
- Rattus.Yampa: (>>>) :: forall k cat (a :: k) (b :: k) (c :: k). Category cat => cat a b -> cat b c -> cat a c
+ Rattus.Yampa: (>>>) :: forall {k} cat (a :: k) (b :: k) (c :: k). Category cat => cat a b -> cat b c -> cat a c
- Rattus.Yampa: integral :: (Stable a, VectorSpace a s) => a -> SF a a
+ Rattus.Yampa: integral :: (Stable a, VectorSpace a s, Fractional s) => a -> SF a a

Files

Rattus.cabal view
@@ -1,6 +1,6 @@ cabal-version:       1.18 name:                Rattus-version:             0.5.0.1+version:             0.5.1 category:            FRP synopsis:            A modal FRP language description:@@ -131,7 +131,7 @@ custom-setup   setup-depends:     base  >= 4.5 && < 5,-    Cabal >= 1.18+    Cabal >= 1.18  && < 4   library@@ -155,7 +155,7 @@                        Rattus.Plugin.Utils                        Rattus.Plugin.Dependency                        Rattus.Plugin.StableSolver-  build-depends:       base >=4.12 && <5, containers, ghc >= 8.6 && < 9.3, ghc-prim, simple-affine-space, transformers+  build-depends:       base >=4.12 && <5, containers, ghc >= 8.6 && < 9.7, ghc-prim, simple-affine-space, transformers   hs-source-dirs:      src   default-language:    Haskell2010   ghc-options:         -W
docs/paper.pdf view

binary file changed (326270 → 1411474 bytes)

src/Rattus/Event.hs view
@@ -9,6 +9,8 @@   , never   , switch   , switchTrans+  , dswitchTrans+  , combine   , Event   , trigger   , triggerMap@@ -20,7 +22,7 @@ import Rattus.Stream hiding (map) import qualified Rattus.Stream as Str -import Prelude hiding (map)+import Prelude hiding (map,zipWith)  -- | Events are simply streams of 'Maybe''s. type Event a = Str (Maybe' a)@@ -45,6 +47,16 @@ switch  _xs       (Just' (a ::: as) ::: fas)   = a ::: (delay switch <#> as <#> fas)  +-- | @combine f s e@ is similar to @switch s e@, but instead of+-- switching to new streams @s'@ every time the event 'e' occurs with+-- some value @s'@, the new stream @s'@ is combined with the current+-- stream @s@ using @zipWith f s' s@.+combine :: Box (a -> a -> a) -> Str a -> Event (Str a) -> Str a+combine f (x ::: xs) (Nothing' ::: fas) = x  ::: delay (combine f (adv xs) (adv fas))+combine f xs         (Just' as ::: fas) = x' ::: delay (combine f (adv xs') (adv fas))+  where (x' ::: xs') = zipWith f xs as++ -- | Like 'switch' but works on stream functions instead of -- streams. That is, @switchTrans s e@ will behave like @s@ but -- switches to @s'$ every time the event 'e' occurs with some value@@ -57,6 +69,17 @@ switchTrans' (b ::: bs) (Nothing' ::: fs) (_:::as) = b ::: (delay switchTrans' <#> bs <#> fs <#> as) switchTrans' _xs        (Just' f ::: fs)  as@(_:::as') = b' ::: (delay switchTrans' <#> bs' <#> fs <#> as')   where (b' ::: bs') = f as++++-- | Like 'switchTrans' but takes a delayed event as input, which+-- allows the switch to incorporate feedback from itself.+dswitchTrans :: (Str a -> Str b) -> O (Event (Str a -> Str b)) -> (Str a -> Str b)+dswitchTrans f es as = dswitchTrans' (f as) es as++-- | Helper function for 'dswitchTrans'.+dswitchTrans' :: Str b -> O (Event (Str a -> Str b)) -> Str a -> Str b+dswitchTrans' (b ::: bs) de (_:::as) = b ::: (delay switchTrans' <#> bs <#> de <#> as)   -- | Trigger an event as every time the given predicate turns true on
src/Rattus/Plugin.hs view
@@ -73,9 +73,11 @@     es' <- mapM (\ (v,e) -> do                     e' <- toSingleTick e                     lazy <- allowLazyData guts v+                    allowRec <- allowRecursion guts v                     e'' <- strictifyExpr (SCxt (nameSrcSpan $ getName v) (not lazy))e'                     checkExpr CheckExpr{ recursiveSet = Set.fromList vs, oldExpr = e,-                                         fatalError = False, verbose = debugMode opts} e''+                                         fatalError = False, verbose = debugMode opts,+                                         allowRecExp = allowRec} e''                     return e'') bs     return (Rec (zip vs es'))   else return b@@ -88,9 +90,11 @@       -- liftIO $ putStrLn "-------- new --------"       -- liftIO $ putStrLn (showSDocUnsafe (ppr e'))       lazy <- allowLazyData guts v+      allowRec <- allowRecursion guts v       e'' <- strictifyExpr (SCxt (nameSrcSpan $ getName v) (not lazy)) e'       checkExpr CheckExpr{ recursiveSet = Set.empty, oldExpr = e,-                           fatalError = False, verbose = debugMode opts} e''+                           fatalError = False, verbose = debugMode opts,+                           allowRecExp = allowRec } e''       return (NonRec v e'')     else return b @@ -108,6 +112,11 @@ allowLazyData guts bndr = do   l <- annotationsOn guts bndr :: CoreM [Rattus]   return (AllowLazyData `elem` l)++allowRecursion :: ModGuts -> CoreBndr -> CoreM Bool+allowRecursion guts bndr = do+  l <- annotationsOn guts bndr :: CoreM [Rattus]+  return (AllowRecursion `elem` l)   shouldTransform :: ModGuts -> CoreBndr -> CoreM Bool
src/Rattus/Plugin/Annotation.hs view
@@ -26,8 +26,14 @@ -- > {-# ANN myFunction AllowLazyData #-} -- > -- > {-# ANN module AllowLazyData #-}+--+-- Rattus only allows guarded recursion, i.e. recursive calls must+-- occur in the scope of a tick. Structural recursion over strict data+-- types is safe as well, but is currently not checked. To disable the+-- guarded recursion check, annotate the module or function with+-- 'AllowRecursion'. -data Rattus = Rattus | NotRattus | AllowLazyData deriving (Typeable, Data, Show, Eq)+data Rattus = Rattus | NotRattus | AllowLazyData | AllowRecursion deriving (Typeable, Data, Show, Ord, Eq)   -- | This annotation type is for internal use only.
src/Rattus/Plugin/CheckSingleTick.hs view
@@ -54,7 +54,8 @@     primAlias :: Map Var Prim,     -- number of ticks (for recursive calls). This is to allow     -- recursive definitions of the form @f = delay (delay (adv f))@.-    ticks :: Int} +    ticks :: Int,+    allowRecursion :: Bool}   primMap :: Map FastString Prim primMap = Map.fromList@@ -89,14 +90,17 @@ getScope  :: Ctx -> Var -> Scope getScope c v =     if v `Set.member` recDef c then-      if ticks c > 0 then Visible+      if ticks c > 0 || allowRecursion c then Visible       else Hidden ("(Mutually) recursive call to " <> ppr v <> " must occur under delay")     else case Map.lookup v (hidden c) of       Just reason ->         if (isStable (stableTypes c) (varType v)) then Visible         else case reason of-          NestedRec rv -> Hidden ("Variable " <> ppr v <> " is no longer in scope:" $$ "It appears in a local recursive definition (namely of " <> ppr rv <> ")"-                       $$ "and is of type " <> ppr (varType v) <> ", which is not stable.")+          NestedRec rv ->+            if allowRecursion c then Visible+            else Hidden ("Variable " <> ppr v <> " is no longer in scope:"+                         $$ "It appears in a local recursive definition (namely of " <> ppr rv <> ")"+                         $$ "and is of type " <> ppr (varType v) <> ", which is not stable.")           BoxApp -> Hidden ("Variable " <> ppr v <> " is no longer in scope:" $$                        "It occurs under " <> keyword "box" $$ "and is of type " <> ppr (varType v) <> ", which is not stable.")           AdvApp -> Hidden ("Variable " <> ppr v <> " is no longer in scope: It occurs under adv.")@@ -123,16 +127,17 @@   return (Just (TypeError (pickFirst (srcLoc cxt) (nameSrcSpan (varName var))) doc))  -emptyCtx :: Set Var -> Ctx-emptyCtx vars =+emptyCtx :: CheckExpr -> Ctx+emptyCtx c =   Ctx { current =  Set.empty,         earlier = Nothing,         hidden = Map.empty,         srcLoc = noLocationInfo,-        recDef = vars,+        recDef = recursiveSet c,         primAlias = Map.empty,         stableTypes = Set.empty,-        ticks = 0}+        ticks = 0,+        allowRecursion = allowRecExp c}   isPrimExpr :: Ctx -> Expr Var -> Maybe (Prim,Var)@@ -169,12 +174,13 @@   recursiveSet :: Set Var,   oldExpr :: Expr Var,   fatalError :: Bool,-  verbose :: Bool+  verbose :: Bool,+  allowRecExp :: Bool   }  checkExpr :: CheckExpr -> Expr Var -> CoreM () checkExpr c e = do-  res <- checkExpr' (emptyCtx (recursiveSet c)) e+  res <- checkExpr' (emptyCtx c) e   case res of     Nothing -> return ()     Just (TypeError src doc) ->
src/Rattus/Plugin/Dependency.hs view
@@ -6,7 +6,7 @@  -- | This module is used to perform a dependency analysis of top-level -- function definitions, i.e. to find out which defintions are--- (mutual) recursive. To this end, this module also provides a+-- (mutual) recursive. To this end, this module also provides -- functions to compute, bound variables and variable occurrences.  module Rattus.Plugin.Dependency (dependency, HasBV (..),printBinds) where@@ -37,7 +37,9 @@ import HsBinds #endif -#if __GLASGOW_HASKELL__ >= 902+#if __GLASGOW_HASKELL__ >= 904+import GHC.Parser.Annotation+#elif __GLASGOW_HASKELL__ >= 902 import Language.Haskell.Syntax.Extension import GHC.Parser.Annotation #endif@@ -77,11 +79,16 @@  printBind (L _ FunBind{fun_id = L _ name}) =    liftIO $ putStr $ (getOccString name ++ " ")+printBind (L _ (VarBind {var_id = name})) =   liftIO $ putStr $ (getOccString name ++ " ")+#if __GLASGOW_HASKELL__ < 904 printBind (L _ (AbsBinds {abs_exports = exp})) = +#else+printBind (L _ (XHsBindsLR (AbsBinds {abs_exports = exp}))) = +#endif   mapM_ (\ e -> liftIO $ putStr $ ((getOccString $ abe_poly e)  ++ " ")) exp-printBind (L _ (VarBind {var_id = name})) =   liftIO $ putStr $ (getOccString name ++ " ") printBind _ = return () + -- | Computes the variables that are bound by a given piece of syntax.  class HasBV a where@@ -89,12 +96,16 @@  instance HasBV (HsBindLR GhcTc GhcTc) where   getBV (FunBind{fun_id = L _ v}) = Set.singleton v-  getBV (AbsBinds {abs_exports = es}) = Set.fromList (map abe_poly es)   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+  getBV (AbsBinds {abs_exports = es}) = Set.fromList (map abe_poly es)+#else+  getBV (XHsBindsLR (AbsBinds {abs_exports = es})) = Set.fromList (map abe_poly es) #endif    instance HasBV a => HasBV (GenLocated b a) where@@ -103,7 +114,11 @@ instance HasBV a => HasBV [a] where   getBV ps = foldl (\s p -> getBV p `Set.union` s) Set.empty ps -+#if __GLASGOW_HASKELL__ >= 904+getRecFieldRhs = hfbRHS+#else+getRecFieldRhs = hsRecFieldArg+#endif  #if __GLASGOW_HASKELL__ >= 902 getConBV (PrefixCon _ ps) = getBV ps@@ -112,35 +127,54 @@ #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+      where run s (L _ f) = getBV (getRecFieldRhs f) `Set.union` s -#if __GLASGOW_HASKELL__ >= 900+#if __GLASGOW_HASKELL__ >= 900 && __GLASGOW_HASKELL__ < 904 instance HasBV CoPat where   getBV CoPat {co_pat_inner = p} = getBV p+#elif __GLASGOW_HASKELL__ >= 904+instance HasBV XXPatGhcTc where+  getBV CoPat {co_pat_inner = p} = getBV p+  getBV (ExpansionPat _ p) = getBV p #endif  instance HasBV (Pat GhcTc) where   getBV (VarPat _ (L _ v)) = Set.singleton v   getBV (LazyPat _ p) = getBV p+#if __GLASGOW_HASKELL__ >= 906+  getBV (AsPat _ (L _ v) _ p) = Set.insert v (getBV p)+#else   getBV (AsPat _ (L _ v) p) = Set.insert v (getBV p)-  getBV (ParPat _ p) = getBV p+#endif   getBV (BangPat _ p) = getBV p   getBV (ListPat _ ps) = getBV ps   getBV (TuplePat _ ps _) = getBV ps   getBV (SumPat _ p _ _) = getBV p   getBV (ViewPat _ _ p) = getBV p+   getBV (SplicePat _ sp) =     case sp of+#if __GLASGOW_HASKELL__ < 906       HsTypedSplice _ _ v _ -> Set.singleton v+      HsSpliced _ _ (HsSplicedPat p) -> getBV p       HsUntypedSplice _ _ v _ ->  Set.singleton v       HsQuasiQuote _ p p' _ _ -> Set.fromList [p,p']-      HsSpliced _ _ (HsSplicedPat p) -> getBV p       _ -> Set.empty+#else+      HsUntypedSpliceExpr _ e -> getFV e+      HsQuasiQuote _ v _  -> Set.singleton v+#endif+   getBV (NPlusKPat _ (L _ v) _ _ _ _) = Set.singleton v   getBV (NPat {}) = Set.empty   getBV (XPat p) = getBV p   getBV (WildPat {}) = Set.empty   getBV (LitPat {}) = Set.empty+#if __GLASGOW_HASKELL__ >= 904  +  getBV (ParPat _ _ p _) = getBV p+#else+  getBV (ParPat _ p) = getBV p+#endif #if __GLASGOW_HASKELL__ >= 900   getBV (ConPat {pat_args = con}) = getConBV con #else@@ -154,14 +188,16 @@   getBV (SigPat _ p)   = getBV p #endif +#if __GLASGOW_HASKELL__ >= 904 -#if __GLASGOW_HASKELL__ >= 810+#elif __GLASGOW_HASKELL__ >= 810 instance HasBV NoExtCon where #else instance HasBV NoExt where #endif+#if __GLASGOW_HASKELL__ < 904   getBV _ = Set.empty-+#endif  -- | Syntax that may contain variables. class HasFV a where@@ -235,8 +271,12 @@   getFV FunBind {fun_matches = ms} = getFV ms   getFV PatBind {pat_rhs = rhs} = getFV rhs   getFV VarBind {var_rhs = rhs} = getFV rhs-  getFV AbsBinds {abs_binds = bs} = getFV bs   getFV PatSynBind {} = Set.empty+#if __GLASGOW_HASKELL__ < 904+  getFV AbsBinds {abs_binds = bs} = getFV bs+#else+  getFV (XHsBindsLR AbsBinds {abs_binds = bs}) = getFV bs+#endif #if __GLASGOW_HASKELL__ < 900   getFV (XHsBindsLR e) = getFV e #endif@@ -295,21 +335,26 @@ #endif   getFV HsRecFields{rec_flds = fs} = getFV fs --#if __GLASGOW_HASKELL__ >= 902+#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 #endif-  getFV HsRecField {hsRecFieldArg = arg}  = getFV arg+  getFV rf  = getFV (getRecFieldRhs rf)  instance HasFV (ArithSeqInfo GhcTc) where   getFV (From e) = getFV e   getFV (FromThen e1 e2) = getFV e1 `Set.union` getFV e2   getFV (FromTo e1 e2) = getFV e1 `Set.union` getFV e2   getFV (FromThenTo e1 e2 e3) = getFV e1 `Set.union` getFV e2 `Set.union` getFV e3-+  +#if __GLASGOW_HASKELL__ >= 904+instance HasFV (HsQuote GhcTc) where+#else instance HasFV (HsBracket GhcTc) where+#endif   getFV (ExpBr _ e) = getFV e   getFV (VarBr _ _ e) = getFV e   getFV _ = Set.empty@@ -319,12 +364,19 @@   getFV (HsCmdArrForm _ e _ _ cmd) = getFV e `Set.union` getFV cmd   getFV (HsCmdApp _ e1 e2) = getFV e1 `Set.union` getFV e2   getFV (HsCmdLam _ l) = getFV l-  getFV (HsCmdPar _ cmd) = getFV cmd   getFV (HsCmdCase _ _ mg) = getFV mg   getFV (HsCmdIf _ _ e1 e2 e3) = getFV e1 `Set.union` getFV e2 `Set.union` getFV e3-  getFV (HsCmdLet _ bs _) = getFV bs   getFV (HsCmdDo _ cmd) = getFV cmd-#if __GLASGOW_HASKELL__ >= 900+#if __GLASGOW_HASKELL__ >= 904+  getFV (HsCmdPar _ _ cmd _) = getFV cmd+  getFV (HsCmdLet _ _ bs _ _) = getFV bs+#else+  getFV (HsCmdPar _ cmd) = getFV cmd+  getFV (HsCmdLet _ bs _) = getFV bs+#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@@ -341,25 +393,20 @@ instance HasFV (HsExpr GhcTc) where   getFV (HsVar _ v) = getFV v   getFV HsUnboundVar {} = Set.empty-  getFV HsConLikeOut {} = Set.empty-  getFV HsRecFld {} = Set.empty   getFV HsOverLabel {} = Set.empty   getFV HsIPVar {} = Set.empty   getFV HsOverLit {} = Set.empty   getFV HsLit {} = Set.empty   getFV (HsLam _ mg) = getFV mg-  getFV (HsLamCase _ mg) = getFV mg   getFV (HsApp _ e1 e2) = getFV e1 `Set.union` getFV e2         getFV (OpApp _ e1 e2 e3) = getFV e1 `Set.union` getFV e2 `Set.union` getFV e3   getFV (NegApp _ e _) = getFV e-  getFV (HsPar _ e) = getFV e   getFV (SectionL _ e1 e2) = getFV e1 `Set.union` getFV e2   getFV (SectionR _ e1 e2) = getFV e1 `Set.union` getFV e2   getFV (ExplicitTuple _ es _) = getFV es   getFV (ExplicitSum _ _ _ e) = getFV e   getFV (HsCase _ e mg) = getFV e  `Set.union` getFV mg   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@@ -373,17 +420,39 @@ #endif   getFV (RecordCon {rcon_flds = fs}) = getFV fs   getFV (ArithSeq _ _ e) = getFV e-  getFV (HsBracket _ e) = getFV e-  getFV HsRnBracketOut {} = Set.empty-  getFV HsTcBracketOut {} = Set.empty+#if __GLASGOW_HASKELL__ >= 906+  getFV HsTypedSplice{} = Set.empty+  getFV HsUntypedSplice{} = Set.empty+#else   getFV HsSpliceE{} = Set.empty+#endif   getFV (HsProc _ _ e) = getFV e-  getFV (HsStatic _ e) = getFV e  -  getFV (HsTick _ _ e) = getFV e-  getFV (HsBinTick _ _ _ e) = getFV e+  getFV (HsStatic _ e) = getFV e   getFV (XExpr e) = getFV e-  -#if __GLASGOW_HASKELL__ >= 808+#if __GLASGOW_HASKELL__ >= 904+  getFV (HsPar _ _ e _) = getFV e  +  getFV (HsLamCase _ _ mg) = getFV mg+  getFV (HsLet _ _ bs _ e) = getFV bs `Set.union` getFV e+  getFV HsRecSel {} = Set.empty+  getFV (HsTypedBracket _ e) = getFV e+  getFV (HsUntypedBracket _ e) = getFV e+#else  +  getFV (HsBinTick _ _ _ e) = getFV e+  getFV (HsTick _ _ e) = getFV e+  getFV (HsLet _ bs e) = getFV bs `Set.union` getFV e+  getFV (HsPar _ e) = getFV e+  getFV (HsLamCase _ mg) = getFV mg+  getFV HsConLikeOut {} = Set.empty+  getFV HsRecFld {} = Set.empty+  getFV (HsBracket _ e) = getFV e+  getFV HsRnBracketOut {} = Set.empty+  getFV HsTcBracketOut {} = Set.empty+#endif++#if __GLASGOW_HASKELL__ >= 906+  getFV (HsAppType _ e _ _) = getFV e+  getFV (ExprWithTySig _ e _) = getFV e  +#elif __GLASGOW_HASKELL__ >= 808   getFV (HsAppType _ e _) = getFV e   getFV (ExprWithTySig _ e _) = getFV e   #else@@ -416,6 +485,12 @@ instance HasFV XXExprGhcTc where   getFV (WrapExpr e) = getFV e   getFV (ExpansionExpr (HsExpanded _e1 e2)) = getFV e2+#if __GLASGOW_HASKELL__ >= 904  +  getFV (HsTick _ e) = getFV e+  getFV (HsBinTick _ _ e) = getFV e+  getFV ConLikeTc{} = Set.empty+#endif+  instance HasFV (e GhcTc) => HasFV (HsWrap e) where   getFV (HsWrap _ e) = getFV e
src/Rattus/Plugin/ScopeCheck.hs view
@@ -5,6 +5,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE CPP #-} @@ -62,6 +63,8 @@ import Data.Either import Data.Maybe +import Data.Data hiding (tyConName)+ import Control.Monad  type ErrorMsg = (Severity,SrcSpan,SDoc)@@ -100,7 +103,9 @@     -- | This flag indicates whether the context was 'stabilized'     -- (stripped of all non-stable stuff). It is set when typechecking     -- 'box', 'arr' and guarded recursion.-    stabilized :: Maybe StableReason}+    stabilized :: Maybe StableReason,+    -- | Allow general recursion.+    allowRecursion :: Bool}   @@ -108,8 +113,8 @@ -- non-recursive definitions, the argument is @Nothing@. Otherwise, it -- contains the recursively defined variables along with the location -- of the recursive definition.-emptyCtxt :: ErrorMsgsRef -> Maybe (Set Var,SrcSpan) -> Ctxt-emptyCtxt em mvar =+emptyCtxt :: ErrorMsgsRef -> Maybe (Set Var,SrcSpan) -> Bool -> Ctxt+emptyCtxt em mvar allowRec =   Ctxt { errorMsgs = em,          current =  Set.empty,          earlier = Left NoDelay,@@ -120,7 +125,8 @@          stableTypes = Set.empty,          stabilized = case mvar of            Just (_,loc) ->  Just (StableRec loc)-           _  ->  Nothing}+           _  ->  Nothing,+         allowRecursion = allowRec}  -- | A local context, consisting of a set of variables. type LCtxt = Set Var@@ -336,8 +342,13 @@ checkPatBind' PatBind{} = do   printMessage' SevError ("(Mutual) recursive pattern binding definitions are not supported in Rattus")   return False-         -checkPatBind' AbsBinds {abs_binds = binds} = liftM and (mapM checkPatBind (bagToList binds))+#if __GLASGOW_HASKELL__ < 904+checkPatBind' AbsBinds {abs_binds = binds} = +#else+checkPatBind' (XHsBindsLR AbsBinds {abs_binds = binds}) = +#endif+  liftM and (mapM checkPatBind (bagToList binds))+ checkPatBind' _ = return True  @@ -390,11 +401,15 @@ getAllBV :: GenLocated l (HsBindLR GhcTc GhcTc) -> Set Var getAllBV (L _ b) = getAllBV' b where   getAllBV' (FunBind{fun_id = L _ v}) = Set.singleton v+#if __GLASGOW_HASKELL__ < 904   getAllBV' (AbsBinds {abs_exports = es, abs_binds = bs}) = Set.fromList (map abe_poly es) `Set.union` foldMap getBV bs+  getAllBV' XHsBindsLR{} = Set.empty+#else+  getAllBV' (XHsBindsLR (AbsBinds {abs_exports = es, abs_binds = bs})) = Set.fromList (map abe_poly es) `Set.union` foldMap getBV bs+#endif   getAllBV' (PatBind {pat_lhs = pat}) = getBV pat   getAllBV' (VarBind {var_id = v}) = Set.singleton v   getAllBV' PatSynBind{} = Set.empty-  getAllBV' XHsBindsLR{} = Set.empty   -- Check nested bindings@@ -508,26 +523,42 @@                             <> " There is a delay, but its scope is interrupted by " <> tickHidden hr <> ".")     _ -> liftM2 (&&) (check e1)  (check e2)   check HsUnboundVar{}  = return True+#if __GLASGOW_HASKELL__ >= 904+  check (HsPar _ _ e _) = check e+  check (HsLamCase _ _ mg) = check mg+  check HsRecSel{} = return True+  check HsTypedBracket{} = notSupported "MetaHaskell"+  check HsUntypedBracket{} = notSupported "MetaHaskell"+#else   check HsConLikeOut{} = return True   check HsRecFld{} = return True+  check (HsPar _ e) = check e+  check (HsLamCase _ mg) = check mg+  check HsBracket{} = notSupported "MetaHaskell"+  check (HsTick _ _ e) = check e+  check (HsBinTick _ _ _ e) = check e+  check HsRnBracketOut{} = notSupported "MetaHaskell"+  check HsTcBracketOut{} = notSupported "MetaHaskell"+#endif+#if __GLASGOW_HASKELL__ >= 904+  check (HsLet _ _ bs _ e) = do+#else+  check (HsLet _ bs e) = do+#endif+    (l,vs) <- checkBind bs+    r <- addVars vs `modifyCtxt` (check e)+    return (r && l)+            check HsOverLabel{} = return True   check HsIPVar{} = notSupported "implicit parameters"   check HsOverLit{} = return True  -  check (HsTick _ _ e) = check e-  check (HsBinTick _ _ _ e) = check e  -  check (HsPar _ e) = check e   check HsLit{} = return True   check (OpApp _ e1 e2 e3) = and <$> mapM check [e1,e2,e3]   check (HsLam _ mg) = check mg-  check (HsLamCase _ mg) = check mg   check (HsCase _ e1 e2) = (&&) <$> check e1 <*> check e2   check (SectionL _ e1 e2) = (&&) <$> check e1 <*> check e2   check (SectionR _ e1 e2) = (&&) <$> check e1 <*> check e2   check (ExplicitTuple _ e _) = check e-  check (HsLet _ bs e) = do-    (l,vs) <- checkBind bs-    r <- addVars vs `modifyCtxt` (check e)-    return (r && l)   check (NegApp _ e _) = check e   check (ExplicitSum _ _ _ e) = check e   check (HsMultiIf _ e) = check e@@ -542,16 +573,21 @@ #endif   check RecordCon { rcon_flds = f} = check f   check (ArithSeq _ _ e) = check e-  check HsBracket{} = notSupported "MetaHaskell"-  check HsRnBracketOut{} = notSupported "MetaHaskell"-  check HsTcBracketOut{} = notSupported "MetaHaskell"+#if __GLASGOW_HASKELL__ >= 906+  check HsTypedSplice{} = notSupported "Template Haskell"+  check HsUntypedSplice{} = notSupported "Template Haskell"+#else   check HsSpliceE{} = notSupported "Template Haskell"+#endif   check (HsProc _ p e) = mod `modifyCtxt` check e     where mod c = addVars (getBV p) (stabilize StableArr c)   check (HsStatic _ e) = check e   check (HsDo _ _ e) = fst <$> checkBind e   check (XExpr e) = check e-#if __GLASGOW_HASKELL__ >= 808+#if __GLASGOW_HASKELL__ >= 906+  check (HsAppType _ e _ _) = check e+  check (ExprWithTySig _ e _) = check e+#elif __GLASGOW_HASKELL__ >= 808   check (HsAppType _ e _) = check e   check (ExprWithTySig _ e _) = check e #else@@ -585,6 +621,11 @@ instance Scope XXExprGhcTc where   check (WrapExpr (HsWrap _ e)) = check e   check (ExpansionExpr (HsExpanded _ e)) = check e+#if __GLASGOW_HASKELL__ >= 904+  check ConLikeTc{} = return True+  check (HsTick _ e) = check e+  check (HsBinTick _ _ e) = check e+#endif #elif __GLASGOW_HASKELL__ >= 810 instance Scope NoExtCon where   check _ = return True@@ -605,16 +646,25 @@   check (HsCmdArrForm _ e1 _ _ e2) = (&&) <$> check e1 <*> check e2   check (HsCmdApp _ e1 e2) = (&&) <$> check e1 <*> check e2   check (HsCmdLam _ e) = check e+#if __GLASGOW_HASKELL__ >= 904+  check (HsCmdPar _ _ e _) = check e+  check (HsCmdLamCase _ _ e) = check e  +  check (HsCmdLet _ _ bs _ e) = do+#else   check (HsCmdPar _ e) = check e-  check (HsCmdCase _ e1 e2) = (&&) <$> check e1 <*> check e2-  check (HsCmdIf _ _ e1 e2 e3) = (&&) <$> ((&&) <$> check e1 <*> check e2) <*> check e3+#if __GLASGOW_HASKELL__ >= 900+  check (HsCmdLamCase _ e) = check e+#endif   check (HsCmdLet _ bs e) = do+#endif     (l,vs) <- checkBind bs     r <- addVars vs `modifyCtxt` (check e)     return (r && l)++  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-  check (HsCmdLamCase _ e) = check e #else   check (HsCmdWrap _ _ e) = check e   check XCmd{} = return True@@ -630,8 +680,15 @@ instance Scope a => Scope (HsRecFields GhcTc a) where   check HsRecFields {rec_flds = fs} = check fs +++#if __GLASGOW_HASKELL__ >= 904+instance Scope b => Scope (HsFieldBind a b) where+  check HsFieldBind{hfbRHS = a} = check a+#else instance Scope b => Scope (HsRecField' a b) where   check HsRecField{hsRecFieldArg = a} = check a+#endif  instance Scope (HsTupArg GhcTc) where   check (Present _ e) = check e@@ -641,9 +698,14 @@ #endif  instance Scope (HsBindLR GhcTc GhcTc) where-  check AbsBinds {abs_binds = binds, abs_ev_vars  = ev} = mod `modifyCtxt` check binds-    where mod c = c { stableTypes= stableTypes c `Set.union`-                      Set.fromList (mapMaybe (isStableConstr . varType) ev)}+#if __GLASGOW_HASKELL__ >= 904+  check (XHsBindsLR AbsBinds {abs_binds = binds, abs_ev_vars  = ev})+#else+  check AbsBinds {abs_binds = binds, abs_ev_vars  = ev}+#endif+    = mod `modifyCtxt` check binds+      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} =@@ -652,7 +714,7 @@ #endif       mod `modifyCtxt` check matches     where mod c = c { stableTypes= stableTypes c `Set.union`-                      Set.fromList (stableConstrFromWrapper wrapper)  `Set.union`+                      Set.fromList (stableConstrFromWrapper' wrapper)  `Set.union`                       Set.fromList (extractStableConstr (varType v))}   check PatBind{pat_lhs = lhs, pat_rhs=rhs} = addVars (getBV lhs) `modifyCtxt` check rhs   check VarBind{var_rhs = rhs} = check rhs@@ -678,6 +740,15 @@     _ ->  Nothing  ++#if __GLASGOW_HASKELL__ >= 906+stableConstrFromWrapper' :: (HsWrapper , a) -> [TyVar]+stableConstrFromWrapper' (x , _) = stableConstrFromWrapper x+#else+stableConstrFromWrapper' :: HsWrapper -> [TyVar]+stableConstrFromWrapper' = stableConstrFromWrapper+#endif+ stableConstrFromWrapper :: HsWrapper -> [TyVar] stableConstrFromWrapper (WpCompose v w) = stableConstrFromWrapper v ++ stableConstrFromWrapper w stableConstrFromWrapper (WpEvLam v) = maybeToList $ isStableConstr (varType v)@@ -704,9 +775,10 @@ checkSCC' ::  Module -> AnnEnv -> SCC (LHsBindLR  GhcTc GhcTc, Set Var) -> TcM (Bool, [ErrorMsg]) checkSCC' mod anEnv scc = do   err <- liftIO (newIORef [])-  res <- checkSCC err scc+  let allowRec = AllowRecursion `Set.member` getAnn mod anEnv scc+  res <- checkSCC allowRec err scc   msgs <- liftIO (readIORef err)-  let anns = getInternalAnn mod anEnv scc+  let anns = getAnn mod anEnv scc   if ExpectWarning `Set.member` anns      then if ExpectError `Set.member` anns          then return (False,[(SevError, getSCCLoc scc, "Annotation to expect both warning and error is not allowed.")])@@ -719,16 +791,15 @@               else return (True,[])          else return (res, msgs) --getInternalAnn :: Module -> AnnEnv -> SCC (LHsBindLR  GhcTc GhcTc, Set Var) -> Set InternalAnn-getInternalAnn mod anEnv scc =+getAnn :: forall a . (Data a, Ord a) => Module -> AnnEnv -> SCC (LHsBindLR  GhcTc GhcTc, Set Var) -> Set a+getAnn mod anEnv scc =   case scc of     (AcyclicSCC (_,vs)) -> Set.unions $ Set.map checkVar vs     (CyclicSCC bs) -> Set.unions $ map (Set.unions . Set.map checkVar . snd) bs-  where checkVar :: Var -> Set InternalAnn+  where checkVar :: Var -> Set a         checkVar v =-          let anns = findAnns deserializeWithData anEnv (NamedTarget name) :: [InternalAnn]-              annsMod = findAnns deserializeWithData anEnv (ModuleTarget mod) :: [InternalAnn]+          let anns = findAnns deserializeWithData anEnv (NamedTarget name) :: [a]+              annsMod = findAnns deserializeWithData anEnv (ModuleTarget mod) :: [a]               name :: Name               name = varName v           in Set.fromList anns `Set.union` Set.fromList annsMod@@ -739,13 +810,13 @@ -- non-recursive definition or a group of (mutual) recursive -- definitions. -checkSCC :: ErrorMsgsRef -> SCC (LHsBindLR  GhcTc GhcTc, Set Var) -> TcM Bool-checkSCC errm (AcyclicSCC (b,_)) = setCtxt (emptyCtxt errm Nothing) (check b)+checkSCC :: Bool -> ErrorMsgsRef -> SCC (LHsBindLR  GhcTc GhcTc, Set Var) -> TcM Bool+checkSCC allowRec errm (AcyclicSCC (b,_)) = setCtxt (emptyCtxt errm Nothing allowRec) (check b) -checkSCC errm (CyclicSCC bs) = (fmap and (mapM check' bs'))+checkSCC allowRec 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,getLocAnn' l))) (checkRec b)+        check' b@(L l _) = setCtxt (emptyCtxt errm (Just (vs,getLocAnn' l)) allowRec) (checkRec b)  -- | Stabilizes the given context, i.e. remove all non-stable types -- and any tick. This is performed on checking 'box', 'arr' and@@ -767,8 +838,8 @@ getScope  :: GetCtxt => Var -> VarScope getScope v =   case ?ctxt of-    Ctxt{recDef = Just (vs,_), earlier = e}-      | v `Set.member` vs ->+    Ctxt{recDef = Just (vs,_), earlier = e, allowRecursion = allowRec} | v `Set.member` vs ->+     if allowRec then Visible else         case e of           Right _ -> Visible           Left NoDelay -> Hidden ("The (mutually) recursive call to " <> ppr v <> " must occur in the scope of a delay")@@ -776,7 +847,7 @@                             <> "There is a delay, but its scope is interrupted by " <> tickHidden hr <> ".")     _ ->  case Map.lookup v (hidden ?ctxt) of             Just (Stabilize (StableRec rv)) ->-              if (isStable (stableTypes ?ctxt) (varType v)) then Visible+              if (isStable (stableTypes ?ctxt) (varType v)) || allowRecursion ?ctxt then Visible               else Hidden ("Variable " <> ppr v <> " is no longer in scope:" $$                        "It appears in a local recursive definition (at " <> ppr rv <> ")"                        $$ "and is of type " <> ppr (varType v) <> ", which is not stable.")@@ -828,7 +899,9 @@ isPrimExpr (L _ e) = isPrimExpr' e where   isPrimExpr' :: GetCtxt => HsExpr GhcTc -> Maybe (Prim,Var)   isPrimExpr' (HsVar _ (L _ v)) = fmap (,v) (isPrim v)-#if __GLASGOW_HASKELL__ >= 808+#if __GLASGOW_HASKELL__ >= 906+  isPrimExpr' (HsAppType _ e _ _) = isPrimExpr e+#elif __GLASGOW_HASKELL__ >= 808   isPrimExpr' (HsAppType _ e _) = isPrimExpr e #else   isPrimExpr' (HsAppType _ e)   = isPrimExpr e@@ -844,9 +917,15 @@   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  +  isPrimExpr' (HsBinTick _ _ _ e) = isPrimExpr e   isPrimExpr' (HsPar _ e) = isPrimExpr e+#else+  isPrimExpr' (XExpr (HsTick _ e)) = isPrimExpr e+  isPrimExpr' (XExpr (HsBinTick _ _ e)) = isPrimExpr e+  isPrimExpr' (HsPar _ _ e _) = isPrimExpr e+#endif    isPrimExpr' _ = Nothing
src/Rattus/Plugin/StableSolver.hs view
@@ -37,8 +37,9 @@  import Data.Set (Set) import qualified Data.Set as Set--+#if __GLASGOW_HASKELL__ >= 904+import GHC.Types.Unique.FM+#endif   @@ -48,6 +49,9 @@   { tcPluginInit = return ()   , tcPluginSolve = \ () -> stableSolver   , tcPluginStop = \ () -> return ()+#if __GLASGOW_HASKELL__ >= 904+  , tcPluginRewrite = \ () -> emptyUFM+#endif   }  @@ -63,8 +67,14 @@   | isStable c ty = Just (wrap cl ty, ct)   | otherwise = Nothing +#if __GLASGOW_HASKELL__ >= 904+stableSolver :: EvBindsVar -> [Ct] -> [Ct] -> TcPluginM TcPluginSolveResult+stableSolver _ given wanted = do+#else stableSolver :: [Ct] -> [Ct] -> [Ct] -> TcPluginM TcPluginResult stableSolver given _derived wanted = do+#endif+   let chSt = concatMap filterCt wanted   let haveSt = Set.fromList $ concatMap (filterTypeVar . fst) $ concatMap filterCt given   case mapM (solveStable haveSt) chSt of
src/Rattus/Plugin/Utils.hs view
@@ -22,6 +22,13 @@   getAlt,   splitForAllTys')   where+#if __GLASGOW_HASKELL__ >= 906+import GHC.Builtin.Types.Prim+import GHC.Tc.Utils.TcType+#endif+#if __GLASGOW_HASKELL__ >= 904+import qualified GHC.Data.Strict as Strict+#endif   #if __GLASGOW_HASKELL__ >= 902 import GHC.Utils.Logger #endif@@ -36,6 +43,8 @@ import MonadUtils #endif ++ import Prelude hiding ((<>))  import Data.Set (Set)@@ -50,6 +59,11 @@ isType _ = False  +#if __GLASGOW_HASKELL__ >= 906+isFunTyCon = isArrowTyCon+repSplitAppTys = splitAppTysNoView+#endif+ #if __GLASGOW_HASKELL__ >= 902 printMessage :: (HasDynFlags m, MonadIO m, HasLogger m) =>                 Severity -> SrcSpan -> SDoc -> m ()@@ -58,7 +72,15 @@                 Severity -> SrcSpan -> MsgDoc -> m () #endif printMessage sev loc doc = do-#if __GLASGOW_HASKELL__ >= 902+#if __GLASGOW_HASKELL__ >= 906+  logger <- getLogger+  liftIO $ putLogMsg logger (logFlags logger)+    (MCDiagnostic sev (if sev == SevError then ErrorWithoutFlag else WarningWithoutFlag) Nothing) loc doc+#elif __GLASGOW_HASKELL__ >= 904+  logger <- getLogger+  liftIO $ putLogMsg logger (logFlags logger)+    (MCDiagnostic sev (if sev == SevError then ErrorWithoutFlag else WarningWithoutFlag)) loc doc+#elif __GLASGOW_HASKELL__ >= 902   dflags <- getDynFlags   logger <- getLogger   liftIO $ putLogMsg logger dflags NoReason sev loc doc@@ -274,14 +296,16 @@  mkSysLocalFromExpr :: MonadUnique m => FastString -> CoreExpr -> m Id #if __GLASGOW_HASKELL__ >= 900-mkSysLocalFromExpr lit e = mkSysLocalM lit One (exprType e)+mkSysLocalFromExpr lit e = mkSysLocalM lit oneDataConTy (exprType e) #else mkSysLocalFromExpr lit e = mkSysLocalM lit (exprType e) #endif   fromRealSrcSpan :: RealSrcSpan -> SrcSpan-#if __GLASGOW_HASKELL__ >= 900+#if __GLASGOW_HASKELL__ >= 904+fromRealSrcSpan span = RealSrcSpan span Strict.Nothing+#elif __GLASGOW_HASKELL__ >= 900 fromRealSrcSpan span = RealSrcSpan span Nothing #else fromRealSrcSpan span = RealSrcSpan span
src/Rattus/Strict.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS -fplugin=Rattus.Plugin #-}+ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeOperators #-}@@ -10,6 +12,8 @@  module Rattus.Strict   ( List(..),+    init',+    listDelay,     reverse',     (+++),     listToMaybe',@@ -22,12 +26,33 @@   )where  import Data.VectorSpace+import Rattus.Primitives+import Rattus.Plugin.Annotation  infixr 2 :* infixr 8 :!  -- | Strict list type. data List a = Nil | !a :! !(List a)+++{-# ANN module Rattus #-}+-- All recursive functions in this module are defined by structural+-- induction on a strict type.+{-# ANN module AllowRecursion #-}++-- | Turns a list of delayed computations into a delayed computation+-- that produces a list of values.+listDelay :: List (O a) -> O (List a)+listDelay Nil = delay Nil+listDelay (x :! xs) = let xs' = listDelay xs in delay (adv x :! adv xs')++-- | Remove the last element from a list if there is one, otherwise+-- return 'Nil'.+init' :: List a -> List a+init' Nil = Nil+init' (_ :! Nil) = Nil+init' (x :! xs) = x :! init' xs  -- | Reverse a list. reverse' :: List a -> List a
src/Rattus/Yampa.hs view
@@ -61,7 +61,7 @@  -- | Compute the integral of a signal. The first argument is the -- offset.-integral :: (Stable a, VectorSpace a s) => a -> SF a a+integral :: (Stable a, VectorSpace a s, Fractional s) => a -> SF a a integral acc = SF sf'   where sf' t a = let acc' = acc ^+^ (realToFrac t *^ a)                   in (delay (integral acc') :* acc')