AsyncRattus 0.1.0.3 → 0.2

raw patch · 13 files changed

+91/−151 lines, 13 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• AsyncRattus.cabal +1/−19
• CHANGELOG.md +12/−1
• src/AsyncRattus.hs +0/−2
• src/AsyncRattus/Channels.hs +3/−5
• src/AsyncRattus/Future.hs +0/−2
• src/AsyncRattus/Plugin.hs +15/−7
• src/AsyncRattus/Plugin/Annotation.hs +15/−25
• src/AsyncRattus/Plugin/ScopeCheck.hs +1/−21
• src/AsyncRattus/Plugin/Strictify.hs +35/−54
• src/AsyncRattus/Plugin/Utils.hs +3/−1
• src/AsyncRattus/Signal.hs +0/−4
• test/IllTyped.hs +0/−5
• test/WellTyped.hs +6/−5

@@ -1,6 +1,6 @@ cabal-version:       1.18 name:                AsyncRattus-version:             0.1.0.3+version:             0.2 category:            FRP synopsis:            An asynchronous modal FRP language description:@@ -78,23 +78,6 @@                          . -            In addition, you have to annotate functions that are-            written in Async Rattus:--            .-            -            > {-# ANN myFunction AsyncRattus #-}--            .--            You can also annotate the whole module as an Async Rattus module:-            -            .--            > {-# ANN module AsyncRattus #-}--            .-             Below is a minimal Async Rattus program using the             "AsyncRattus.Signal" module for programming with signals: @@ -105,7 +88,6 @@             > import AsyncRattus             > import AsyncRattus.Signal             > -            > {-# ANN sums AsyncRattus #-}             > sums :: Sig Int -> Sig Int             > sums = scan (box (+)) 0 

@@ -1,7 +1,18 @@+# 0.2++Instead of marking individual function definitions as Async Rattus+code, all function definitions are treated as Async Rattus if the+Async Rattus plugin is enabled. In practice, this means that a whole+module is declared as Async Rattus code by including the line+```+{-# OPTIONS -fplugin=AsyncRattus.Plugin #-}+```+at the top of the file.+ # 0.1.0.3  Fix concurrency bug in the interaction of output and input channels.-This occurred when using mkInput (and thus also filter functions on+This occurred when using `mkInput` (and thus also filter functions on signals).  # 0.1.0.2

@@ -20,7 +20,5 @@ import AsyncRattus.Strict import AsyncRattus.Primitives -{-# ANN module AsyncRattus #-}- mapO :: Box (a -> b) -> O a -> O b mapO f later = delay (unbox f (adv later))

@@ -49,9 +49,6 @@   -- We encode the existential type using continuation-passing style.   getNext :: p -> (forall q. Producer q a => O q -> b) -> b -{-# ANN module AsyncRattus #-}-{-# ANN module AllowLazyData #-}- instance Producer p a => Producer (O p) a where   getCurrent _ = Nothing'   getNext p cb = cb p@@ -92,6 +89,7 @@               return ((box (Delay (singletonClock ch) (\ (InputValue _ v) -> unsafeCoerce v)))                        :* \ x -> writeChan input (InputValue ch x)) +{-# ANN setOutput' AllowLazyData #-} setOutput' :: Producer p a => (a -> IO ()) -> O p -> IO () setOutput' cb !sig = do   ref <- newIORef (Just' (OutputChannel sig cb))@@ -149,7 +147,8 @@       getNext new (setOutput' cb)  -{-# ANN eventLoop NotAsyncRattus #-}+{-# ANN eventLoop AllowRecursion #-}+{-# ANN eventLoop AllowLazyData #-}  eventLoop :: IO () eventLoop = do inp@(InputValue ch _) <- readChan input@@ -162,7 +161,6 @@                eventLoop  -- | In order for 'setOutput' to work, this IO action must be invoked.- startEventLoop :: IO () startEventLoop = do   started <- atomicModifyIORef eventLoopStarted (\b -> (True,b))

@@ -43,8 +43,6 @@ import Prelude hiding (map, filter, zipWith) import AsyncRattus.Channels -{-# ANN module AsyncRattus #-}- newtype OneShot a = OneShot (F a)  instance Producer (OneShot a) a where

@@ -24,6 +24,8 @@ import qualified Data.Set as Set import Data.Set (Set) +import qualified GHC.LanguageExtensions as LangExt+ import GHC.Plugins import GHC.Tc.Types @@ -37,12 +39,19 @@   installCoreToDos = install,   pluginRecompile = purePlugin,   typeCheckResultAction = typechecked,-  tcPlugin = tcStable+  tcPlugin = tcStable,+  driverPlugin = updateEnv   }   data Options = Options {debugMode :: Bool} ++-- | Enable the @Strict@ language extension.+updateEnv :: [CommandLineOption] -> HscEnv -> IO HscEnv+updateEnv _ env = return env {hsc_dflags = update (hsc_dflags env) } +  where update fls = xopt_set fls LangExt.Strict+ typechecked :: [CommandLineOption] -> ModSummary -> TcGblEnv -> TcM TcGblEnv typechecked _ _ env = checkAll env >> return env @@ -107,12 +116,12 @@   singleTick <- toSingleTick e   when debug $ putMsg $ text "Single-tick: " <> ppr singleTick   lazy <- allowLazyData guts v-  strict <- strictifyExpr (SCxt (nameSrcSpan $ getName v) (not lazy)) singleTick-  when debug $ putMsg $ text "Strict single-tick: " <> ppr strict+  when (not lazy) $ checkStrictData (SCxt (nameSrcSpan $ getName v)) singleTick+  when debug $ putMsg $ text "Strict single-tick: " <> ppr singleTick   checkExpr CheckExpr{ recursiveSet = recursiveSet, oldExpr = e,                         verbose = debug,-                        allowRecExp = allowRec} strict-  transform strict+                        allowRecExp = allowRec} singleTick+  transform singleTick  getModuleAnnotations :: Data a => ModGuts -> [a] getModuleAnnotations guts = anns'@@ -142,9 +151,8 @@  shouldProcessCore :: ModGuts -> CoreBndr -> CoreM Bool shouldProcessCore guts bndr = do-  l <- annotationsOn guts bndr :: CoreM [AsyncRattus]   expectScopeError <- expectError guts bndr-  return (AsyncRattus `elem` l && notElem NotAsyncRattus l && userFunction bndr && not expectScopeError)+  return (userFunction bndr && not expectScopeError)  annotationsOn :: (Data a) => ModGuts -> CoreBndr -> CoreM [a] annotationsOn guts bndr = do

@@ -3,37 +3,27 @@  import Data.Data --- | Use this type to mark a Haskell function definition as an--- Asynchronous Rattus function:------ > {-# ANN myFunction AsyncRattus #-}--- --- Or mark a whole module as consisting of Asynchronous Rattus functions only:------ > {-# ANN module AsyncRattus #-}------ If you use the latter option, you can mark exceptions--- (i.e. functions that should be treated as ordinary Haskell function--- definitions) as follows:------ > {-# ANN myFunction NotAsyncRattus #-}------ By default all Asynchronous Rattus functions are checked for use of lazy data--- types, since these may cause memory leaks. If any lazy data types--- are used, a warning is issued. These warnings can be disabled by--- annotating the module or the function with 'AllowLazyData'+-- | By default all Async Rattus functions are checked for use of lazy+-- data types, since these may cause memory leaks. If any lazy data+-- types are used, a warning is issued. These warnings can be disabled+-- by annotating the module or the function with 'AllowLazyData' -- -- > {-# ANN myFunction AllowLazyData #-} -- > -- > {-# ANN module AllowLazyData #-} ----- Asynchronous 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'.+-- Async 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'.+-- +-- > {-# ANN myFunction AllowRecursion #-}+-- >+-- > {-# ANN module AllowRecursion #-} -data AsyncRattus = AsyncRattus | NotAsyncRattus | AllowLazyData | AllowRecursion deriving (Typeable, Data, Show, Ord, Eq)++data AsyncRattus = AllowLazyData | AllowRecursion deriving (Typeable, Data, Show, Ord, Eq)   -- | This annotation type is for internal use only.

@@ -177,8 +177,7 @@ -- found, the current execution is halted with 'exitFailure'. checkAll :: TcGblEnv -> TcM () checkAll env = do-  let dep = dependency (tcg_binds env)-  let bindDep = filter (filterBinds (tcg_mod env) (tcg_ann_env env)) dep+  let bindDep = dependency (tcg_binds env)   result <- mapM (checkSCC' (tcg_mod env) (tcg_ann_env env)) bindDep   let (res,msgs) = foldl' (\(b,l) (b',l') -> (b && b', l ++ l')) (True,[]) result   printAccErrMsgs msgs@@ -189,25 +188,6 @@ printAccErrMsgs msgs = mapM_ printMsg (sortOn (\(_,l,_)->l) msgs)   where printMsg (sev,loc,doc) = printMessage sev loc doc ---- | This function checks whether a given top-level definition (either--- a single non-recursive definition or a group of mutual recursive--- definitions) is marked as Asynchronous Rattus code (via an annotation). In a--- group of mutual recursive definitions, the whole group is--- considered Asynchronous Rattus code if at least one of its constituents is--- marked as such.-filterBinds :: Module -> AnnEnv -> SCC (LHsBindLR  GhcTc GhcTc, Set Var) -> Bool-filterBinds mod anEnv scc =-  case scc of-    (AcyclicSCC (_,vs)) -> any checkVar vs-    (CyclicSCC bs) -> any (any checkVar . snd) bs-  where checkVar :: Var -> Bool-        checkVar v =-          let anns = findAnns deserializeWithData anEnv (NamedTarget name) :: [AsyncRattus]-              annsMod = findAnns deserializeWithData anEnv (ModuleTarget mod) :: [AsyncRattus]-              name :: Name-              name = varName v-          in AsyncRattus `elem` anns || (not (NotAsyncRattus `elem` anns)  && AsyncRattus `elem` annsMod)   

@@ -1,68 +1,41 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module AsyncRattus.Plugin.Strictify-  (strictifyExpr, SCxt (..)) where+  (checkStrictData, SCxt (..)) where import Prelude hiding ((<>))+import Control.Monad import AsyncRattus.Plugin.Utils  import GHC.Plugins import GHC.Types.Tickish -data SCxt = SCxt {srcSpan :: SrcSpan, checkStrictData :: Bool}+data SCxt = SCxt {srcSpan :: SrcSpan} --- | Transforms all functions into strict functions. If the--- 'checkStrictData' field of the 'SCxt' argument is set to @True@,--- then this function also checks for use of non-strict data types and--- produces warnings if it finds any.-strictifyExpr :: SCxt -> CoreExpr -> CoreM CoreExpr-strictifyExpr ss (Let (NonRec b e1) e2) = do-  e1' <- strictifyExpr ss e1-  e2' <- strictifyExpr ss 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' -> 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-  e' <- strictifyExpr ss e-  return (Let (Rec es') e')-strictifyExpr ss (Lam b e)-   | not (isCoVar b) && not (isTyVar b) && tcIsLiftedTypeKind(typeKind (varType b))-    = do-       e' <- strictifyExpr ss e-       b' <- mkSysLocalFromVar (fsLit "strict") b-       return (Lam b' (Case (varToCoreExpr b') b (exprType e) [mkAlt DEFAULT [] e' ]))-   | otherwise = do-       e' <- strictifyExpr ss e-       return (Lam b e')-strictifyExpr ss (Cast e c) = do-  e' <- strictifyExpr ss e-  return (Cast e' c)-strictifyExpr ss (Tick t@(SourceNote span _) e) = do-  e' <- strictifyExpr (ss{srcSpan = fromRealSrcSpan span}) e-  return (Tick t e')-strictifyExpr ss (App e1 e2@Lit{}) =-  do e1' <- strictifyExpr ss e1-     return (App e1' e2)-strictifyExpr ss (App e1 e2)-  | (checkStrictData ss && not (isType e2) && tcIsLiftedTypeKind(typeKind (exprType e2))-        && not (isStrict (exprType e2))) = -      if isDeepseqForce e2 || isLit e2 then-        do e1' <- strictifyExpr ss e1-           e2' <- strictifyExpr ss e2-           return (App e1' e2')-      else-        do (printMessage SevWarning (srcSpan ss)+-- | Checks whether the given expression uses non-strict data types+-- and issues a warning if it finds any such use.+checkStrictData :: SCxt -> CoreExpr -> CoreM ()+checkStrictData ss (Let (NonRec _ e1) e2) = +  checkStrictData ss e1 >> checkStrictData ss e2+checkStrictData ss (Case e _ _ alts) = do+  checkStrictData ss e+  mapM_ ((\(_,_,e) ->  checkStrictData ss e) . getAlt) alts+checkStrictData ss (Let (Rec es) e) = do+  mapM_ (\ (_,e) -> checkStrictData ss e) es+  checkStrictData ss e+checkStrictData ss (Lam _ e) = checkStrictData ss e+checkStrictData ss (Cast e _) = checkStrictData ss e+checkStrictData ss (Tick (SourceNote span _) e) = +  checkStrictData (ss{srcSpan = fromRealSrcSpan span}) e+checkStrictData ss (App e1 e2)+  | isPushCallStack e1 = return ()+  | otherwise = do +    when (not (isType e2) && tcIsLiftedTypeKind(typeKind (exprType e2))+        && not (isStrict (exprType e2)) && not (isDeepseqForce e2) && not (isLit e2))+          (printMessage SevWarning (srcSpan ss)                (text "The use of lazy type " <> ppr (exprType e2) <> " may lead to memory leaks. Use Control.DeepSeq.force on lazy types."))-           e1' <- strictifyExpr ss{checkStrictData = False} e1-           e2' <- strictifyExpr ss{checkStrictData = False} e2-           return (App e1' e2')-  | otherwise = do-      e1' <- strictifyExpr ss e1-      e2' <- strictifyExpr ss e2-      return (App e1' e2')-strictifyExpr _ss e = return e+    checkStrictData ss e1+    checkStrictData ss e2+checkStrictData _ss _ = return ()  isLit :: CoreExpr -> Bool isLit Lit{} = True@@ -70,6 +43,14 @@   | Just (name,mod) <- getNameModule v = mod == "GHC.CString" && name == "unpackCString#" isLit _ = False ++isPushCallStack :: CoreExpr -> Bool+isPushCallStack (Var v) =+  case getNameModule v of+    Just (name, mod) -> mod == "GHC.Stack.Types" && name == "pushCallStack"+    _ -> False+isPushCallStack (App x _) = isPushCallStack x+isPushCallStack _ = False  isDeepseqForce :: CoreExpr -> Bool isDeepseqForce (App (App (App (Var v) _) _) _) =

@@ -187,7 +187,7 @@  -- | The set of stable built-in types. ghcStableTypes :: Set FastString-ghcStableTypes = Set.fromList ["Int","Bool","Float","Double","Char", "IO"]+ghcStableTypes = Set.fromList ["Word","Int","Bool","Float","Double","Char", "IO"]  isGhcStableType :: FastString -> Bool isGhcStableType = (`Set.member` ghcStableTypes)@@ -306,6 +306,8 @@         Just (name,mod)           | mod == "GHC.Num.Integer" && name == "Integer" -> True           | mod == "Data.Text.Internal" && name == "Text" -> True+          | mod == "GHC.IORef" && name == "IORef" -> True+          | mod == "GHC.MVar" && name == "MVar" -> True           -- If it's a Rattus type constructor check if it's a box           | isRattModule mod && (name == "Box" || name == "O" || name == "Output") -> True             -- If its a built-in type check the set of stable built-in types

@@ -64,10 +64,6 @@   getCurrent (SigMaybe p) = current p   getNext (SigMaybe p) cb = cb (delay (SigMaybe (adv (future p)))) ---{-# ANN module AsyncRattus #-}- -- | Get the current value of a signal. current :: Sig a -> a current (x ::: _) = x

@@ -8,9 +8,6 @@ import AsyncRattus.Plugin.Annotation (InternalAnn (..))  -{-# ANN module AsyncRattus #-}-- {-# ANN loopIndirect ExpectError #-} loopIndirect :: Sig Int loopIndirect = run@@ -165,6 +162,4 @@ addDelay :: O Int -> O Int -> O Int addDelay x y = delay (adv x + adv y) --{-# ANN main NotAsyncRattus #-} main = putStrLn "This file should not type check"

@@ -9,10 +9,6 @@ import Data.Set as Set import Data.Text ---{-# ANN module AsyncRattus #-}- boxedInt :: Box Int boxedInt = box 8 @@ -142,5 +138,10 @@ leaky :: Sig () -> (() -> Bool) -> Sig Bool leaky (() ::: d) p = p () ::: delay (let d' = adv d in (leaky d' (\ _ -> current (leaky d' (\ _ -> True))))) -{-# ANN main NotAsyncRattus #-}+unusedAdv :: O () -> O ()+unusedAdv d = delay (adv d `seq` ())++unusedAdv' :: O () -> O ()+unusedAdv' d = delay (let _ = adv d in ())+ main = putStrLn "This file should just type check"