diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ +# 0.3 + +- Include the Widgets library. +- Replace module names from AsyncRattus to WidgetRattus + # 0.2 Extend continuous types so that they can track their channel diff --git a/WidgetRattus.cabal b/WidgetRattus.cabal --- a/WidgetRattus.cabal +++ b/WidgetRattus.cabal @@ -1,27 +1,37 @@ cabal-version: 1.18 name: WidgetRattus -version: 0.2 +version: 0.3 category: FRP -synopsis: An asynchronous modal FRP language +synopsis: An asynchronous modal FRP language for GUI programming description: This library implements an experimental variant of the Async Rattus programming language that features extensions for implementing GUIs. + A comprehensive introduction can be found in this + . + + . + + Several example GUIs implemented using Widget Rattus can be found + . -homepage: https://github.com/pa-ba/AsyncRattus/ +homepage: https://github.com/pa-ba/AsyncRattus/tree/WidgetRattus bug-reports: https://github.com/pa-ba/AsyncRattus/issues License: BSD3 License-file: LICENSE -copyright: Copyright (C) 2023 Emil Houlborg, Gregers RΓΈrdam, Patrick Bahr -Author: Emil Houlborg, Gregers RΓΈrdam, Patrick Bahr +copyright: Copyright (C) 2024 Emil Houlborg, Gregers RΓΈrdam, Patrick Bahr, Jean-Claude Sebastian Disch, Asger Lademark Heegaard +Author: Emil Houlborg, Gregers RΓΈrdam, Patrick Bahr, Jean-Claude Sebastian Disch, Asger Lademark Heegaard maintainer: Patrick Bahr stability: experimental build-type: Custom extra-source-files: CHANGELOG.md + examples/gui/src/*.hs +extra-doc-files: docs/paper.pdf + custom-setup setup-depends: @@ -30,34 +40,38 @@ library - exposed-modules: AsyncRattus - AsyncRattus.Signal - AsyncRattus.Future - AsyncRattus.Strict - AsyncRattus.Plugin - AsyncRattus.Primitives - AsyncRattus.InternalPrimitives - AsyncRattus.Channels - AsyncRattus.Plugin.Annotation + exposed-modules: WidgetRattus + WidgetRattus.Signal + WidgetRattus.Future + WidgetRattus.Strict + WidgetRattus.Plugin + WidgetRattus.Primitives + WidgetRattus.InternalPrimitives + WidgetRattus.Channels + WidgetRattus.Plugin.Annotation + WidgetRattus.Widgets - other-modules: AsyncRattus.Plugin.ScopeCheck - AsyncRattus.Plugin.SingleTick - AsyncRattus.Plugin.CheckClockCompatibility - AsyncRattus.Plugin.Strictify - AsyncRattus.Plugin.Utils - AsyncRattus.Plugin.Dependency - AsyncRattus.Plugin.StableSolver - AsyncRattus.Plugin.Transform - AsyncRattus.Plugin.PrimExpr - AsyncRattus.Derive + other-modules: WidgetRattus.Plugin.ScopeCheck + WidgetRattus.Plugin.SingleTick + WidgetRattus.Plugin.CheckClockCompatibility + WidgetRattus.Plugin.Strictify + WidgetRattus.Plugin.Utils + WidgetRattus.Plugin.Dependency + WidgetRattus.Plugin.StableSolver + WidgetRattus.Plugin.Transform + WidgetRattus.Plugin.PrimExpr + WidgetRattus.Widgets.InternalTypes + WidgetRattus.Derive build-depends: base >=4.16 && <5, containers >= 0.6.5 && < 0.8, - ghc >= 9.2 && < 9.9, - ghc-boot >= 9.2 && < 9.9, + ghc >= 9.2 && < 9.7, + ghc-boot >= 9.2 && < 9.7, hashtables >= 1.3.1 && < 1.4, simple-affine-space >= 0.2.1 && < 0.3, transformers >= 0.5.6 && < 0.7, - template-haskell >= 2.17 && < 2.22 + template-haskell >= 2.17 && < 2.23, + text >= 1.2 && < 3, + monomer >= 1.4 && < 2 hs-source-dirs: src default-language: Haskell2010 ghc-options: -W @@ -69,7 +83,7 @@ main-is: test/IllTyped.hs default-language: Haskell2010 build-depends: WidgetRattus, base - ghc-options: -fplugin=AsyncRattus.Plugin + ghc-options: -fplugin=WidgetRattus.Plugin Test-Suite well-typed @@ -78,5 +92,5 @@ hs-source-dirs: test default-language: Haskell2010 build-depends: WidgetRattus, base, containers, text - ghc-options: -fplugin=AsyncRattus.Plugin + ghc-options: -fplugin=WidgetRattus.Plugin diff --git a/docs/paper.pdf b/docs/paper.pdf new file mode 100644 Binary files /dev/null and b/docs/paper.pdf differ diff --git a/examples/gui/src/Calculator.hs b/examples/gui/src/Calculator.hs new file mode 100644 --- /dev/null +++ b/examples/gui/src/Calculator.hs @@ -0,0 +1,99 @@ +{-# OPTIONS -fplugin=WidgetRattus.Plugin #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +import WidgetRattus +import WidgetRattus.Signal +import WidgetRattus.Widgets +import Prelude hiding (map, const, zipWith, zip, filter, getLine, putStrLn,null) +import Data.Text (Text) + +nums :: List Int +nums = [0..9] + +data Op = Plus | Minus | Equals | Reset + +compute :: (Int :* Op :* Bool -> Maybe' (Int :* Op) -> Int :* Op :* Bool) +compute (n :* op :* _) Nothing' = (n :* op :* False) +compute _ (Just' (_ :* Reset)) = (0 :* Reset :* True) +compute (n :* Plus :* _) (Just' (m :* op)) = (n + m) :* op :* True +compute (n :* Minus :* _) (Just' (m :* op)) = (n - m) :* op :* True +compute (_ :* Equals :* _) (Just' (m :* op)) = m :* op :* True +compute (_ :* Reset :* _) (Just' (m :* op)) = m :* op :* True + + +window :: C VStack +window = do + + -- construct number buttons + numBtns :: List Button + <- mapM (mkButton . const) nums + let [b0, b1, b2, b3, b4, b5, b6, b7, b8, b9] = numBtns + -- construct operator buttons + resetBut <- mkButton (const ("C"::Text)) + addBut <- mkButton (const ("+"::Text)) + subBut <- mkButton (const ("-"::Text)) + eqBut <- mkButton (const ("="::Text)) + + -- signal to construct numbers + let numClicks :: List (O (Sig (Int -> Int))) + = zipWith' (\b n -> mapAwait (box (\ _ x -> x * 10 + n)) (btnOnClickSig b)) numBtns nums + + + + -- signal to reset the current number to 0, after clicking an + -- operator button + let resetSig :: O (Sig (Int -> Int)) + = mapAwait (box (\ _ _ -> 0)) + $ interleaveAll (box (\ a _ -> a)) + $ map' btnOnClickSig [addBut, subBut, eqBut,resetBut] + + -- combine signals to construct the number signal + let sigList = resetSig :! numClicks :: List (O (Sig (Int -> Int))) + let combinedSig = interleaveAll (box (\ a _ -> a)) sigList + + -- number signal (i.e. the multidigit number that has been + -- constructed) + let numberSig :: Sig Int + = scanAwait (box (\ a f-> f a)) 0 combinedSig + -- operator signal + let opSig :: O (Sig Op) + = interleaveAll (box (\ a _ -> a)) + $ map' (\ (op :* btn) -> mapAwait (box (\ _ -> op)) (btnOnClickSig btn) ) + [(Plus :* addBut), (Minus :* subBut), (Equals :* eqBut), (Reset :* resetBut)] + + -- signal consisting of an operand (i.e. a number) @n@ and an + -- operator @op@. @n@ is the value of @numberSig@ just before + -- clicking an operator button, and op is taken from opSig + let operand :: Sig (Maybe' (Int :* Op)) + = Nothing' ::: triggerAwaitM (box (\op n -> Just' (n :* op))) opSig (buffer 0 numberSig) + + -- The result signal consisting of a number n that is the result + -- of the current computation, an operator op that still needs to + -- applied to n and a Boolean b that indicates whether we have + -- just calculated n (and thus n should be displayed) + let resSig :: Sig (Int :* Op :* Bool) + = scan (box compute) (0 :* Plus :* True) operand + -- The signal that should be displayed + let displaySig :: Sig Int + = zipWith (box (\ (n :* _ :* b) m -> if b then n else m)) resSig numberSig + + -- label to display the result (and operands) + result <- mkLabel displaySig + + -- lay out widgets + operators <- mkConstVStack (resetBut :* addBut :* subBut :* eqBut) + row1 <- mkConstHStack (b7 :* b8 :* b9) + row2 <- mkConstHStack (b4 :* b5 :* b6) + row3 <- mkConstHStack (b1 :* b2 :* b3) + + numbers <- mkConstVStack (row1 :* row2 :* row3 :* b0) + + input <- mkConstHStack (numbers :* operators) + + mkConstVStack (result :* input) + +main :: IO () +main = runApplication window diff --git a/examples/gui/src/Counter.hs b/examples/gui/src/Counter.hs new file mode 100644 --- /dev/null +++ b/examples/gui/src/Counter.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLists #-} +{-# OPTIONS -fplugin=WidgetRattus.Plugin #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Evaluate" #-} +{-# HLINT ignore "Use const" #-} +{-# LANGUAGE ScopedTypeVariables #-} + +import WidgetRattus +import WidgetRattus.Signal +import WidgetRattus.Widgets + +import Prelude hiding (map, const, zipWith, zip, filter, getLine, putStrLn,null) +import Data.Text hiding (filter, map, all) + +window :: C VStack +window = do + btn <- mkButton (const ("Increment" :: Text)) + let sig = btnOnClickSig btn + let sig' = scanAwait (box (\ n _ -> n+1 :: Int)) 0 sig + lbl <- mkLabel sig' + mkConstVStack (lbl :* btn) + + +main :: IO () +main = runApplication window diff --git a/examples/gui/src/FlightBooker.hs b/examples/gui/src/FlightBooker.hs new file mode 100644 --- /dev/null +++ b/examples/gui/src/FlightBooker.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLists #-} +{-# OPTIONS -fplugin=WidgetRattus.Plugin #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Evaluate" #-} +{-# HLINT ignore "Use const" #-} + +import WidgetRattus +import WidgetRattus.Signal +import WidgetRattus.Widgets +import Prelude hiding (map, const, zipWith, zipWith3, zip, filter, getLine, putStrLn,null) +import Data.Text (Text) + +-- Benchmark 3 +isDate :: Text -> Bool +isDate txt = case splitOn' "-" txt of + [dayStr, monthStr, yearStr] -> + let day = readMaybe' dayStr + month = readMaybe' monthStr + year = readMaybe' yearStr + in isValid day month year + _ -> False + where + isValid :: Maybe' Int -> Maybe' Int -> Maybe' Int -> Bool + isValid (Just' d) (Just' m) (Just' y) + | m < 1 || m > 12 = False + | d < 1 || d > daysInMonth m y = False + | otherwise = True + isValid _ _ _ = False + + daysInMonth :: Int -> Int -> Int + daysInMonth m y + | m `elem` ([4, 6, 9, 11] :: List Int) = 30 + | m == 2 = if isLeapYear y then 29 else 28 + | otherwise = 31 + + isLeapYear :: Int -> Bool + isLeapYear y = y `mod` 4 == 0 && (y `mod` 100 /= 0 || y `mod` 400 == 0) + +isLater :: Text -> Text -> Bool +isLater dep ret = case (splitOn' "-" dep, splitOn' "-" ret) of + ([depDayStr, depMonthStr, depYearStr], [retDayStr, retMonthStr, retYearStr]) -> + let depDay = readMaybe' depDayStr + depMonth = readMaybe' depMonthStr + depYear = readMaybe' depYearStr + retDay = readMaybe' retDayStr + retMonth = readMaybe' retMonthStr + retYear = readMaybe' retYearStr + in all isJust' ([depDay, depMonth, depYear, retDay, retMonth, retYear] :: List (Maybe' Int)) && + (depYear < retYear || + (depYear == retYear && (depMonth < retMonth || + (depMonth == retMonth && depDay < retDay)))) + _ -> False + +bookingToText :: Bool -> Text -> Text -> Text +bookingToText oneWay dep ret = + "You have booked a " <> if oneWay then "one-way flight on " <> dep + else "return flight from " <> dep <> " to " <> ret + +window :: C VStack +window = do + dropDown <- mkTextDropdown (const ["One-Way", "Return-Flight"]) "One-Way" + tf1 <- mkTextField "01-01-2021" + tf2 <- mkTextField "01-02-2021" + button <- mkButton (const ("Book" :: Text)) + + let isRF = map (box (== "Return-Flight")) (tddCurr dropDown) + let isOW = map (box (== "One-Way")) (tddCurr dropDown) + + let labelSig = zipWith3 (box bookingToText) isOW (tfContent tf1) (tfContent tf2) + + let sig = scanAwait (box (\ _ _ -> True )) False (btnOnClickSig button) + + label <- mkLabel labelSig + + popup <- mkPopup sig (const (mkWidget label)) + + let tf1IsDate = map (box isDate) (tfContent tf1) + let tf1IsLater = zipWith (box isLater) (tfContent tf1) (tfContent tf2) + + let oneWayAndDate = zipWith (box (&&)) isOW tf1IsDate + let returnFlightAndIsLater = zipWith (box (&&)) isRF tf1IsLater + let validBooking = zipWith (box (||)) oneWayAndDate returnFlightAndIsLater + + mkConstVStack (popup :* dropDown :* tf1 :* setEnabled tf2 isRF :* setEnabled button validBooking) + +main :: IO () +main = runApplication window diff --git a/examples/gui/src/TemperatureConverter.hs b/examples/gui/src/TemperatureConverter.hs new file mode 100644 --- /dev/null +++ b/examples/gui/src/TemperatureConverter.hs @@ -0,0 +1,50 @@ +{-# OPTIONS -fplugin=WidgetRattus.Plugin #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLists #-} +{-# OPTIONS -fplugin=WidgetRattus.Plugin #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Evaluate" #-} +{-# HLINT ignore "Use const" #-} + + +import WidgetRattus +import WidgetRattus.Signal +import WidgetRattus.Widgets +import Prelude hiding (map, const, zipWith, zip, filter, getLine, putStrLn,null) +import Data.Text hiding (filter, map, all) +import Data.Text.Read + +-- Benchmark 2 +celsiusToFahrenheit :: Text -> Text +celsiusToFahrenheit t = + case signed decimal t of + Right (t', _) -> toText (t' * 9 `div` 5 + 32) + Left _ -> "Invalid input" + +fahrenheitToCelsius :: Text -> Text +fahrenheitToCelsius t = + case signed decimal t of + Right (t', _) -> toText ((t' - 32) * 5 `div` 9) + Left _ -> "Invalid input" + +window :: C HStack +window = do + tfF1 <- mkTextField "32" + tfC1 <- mkTextField "0" + + let convertFtoC = map (box fahrenheitToCelsius) (tfContent tfF1) + let convertCtoF = map (box celsiusToFahrenheit) (tfContent tfC1) + + let tfF2 = addInputSigTF tfF1 (future convertCtoF) + let tfC2 = addInputSigTF tfC1 (future convertFtoC) + + fLabel <- mkLabel (const ("Fahrenheit" :: Text)) + cLabel <- mkLabel (const ("Celsius" :: Text)) + + fStack <- mkConstVStack (tfF2 :* fLabel) + cStack <- mkConstVStack (tfC2 :* cLabel) + mkConstHStack (fStack :* cStack) + + +main :: IO () +main = runApplication window diff --git a/examples/gui/src/Timer.hs b/examples/gui/src/Timer.hs new file mode 100644 --- /dev/null +++ b/examples/gui/src/Timer.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLists #-} +{-# OPTIONS -fplugin=WidgetRattus.Plugin #-} + +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ScopedTypeVariables #-} + + +import WidgetRattus +import WidgetRattus.Signal +import WidgetRattus.Widgets +import Prelude hiding (map, const, zipWith, zip, filter, getLine, putStrLn,null) +import Data.Text hiding (filter, map, all) + + +everySecond :: Box (O()) +everySecond = timer 1000000 + +everySecondSig :: O (Sig ()) +everySecondSig = mkSig everySecond + +nats :: (Int :* Int) -> Sig (Int :* Int) +nats (n :* max) = stop + (box (\ (n :* max) -> n >= max)) + (scanAwait (box (\ (n :* max) _ -> (n + 1) :* max)) (n :* max) everySecondSig) + + +reset :: (Int :* Int) -> (Int :* Int) +reset (_ :* max) = (0 :* max) + +setMax :: Int -> (Int :* Int) -> (Int :* Int) +setMax max' (n :* _) = ((min n max') :* max') + +window :: C VStack +window = do + slider <- mkSlider 50 (const 1) (const 100) + resetBtn <- mkButton (const ("Reset" :: Text)) + + let resSig :: O (Sig ()) + = mkSig (btnOnClick resetBtn) + let resetSig :: O (Sig (Int :* Int -> Int :* Int)) + = mapAwait (box (\ _ -> reset)) resSig + + let currentMax :: Int + = current (sldCurr slider) + let setMaxSig :: O (Sig (Int :* Int -> Int :* Int)) + = mapAwait (box setMax) (future (sldCurr slider)) + + let inputSig :: O (Sig (Int :* Int -> Int :* Int)) + = interleave (box (.)) resetSig setMaxSig + + let inputSig' :: O (Sig (Int :* Int -> Sig (Int :* Int))) + = mapAwait (box (nats .)) inputSig + + let counterSig :: Sig (Int :* Int) + = switchR (nats (0 :* currentMax)) inputSig' + + let currentSig = map (box fst') counterSig + let maxSig = map (box snd') counterSig + + label <- mkLabel currentSig + pb <- mkProgressBar (const 0) maxSig currentSig + + mkConstVStack (slider :* resetBtn :* label :* pb) + +main :: IO () +main = runApplication window diff --git a/src/AsyncRattus.hs b/src/AsyncRattus.hs deleted file mode 100644 --- a/src/AsyncRattus.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# OPTIONS -fplugin=AsyncRattus.Plugin #-} - - --- | The bare-bones Asynchronous Rattus language. To program with streams, --- you can use "AsyncRattus.Stream". - -module AsyncRattus ( - -- * Asynchronous Rattus language primitives - module AsyncRattus.Primitives, - -- * Strict data types - module AsyncRattus.Strict, - -- * Derive class instance declarations - module AsyncRattus.Derive, - -- * Annotation - AsyncRattus(..), - -- * other - mapO - ) - where - -import AsyncRattus.Plugin -import AsyncRattus.Strict -import AsyncRattus.Primitives -import AsyncRattus.Derive - -mapO :: Box (a -> b) -> O a -> O b -mapO f later = delay (unbox f (adv later)) diff --git a/src/AsyncRattus/Channels.hs b/src/AsyncRattus/Channels.hs deleted file mode 100644 --- a/src/AsyncRattus/Channels.hs +++ /dev/null @@ -1,211 +0,0 @@ -{-# OPTIONS -fplugin=AsyncRattus.Plugin #-} - -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - --- | This module is meant for library authors that want to build APIs --- for interacting with asynchronous resources, e.g. a GUI framework. - -module AsyncRattus.Channels ( - getInput, - setOutput, - mkInput, - startEventLoop, - timer, - Producer (..), - chan, - C (..), - delayC, - wait, - Chan -) where -import AsyncRattus.InternalPrimitives - -import AsyncRattus.Plugin.Annotation -import AsyncRattus.Strict -import Control.Monad -import System.IO.Unsafe -import Data.IORef -import Unsafe.Coerce -import qualified Data.HashTable.IO as H -import Data.HashTable.IO (BasicHashTable) -import qualified Data.IntSet as IntSet -import Control.Concurrent hiding (Chan) - --- | A type @p@ satisfying @Producer p a@ is essentially a signal that --- produces values of type @a@ but it might not produce such values at --- each tick. -class Producer p a | p -> a where - -- | Get the current value of the producer if any. - getCurrent :: p -> Maybe' a - -- | Get the next state of the producer. Morally, the type of this - -- method should be - -- - -- > getNext :: p -> (exists q. Producer q a => O q) - -- - -- We encode the existential type using continuation-passing style. - getNext :: p -> (forall q. Producer q a => O q -> b) -> b - -instance Producer p a => Producer (O p) a where - getCurrent _ = Nothing' - getNext p cb = cb p - -instance Producer p a => Producer (Box p) a where - getCurrent p = getCurrent (unbox p) - getNext p cb = getNext (unbox p) cb - -newtype C a = C {unC :: IO a} deriving (Functor, Applicative, Monad) - -chan :: C (Chan a) -chan = C (Chan <$> atomicModifyIORef nextFreshChannel (\ x -> (x - 1, x))) - -delayC :: O (C a) -> C (O a) -delayC d = return (delay (unsafePerformIO (unC (adv d)))) - -{-# ANN wait AllowRecursion #-} -wait :: Chan a -> O a -wait (Chan ch) = Delay (singletonClock ch) (lookupInp ch) - -{-# NOINLINE nextFreshChannel #-} -nextFreshChannel :: IORef InputChannelIdentifier -nextFreshChannel = unsafePerformIO (newIORef (-1)) - - -{-# NOINLINE inputValue #-} -inputValue :: MVar (Maybe' InputValue) -inputValue = unsafePerformIO (newMVar Nothing') - -{-# NOINLINE inputSem #-} -inputSem :: MVar () -inputSem = unsafePerformIO newEmptyMVar - -data OutputChannel where - OutputChannel :: Producer p a => !(O p) -> !(a -> IO ()) -> OutputChannel - - -{-# NOINLINE output #-} -output :: BasicHashTable InputChannelIdentifier (List (IORef (Maybe' OutputChannel))) -output = unsafePerformIO (H.new) - -{-# NOINLINE eventLoopStarted #-} -eventLoopStarted :: IORef Bool -eventLoopStarted = unsafePerformIO (newIORef False) - - --- | This function can be used to implement input signals. It returns --- a boxed delayed computation @s@ and a callback function @cb@. The --- signal @mkSig s@ will produce a new value @v@ whenever the callback --- function @cb@ is called with argument @v@. -getInput :: IO (Box (O a) :* (a -> IO ())) -getInput = do ch <- atomicModifyIORef nextFreshChannel (\ x -> (x - 1, x)) - return ((box (Delay (singletonClock ch) (lookupInp ch))) - :* \ x -> newInput ch x) - - -newInput :: InputChannelIdentifier -> a -> IO () -newInput ch x = do iv <- takeMVar inputValue - case iv of - Nothing' -> putMVar inputValue (Just' (OneInput ch x)) >> putMVar inputSem () - Just' more -> putMVar inputValue (Just' (MoreInputs ch x more)) - -{-# ANN lookupInp AllowRecursion #-} -lookupInp :: InputChannelIdentifier -> InputValue -> a -lookupInp _ (OneInput _ v) = unsafeCoerce v -lookupInp ch (MoreInputs ch' v more) = if ch' == ch then unsafeCoerce v else lookupInp ch more - -{-# ANN setOutput' AllowLazyData #-} -setOutput' :: Producer p a => (a -> IO ()) -> O p -> IO () -setOutput' cb !sig = do - ref <- newIORef (Just' (OutputChannel sig cb)) - let upd Nothing = (Just (ref :! Nil),()) - upd (Just ls) = (Just (ref :! ls),()) - let upd' ch Nothing = do - forkIO (threadDelay ch >> newInput ch ()) - return (Just (ref :! Nil),()) - upd' _ (Just ls) = return (Just (ref :! ls),()) - let run pre ch = - if ch > 0 then - pre >> H.mutateIO output ch (upd' ch) - else - pre >> H.mutate output ch upd - IntSet.foldl' run (return ()) (extractClock sig) - - --- | This function can be used to produces outputs. Given a signal @s@ --- and function @f@, the call @setOutput s f@ registers @f@ as a --- callback function that is called with argument @v@ whenever the --- signal produces a new value @v@. For this function to work, --- 'startEventLoop' must be called. -setOutput :: Producer p a => p -> (a -> IO ()) -> IO () -setOutput !sig cb = do - case getCurrent sig of - Just' cur' -> cb cur' - Nothing' -> return () - getNext sig (setOutput' cb) - --- | This function is essentially the composition of 'getInput' and --- 'setOutput'. It turns any producer into a signal. -mkInput :: Producer p a => p -> IO (Box (O a)) -mkInput p = do (out :* cb) <- getInput - setOutput p cb - return out - --- | @timer n@ produces a delayed computation that ticks every @n@ --- milliseconds. In particular @mkSig (timer n)@ is a signal that --- produces a new value every #n# milliseconds. -timer :: Int -> Box (O ()) -timer d = Box (Delay (singletonClock (d `max` 10)) (\ _ -> ())) - - -update :: InputValue -> IORef (Maybe' OutputChannel) -> IO () -update inp ref = do - mout <- readIORef ref - case mout of - Nothing' -> return () - Just' (OutputChannel (Delay _ sigf) cb) -> do - writeIORef ref Nothing' - let new = sigf inp - case getCurrent new of - Just' w' -> cb w' - Nothing' -> return () - getNext new (setOutput' cb) - - -{-# ANN getOutputsForInputs AllowRecursion #-} -{-# ANN getOutputsForInputs AllowLazyData #-} -getOutputsForInputs :: List (IORef (Maybe' OutputChannel)) -> InputValue -> IO (List (IORef (Maybe' OutputChannel))) -getOutputsForInputs acc (OneInput ch _) = do res <- H.lookup output ch - case res of - Nothing -> return acc - Just ls -> H.delete output ch >> return (acc `union'` ls) -getOutputsForInputs acc (MoreInputs ch _ more) = do res <- H.lookup output ch - case res of - Nothing -> getOutputsForInputs acc more - Just ls -> H.delete output ch >> getOutputsForInputs (acc `union'` ls) more - -{-# ANN eventLoop AllowRecursion #-} -{-# ANN eventLoop AllowLazyData #-} - -eventLoop :: IO () -eventLoop = do _ <- takeMVar inputSem - minp <- takeMVar inputValue - putMVar inputValue Nothing' - case minp of - Nothing' -> error "AsyncRattus.Channels.eventLoop unexpected state" - Just' inp -> do - ls <- getOutputsForInputs Nil inp - mapM_ (update inp) ls - eventLoop - --- | In order for 'setOutput' to work, this IO action must be invoked. -startEventLoop :: IO () -startEventLoop = do - started <- atomicModifyIORef eventLoopStarted (\b -> (True,b)) - when (not started) eventLoop diff --git a/src/AsyncRattus/Derive.hs b/src/AsyncRattus/Derive.hs deleted file mode 100644 --- a/src/AsyncRattus/Derive.hs +++ /dev/null @@ -1,117 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ExistentialQuantification #-} - - -module AsyncRattus.Derive (continuous) where - -import AsyncRattus.InternalPrimitives -import Language.Haskell.TH -import Language.Haskell.TH.Syntax -import Control.Monad - - -data DataInfo = forall flag . DataInfo Cxt Name [TyVarBndr flag] [Con] [DerivClause] - -{-| - This function provides a list (of the given length) of new names based - on the given string. --} -newNames :: Int -> String -> Q [Name] -newNames n name = replicateM n (newName name) - - -{-| - This is the @Q@-lifted version of 'abstractNewtype. --} -abstractNewtypeQ :: Q Info -> Q (Maybe DataInfo) -abstractNewtypeQ = liftM abstractNewtype - - -{-| Apply a class name to type arguments to construct a type class - constraint. --} - -mkClassP :: Name -> [Type] -> Type -mkClassP name = foldl AppT (ConT name) - - -{-| This function provides the name and the arity of the given data -constructor, and if it is a GADT also its type. --} -normalCon :: Con -> [(Name,[StrictType], Maybe Type)] -normalCon (NormalC constr args) = [(constr, args, Nothing)] -normalCon (RecC constr args) = [(constr, map (\(_,s,t) -> (s,t)) args, Nothing)] -normalCon (InfixC a constr b) = [(constr, [a,b], Nothing)] -normalCon (ForallC _ _ constr) = normalCon constr -normalCon (GadtC (constr:_) args typ) = [(constr,args,Just typ)] -normalCon (RecGadtC (constr : _) args typ) = [(constr,map dropFst args,Just typ)] - where dropFst (_,x,y) = (x,y) -normalCon _ = error "missing case for 'normalCon'" - -normalCon' :: Con -> [(Name,[Type], Maybe Type)] -normalCon' con = map conv (normalCon con) - where conv (n, ts, t) = (n, map snd ts, t) - -mkInstanceD :: Cxt -> Type -> [Dec] -> Dec -mkInstanceD cxt ty decs = InstanceD Nothing cxt ty decs - -{-| - This function returns the name of a bound type variable --} -tyVarBndrName (PlainTV n _) = n -tyVarBndrName (KindedTV n _ _) = n - -{-| - This function abstracts away @newtype@ declaration, it turns them into - @data@ declarations. --} -abstractNewtype :: Info -> Maybe DataInfo -abstractNewtype (TyConI (NewtypeD cxt name args _ constr derive)) - = Just (DataInfo cxt name args [constr] derive) -abstractNewtype (TyConI (DataD cxt name args _ constrs derive)) - = Just (DataInfo cxt name args constrs derive) -abstractNewtype _ = Nothing - -continuous :: Name -> Q [Dec] -continuous fname = do - Just (DataInfo _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname - let argNames = map (VarT . tyVarBndrName) args - complType = foldl AppT (ConT name) argNames - preCond = map (mkClassP ''Continuous . (: [])) argNames - classType = AppT (ConT ''Continuous) complType - let constrs' = concatMap normalCon' constrs - progressAndNextDecl <- funD 'progressAndNext (map genProgressAndNext constrs') - progressInternalDecl <- funD 'progressInternal (map genProgressInternal constrs') - nextProgressDecl <- funD 'nextProgress (map genNextProgress constrs') - return [mkInstanceD preCond classType [progressAndNextDecl,progressInternalDecl,nextProgressDecl]] - where genProgressAndNext (constr, args,_) = do - let n = length args - varNs <- newNames n "x" - varNsR <- newNames n "y" - varNsS <- newNames n "z" - varIn <- newName "_inp" - let pat = ConP constr [] $ map VarP varNs - - progressInternalExp <- [|progressAndNext|] - let lets = zipWith3 (\ x y z -> ValD (TupP [VarP y, VarP z]) (NormalB (progressInternalExp `AppE` VarE varIn `AppE` VarE x)) []) varNs varNsR varNsS - clockUnionExp <- [|clockUnion|] - result <- appsE ( conE constr : (map varE varNsR)) - clock <- if n == 0 then [|emptyClock|] else return (foldl1 (\ x y -> (clockUnionExp `AppE` x) `AppE` y) (map VarE varNsS)) - let body = LetE lets (TupE [Just result, Just clock]) - return $ Clause [VarP varIn, pat] (NormalB body) [] - genProgressInternal (constr, args,_) = do - let n = length args - varNs <- newNames n "x" - varIn <- newName "_inp" - let pat = ConP constr [] $ map VarP varNs - allVars = map varE varNs - inpVar = varE varIn - body <- appsE ( conE constr : (map (\ x -> [|progressInternal $inpVar $x|]) allVars)) - return $ Clause [VarP varIn, pat] (NormalB body) [] - genNextProgress (constr, args,_) = do - let n = length args - varNs <- newNames n "x" - let pat = ConP constr [] $ map VarP varNs - allVars = map varE varNs - body <- if n == 0 then [|emptyClock|] else foldl1 (\ x y -> [|clockUnion $x $y|]) ((map (\ x -> [|nextProgress $x|]) allVars)) - return $ Clause [pat] (NormalB body) [] diff --git a/src/AsyncRattus/Future.hs b/src/AsyncRattus/Future.hs deleted file mode 100644 --- a/src/AsyncRattus/Future.hs +++ /dev/null @@ -1,219 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TypeOperators #-} -{-# OPTIONS -fplugin=AsyncRattus.Plugin #-} - - --- | Programming with futures. - -module AsyncRattus.Future - ( F(..) - , SigF(..) - , mkSigF - , mkSigF' - , current - , future - , bindF - , mapF - , sync - , syncF - , switchAwait - , switch - , switchS - , filterMap - , filterMapAwait - , filterAwait - , filter - , trigger - , triggerAwait - , map - , mapAwait - , zipWith - , zipWithAwait - , fromSig - , scan - , scanAwait - ) - -where - -import AsyncRattus -import AsyncRattus.Signal (Sig(..)) -import Prelude hiding (map, filter, zipWith) -import AsyncRattus.Channels - -newtype OneShot a = OneShot (F a) - -instance Producer (OneShot a) a where - getCurrent (OneShot (Now x)) = Just' x - getCurrent (OneShot (Wait _)) = Nothing' - - getNext (OneShot (Now _)) cb = cb (never :: O (OneShot a)) - getNext (OneShot (Wait x)) cb = cb (delay (OneShot (adv x))) - -instance Producer p a => Producer (F p) a where - getCurrent (Now x) = getCurrent x - getCurrent (Wait _) = Nothing' - - getNext (Now x) cb = getNext x cb - getNext (Wait x) cb = cb x - -instance Producer (SigF a) a where - getCurrent (x :>: _) = Just' x - getNext (_ :>: xs) cb = cb xs - - - --- | @F a@ will produces a value of type @a@ after zero or more ticks --- of some clocks -data F a = Now !a | Wait !(O (F a)) - - - -bindF :: F a -> Box (a -> F b) -> F b -bindF (Now x) f = unbox f x -bindF (Wait x) f = Wait (delay (bindF (adv x) f)) - -mapF :: Box (a -> b) -> F a -> F b -mapF f d = d `bindF` (box (\ x -> Now (unbox f x))) - - -sync :: O (F a) -> O (F b) -> O (F a :* F b) -sync x y = delay (case select x y of - Fst x' y' -> (x' :* Wait y') - Snd x' y' -> (Wait x' :* y') - Both x' y' -> (x' :* y')) - -syncF :: (Stable a, Stable b) => F a -> F b -> F (a :* b) -syncF (Now x) (Now y) = Now (x :* y) -syncF (Wait x) (Now y) = Wait (delay (syncA (adv x) y)) -syncF (Now x) (Wait y) = Wait (delay (syncB x (adv y))) -syncF (Wait x) (Wait y) = Wait (delay (case select x y of - Fst x' y' -> syncF x' (Wait y') - Snd x' y' -> syncF (Wait x') y' - Both x' y' -> syncF x' y' - )) - -syncA :: (Stable b) => F a -> b -> F (a :* b) -syncA (Now x) y = Now (x :* y) -syncA (Wait x) y = Wait (delay (syncA (adv x) y)) - - -syncB :: (Stable a) => a -> F b -> F (a :* b) -syncB x (Now y) = Now (x :* y) -syncB x (Wait y) = Wait (delay (syncB x (adv y))) - - --- | @SigF a@ is a signal of values of type @a@. In contrast to 'Sig', --- 'SigF' supports the 'filter' and 'filterMap' functions. -data SigF a = !a :>: !(O (F (SigF a))) - - --- | Get the current value of a signal. -current :: SigF a -> a -current (x :>: _) = x - - --- | Get the future the signal. -future :: SigF a -> O (F (SigF a)) -future (_ :>: xs) = xs - - -mkSigF :: Box (O a) -> F (SigF a) -mkSigF b = Wait (mkSigF' b) where - -mkSigF' :: Box (O a) -> O (F (SigF a)) -mkSigF' b = delay (Now (adv (unbox b) :>: mkSigF' b)) - - -fromSig :: Sig a -> SigF a -fromSig (x ::: xs) = x :>: delay (Now (fromSig (adv xs))) - - -switchAwait :: F (SigF a) -> F (SigF a) -> F(SigF a) -switchAwait _ (Now ys) = Now ys -switchAwait (Now (x :>: xs)) (Wait ys) = Now (x :>: delay (uncurry' switchAwait (adv (sync xs ys)) )) -switchAwait (Wait xs) (Wait ys) = Wait (delay (uncurry' switchAwait (adv (sync xs ys)) )) - -switch :: SigF a -> F (SigF a) -> SigF a -switch _ (Now ys) = ys -switch (x :>: xs) (Wait ys) = x :>: delay (uncurry' switchAwait (adv (sync xs ys))) - -switchS :: Stable a => SigF a -> F (a -> SigF a) -> SigF a -switchS (x :>: _) (Now f) = f x -switchS (x :>: xs) (Wait ys) = x :>: delay (uncurry' (switchAwaitS x) (adv (sync xs ys))) - -switchAwaitS :: Stable a => a -> F (SigF a) -> F (a -> SigF a) -> F (SigF a) -switchAwaitS _ (Now (x :>: _)) (Now f) = Now (f x) -switchAwaitS _ (Now (x :>: xs)) (Wait ys) = - Now (x :>: delay (uncurry' (switchAwaitS x) (adv (sync xs ys)))) -switchAwaitS x (Wait _) (Now f) = Now (f x) -switchAwaitS x (Wait xs) (Wait ys) = Wait (delay (uncurry' (switchAwaitS x) (adv (sync xs ys)))) - - - -filterMapAwait :: Box (a -> Maybe' b) -> F(SigF a) -> F (SigF b) -filterMapAwait f (Wait xs) = Wait (delay (filterMapAwait f (adv xs))) -filterMapAwait f (Now (x :>: xs)) = case unbox f x of - Just' y -> Now (y :>: delay (filterMapAwait f (adv xs))) - Nothing' -> Wait (delay (filterMapAwait f (adv xs))) - -filterMap :: Box (a -> Maybe' b) -> SigF a -> F (SigF b) -filterMap f xs = filterMapAwait f (Now xs) - - -filterAwait :: Box (a -> Bool) -> F( SigF a) -> F (SigF a) -filterAwait p = filterMapAwait (box (\ x -> if unbox p x then Just' x else Nothing')) - -filter :: Box (a -> Bool) -> SigF a -> F (SigF a) -filter p = filterMap (box (\ x -> if unbox p x then Just' x else Nothing')) - -trigger :: Stable b => Box (a -> b -> c) -> SigF a -> SigF b -> SigF c -trigger f (a :>: as) (b :>: bs) = - unbox f a b :>: - delay (uncurry' (trigger' b f) (adv (sync as bs))) - -triggerAwait :: Stable b => Box (a -> b -> c) -> F (SigF a) -> SigF b -> F (SigF c) -triggerAwait f (Now (a :>: as)) (b :>: bs) - = Now (unbox f a b :>: delay (uncurry' (trigger' b f) (adv (sync as bs)))) -triggerAwait f (Wait as) (b :>: bs) - = Wait (delay (uncurry' (trigger' b f) (adv (sync as bs)))) - -trigger' :: Stable b => b -> Box (a -> b -> c) -> F (SigF a) -> F (SigF b) -> F (SigF c) -trigger' b f (Now (a :>: as)) (Wait bs) = - Now (unbox f a b :>: delay (uncurry' (trigger' b f) (adv (sync as bs)))) -trigger' _ f (Now (a :>: as)) (Now (b :>: bs)) = - Now (unbox f a b :>: delay (uncurry' (trigger' b f) (adv (sync as bs)))) -trigger' b f (Wait as) (Wait bs) = - Wait (delay (uncurry' (trigger' b f) (adv (sync as bs)))) -trigger' _ f (Wait as) (Now (b :>: bs)) = - Wait (delay (uncurry' (trigger' b f) (adv (sync as bs)))) - - -mapAwait :: Box (a -> b) -> F (SigF a) -> F (SigF b) -mapAwait f (Now (x :>: xs)) = Now (unbox f x :>: delay (mapAwait f (adv xs))) -mapAwait f (Wait xs) = Wait (delay (mapAwait f (adv xs))) - -map :: Box (a -> b) -> SigF a -> SigF b -map f (x :>: xs) = unbox f x :>: delay (mapAwait f (adv xs)) - - - -zipWith :: (Stable a, Stable b) => Box(a -> b -> c) -> SigF a -> SigF b -> SigF c -zipWith f (a :>: as) (b :>: bs) = unbox f a b :>: delay (uncurry' (zipWithAwait f a b) (adv (sync as bs))) - -zipWithAwait :: (Stable a, Stable b) => Box(a -> b -> c) -> a -> b -> F (SigF a) -> F (SigF b) -> F (SigF c) -zipWithAwait f _ _ (Now (a :>: as)) (Now (b :>: bs)) = Now (unbox f a b :>: delay (uncurry' (zipWithAwait f a b) (adv (sync as bs)))) -zipWithAwait f _ b (Now (a :>: as)) (Wait bs) = Now (unbox f a b :>: delay (uncurry' (zipWithAwait f a b) (adv (sync as bs)))) -zipWithAwait f a _ (Wait as) (Now (b :>: bs)) = Now (unbox f a b :>: delay (uncurry' (zipWithAwait f a b) (adv (sync as bs)))) -zipWithAwait f a b (Wait as) (Wait bs) = Wait (delay (uncurry' (zipWithAwait f a b) (adv (sync as bs)))) - -scan :: (Stable b) => Box(b -> a -> b) -> b -> SigF a -> SigF b -scan f acc (a :>: as) = acc' :>: delay (scanAwait f acc' (adv as)) - where acc' = unbox f acc a - -scanAwait :: (Stable b) => Box (b -> a -> b) -> b -> F (SigF a) -> F (SigF b) -scanAwait f acc (Now (a :>: as)) = Now (acc' :>: delay (scanAwait f acc' (adv as))) - where acc' = unbox f acc a -scanAwait f acc (Wait as) = Wait (delay (scanAwait f acc (adv as))) diff --git a/src/AsyncRattus/InternalPrimitives.hs b/src/AsyncRattus/InternalPrimitives.hs deleted file mode 100644 --- a/src/AsyncRattus/InternalPrimitives.hs +++ /dev/null @@ -1,263 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} - -module AsyncRattus.InternalPrimitives where - -import Prelude hiding (Left, Right) -import Data.IntSet (IntSet) -import qualified Data.IntSet as IntSet -import Data.IORef -import Control.Concurrent.MVar -import System.IO.Unsafe -import System.Mem.Weak -import Control.Monad - --- An input channel is identified by an integer. The programmer should not know about it. -type InputChannelIdentifier = Int - -type Clock = IntSet - -singletonClock :: InputChannelIdentifier -> Clock -singletonClock = IntSet.singleton - -emptyClock :: Clock -emptyClock = IntSet.empty - -clockUnion :: Clock -> Clock -> Clock -clockUnion = IntSet.union - -channelMember :: InputChannelIdentifier -> Clock -> Bool -channelMember = IntSet.member - -data InputValue where - OneInput :: !InputChannelIdentifier -> !a -> InputValue - MoreInputs :: !InputChannelIdentifier -> !a -> !InputValue -> InputValue - -inputInClock :: InputValue -> Clock -> Bool -inputInClock (OneInput ch _) cl = channelMember ch cl -inputInClock (MoreInputs ch _ more) cl = channelMember ch cl || inputInClock more cl - - --- | The "later" type modality. A value @v@ of type @O 𝜏@ consists of --- two components: Its clock, denoted @cl(v)@, and a delayed --- computation that will produce a value of type @𝜏@ as soon as the --- clock @cl(v)@ ticks. The clock @cl(v)@ is only used for type --- checking and is not directly accessible, whereas the delayed --- computation is accessible via 'adv' and 'select'. - -data O a = Delay !Clock (InputValue -> a) - --- | The return type of the 'select' primitive. -data Select a b = Fst !a !(O b) | Snd !(O a) !b | Both !a !b - -asyncRattusError pr = error (pr ++ ": Did you forget to mark this as Async Rattus code?") - --- | This is the constructor for the "later" modality 'O': --- --- > Ξ“ βœ“ΞΈ ⊒ t :: 𝜏 --- > -------------------- --- > Ξ“ ⊒ delay t :: O 𝜏 --- --- The typing rule requires that its argument @t@ typecheck with an --- additional tick @βœ“ΞΈ@ of some clock @ΞΈ@. -{-# INLINE [1] delay #-} -delay :: a -> O a -delay _ = asyncRattusError "delay" - -extractClock :: O a -> Clock -extractClock (Delay cl _) = cl - -{-# INLINE [1] adv' #-} -adv' :: O a -> InputValue -> a -adv' (Delay _ f) inp = f inp - - --- | This is the eliminator for the "later" modality 'O': --- --- > Ξ“ ⊒ t :: O 𝜏 Ξ“' tick-free --- > --------------------------------- --- > Ξ“ βœ“cl(t) Ξ“' ⊒ adv t :: 𝜏 --- --- It requires that a tick @βœ“ΞΈ@ is in the context whose clock matches --- exactly the clock of @t@, i.e. @ΞΈ = cl(t)@. - -{-# INLINE [1] adv #-} -adv :: O a -> a -adv _ = asyncRattusError "adv" - --- | If we want to eliminate more than one delayed computation, i.e.\ --- two @s :: O Οƒ@ and @t :: O 𝜏@, we need to use 'select' instead of --- just 'adv'. --- --- > Ξ“ ⊒ s :: O Οƒ Ξ“ ⊒ t :: O 𝜏 Ξ“' tick-free --- > -------------------------------------------------- --- > Ξ“ βœ“cl(s)βŠ”cl(t) Ξ“' ⊒ select s t :: Select Οƒ 𝜏 --- --- It requires that we have a tick @βœ“ΞΈ@ in the context whose clock --- matches the union of the clocks of @s@ and @t@, i.e. @ΞΈ = --- cl(s)βŠ”cl(t)@. The union of two clocks ticks whenever either of the --- two clocks ticks, i.e. @cl(s)βŠ”cl(t)@, whenever @cl(s)@ or @cl(t)@ --- ticks. --- --- That means there are three possible outcomes, which are reflected --- in the result type of @select s t@. A value of @Select Οƒ 𝜏@ is --- either --- --- * a value of type @Οƒ@ and a delayed computation of type @O 𝜏@, if --- @cl(s)@ ticks before @cl(t)@, --- --- * a value of type @𝜏@ and a delayed computation of type @O Οƒ@, if --- @cl(t)@ ticks before @cl(s)@, or --- --- * a value of type @Οƒ@ and a value of type @𝜏@, if @cl(s)@ and --- * @cl(s)@ tick simultaneously. - - -{-# INLINE [1] select #-} -select :: O a -> O b -> Select a b -select _ _ = asyncRattusError "select" - -select' :: O a -> O b -> InputValue -> Select a b -select' a@(Delay clA inpFA) b@(Delay clB inpFB) inp - = if inputInClock inp clA then - if inputInClock inp clB then Both (inpFA inp) (inpFB inp) - else Fst (inpFA inp) b - else Snd a (inpFB inp) - - - --- | The clock of @never :: O 𝜏@ will never tick, i.e. it will never --- produce a value of type @𝜏@. With 'never' we can for example --- implement the constant signal @x ::: never@ of type @Sig a@ for any @x :: --- a@. -never :: O a -never = Delay emptyClock (error "Trying to adv on the 'never' delayed computation") - --- | A type is @Stable@ if it is a strict type and the later modality --- @O@ and function types only occur under @Box@. --- --- For example, these types are stable: @Int@, @Box (a -> b)@, @Box (O --- Int)@, @Box (Sig a -> Sig b)@. --- --- But these types are not stable: @[Int]@ (because the list type is --- not strict), @Int -> Int@, (function type is not stable), @O --- Int@, @Sig Int@. - -class Stable a where - - - --- | The "stable" type modality. A value of type @Box a@ is a --- time-independent computation that produces a value of type @a@. --- Use 'box' and 'unbox' to construct and consume 'Box'-types. -data Box a = Box a - - --- | This is the constructor for the "stable" modality 'Box': --- --- > Ξ“β˜ ⊒ t :: 𝜏 --- > -------------------- --- > Ξ“ ⊒ box t :: Box 𝜏 --- --- where Ξ“β˜ is obtained from Ξ“ by removing all ticks and all variables --- @x :: 𝜏@, where 𝜏 is not a stable type. - -{-# INLINE [1] box #-} -box :: a -> Box a -box x = Box x - - --- | This is the eliminator for the "stable" modality 'Box': --- --- > Ξ“ ⊒ t :: Box 𝜏 --- > ------------------ --- > Ξ“ ⊒ unbox t :: 𝜏 -{-# INLINE [1] unbox #-} -unbox :: Box a -> a -unbox (Box d) = d - - -defaultPromote :: Continuous a => a -> Box a -defaultPromote x = unsafePerformIO $ - do r <- newIORef x - r' <- mkWeakIORef r (return ()) - modifyIORef promoteStore (ContinuousData r' :) - return (Box (unsafePerformIO $ readIORef r)) - - -class Continuous p where - -- | Computes the same as 'progressInternal' and 'nextProgress'. In - -- particular @progressAndNext inp v = (progressInternal inp v, - -- nextProgress (progressInternal inp v))@. - progressAndNext :: InputValue -> p -> (p , Clock) - - -- | Progresses the continuous value, given the input value from - -- some channel - progressInternal :: InputValue -> p -> p - -- | Computes the set of channels that the continuous value is - -- depending on. That is if @nextProgress v = cl@ and a new input - -- @inp@ on channel @ch@ arrives, then @progressInternal inp v = v@. - nextProgress :: p -> Clock - promoteInternal :: p -> Box p - promoteInternal = defaultPromote - --- For stable types we can circumvent the "promote store". -instance {-# OVERLAPPABLE #-} Stable a => Continuous a where - progressAndNext _ x = (x , emptyClock) - progressInternal _ x = x - nextProgress _ = emptyClock - promoteInternal = Box - -data ContinuousData where - ContinuousData :: Continuous a => !(Weak (IORef a)) -> ContinuousData - --- TODO: The list type needs to be replaced by a more efficient --- mutable data structure. -{-# NOINLINE promoteStore #-} -promoteStore :: IORef [ContinuousData] -promoteStore = unsafePerformIO (newIORef []) - -{-# NOINLINE progressPromoteStoreMutex #-} -progressPromoteStoreMutex :: MVar () -progressPromoteStoreMutex = unsafePerformIO (newMVar ()) - - --- | Atomic version of 'progressPromoteStore'. - -progressPromoteStoreAtomic :: InputValue -> IO () -progressPromoteStoreAtomic inp = do - takeMVar progressPromoteStoreMutex - progressPromoteStore inp - putMVar progressPromoteStoreMutex () - - --- | For promote to work, its argument must be stored in the "promote --- store", and whenenver an input is received on some channel, all --- values in the "promote store" must be advanced (using --- 'progressInternal'). - -progressPromoteStore :: InputValue -> IO () -progressPromoteStore inp = do - xs <- atomicModifyIORef promoteStore (\x -> ([],x)) - xs' <- filterM run xs - atomicModifyIORef promoteStore (\x -> (x ++ xs',())) - where run (ContinuousData x) = do - d <- deRefWeak x - case d of - Nothing -> return False - Just x -> modifyIORef' x (progressInternal inp) >> return True - -promote :: Continuous a => a -> Box a -promote x = promoteInternal x - -newtype Chan a = Chan InputChannelIdentifier - -{-# RULES - "unbox/box" forall x. unbox (box x) = x - #-} - - -{-# RULES - "box/unbox" forall x. box (unbox x) = x - #-} diff --git a/src/AsyncRattus/Plugin.hs b/src/AsyncRattus/Plugin.hs deleted file mode 100644 --- a/src/AsyncRattus/Plugin.hs +++ /dev/null @@ -1,162 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE CPP #-} - - --- | The plugin to make it all work. - -module AsyncRattus.Plugin (plugin, AsyncRattus(..)) where -import AsyncRattus.Plugin.StableSolver -import AsyncRattus.Plugin.ScopeCheck -import AsyncRattus.Plugin.Strictify -import AsyncRattus.Plugin.SingleTick -import AsyncRattus.Plugin.CheckClockCompatibility -import AsyncRattus.Plugin.Utils -import AsyncRattus.Plugin.Annotation -import AsyncRattus.Plugin.Transform - -import Prelude hiding ((<>)) - -import Control.Monad -import Data.Maybe -import Data.List -import Data.Data hiding (tyConName) -import qualified Data.Set as Set -import Data.Set (Set) - -import qualified GHC.LanguageExtensions as LangExt - -import GHC.Plugins -import GHC.Tc.Types - --- | Use this to enable Asynchronous Rattus' plugin, either by supplying the option --- @-fplugin=AsyncRattus.Plugin@ directly to GHC, or by including the --- following pragma in each source file: --- --- > {-# OPTIONS -fplugin=AsyncRattus.Plugin #-} -plugin :: Plugin -plugin = defaultPlugin { - installCoreToDos = install, - pluginRecompile = purePlugin, - typeCheckResultAction = typechecked, - 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 - -install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] -install opts todo = case find findSamePass todo of -- check that we don't run the transformation twice - Nothing -> return (strPass : todo) -- (e.g. if the "-fplugin" option is used twice) - _ -> return todo - where name = "Async Rattus strictify" - strPass = CoreDoPluginPass name (strictifyProgram Options{debugMode = dmode}) - dmode = "debug" `elem` opts - findSamePass (CoreDoPluginPass s _) = s == name - findSamePass _ = False - - --- | Apply the following operations to all Asynchronous Rattus definitions in the --- program: --- --- * Transform into single tick form (see SingleTick module) --- * Check whether lazy data types are used (see Strictify module) --- * Transform into call-by-value form (see Strictify module) - -strictifyProgram :: Options -> ModGuts -> CoreM ModGuts -strictifyProgram opts guts = do - newBinds <- mapM (strictify opts guts) (mg_binds guts) - return guts { mg_binds = newBinds } - -strictify :: Options -> ModGuts -> CoreBind -> CoreM CoreBind -strictify opts guts b@(Rec bs) = do - let debug = debugMode opts - tr <- liftM or (mapM (shouldProcessCore guts . fst) bs) - if tr then do - let vs = map fst bs - es' <- mapM (\ (v,e) -> do - processCore <- shouldProcessCore guts v - if not processCore - then do - when debug $ putMsg $ text "Skipping binding: " <> ppr v - return e - else checkAndTransform guts (Set.fromList vs) debug v e - ) bs - when debug $ putMsg $ "Plugin | result of transformation: " <> ppr es' - return (Rec (zip vs es')) - else return b -strictify opts guts b@(NonRec v e) = do - let debug = debugMode opts - when debug $ putMsg $ text "Processing binding: " <> ppr v <> text " | Non-recursive binding" - when debug $ putMsg $ text "Expr: " <> ppr e - processCore <- shouldProcessCore guts v - if not processCore then do - when debug $ putMsg $ text "Skipping binding: " <> ppr v - return b - else do - transformed <- checkAndTransform guts Set.empty debug v e - when debug $ putMsg $ "Plugin | result of transformation: " <> ppr transformed - return $ NonRec v transformed - -checkAndTransform :: ModGuts -> Set Var -> Bool -> Var -> CoreExpr -> CoreM CoreExpr -checkAndTransform guts recursiveSet debug v e = do - when debug $ putMsg $ text "Processing binding: " <> ppr v - when debug $ putMsg $ text "Expr: " <> ppr e - allowRec <- allowRecursion guts v - singleTick <- toSingleTick e - when debug $ putMsg $ text "Single-tick: " <> ppr singleTick - lazy <- allowLazyData guts v - 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} singleTick - transform singleTick - -getModuleAnnotations :: Data a => ModGuts -> [a] -getModuleAnnotations guts = anns' - where anns = filter (\a-> case ann_target a of - ModuleTarget m -> m == (mg_module guts) - _ -> False) (mg_anns guts) - anns' = mapMaybe (fromSerialized deserializeWithData . ann_value) anns - - - - -allowLazyData :: ModGuts -> CoreBndr -> CoreM Bool -allowLazyData guts bndr = do - l <- annotationsOn guts bndr :: CoreM [AsyncRattus] - return (AllowLazyData `elem` l) - -allowRecursion :: ModGuts -> CoreBndr -> CoreM Bool -allowRecursion guts bndr = do - l <- annotationsOn guts bndr :: CoreM [AsyncRattus] - return (AllowRecursion `elem` l) - -expectError :: ModGuts -> CoreBndr -> CoreM Bool -expectError guts bndr = do - l <- annotationsOn guts bndr :: CoreM [InternalAnn] - return $ ExpectError `elem` l - - -shouldProcessCore :: ModGuts -> CoreBndr -> CoreM Bool -shouldProcessCore guts bndr = do - expectScopeError <- expectError guts bndr - return (userFunction bndr && not expectScopeError) - -annotationsOn :: (Data a) => ModGuts -> CoreBndr -> CoreM [a] -annotationsOn guts bndr = do - (_,anns) <- getAnnotations deserializeWithData guts - return $ - lookupWithDefaultUFM anns [] (varName bndr) ++ - getModuleAnnotations guts diff --git a/src/AsyncRattus/Plugin/Annotation.hs b/src/AsyncRattus/Plugin/Annotation.hs deleted file mode 100644 --- a/src/AsyncRattus/Plugin/Annotation.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -module AsyncRattus.Plugin.Annotation (AsyncRattus(..), InternalAnn (..)) where - -import Data.Data - --- | 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 #-} --- --- 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 = AllowLazyData | AllowRecursion deriving (Typeable, Data, Show, Ord, Eq) - - --- | This annotation type is for internal use only. -data InternalAnn = ExpectError | ExpectWarning deriving (Typeable, Data, Show, Eq, Ord) diff --git a/src/AsyncRattus/Plugin/CheckClockCompatibility.hs b/src/AsyncRattus/Plugin/CheckClockCompatibility.hs deleted file mode 100644 --- a/src/AsyncRattus/Plugin/CheckClockCompatibility.hs +++ /dev/null @@ -1,261 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE CPP #-} - --- | This module implements the check that the transformed code is --- typable in the single tick calculus. - -module AsyncRattus.Plugin.CheckClockCompatibility - (checkExpr, CheckExpr (..)) where - -import GHC.Types.Tickish -import GHC.Plugins - -import AsyncRattus.Plugin.Utils -import qualified AsyncRattus.Plugin.PrimExpr as Prim -import Prelude hiding ((<>)) -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Maybe (isJust) -import Control.Monad (foldM, when) -import Control.Applicative ((<|>)) -import System.Exit (exitFailure) - -type LCtx = Set Var -data HiddenReason = BoxApp | AdvApp | NestedRec Var | FunDef | DelayApp -type Hidden = Map Var HiddenReason - -data TypeError = TypeError SrcSpan SDoc - - -data Ctx = Ctx - { current :: LCtx, - hidden :: Hidden, - earlier :: Maybe LCtx, - srcLoc :: SrcSpan, - recDef :: Set Var, -- ^ recursively defined variables - stableTypes :: Set Var, - allowRecursion :: Bool, - allowGuardedRec :: Bool - } - -hasTick :: Ctx -> Bool -hasTick = isJust . earlier - -stabilize :: HiddenReason -> Ctx -> Ctx -stabilize hr c = c - {current = Set.empty, - earlier = Nothing, - hidden = hidden c `Map.union` Map.fromSet (const hr) ctxHid, - allowGuardedRec = False - } - where ctxHid = maybe (current c) (Set.union (current c)) (earlier c) - -data Scope = Hidden SDoc | Visible - -getScope :: Ctx -> Var -> Scope -getScope c v = - if v `Set.member` recDef c then - if allowGuardedRec c || allowRecursion c || typeClassFunction v 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 -> - 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.") - - FunDef -> Hidden ("Variable " <> ppr v <> " is no longer in scope: It occurs in a function that is defined under a delay, is a of a non-stable type " <> ppr (varType v) <> ", and is bound outside delay") - DelayApp -> Hidden ("Variable " <> ppr v <> " is no longer in scope: It occurs under two occurrences of delay and is a of a non-stable type " <> ppr (varType v)) - Nothing - | maybe False (Set.member v) (earlier c) -> - if isStable (stableTypes c) (varType v) then Visible - else Hidden ("Variable " <> ppr v <> " is no longer in scope:" $$ - "It occurs under delay" $$ "and is of type " <> ppr (varType v) <> ", which is not stable.") - | Set.member v (current c) -> Visible - | otherwise -> Visible - - - -pickFirst :: SrcSpan -> SrcSpan -> SrcSpan -pickFirst s@RealSrcSpan{} _ = s -pickFirst _ s = s - -typeError :: Ctx -> Var -> SDoc -> TypeError -typeError ctx var = TypeError (pickFirst (srcLoc ctx) (nameSrcSpan (varName var))) - -instance Outputable TypeError where - ppr (TypeError srcLoc sdoc) = text "TypeError at " <> ppr srcLoc <> text ": " <> ppr sdoc - -emptyCtx :: CheckExpr -> Ctx -emptyCtx c = - Ctx { current = Set.empty, - earlier = Nothing, - hidden = Map.empty, - srcLoc = noLocationInfo, - recDef = recursiveSet c, - stableTypes = Set.empty, - allowRecursion = allowRecExp c, - allowGuardedRec = False - } - -stabilizeLater :: Ctx -> Ctx -stabilizeLater c = - case earlier c of - Just earl -> c {earlier = Nothing, - hidden = hidden c `Map.union` Map.fromSet (const FunDef) earl} - Nothing -> c - -isStableConstr :: Type -> CoreM (Maybe Var) -isStableConstr t = - case splitTyConApp_maybe t of - Just (con,[args]) -> - case getNameModule con of - Just (name, mod) -> - if isRattModule mod && name == "Stable" - then return (getTyVar_maybe args) - else return Nothing - _ -> return Nothing - _ -> return Nothing - --- should be equatable -type SymbolicClock = Set Var - -mkClock1 :: Var -> SymbolicClock -mkClock1 = Set.singleton - -mkClock2 :: Var -> Var -> SymbolicClock -mkClock2 v1 v2 = Set.fromList [v1, v2] - -newtype CheckResult = CheckResult{ - -- if present, contains the variable of the primitive applied so we can report its position - -- in case of an error, and the clock for the primitive - prim :: Maybe (Var, SymbolicClock) -} - -instance Outputable CheckResult where - ppr (CheckResult prim) = text "CheckResult {prim = " <> ppr prim <> text "}" - -emptyCheckResult :: CheckResult -emptyCheckResult = CheckResult {prim = Nothing} - -data CheckExpr = CheckExpr{ - recursiveSet :: Set Var, - oldExpr :: Expr Var, - verbose :: Bool, - allowRecExp :: Bool - } - -checkExpr :: CheckExpr -> Expr Var -> CoreM () -checkExpr c e = do - when (verbose c) $ putMsg $ text "checkExpr: " <> ppr e - res <- checkExpr' (emptyCtx c) e - case res of - Right _ -> do when (verbose c) $ putMsgS "checkExpr succeeded." - Left (TypeError src doc) -> - let printErrMsg = if verbose c - then do - printMessage SevError src ("Internal error in Async Rattus Plugin: single tick transformation did not preserve typing." $$ doc) - putMsgS "-------- old --------" - putMsg $ ppr (oldExpr c) - putMsgS "-------- new --------" - putMsg (ppr e) - - else do - printMessage SevError noSrcSpan ("Internal error in Async Rattus Plugin: single tick transformation did not preserve typing." $$ - "Compile with flags \"-fplugin-opt AsyncRattus.Plugin:debug\" and \"-g2\" for detailed information") - in do - printErrMsg - liftIO exitFailure - - -checkExpr' :: Ctx -> Expr Var -> CoreM (Either TypeError CheckResult) -checkExpr' c (App e e') | isType e' || (not $ tcIsLiftedTypeKind $ typeKind $ exprType e') - = checkExpr' c e -checkExpr' c@Ctx{current = cur, earlier = earl} expr@(App e e') = - case Prim.isPrimExpr expr of - Just (Prim.BoxApp _) -> - checkExpr' (stabilize BoxApp c) e' - Just (Prim.DelayApp f _) -> do - let c' = case earl of - Nothing -> c{current = Set.empty, earlier = Just cur, allowGuardedRec = True} - Just earl' -> c{ current = Set.empty, earlier = Just cur, allowGuardedRec = True, - hidden = hidden c `Map.union` Map.fromSet (const DelayApp) earl'} - eRes <- checkExpr' c' e' - case eRes of - Left err -> return $ Left err - Right (CheckResult {prim = Nothing}) -> return $ Left $ typeError c f (text "Each delay must contain an adv or select") - Right _ -> return $ Right emptyCheckResult - Just (Prim.AdvApp f _) | not (hasTick c) -> return $ Left $ typeError c f (text "can only use adv under delay") - Just (Prim.AdvApp f (arg, _)) -> return $ Right $ CheckResult {prim = Just (f, mkClock1 arg)} - Just (Prim.SelectApp f _ _) | not (hasTick c) -> return $ Left $ typeError c f (text "can only use select under delay") - Just (Prim.SelectApp f (arg1, _) (arg2, _))-> return $ Right $ CheckResult {prim = Just (f, mkClock2 arg1 arg2)} - Nothing -> checkBoth c e e' -checkExpr' c (Case e v _ alts) = do - res <- checkExpr' c' e - resAll <- mapM (\(Alt _ _ altE) -> checkExpr' c altE) alts - foldM (fmap return . combine c) res resAll - where c' = addVars [v] c -checkExpr' c (Lam v e) - | isTyVar v || (not $ tcIsLiftedTypeKind $ typeKind $ varType v) = do - is <- isStableConstr (varType v) - let c' = case is of - Nothing -> c - Just t -> c{stableTypes = Set.insert t (stableTypes c)} - checkExpr' c' e - | otherwise = checkExpr' (addVars [v] (stabilizeLater c)) e -checkExpr' _ (Type _) = return $ Right emptyCheckResult -checkExpr' _ (Lit _) = return $ Right emptyCheckResult -checkExpr' _ (Coercion _) = return $ Right emptyCheckResult -checkExpr' c (Tick (SourceNote span _name) e) = - checkExpr' c{srcLoc = fromRealSrcSpan span} e -checkExpr' c (Tick _ e) = checkExpr' c e -checkExpr' c (Cast e _) = checkExpr' c e -checkExpr' c (Let (NonRec _ e1) e2) = do - res1 <- checkExpr' c e1 - res2 <- checkExpr' c e2 - return $ combine c res1 res2 -checkExpr' c (Let (Rec binds) e2) = do - resAll <- mapM (\ (v,e) -> checkExpr' (c' v) e) binds - res <- checkExpr' (addVars vs c) e2 - foldM (fmap return . combine c) res resAll - where vs = map fst binds - ctxHid = maybe (current c) (Set.union (current c)) (earlier c) - c' v = c {current = Set.empty, - earlier = Nothing, - hidden = hidden c `Map.union` - Map.fromSet (const (NestedRec v)) ctxHid, - recDef = recDef c `Set.union` Set.fromList vs } -checkExpr' c (Var v) - | tcIsLiftedTypeKind $ typeKind $ varType v = case getScope c v of - Hidden reason -> return $ Left $ typeError c v reason - Visible -> return $ Right emptyCheckResult - | otherwise = return $ Right emptyCheckResult - -addVars :: [Var] -> Ctx -> Ctx -addVars v c = c{current = Set.fromList v `Set.union` current c } - -checkBoth :: Ctx -> CoreExpr -> CoreExpr -> CoreM (Either TypeError CheckResult) -checkBoth c e e' = do - c1 <- checkExpr' c e - c2 <- checkExpr' c e' - return $ combine c c1 c2 - --- Combines two CheckResults such that the clocks therein are compatible. --- If both CheckResults have PrimVars, one is picked arbitrarily. -combine :: Ctx -> Either TypeError CheckResult -> Either TypeError CheckResult -> Either TypeError CheckResult -combine c eRes1 eRes2 = do - res1 <- eRes1 - res2 <- eRes2 - case (res1, res2) of - (CheckResult (Just (_, cl1)), CheckResult (Just (_, cl2))) | cl1 == cl2 -> Right res2 - (CheckResult (Just _), CheckResult (Just (p, _))) -> Left $ typeError c p "Only one adv/select allowed in a delay" - (CheckResult maybeP, CheckResult maybeP') -> Right $ CheckResult {prim = maybeP <|> maybeP'} diff --git a/src/AsyncRattus/Plugin/Dependency.hs b/src/AsyncRattus/Plugin/Dependency.hs deleted file mode 100644 --- a/src/AsyncRattus/Plugin/Dependency.hs +++ /dev/null @@ -1,385 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# 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 --- (mutual) recursive. To this end, this module also provides --- functions to compute, bound variables and variable occurrences. - -module AsyncRattus.Plugin.Dependency (dependency, HasBV (..),printBinds) where - - -import GHC.Plugins -import GHC.Data.Bag -import GHC.Hs.Type - - -import GHC.Hs.Extension -import GHC.Hs.Expr -import GHC.Hs.Pat -import GHC.Hs.Binds - -#if __GLASGOW_HASKELL__ >= 904 -import GHC.Parser.Annotation -#else -import Language.Haskell.Syntax.Extension -import GHC.Parser.Annotation -#endif - - -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Graph -import Data.Maybe -import Data.Either -import Prelude hiding ((<>)) - - - --- | Compute the dependencies of a bag of bindings, returning a list --- of the strongly-connected components. -dependency :: Bag (LHsBindLR GhcTc GhcTc) -> [SCC (LHsBindLR GhcTc GhcTc, Set Var)] -dependency binds = map AcyclicSCC noDeps ++ catMaybes (map filterJust (stronglyConnComp (concat deps))) - where (deps,noDeps) = partitionEithers $ map mkDep $ bagToList binds - mkDep :: GenLocated l (HsBindLR GhcTc GhcTc) -> - Either [(Maybe (GenLocated l (HsBindLR GhcTc GhcTc), Set Var), Name, [Name])] - (GenLocated l (HsBindLR GhcTc GhcTc), Set Var) - mkDep b = - let dep = map varName $ Set.toList (getFV b) - vars = getBV b in - case Set.toList vars of - (v:vs) -> Left ((Just (b,vars), varName v , dep) : map (\ v' -> (Nothing, varName v' , dep)) vs) - [] -> Right (b,vars) - filterJust (AcyclicSCC Nothing) = Nothing -- this should not happen - filterJust (AcyclicSCC (Just b)) = Just (AcyclicSCC b) - filterJust (CyclicSCC bs) = Just (CyclicSCC (catMaybes bs)) - - -printBinds (AcyclicSCC bind) = liftIO (putStr "acyclic bind: ") >> printBind (fst bind) >> liftIO (putStrLn "") -printBinds (CyclicSCC binds) = liftIO (putStr "cyclic binds: ") >> mapM_ (printBind . fst) binds >> liftIO (putStrLn "") - - -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 _ = return () - - --- | Computes the variables that are bound by a given piece of syntax. - -class HasBV a where - getBV :: a -> Set Var - -instance HasBV (HsBindLR GhcTc GhcTc) where - getBV (FunBind{fun_id = L _ v}) = Set.singleton v - getBV (PatBind {pat_lhs = pat}) = getBV pat - getBV (VarBind {var_id = v}) = Set.singleton v - getBV PatSynBind{} = Set.empty -#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) -#endif - -instance HasBV a => HasBV (GenLocated b a) where - getBV (L _ e) = getBV e - -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 - -getConBV (PrefixCon _ ps) = getBV ps -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__ < 904 -instance HasBV CoPat where - getBV CoPat {co_pat_inner = p} = getBV p -#else -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) -#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'] - _ -> 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 - getBV (ConPat {pat_args = con}) = getConBV con - getBV (SigPat _ p _) = getBV p - -#if __GLASGOW_HASKELL__ < 904 -instance HasBV NoExtCon where - getBV _ = Set.empty -#endif - --- | Syntax that may contain variables. -class HasFV a where - -- | Compute the set of variables occurring in the given piece of - -- syntax. The name falsely suggests that returns free variables, - -- but in fact it returns all variable occurrences, no matter - -- whether they are free or bound. - getFV :: a -> Set Var - -instance HasFV a => HasFV (GenLocated b a) where - getFV (L _ e) = getFV e - -instance HasFV a => HasFV [a] where - getFV es = foldMap getFV es - -instance HasFV a => HasFV (Bag a) where - getFV es = foldMap getFV es - -instance HasFV Var where - getFV v = Set.singleton v - -instance HasFV a => HasFV (MatchGroup GhcTc a) where - getFV MG {mg_alts = alts} = getFV alts - -instance HasFV a => HasFV (Match GhcTc a) where - getFV Match {m_grhss = rhss} = getFV rhss - -instance HasFV (HsTupArg GhcTc) where - getFV (Present _ e) = getFV e - getFV Missing {} = Set.empty - -instance HasFV a => HasFV (GRHS GhcTc a) where - getFV (GRHS _ g b) = getFV g `Set.union` getFV b - -instance HasFV a => HasFV (GRHSs GhcTc a) where - getFV GRHSs {grhssGRHSs = rhs, grhssLocalBinds = lbs} = - getFV rhs `Set.union` getFV lbs - - -instance HasFV (HsLocalBindsLR GhcTc GhcTc) where - getFV (HsValBinds _ bs) = getFV bs - getFV (HsIPBinds _ bs) = getFV bs - getFV EmptyLocalBinds {} = Set.empty - -instance HasFV (HsValBindsLR GhcTc GhcTc) where - getFV (ValBinds _ b _) = getFV b - getFV (XValBindsLR b) = getFV b - -instance HasFV (NHsValBindsLR GhcTc) where - getFV (NValBinds bs _) = foldMap (getFV . snd) bs - -instance HasFV (HsBindLR GhcTc GhcTc) where - getFV FunBind {fun_matches = ms} = getFV ms - getFV PatBind {pat_rhs = rhs} = getFV rhs - getFV VarBind {var_rhs = rhs} = getFV rhs - 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 - -instance HasFV (IPBind GhcTc) where - getFV (IPBind _ _ e) = getFV e - -instance HasFV (HsIPBinds GhcTc) where - getFV (IPBinds _ bs) = getFV bs - -instance HasFV (ApplicativeArg GhcTc) where - getFV ApplicativeArgOne { arg_expr = e } = getFV e - getFV ApplicativeArgMany {app_stmts = es, final_expr = e} = getFV es `Set.union` getFV e - -instance HasFV (ParStmtBlock GhcTc GhcTc) where - getFV (ParStmtBlock _ es _ _) = getFV es - -instance HasFV a => HasFV (StmtLR GhcTc GhcTc a) where - getFV (LastStmt _ e _ _) = getFV e - getFV (BindStmt _ _ e) = getFV e - 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 - - -instance HasFV (HsRecFields GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))) where - getFV HsRecFields{rec_flds = fs} = getFV fs - -#if __GLASGOW_HASKELL__ >= 904 -instance HasFV (HsFieldBind o (GenLocated SrcSpanAnnA (HsExpr GhcTc))) where -#else -instance HasFV (HsRecField' o (GenLocated SrcSpanAnnA (HsExpr GhcTc))) where -#endif - 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 - -instance HasFV (HsCmd GhcTc) where - getFV (HsCmdArrApp _ e1 e2 _ _) = getFV e1 `Set.union` getFV e2 - 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 (HsCmdCase _ _ mg) = getFV mg - getFV (HsCmdIf _ _ e1 e2 e3) = getFV e1 `Set.union` getFV e2 `Set.union` getFV e3 - getFV (HsCmdDo _ cmd) = getFV cmd -#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 -#else - getFV (HsCmdLamCase _ mg) = getFV mg -#endif - getFV (XCmd e) = getFV e - - -instance (HasFV a, HasFV b) => HasFV (Either a b) where - getFV (Left x) = getFV x - getFV (Right x) = getFV x - -#if __GLASGOW_HASKELL__ >= 908 -instance HasFV (LHsRecUpdFields GhcTc) where - getFV RegularRecUpdFields {recUpdFields = x} = getFV x - getFV OverloadedRecUpdFields {olRecUpdFields = x} = getFV x -#endif - -instance HasFV (HsCmdTop GhcTc) where - getFV (HsCmdTop _ cmd) = getFV cmd - -instance HasFV (HsExpr GhcTc) where - getFV (HsVar _ v) = getFV v - getFV HsUnboundVar {} = Set.empty - getFV HsOverLabel {} = Set.empty - getFV HsIPVar {} = Set.empty - getFV HsOverLit {} = Set.empty - getFV HsLit {} = Set.empty - getFV (HsLam _ 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 (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 (HsDo _ _ e) = getFV e - 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` getFV fs - getFV (RecordCon {rcon_flds = fs}) = getFV fs - getFV (ArithSeq _ _ e) = getFV e -#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 (XExpr e) = getFV e -#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 -#else - getFV (HsAppType _ e _) = getFV e - getFV (ExprWithTySig _ e _) = getFV e -#endif - getFV (HsIf _ e1 e2 e3) = getFV e1 `Set.union` getFV e2 `Set.union` getFV e3 - getFV (HsPragE _ _ e) = getFV e - - -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 diff --git a/src/AsyncRattus/Plugin/PrimExpr.hs b/src/AsyncRattus/Plugin/PrimExpr.hs deleted file mode 100644 --- a/src/AsyncRattus/Plugin/PrimExpr.hs +++ /dev/null @@ -1,109 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module AsyncRattus.Plugin.PrimExpr ( - Prim (..), - PrimInfo (..), - function, - prim, - isPrimExpr -) where - -import Data.Map (Map) -import qualified Data.Map as Map -import GHC.Plugins -import AsyncRattus.Plugin.Utils -import Prelude hiding ((<>)) - -data Prim = Delay | Adv | Box | Select - --- DelayApp has the following fields: Var = delay f, T1 = value type, T2 = later type (O v a) --- AdvApp has the following fields: Var = adv f, TypedArg = var and type for arg -data PrimInfo = DelayApp Var Type | AdvApp Var TypedArg | BoxApp Var | SelectApp Var TypedArg TypedArg - -type TypedArg = (Var, Type) - -data PartialPrimInfo = PartialPrimInfo { - primPart :: Prim, - functionPart :: Var, - args :: [Var], - typeArgs :: [Type] -} - -instance Outputable PartialPrimInfo where - ppr (PartialPrimInfo Delay f _ typeArgs) = text "PartialPrimInfo { prim = Delay, function = " <> ppr f <> text "args = (not printing since it should be undefined) , typeArgs = " <> ppr typeArgs - ppr (PartialPrimInfo prim f args typeArgs) = text "PartialPrimInfo { prim = " <> ppr prim <> text ", function = " <> ppr f <> text ", args = " <> ppr args <> text ", typeArgs = " <> ppr typeArgs - -instance Outputable Prim where - ppr Delay = "delay" - ppr Adv = "adv" - ppr Select = "select" - ppr Box = "box" - -instance Outputable PrimInfo where - ppr (DelayApp f _) = text "DelayApp - function " <> ppr f - ppr (BoxApp f) = text "BoxApp - function " <> ppr f - ppr (AdvApp f arg) = text "AdvApp - function " <> ppr f <> text " | arg " <> ppr arg - ppr (SelectApp f arg arg2) = text "SelectApp - function " <> ppr f <> text " | arg " <> ppr arg <> text " | arg2 " <> ppr arg2 - -primMap :: Map FastString Prim -primMap = Map.fromList - [("delay", Delay), - ("adv", Adv), - ("select", Select), - ("box", Box) - ] - - -isPrim :: Var -> Maybe Prim -isPrim v = case getNameModule v of - Just (name, mod) | isRattModule mod -> Map.lookup name primMap - _ -> Nothing - -createPartialPrimInfo :: Prim -> Var -> PartialPrimInfo -createPartialPrimInfo prim function = - PartialPrimInfo { - primPart = prim, - functionPart = function, - args = [], - typeArgs = [] - } - -function :: PrimInfo -> Var -function (DelayApp f _) = f -function (BoxApp f) = f -function (AdvApp f _) = f -function (SelectApp f _ _) = f - -prim :: PrimInfo -> Prim -prim (DelayApp {}) = Delay -prim (BoxApp _) = Box -prim (AdvApp {}) = Adv -prim (SelectApp {}) = Select - -validatePartialPrimInfo :: PartialPrimInfo -> Maybe PrimInfo -validatePartialPrimInfo (PartialPrimInfo Select f [arg2V, argV] [arg2T, argT]) = Just $ SelectApp f (argV, argT) (arg2V, arg2T) -validatePartialPrimInfo (PartialPrimInfo Delay f [_] [argT]) = Just $ DelayApp f argT -validatePartialPrimInfo (PartialPrimInfo {primPart = Box, functionPart = f}) = Just $ BoxApp f -validatePartialPrimInfo (PartialPrimInfo Adv f [argV] [argT]) = Just $ AdvApp f (argV, argT) -validatePartialPrimInfo _ = Nothing - -isPrimExpr :: Expr Var -> Maybe PrimInfo -isPrimExpr expr = isPrimExpr' expr >>= validatePartialPrimInfo - -isPrimExpr' :: Expr Var -> Maybe PartialPrimInfo -isPrimExpr' (App e (Type t)) = case mPPI of - Just pPI@(PartialPrimInfo {typeArgs = tArgs}) -> Just pPI {typeArgs = t : tArgs} - Nothing -> Nothing - where mPPI = isPrimExpr' e -isPrimExpr' (App e e') = - case isPrimExpr' e of - Just partPrimInfo@(PartialPrimInfo { primPart = Delay, args = args}) -> Just partPrimInfo {args = undefined : args} - Just partPrimInfo@(PartialPrimInfo { args = args}) -> Just partPrimInfo {args = maybe args (:args) (getMaybeVar e')} - _ -> Nothing -isPrimExpr' (Var v) = case isPrim v of - Just p -> Just $ createPartialPrimInfo p v - Nothing -> Nothing -isPrimExpr' (Tick _ e) = isPrimExpr' e -isPrimExpr' (Lam v e) - | isTyVar v || (not $ tcIsLiftedTypeKind $ typeKind $ varType v) = isPrimExpr' e -isPrimExpr' _ = Nothing diff --git a/src/AsyncRattus/Plugin/ScopeCheck.hs b/src/AsyncRattus/Plugin/ScopeCheck.hs deleted file mode 100644 --- a/src/AsyncRattus/Plugin/ScopeCheck.hs +++ /dev/null @@ -1,812 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE CPP #-} - - - --- | This module implements the source plugin that checks the variable --- scope of of Async Rattus programs. - -module AsyncRattus.Plugin.ScopeCheck (checkAll) where - -import AsyncRattus.Plugin.Utils -import AsyncRattus.Plugin.Dependency -import AsyncRattus.Plugin.Annotation - -import Control.Monad.Trans.State.Strict -import Data.IORef - -import Prelude hiding ((<>)) - -import GHC.Parser.Annotation -import GHC.Plugins -import GHC.Tc.Types -import GHC.Data.Bag -import GHC.Tc.Types.Evidence -import GHC.Hs.Extension -import GHC.Hs.Expr -import GHC.Hs.Pat -import GHC.Hs.Binds - -import Data.Graph -import qualified Data.Set as Set -import qualified Data.Map as Map -import Data.Set (Set) -import Data.Map (Map) -import Data.List -import Data.List.NonEmpty (NonEmpty(..),(<|),nonEmpty) -import System.Exit -import Data.Either -import Data.Maybe - -import Data.Data hiding (tyConName) - -import Control.Monad - -type ErrorMsg = (Severity,SrcSpan,SDoc) -type ErrorMsgsRef = IORef [ErrorMsg] - --- | The current context for scope checking -data Ctxt = Ctxt - { - errorMsgs :: ErrorMsgsRef, - -- | Variables that are in scope now (i.e. occurring in the typing - -- context but not to the left of a tick) - current :: LCtxt, - -- | Variables that are in the typing context, but to the left of a - -- tick - earlier :: Either NoTickReason (NonEmpty LCtxt), - -- | Variables that have fallen out of scope. The map contains the - -- reason why they have fallen out of scope. - hidden :: Hidden, - -- -- | Same as 'hidden' but for recursive variables. - -- hiddenRec :: Hidden, - -- | The current location information. - srcLoc :: SrcSpan, - -- | If we are in the body of a recursively defined function, this - -- field contains the variables that are defined recursively - -- (could be more than one due to mutual recursion or because of a - -- recursive pattern definition) and the location of the recursive - -- definition. - recDef :: Maybe RecDef, - -- | Type variables with a 'Stable' constraint attached to them. - stableTypes :: Set Var, - -- | A mapping from variables to the primitives that they are - -- defined equal to. For example, a program could contain @let - -- mydel = delay in mydel 1@, in which case @mydel@ is mapped to - -- 'Delay'. - primAlias :: Map Var Prim, - -- | Allow general recursion. - allowRecursion :: Bool} - - - --- | The starting context for checking a top-level definition. For --- 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) -> Bool -> Ctxt -emptyCtxt em mvar allowRec = - Ctxt { errorMsgs = em, - current = Set.empty, - earlier = Left NoDelay, - hidden = Map.empty, - srcLoc = noLocationInfo, - recDef = mvar, - primAlias = Map.empty, - stableTypes = Set.empty, - allowRecursion = allowRec} - --- | A local context, consisting of a set of variables. -type LCtxt = Set Var - --- | The recursively defined variables + the position where the --- recursive definition starts -type RecDef = (Set Var, SrcSpan) - - - - -data StableReason = StableRec SrcSpan | StableBox deriving Show - --- | Indicates, why a variable has fallen out of scope. -data HiddenReason = Stabilize StableReason | FunDef | DelayApp | AdvApp | SelectApp deriving Show - --- | Indicates, why there is no tick -data NoTickReason = NoDelay | TickHidden HiddenReason deriving Show - --- | Hidden context, containing variables that have fallen out of --- context along with the reason why they have. -type Hidden = Map Var HiddenReason - --- | The 5 primitive Asynchronous Rattus operations. -data Prim = Delay | Adv | Select | Box | Unbox deriving Show - --- | This constraint is used to pass along the context implicitly via --- an implicit parameter. -type GetCtxt = ?ctxt :: Ctxt - - -type CheckM = StateT ([Maybe (Prim, SrcSpan)]) TcM - --- | This type class is implemented for each AST type @a@ for which we --- can check whether it adheres to the scoping rules of Asynchronous Rattus. -class Scope a where - -- | Check whether the argument is a scope correct piece of syntax - -- in the given context. - check :: GetCtxt => a -> CheckM Bool - --- | This is a variant of 'Scope' for syntax that can also bind --- variables. -class ScopeBind a where - -- | 'checkBind' checks whether its argument is scope-correct and in - -- addition returns the the set of variables bound by it. - checkBind :: GetCtxt => a -> CheckM (Bool,Set Var) - - --- | set the current context. -setCtxt :: Ctxt -> (GetCtxt => a) -> a -setCtxt c a = let ?ctxt = c in a - - --- | modify the current context. -modifyCtxt :: (Ctxt -> Ctxt) -> (GetCtxt => a) -> (GetCtxt => a) -modifyCtxt f a = - let newc = f ?ctxt in - let ?ctxt = newc in a - - - - -getLocAnn' :: SrcSpanAnn' b -> SrcSpan -getLocAnn' = locA - - -updateLoc :: SrcSpanAnn' b -> (GetCtxt => a) -> (GetCtxt => a) -updateLoc src = modifyCtxt (\c -> c {srcLoc = getLocAnn' src}) - - --- | Check all definitions in the given module. If Scope errors are --- found, the current execution is halted with 'exitFailure'. -checkAll :: TcGblEnv -> TcM () -checkAll env = do - 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 - if res then return () else liftIO exitFailure - - -printAccErrMsgs :: [ErrorMsg] -> TcM () -printAccErrMsgs msgs = mapM_ printMsg (sortOn (\(_,l,_)->l) msgs) - where printMsg (sev,loc,doc) = printMessage sev loc doc - - - - -instance Scope a => Scope (GenLocated SrcSpan a) where - check (L l x) = (\c -> c {srcLoc = l}) `modifyCtxt` check x - -instance Scope a => Scope (GenLocated (SrcSpanAnn' b) a) where - check (L l x) = updateLoc l $ check x - -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 (Match GhcTc (GenLocated SrcAnno (HsExpr GhcTc))) where - check Match{m_pats=ps,m_grhss=rhs} = addVars (getBV ps) `modifyCtxt` check rhs - -instance Scope (Match GhcTc (GenLocated SrcAnno (HsCmd GhcTc))) where - check Match{m_pats=ps,m_grhss=rhs} = addVars (getBV ps) `modifyCtxt` check rhs - - -instance Scope (MatchGroup GhcTc (GenLocated SrcAnno (HsExpr GhcTc))) where - check MG {mg_alts = alts} = check alts - - -instance Scope (MatchGroup GhcTc (GenLocated SrcAnno (HsCmd GhcTc))) where - check MG {mg_alts = alts} = check alts - - -instance Scope a => ScopeBind (StmtLR GhcTc GhcTc a) where - checkBind (LastStmt _ b _ _) = ( , Set.empty) <$> check b - checkBind (BindStmt _ p b) = do - let vs = getBV p - let c' = addVars vs ?ctxt - r <- setCtxt c' (check b) - return (r,vs) - checkBind (BodyStmt _ b _ _) = ( , Set.empty) <$> check b - checkBind (LetStmt _ bs) = checkBind bs - checkBind ParStmt{} = notSupported "monad comprehensions" - checkBind TransStmt{} = notSupported "monad comprehensions" - checkBind ApplicativeStmt{} = notSupported "applicative do notation" - checkBind RecStmt{} = notSupported "recursive do notation" - -instance ScopeBind a => ScopeBind [a] where - checkBind [] = return (True,Set.empty) - checkBind (x:xs) = do - (r,vs) <- checkBind x - (r',vs') <- addVars vs `modifyCtxt` (checkBind xs) - return (r && r',vs `Set.union` vs') - -instance ScopeBind a => ScopeBind (GenLocated SrcSpan a) where - checkBind (L l x) = (\c -> c {srcLoc = l}) `modifyCtxt` checkBind x - -instance ScopeBind a => ScopeBind (GenLocated (SrcSpanAnn' b) a) where - checkBind (L l x) = updateLoc l $ checkBind x - -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') - -checkRec :: GetCtxt => LHsBindLR GhcTc GhcTc -> CheckM Bool -checkRec b = liftM2 (&&) (checkPatBind b) (check b) - -checkPatBind :: GetCtxt => LHsBindLR GhcTc GhcTc -> CheckM Bool -checkPatBind (L l b) = updateLoc l $ checkPatBind' b - -checkPatBind' :: GetCtxt => HsBindLR GhcTc GhcTc -> CheckM Bool -checkPatBind' PatBind{} = do - printMessage' SevError ("(Mutual) recursive pattern binding definitions are not supported in Asynchronous Rattus") - return False -#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 - - --- | Check the scope of a list of (mutual) recursive bindings. The --- second argument is the set of variables defined by the (mutual) --- recursive bindings -checkRecursiveBinds :: GetCtxt => [LHsBindLR GhcTc GhcTc] -> Set Var -> CheckM (Bool, Set Var) -checkRecursiveBinds bs vs = do - res <- fmap and (mapM check' bs) - return (res, vs) - 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, - earlier = Left (TickHidden $ Stabilize $ StableRec l), - hidden = hidden c `Map.union` - (Map.fromSet (const (Stabilize (StableRec l))) ctxHid), - recDef = maybe (Just (vs,l)) (\(vs',_) -> Just (Set.union vs' vs,l)) (recDef c) - -- TODO fix location info of recDef (needs one location for each var) - } - - -instance ScopeBind (SCC (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var)) where - checkBind (AcyclicSCC (b,vs)) = (, vs) <$> check b - checkBind (CyclicSCC bs) = checkRecursiveBinds (map fst bs) (foldMap snd bs) - -instance ScopeBind (HsValBindsLR GhcTc GhcTc) where - checkBind (ValBinds _ bs _) = checkBind (dependency bs) - - checkBind (XValBindsLR (NValBinds binds _)) = checkBind binds - - -instance ScopeBind (HsBindLR GhcTc GhcTc) where - checkBind b = (, getBV b) <$> check b - - --- | Compute the set of variables defined by the given Haskell binder. -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 - - --- Check nested bindings -instance ScopeBind (RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))) where - checkBind (NonRecursive, bs) = checkBind $ bagToList bs - checkBind (Recursive, bs) = checkRecursiveBinds bs' (foldMap getAllBV bs') - where bs' = bagToList bs - - -instance ScopeBind (HsLocalBindsLR GhcTc GhcTc) where - checkBind (HsValBinds _ bs) = checkBind bs - checkBind HsIPBinds {} = notSupported "implicit parameters" - checkBind EmptyLocalBinds{} = return (True,Set.empty) - -type SrcAnno = SrcSpanAnnA - -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) - -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) - -instance Show Var where - show v = getOccString v - - -tickHidden :: HiddenReason -> SDoc -tickHidden FunDef = "a function definition" -tickHidden DelayApp = "a nested application of delay" -tickHidden AdvApp = "an application of adv" -tickHidden SelectApp = "an application of select" -tickHidden (Stabilize StableBox) = "an application of box" -tickHidden (Stabilize (StableRec src)) = "a nested recursive definition (at " <> ppr src <> ")" - -isSelect :: GetCtxt => LHsExpr GhcTc -> Bool -isSelect e = - case isPrimExpr e of - Just (Select, _) -> True - _ -> False - -instance Scope (HsExpr GhcTc) where - check (HsVar _ (L _ v)) - | Just p <- isPrim v = - case p of - Unbox -> return True - _ -> printMessageCheck SevError ("Defining an alias for " <> ppr v <> " is not allowed") - | otherwise = case getScope v of - Hidden reason -> printMessageCheck SevError reason - Visible -> return True - ImplUnboxed -> return True - -- printMessageCheck SevWarning - -- (ppr v <> text " is an external temporal function used under delay, which may cause time leaks.") - check (HsApp _ (L _ (HsApp _ f arg)) arg2) | isSelect f = - case earlier ?ctxt of - Right (er :| ers) -> do - res <- get - case res of - Just _ : _ -> printMessageCheck SevError ("only one adv or select may be used in the scope of a delay.") - Nothing : pre -> do put pre - b1 <- mod `modifyCtxt` check arg - b2 <- mod `modifyCtxt` check arg2 - modify (Just (Select, srcLoc ?ctxt) :) - return $ b1 && b2 - _ -> error "Asynchronous Rattus: internal error" - where mod c = c{earlier = case nonEmpty ers of - Nothing -> Left $ TickHidden SelectApp - Just ers' -> Right ers', - current = er, - hidden = hidden ?ctxt `Map.union` - Map.fromSet (const SelectApp) (current ?ctxt)} - Left NoDelay -> printMessageCheck SevError "select may only be used in the scope of a delay." - Left (TickHidden hr) -> printMessageCheck SevError ("select may only be used in the scope of a delay. " - <> " There is a delay, but its scope is interrupted by " <> tickHidden hr <> ".") - check (HsApp _ e1 e2) = - case isPrimExpr e1 of - Just (p,_) -> case p of - Box -> do - ch <- stabilize StableBox `modifyCtxt` check e2 - return ch - Unbox -> check e2 - Delay -> do modify (Nothing :) - b <- (\c -> c{current = Set.empty, - earlier = case earlier c of - Left _ -> Right (current c :| []) - Right cs -> Right (current c <| cs)}) - `modifyCtxt` check e2 - res <- get - case res of - Nothing : _ -> printMessageCheck SevError "No adv or select found in the scope of this occurrence of delay" - _ : pre -> put pre >> return b - _ -> error "Asynchronous Rattus: internal error" - Adv -> case earlier ?ctxt of - Right (er :| ers) -> do - res <- get - case res of - Just _ : _ -> printMessageCheck SevError ("only one adv or select may be used in the scope of a delay.") - Nothing : pre -> do put pre - b <- mod `modifyCtxt` check e2 - modify (Just (Adv,srcLoc ?ctxt) :) - return b - _ -> error "Asynchronous Rattus: internal error" - where mod c = c{earlier = case nonEmpty ers of - Nothing -> Left $ TickHidden AdvApp - Just ers' -> Right ers', - current = er, - hidden = hidden ?ctxt `Map.union` - Map.fromSet (const AdvApp) (current ?ctxt)} - Left NoDelay -> printMessageCheck SevError ("adv may only be used in the scope of a delay.") - Left (TickHidden hr) -> printMessageCheck SevError ("adv may only be used in the scope of a delay. " - <> " There is a delay, but its scope is interrupted by " <> tickHidden hr <> ".") - Select -> printMessageCheck SevError ("select must be fully applied") - _ -> 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 HsLit{} = return True - check (OpApp _ e1 e2 e3) = and <$> mapM check [e1,e2,e3] - check (HsLam _ 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 (NegApp _ e _) = check e - check (ExplicitSum _ _ _ e) = check e - check (HsMultiIf _ e) = check e - check (ExplicitList _ e) = check e - check HsProjection {} = return True - check HsGetField {gf_expr = e} = check e - check RecordUpd { rupd_expr = e, rupd_flds = fs} = (&&) <$> check e <*> check fs - check RecordCon { rcon_flds = f} = check f - check (ArithSeq _ _ e) = check e -#if __GLASGOW_HASKELL__ >= 906 - check HsTypedSplice{} = notSupported "Template Haskell" - check HsUntypedSplice{} = notSupported "Template Haskell" -#else - check HsSpliceE{} = notSupported "Template Haskell" -#endif - check (HsProc _ _ e) = check e - check (HsStatic _ e) = check e - check (HsDo _ _ e) = fst <$> checkBind e - check (XExpr e) = check e -#if __GLASGOW_HASKELL__ >= 906 - check (HsAppType _ e _ _) = check e - check (ExprWithTySig _ e _) = check e -#else - check (HsAppType _ e _) = check e - check (ExprWithTySig _ e _) = check e -#endif - check (HsPragE _ _ e) = check e - check (HsIf _ e1 e2 e3) = and <$> mapM check [e1,e2,e3] - - -instance (Scope a, Scope b) => Scope (Either a b) where - check (Left x) = check x - check (Right x) = check x - - -#if __GLASGOW_HASKELL__ >= 908 -instance Scope (LHsRecUpdFields GhcTc) where - check RegularRecUpdFields {recUpdFields = x} = check x - check OverloadedRecUpdFields {olRecUpdFields = x} = check x -#endif - - -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 - -instance Scope (HsCmdTop GhcTc) where - check (HsCmdTop _ e) = check e - -instance Scope (HsCmd GhcTc) where - check (HsCmdArrApp _ e1 e2 _ _) = (&&) <$> check e1 <*> check e2 - check (HsCmdDo _ e) = fst <$> checkBind e - 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 (HsCmdLamCase _ e) = check e - 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 - check (XCmd (HsWrap _ e)) = check e - - -instance Scope (ArithSeqInfo GhcTc) where - check (From e) = check e - check (FromThen e1 e2) = (&&) <$> check e1 <*> check e2 - check (FromTo e1 e2) = (&&) <$> check e1 <*> check e2 - check (FromThenTo e1 e2 e3) = (&&) <$> ((&&) <$> check e1 <*> check e2) <*> check e3 - -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 - check Missing{} = return True - -instance Scope (HsBindLR GhcTc GhcTc) where -#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, - fun_ext = wrapper} = - mod `modifyCtxt` check matches - where mod c = c { stableTypes= stableTypes c `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 - check PatSynBind {} = return True -- pattern synonyms are not supported - - --- | Checks whether the given type is a type constraint of the form --- @Stable a@ for some type variable @a@. In that case it returns the --- type variable @a@. -isStableConstr :: Type -> Maybe TyVar -isStableConstr t = - case splitTyConApp_maybe t of - Just (con,[args]) -> - case getNameModule con of - Just (name, mod) -> - if isRattModule mod && name == "Stable" - then (getTyVar_maybe args) - else Nothing - _ -> Nothing - _ -> 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) -stableConstrFromWrapper _ = [] - - --- | Given a type @(C1, ... Cn) => t@, this function returns the list --- of type variables @[a1,...,am]@ for which there is a constraint --- @Stable ai@ among @C1, ... Cn@. -extractStableConstr :: Type -> [TyVar] -extractStableConstr = mapMaybe isStableConstr . map irrelevantMult . fst . splitFunTys . snd . splitForAllTys' - - -getSCCLoc :: SCC (LHsBindLR GhcTc GhcTc, Set Var) -> SrcSpan -getSCCLoc (AcyclicSCC (L l _ ,_)) = getLocAnn' l -getSCCLoc (CyclicSCC ((L l _,_ ) : _)) = getLocAnn' l -getSCCLoc _ = noLocationInfo - -checkSCC' :: Module -> AnnEnv -> SCC (LHsBindLR GhcTc GhcTc, Set Var) -> TcM (Bool, [ErrorMsg]) -checkSCC' mod anEnv scc = do - err <- liftIO (newIORef []) - let allowRec = AllowRecursion `Set.member` getAnn mod anEnv scc - res <- checkSCC allowRec err scc - msgs <- liftIO (readIORef err) - 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.")]) - else if any (\(s,_,_) -> case s of SevWarning -> True; _ -> False) msgs - then return (res, filter (\(s,_,_) -> case s of SevWarning -> False; _ -> True) msgs) - else return (False,[(SevError, getSCCLoc scc, "Warning was expected, but typechecking produced no warning.")]) - else if ExpectError `Set.member` anns - then if res - then return (False,[(SevError, getSCCLoc scc, "Error was expected, but typechecking produced no error.")]) - else return (True,[]) - else return (res, msgs) -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 a - checkVar v = - 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 - - - --- | Checks a top-level definition group, which is either a single --- non-recursive definition or a group of (mutual) recursive --- definitions. - -checkSCC :: Bool -> ErrorMsgsRef -> SCC (LHsBindLR GhcTc GhcTc, Set Var) -> TcM Bool -checkSCC allowRec errm (AcyclicSCC (b,_)) = setCtxt (emptyCtxt errm Nothing allowRec) (evalStateT (check b) []) - -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)) allowRec) (evalStateT (checkRec b) []) - --- | Stabilizes the given context, i.e. remove all non-stable types --- and any tick. This is performed on checking 'box', and --- guarded recursive definitions. To provide better error messages a --- reason has to be given as well. -stabilize :: StableReason -> Ctxt -> Ctxt -stabilize sr c = c - {current = Set.empty, - earlier = Left $ TickHidden hr, - hidden = hidden c `Map.union` Map.fromSet (const hr) ctxHid} - where ctxHid = either (const $ current c) (foldl' Set.union (current c)) (earlier c) - hr = Stabilize sr - -data VarScope = Hidden SDoc | Visible | ImplUnboxed - - --- | This function checks whether the given variable is in scope. -getScope :: GetCtxt => Var -> VarScope -getScope v = - case ?ctxt of - 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") - Left (TickHidden hr) -> Hidden ("The (mutually) recursive call to " <> ppr v <> " must occur in the scope of a delay. " - <> "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)) || 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.") - Just (Stabilize StableBox) -> - if (isStable (stableTypes ?ctxt) (varType v)) then Visible - else 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.") - Just AdvApp -> Hidden ("Variable " <> ppr v <> " is no longer in scope: It occurs under adv.") - Just SelectApp -> Hidden ("Variable " <> ppr v <> " is no longer in scope: It occurs under select.") - Just DelayApp -> Hidden ("Variable " <> ppr v <> " is no longer in scope due to repeated application of delay") - Just FunDef -> if (isStable (stableTypes ?ctxt) (varType v)) then Visible - else Hidden ("Variable " <> ppr v <> " is no longer in scope: It occurs in a function that is defined under a delay, is a of a non-stable type " <> ppr (varType v) <> ", and is bound outside delay") - Nothing - | either (const False) (any (Set.member v)) (earlier ?ctxt) -> - if isStable (stableTypes ?ctxt) (varType v) then Visible - else Hidden ("Variable " <> ppr v <> " is no longer in scope:" $$ - "It occurs under delay" $$ "and is of type " <> ppr (varType v) <> ", which is not stable.") - | Set.member v (current ?ctxt) -> Visible - | isTemporal (varType v) && isRight (earlier ?ctxt) && userFunction v - -> ImplUnboxed - | otherwise -> Visible - --- | A map from the syntax of a primitive of Asynchronous Rattus to 'Prim'. -primMap :: Map FastString Prim -primMap = Map.fromList - [("Delay", Delay), - ("delay", Delay), - ("adv", Adv), - ("select", Select), - ("box", Box), - ("unbox", Unbox)] - - --- | Checks whether a given variable is in fact an Asynchronous Rattus primitive. -isPrim :: GetCtxt => Var -> Maybe Prim -isPrim v - | Just p <- Map.lookup v (primAlias ?ctxt) = Just p - | otherwise = do - (name,mod) <- getNameModule v - if isRattModule mod then Map.lookup name primMap - else Nothing - - --- | Checks whether a given expression is in fact a Asynchronous Rattus primitive. -isPrimExpr :: GetCtxt => LHsExpr GhcTc -> Maybe (Prim,Var) -isPrimExpr (L _ e) = isPrimExpr' e where - isPrimExpr' :: GetCtxt => HsExpr GhcTc -> Maybe (Prim,Var) - isPrimExpr' (HsVar _ (L _ v)) = fmap (,v) (isPrim v) -#if __GLASGOW_HASKELL__ >= 906 - isPrimExpr' (HsAppType _ e _ _) = isPrimExpr e -#else - isPrimExpr' (HsAppType _ e _) = isPrimExpr e -#endif - - isPrimExpr' (XExpr (WrapExpr (HsWrap _ e))) = isPrimExpr' e - isPrimExpr' (XExpr (ExpansionExpr (HsExpanded _ e))) = isPrimExpr' e - isPrimExpr' (HsPragE _ _ e) = isPrimExpr e -#if __GLASGOW_HASKELL__ < 904 - isPrimExpr' (HsTick _ _ 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 - - --- | This type class provides default implementations for 'check' and --- 'checkBind' for Haskell syntax that is not supported. These default --- implementations simply print an error message. -class NotSupported a where - notSupported :: GetCtxt => SDoc -> CheckM a - -instance NotSupported Bool where - notSupported doc = printMessageCheck SevError ("Asynchronous Rattus does not support " <> doc) - -instance NotSupported (Bool,Set Var) where - notSupported doc = (,Set.empty) <$> notSupported doc - - --- | Add variables to the current context. -addVars :: Set Var -> Ctxt -> Ctxt -addVars vs c = c{current = vs `Set.union` current c } - --- | Print a message with the current location. -printMessage' :: GetCtxt => Severity -> SDoc -> CheckM () -printMessage' sev doc = - liftIO (modifyIORef (errorMsgs ?ctxt) ((sev ,srcLoc ?ctxt, doc) :)) - --- | Print a message with the current location. Returns 'False', if --- the severity is 'SevError' and otherwise 'True. -printMessageCheck :: GetCtxt => Severity -> SDoc -> CheckM Bool -printMessageCheck sev doc = printMessage' sev doc >> - case sev of - SevError -> return False - _ -> return True diff --git a/src/AsyncRattus/Plugin/SingleTick.hs b/src/AsyncRattus/Plugin/SingleTick.hs deleted file mode 100644 --- a/src/AsyncRattus/Plugin/SingleTick.hs +++ /dev/null @@ -1,226 +0,0 @@ --- | This module implements the translation from the multi-tick --- calculus to the single tick calculus. - -{-# LANGUAGE CPP #-} - -module AsyncRattus.Plugin.SingleTick - (toSingleTick) where - -#if __GLASGOW_HASKELL__ >= 900 -import GHC.Plugins -#else -import GhcPlugins -#endif - - -import AsyncRattus.Plugin.Utils -import Prelude hiding ((<>)) -import Control.Monad.Trans.Writer.Strict -import Control.Monad.Trans.Class -import Data.List - --- | Transform the given expression from the multi-tick calculus into --- the single tick calculus form. -toSingleTick :: CoreExpr -> CoreM CoreExpr -toSingleTick (Let (Rec bs) e) = do - e' <- toSingleTick e - bs' <- mapM (mapM toSingleTick) bs - return (Let (Rec bs') e') -toSingleTick (Let (NonRec b e1) e2) = do - e1' <- toSingleTick e1 - e2' <- toSingleTick e2 - return (Let (NonRec b e1') e2') -toSingleTick (Case e b ty alts) = do - e' <- toSingleTick e - 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 - return (Cast e' c) -toSingleTick (Tick t e) = do - e' <- toSingleTick e - return (Tick t e') -toSingleTick (Lam x e) = do - (e', advs) <- runWriterT (extractAdv' e) - advs' <- mapM (\ (x,a,b) -> fmap (\b' -> (x,a,b')) (toSingleTick b)) advs - return (foldLets' advs' (Lam x e')) -toSingleTick (App e1 e2) - | isDelayApp e1 = do - (e2', advs) <- runWriterT (extractAdv e2) - advs' <- mapM (mapM toSingleTick) advs - return (foldLets advs' (App e1 e2')) - | otherwise = do - e1' <- toSingleTick e1 - e2' <- toSingleTick e2 - return (App e1' e2') - -toSingleTick e@Type{} = return e -toSingleTick e@Var{} = return e -toSingleTick e@Lit{} = return e -toSingleTick e@Coercion{} = return e - -foldLets :: [(Id,CoreExpr)] -> CoreExpr -> CoreExpr -foldLets ls e = foldl' (\e' (x,b) -> Let (NonRec x b) e') e ls - -foldLets' :: [(Id,CoreExpr,CoreExpr)] -> CoreExpr -> CoreExpr -foldLets' ls e = foldl' (\e' (x,a,b) -> Let (NonRec x (App a b)) e') e ls - -extractAdvApp :: CoreExpr -> CoreExpr -> WriterT [(Id,CoreExpr)] CoreM CoreExpr -extractAdvApp e1 e2 - | isVar e2 = return (App e1 e2) - | otherwise = do - x <- lift (mkSysLocalFromExpr (fsLit "adv") e2) - tell [(x,e2)] - return (App e1 (Var x)) - --- removes casts and ticks from a tree -filterTree :: CoreExpr -> CoreExpr -filterTree (Cast e _) = filterTree e -filterTree (Tick _ e) = filterTree e -filterTree e = e - - -extractSelectApp :: CoreExpr -> CoreExpr -> WriterT [(Id,CoreExpr)] CoreM CoreExpr -extractSelectApp e1 e2 - | isVar e' && isVar e2 = return (App e1 e2) - | isVar e2 = do - x <- lift (mkSysLocalFromExpr (fsLit "selectFreshVar") e') - tell [(x, e')] - return (App (App e (Var x)) e2) - | isVar e' = do - x <- lift (mkSysLocalFromExpr (fsLit "selectFreshVar") e2) - tell [(x, e2)] - return (App e1 (Var x)) - | otherwise = do - x <- lift (mkSysLocalFromExpr (fsLit "selectFreshVar") e') - y <- lift (mkSysLocalFromExpr (fsLit "selectFreshVar") e2) - tell [(x, e')] - tell [(y, e2)] - return (App (App e (Var x)) (Var y)) - where (App e e') = filterTree e1 - - --- This is used to pull adv out of delayed terms. The writer monad --- returns mappings from fresh variables to terms that occur as --- argument of adv. --- --- That is, occurrences of @adv t@ are replaced with @adv x@ (for some --- fresh variable @x@) and the pair @(x,t)@ is returned in the --- writer monad. -extractAdv :: CoreExpr -> WriterT [(Id,CoreExpr)] CoreM CoreExpr -extractAdv (App expr@(App e _) e2) | isSelectApp e = extractSelectApp expr e2 -extractAdv e@(App e1 e2) - | isAdvApp e1 = extractAdvApp e1 e2 - | isSelectApp e1 = extractSelectApp e1 e2 - | isDelayApp e1 = do - (e2', advs) <- lift $ runWriterT (extractAdv e2) - advs' <- mapM (mapM extractAdv) advs - return (foldLets advs' (App e1 e2')) - | isBoxApp e1 = lift $ toSingleTick e - | otherwise = do - e1' <- extractAdv e1 - e2' <- extractAdv e2 - return (App e1' e2') -extractAdv (Lam x e) = do - (e', advs) <- lift $ runWriterT (extractAdv' e) - advs' <- mapM (\ (x,a,b) -> fmap (\b' -> (x,b')) (extractAdvApp a b)) advs - return (foldLets advs' (Lam x e')) -extractAdv (Case e b ty alts) = do - e' <- extractAdv e - 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 - return (Cast e' c) -extractAdv (Tick t e) = do - e' <- extractAdv e - return (Tick t e') -extractAdv e@(Let Rec{} _) = lift $ toSingleTick e -extractAdv (Let (NonRec b e1) e2) = do - e1' <- extractAdv e1 - e2' <- extractAdv e2 - return (Let (NonRec b e1') e2') -extractAdv e@Type{} = return e -extractAdv e@Var{} = return e -extractAdv e@Lit{} = return e -extractAdv e@Coercion{} = return e - --- This is used to pull adv out of lambdas. The writer monad returns --- mappings from fresh variables to occurrences of adv and the term it --- is applied to. --- --- That is occurrences of @adv t@ are replaced with a fresh variable --- @x@ and the triple @(x,adv,t)@ is returned in the writer monad. --- For select a b, the triple @(x, select a, b) is returned in the writer monad. -extractAdv' :: CoreExpr -> WriterT [(Id,CoreExpr,CoreExpr)] CoreM CoreExpr -extractAdv' e@(App e1 e2) - | isAdvApp e1 = do - x <- lift (mkSysLocalFromExpr (fsLit "adv") e) - tell [(x,e1,e2)] - return (Var x) - | isSelectApp e1 = do - x <- lift (mkSysLocalFromExpr (fsLit "select") e) - tell [(x,e1,e2)] - return (Var x) - | isDelayApp e1 = do - (e2', advs) <- lift $ runWriterT (extractAdv e2) - advs' <- mapM (mapM extractAdv') advs - return (foldLets advs' (App e1 e2')) - | isBoxApp e1 = lift $ toSingleTick e - | otherwise = do - e1' <- extractAdv' e1 - e2' <- extractAdv' e2 - return (App e1' e2') -extractAdv' (Lam x e) = do - e' <- extractAdv' e - return (Lam x e') -extractAdv' (Case e b ty alts) = do - e' <- extractAdv' e - 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 - return (Cast e' c) -extractAdv' (Tick t e) = do - e' <- extractAdv' e - return (Tick t e') -extractAdv' e@(Let Rec{} _) = lift $ toSingleTick e -extractAdv' (Let (NonRec b e1) e2) = do - e1' <- extractAdv' e1 - e2' <- extractAdv' e2 - return (Let (NonRec b e1') e2') -extractAdv' e@Type{} = return e -extractAdv' e@Var{} = return e -extractAdv' e@Lit{} = return e -extractAdv' e@Coercion{} = return e - - - -isDelayApp :: CoreExpr -> Bool -isDelayApp = isPrimApp (== "delay") - -isBoxApp :: CoreExpr -> Bool -isBoxApp = isPrimApp (\occ -> occ == "Box" || occ == "box") - -isAdvApp :: CoreExpr -> Bool -isAdvApp = isPrimApp (== "adv") - -isSelectApp :: CoreExpr -> Bool -isSelectApp = isPrimApp (== "select") - -isPrimApp :: (String -> Bool) -> CoreExpr -> Bool -isPrimApp p (App e e') - | isType e' || not (tcIsLiftedTypeKind(typeKind (exprType e'))) = isPrimApp p e - | otherwise = False -isPrimApp p (Cast e _) = isPrimApp p e -isPrimApp p (Tick _ e) = isPrimApp p e -isPrimApp p (Var v) = isPrimVar p v -isPrimApp _ _ = False - -isPrimVar :: (String -> Bool) -> Var -> Bool -isPrimVar p v = maybe False id $ do - let name = varName v - mod <- nameModule_maybe name - let occ = getOccString name - return (p occ - && moduleNameString (moduleName mod) == "AsyncRattus.InternalPrimitives") diff --git a/src/AsyncRattus/Plugin/StableSolver.hs b/src/AsyncRattus/Plugin/StableSolver.hs deleted file mode 100644 --- a/src/AsyncRattus/Plugin/StableSolver.hs +++ /dev/null @@ -1,83 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} - - --- | This module implements a constraint solver plugin for the --- 'Stable' type class. - -module AsyncRattus.Plugin.StableSolver (tcStable) where - -import AsyncRattus.Plugin.Utils - ( getNameModule, isRattModule, isStable ) - -import Prelude hiding ((<>)) - -import GHC.Plugins - (Type, Var, CommandLineOption,tyConSingleDataCon, - mkCoreConApps,getTyVar_maybe) -import GHC.Core -import GHC.Tc.Types.Evidence -import GHC.Core.Class -import GHC.Tc.Types -import GHC.Tc.Types.Constraint - -import Data.Set (Set) -import qualified Data.Set as Set -#if __GLASGOW_HASKELL__ >= 904 -import GHC.Types.Unique.FM -#endif - - - --- | Constraint solver plugin for the 'Stable' type class. -tcStable :: [CommandLineOption] -> Maybe TcPlugin -tcStable _ = Just $ TcPlugin - { tcPluginInit = return () - , tcPluginSolve = \ () -> stableSolver - , tcPluginStop = \ () -> return () -#if __GLASGOW_HASKELL__ >= 904 - , tcPluginRewrite = \ () -> emptyUFM -#endif - } - - -wrap :: Class -> Type -> EvTerm -wrap cls ty = EvExpr appDc - where - tyCon = classTyCon cls - dc = tyConSingleDataCon tyCon - appDc = mkCoreConApps dc [Type ty] - -solveStable :: Set Var -> (Type, (Ct,Class)) -> Maybe (EvTerm, Ct) -solveStable c (ty,(ct,cl)) - | 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 - Just evs -> return $ TcPluginOk evs [] - Nothing -> return $ TcPluginOk [] [] - - where -#if __GLASGOW_HASKELL__ >= 908 - filterCt ct@(CDictCan (DictCt {di_cls = cl, di_tys = [ty]})) -#else - filterCt ct@(CDictCan {cc_class = cl, cc_tyargs = [ty]}) -#endif - = case getNameModule cl of - Just (name,mod) - | isRattModule mod && name == "Stable" -> [(ty,(ct,cl))] - _ -> [] - filterCt _ = [] - filterTypeVar ty = case getTyVar_maybe ty of - Just v -> [v] - Nothing -> [] diff --git a/src/AsyncRattus/Plugin/Strictify.hs b/src/AsyncRattus/Plugin/Strictify.hs deleted file mode 100644 --- a/src/AsyncRattus/Plugin/Strictify.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} -module AsyncRattus.Plugin.Strictify - (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} - --- | 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) - | ignoreArgument 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.")) - checkStrictData ss e1 - checkStrictData ss e2 -checkStrictData _ss _ = return () - -isLit :: CoreExpr -> Bool -isLit Lit{} = True -isLit (App (Var v) Lit{}) - | Just (name,mod) <- getNameModule v = mod == "GHC.CString" && name == "unpackCString#" -isLit _ = False - - -ignoreArgument :: CoreExpr -> Bool -ignoreArgument (Var v) = - case getNameModule v of - Just (name, mod) -> - ((mod == "GHC.Exts" || mod == "GHC.IsList") && (name == "fromList" || name == "fromListN")) || - (mod == "Data.String" && name == "fromString") || - (mod == "GHC.Stack.Types" && name == "pushCallStack") || - (mod == "Data.Text.Internal" && name == "pack") - _ -> False -ignoreArgument (App x _) = ignoreArgument x -ignoreArgument _ = False - -isDeepseqForce :: CoreExpr -> Bool -isDeepseqForce (App (App (App (Var v) _) _) _) = - case getNameModule v of - Just (name, mod) -> mod == "Control.DeepSeq" && name == "force" - _ -> False -isDeepseqForce _ = False diff --git a/src/AsyncRattus/Plugin/Transform.hs b/src/AsyncRattus/Plugin/Transform.hs deleted file mode 100644 --- a/src/AsyncRattus/Plugin/Transform.hs +++ /dev/null @@ -1,143 +0,0 @@ -{-# LANGUAGE TupleSections #-} -module AsyncRattus.Plugin.Transform ( - transform -) where - -import GHC.Core.Opt.Monad -import GHC.Plugins -import AsyncRattus.Plugin.PrimExpr -import AsyncRattus.Plugin.Utils -import Data.Maybe (fromJust) -import Prelude hiding ((<>)) -import Data.Functor ((<&>)) -import Control.Applicative ((<|>)) -import Data.Tuple (swap) - -data Ctx = Ctx { - fresh :: Maybe Var -} - -emptyCtx :: Ctx -emptyCtx = Ctx { - fresh = Nothing -} - -replaceVar :: Var -> Var -> Expr Var -> Expr Var -replaceVar match rep (Var v) = if v == match then Var rep else Var v -replaceVar match rep (App e e') = App (replaceVar match rep e) (replaceVar match rep e') -replaceVar match rep (Tick _ e) = replaceVar match rep e -replaceVar match rep (Lam v e) = Lam (if v == match then rep else v) (replaceVar match rep e) -replaceVar match rep (Let (NonRec b e') e) = - Let (NonRec newB (replaceVar match rep e')) (replaceVar match rep e) - where newB = if b == match then rep else b -replaceVar match rep (Cast e _) = replaceVar match rep e -replaceVar match rep (Case e b t alts) = - Case newExpr newB t (map (\(Alt con binds expr) -> Alt con (map (\v -> if v == match then rep else v) binds) (replaceVar match rep expr)) alts) - where newExpr = replaceVar match rep e - newB = if b == match then rep else b -replaceVar _ _ e = e - -transformPrim :: Ctx -> Expr Var -> CoreM (Expr Var, PrimInfo) -transformPrim ctx expr@(App e e') = case isPrimExpr expr of - Just primInfo@(AdvApp f _) -> do - varAdv' <- adv'Var - let newE = replaceVar f varAdv' e - return (App (App newE e') (Var (fromJust $ fresh ctx)), primInfo) - Just primInfo@(SelectApp f _ _) -> do - varSelect' <- select'Var - let newE = replaceVar f varSelect' e - return (App (App newE e') (Var (fromJust $ fresh ctx)), primInfo) - Just (DelayApp _ t) -> do - bigDelayVar <- bigDelay - inputValueV <- inputValueVar - let inputValueType = mkTyConTy inputValueV - inpVar <- mkSysLocalM (fsLit "inpV") inputValueType inputValueType - let ctx' = ctx {fresh = Just inpVar} - (newExpr, maybePrimInfo) <- transform' ctx' e' - let primInfo = fromJust maybePrimInfo - let lambdaExpr = Lam inpVar newExpr - clockCode <- constructClockExtractionCode primInfo - return (App (App (App (Var bigDelayVar) (Type t)) clockCode) lambdaExpr, primInfo) - Just primInfo -> do - error $ showSDocUnsafe $ text "transformPrim: Cannot transform " <> ppr (prim primInfo) - Nothing -> error "Cannot transform non-prim applications" -transformPrim _ _ = do - error "Cannot transform anything else than prim applications" - - -transform :: CoreExpr -> CoreM CoreExpr -transform expr = fst <$> transform' emptyCtx expr - -transform' :: Ctx -> CoreExpr -> CoreM (CoreExpr, Maybe PrimInfo) -transform' ctx expr@(App e e') = case isPrimExpr expr of - Just (BoxApp _) -> do - (newExpr, primInfo) <- transform' ctx e' - return (App e newExpr, primInfo) - (Just _) -> do - (newExpr, primInfo) <- transformPrim ctx expr - return (newExpr, Just primInfo) - Nothing -> do - (newExpr, primInfo) <- transform' ctx e - (newExpr', primInfo') <- transform' ctx e' - return (App newExpr newExpr', primInfo <|> primInfo') -transform' ctx (Lam b rhs) = do - (newExpr, primInfo) <- transform' ctx rhs - return (Lam b newExpr, primInfo) -transform' ctx (Let (NonRec b rhs) e) = do - (newRhs, primInfo) <- transform' ctx rhs - (newExpr, primInfo') <- transform' ctx e - return (Let (NonRec b newRhs) newExpr, primInfo <|> primInfo') -transform' ctx (Let (Rec binds) e) = do - transformedBinds <- mapM (\(b, bindE) -> fmap (b,) (transform' ctx bindE)) binds - (e', mPi) <- transform' ctx e - let primInfos = map (\(_, (_, p)) -> p) transformedBinds - let firstPrimInfo = foldl (<|>) mPi primInfos - newBinds <- mapM (\(b, (e, _)) -> return (b, e)) transformedBinds - return (Let (Rec newBinds) e', firstPrimInfo) -transform' ctx (Case e b t alts) = do - -- The checking pass has ensured that there are not advances on different - -- clocks. Thus we can just pick the first PrimInfo we find. - (expr, primInfo) <- transform' ctx e - - -- For each alternative, transform it and save the maybePrimInfo-value - transformed <- mapM (\(Alt con binds expr) -> transform' ctx expr <&> fmap (Alt con binds) . swap) alts - - -- Of all the primInfos we have, pick the first one. This is safe because - -- the checking pass has ensured that the clocks of all primitives. - let firstPrimInfo = foldl (\acc (p, _) -> acc <|> p) primInfo transformed - let alts' = map snd transformed - return (Case expr b t alts', firstPrimInfo) -transform' ctx (Cast e c) = do (e' , p) <- transform' ctx e; return (Cast e' c, p) -transform' ctx (Tick t e) = do (e' , p) <- transform' ctx e; return (Tick t e', p) -transform' _ e = return (e, Nothing) - -constructClockExtractionCode :: PrimInfo -> CoreM CoreExpr -constructClockExtractionCode (AdvApp _ arg) = createClockCode arg -constructClockExtractionCode (SelectApp _ arg arg2) = clockUnion arg arg2 -constructClockExtractionCode primInfo = error $ "Cannot construct clock for prim " ++ showSDocUnsafe (ppr (prim primInfo)) - - -createClockCode :: (Var, Type) -> CoreM CoreExpr -createClockCode (argV, argT) = do - extractClock <- extractClockVar - return $ App (App (Var extractClock) (Type argT)) (Var argV) - --- Generate code for union of two clocks. --- clockUnion (aVar, aType) (bVar, bType) returns the AST for: --- Set.union (extractClock aVar) (extractClock bVar) - -clockUnion :: (Var,Type) -> (Var, Type) -> CoreM CoreExpr -clockUnion arg arg2 = do - clock1Code <- createClockCode arg - clock2Code <- createClockCode arg2 - unionVar' <- unionVar - return $ - App - ( - App - ( - (Var unionVar') - ) - clock1Code - ) - clock2Code diff --git a/src/AsyncRattus/Plugin/Utils.hs b/src/AsyncRattus/Plugin/Utils.hs deleted file mode 100644 --- a/src/AsyncRattus/Plugin/Utils.hs +++ /dev/null @@ -1,380 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE CPP #-} - -module AsyncRattus.Plugin.Utils ( - printMessage, - Severity(..), - isRattModule, - adv'Var, - select'Var, - bigDelay, - inputValueVar, - extractClockVar, - unionVar, - isGhcModule, - getNameModule, - isStable, - isStrict, - isTemporal, - userFunction, - typeClassFunction, - getVar, - getMaybeVar, - getModuleFS, - isVar, - isType, - mkSysLocalFromVar, - mkSysLocalFromExpr, - fromRealSrcSpan, - noLocationInfo, - mkAlt, - getAlt, - splitForAllTys') - where - -#if __GLASGOW_HASKELL__ >= 908 -import GHC.Types.Error (ResolvedDiagnosticReason (..)) -#endif - -#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 -import Control.Concurrent.MVar (readMVar) -#else -import Data.IORef (readIORef) -#endif -import GHC.Utils.Logger -import GHC.Plugins -import GHC.Utils.Error hiding (errorMsg) -import GHC.Utils.Monad - - -import GHC.Types.Name.Cache (NameCache(nsNames), lookupOrigNameCache, OrigNameCache) -import qualified GHC.Types.Name.Occurrence as Occurrence -import GHC.Types.TyThing - -import Prelude hiding ((<>)) -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Char -import Data.Maybe - - -getMaybeVar :: CoreExpr -> Maybe Var -getMaybeVar (App e e') - | isType e' || not (tcIsLiftedTypeKind (typeKind (exprType e'))) = getMaybeVar e - | otherwise = Nothing -getMaybeVar (Cast e _) = getMaybeVar e -getMaybeVar (Tick _ e) = getMaybeVar e -getMaybeVar (Var v) = Just v -getMaybeVar _ = Nothing - -getVar :: CoreExpr -> Var -getVar = fromJust . getMaybeVar - -isVar :: CoreExpr -> Bool -isVar = isJust . getMaybeVar - -isType Type {} = True -isType (App e _) = isType e -isType (Cast e _) = isType e -isType (Tick _ e) = isType e -isType _ = False - -#if __GLASGOW_HASKELL__ >= 906 -isFunTyCon = isArrowTyCon -repSplitAppTys = splitAppTysNoView -#endif - - -printMessage :: (HasDynFlags m, MonadIO m, HasLogger m) => - Severity -> SrcSpan -> SDoc -> m () -printMessage sev loc doc = do -#if __GLASGOW_HASKELL__ >= 908 - logger <- getLogger - liftIO $ putLogMsg logger (logFlags logger) - (MCDiagnostic sev (if sev == SevError then ResolvedDiagnosticReason ErrorWithoutFlag else ResolvedDiagnosticReason WarningWithoutFlag) Nothing) loc doc -#elif __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 -#else - dflags <- getDynFlags - logger <- getLogger - liftIO $ putLogMsg logger dflags NoReason sev loc doc -#endif - -instance Ord FastString where - compare = uniqCompareFS - -{- -****************************************************** -* Extracting variables * -****************************************************** --} - - -origNameCache :: CoreM OrigNameCache -origNameCache = do - hscEnv <- getHscEnv -#if __GLASGOW_HASKELL__ >= 904 - let nameCache = hsc_NC hscEnv - liftIO $ readMVar (nsNames nameCache) -#else - nameCache <- liftIO $ readIORef (hsc_NC hscEnv) - return $ nsNames nameCache -#endif - - -getNamedThingFromModuleAndOccName :: String -> OccName -> CoreM TyThing -getNamedThingFromModuleAndOccName moduleName occName = do - origNameCache <- origNameCache - case filter ((moduleName ==) . unpackFS . getModuleFS) (moduleEnvKeys origNameCache) of - mod : _ -> lookupThing $ fromJust $ lookupOrigNameCache origNameCache mod occName - _ -> error ( ("internal error: cannot find module " ++ moduleName ++ "; " ++ show (map (unpackFS . getModuleFS) $ moduleEnvKeys origNameCache))) - -getVarFromModule :: String -> String -> CoreM Var -getVarFromModule moduleName = fmap tyThingId . getNamedThingFromModuleAndOccName moduleName . mkOccName Occurrence.varName - -getTyConFromModule :: String -> String -> CoreM TyCon -getTyConFromModule moduleName = fmap tyThingTyCon . getNamedThingFromModuleAndOccName moduleName . mkOccName Occurrence.tcName - -adv'Var :: CoreM Var -adv'Var = getVarFromModule "AsyncRattus.InternalPrimitives" "adv'" - -select'Var :: CoreM Var -select'Var = getVarFromModule "AsyncRattus.InternalPrimitives" "select'" - -bigDelay :: CoreM Var -bigDelay = getVarFromModule "AsyncRattus.InternalPrimitives" "Delay" - -inputValueVar :: CoreM TyCon -inputValueVar = getTyConFromModule "AsyncRattus.InternalPrimitives" "InputValue" - -extractClockVar :: CoreM Var -extractClockVar = getVarFromModule "AsyncRattus.InternalPrimitives" "extractClock" - -unionVar :: CoreM Var -unionVar = getVarFromModule "AsyncRattus.InternalPrimitives" "clockUnion" - -rattModules :: Set FastString -rattModules = Set.fromList ["AsyncRattus.InternalPrimitives","AsyncRattus.Channels"] - -getModuleFS :: Module -> FastString -getModuleFS = moduleNameFS . moduleName - -isRattModule :: FastString -> Bool -isRattModule = (`Set.member` rattModules) - -isGhcModule :: FastString -> Bool -isGhcModule = (== "GHC.Types") - -getNameModule :: NamedThing a => a -> Maybe (FastString, FastString) -getNameModule v = do - let name = getName v - mod <- nameModule_maybe name - return (getOccFS name,moduleNameFS (moduleName mod)) - - --- | The set of stable built-in types. -ghcStableTypes :: Set FastString -ghcStableTypes = Set.fromList ["Word","Int","Bool","Float","Double","Char", "IO"] - -isGhcStableType :: FastString -> Bool -isGhcStableType = (`Set.member` ghcStableTypes) - - -newtype TypeCmp = TC Type - -instance Eq TypeCmp where - (TC t1) == (TC t2) = eqType t1 t2 - -instance Ord TypeCmp where - compare (TC t1) (TC t2) = nonDetCmpType t1 t2 - -isTemporal :: Type -> Bool -isTemporal t = isTemporalRec 0 Set.empty t - - -isTemporalRec :: Int -> Set TypeCmp -> Type -> Bool -isTemporalRec d _ _ | d == 100 = False -isTemporalRec _ pr t | Set.member (TC t) pr = False -isTemporalRec d pr t = do - let pr' = Set.insert (TC t) pr - case splitTyConApp_maybe t of - Nothing -> False - Just (con,args) -> - case getNameModule con of - Nothing -> False - Just (name,mod) - -- If it's a Rattus type constructor check if it's a box - | isRattModule mod && (name == "Box" || name == "O") -> True - | isFunTyCon con -> or (map (isTemporalRec (d+1) pr') args) - | isAlgTyCon con -> - case algTyConRhs con of - DataTyCon {data_cons = cons} -> or (map check cons) - where check con = case dataConInstSig con args of - (_, _,tys) -> or (map (isTemporalRec (d+1) pr') tys) - _ -> or (map (isTemporalRec (d+1) pr') args) - _ -> False - - --- | Check whether the given type is stable. This check may use --- 'Stable' constraints from the context. - -isStable :: Set Var -> Type -> Bool -isStable c t = isStableRec c 0 Set.empty t - --- | Check whether the given type is stable. This check may use --- 'Stable' constraints from the context. - -isStableRec :: Set Var -> Int -> Set TypeCmp -> Type -> Bool --- To prevent infinite recursion (when checking recursive types) we --- keep track of previously checked types. This, however, is not --- enough for non-regular data types. Hence we also have a counter. -isStableRec _ d _ _ | d == 100 = True -isStableRec _ _ pr t | Set.member (TC t) pr = True -isStableRec c d pr t = do - let pr' = Set.insert (TC t) pr - case splitTyConApp_maybe t of - Nothing -> case getTyVar_maybe t of - Just v -> -- if it's a type variable, check the context - v `Set.member` c - Nothing -> False - Just (con,args) -> - 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" || name == "Chan") -> True - -- If its a built-in type check the set of stable built-in types - | 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) -} - | isAlgTyCon con -> - case algTyConRhs con of - DataTyCon {data_cons = cons, is_enum = enum} - | enum -> True - | all hasStrictArgs cons -> - and (map check cons) - | otherwise -> False - where check con = case dataConInstSig con args of - (_, _,tys) -> and (map (isStableRec c (d+1) pr') tys) - TupleTyCon {} -> null args - _ -> False - _ -> False - - - -isStrict :: Type -> Bool -isStrict t = isStrictRec 0 Set.empty t - -splitForAllTys' :: Type -> ([TyCoVar], Type) -splitForAllTys' = splitForAllTyCoVars - --- | Check whether the given type is stable. This check may use --- 'Stable' constraints from the context. - -isStrictRec :: Int -> Set TypeCmp -> Type -> Bool --- To prevent infinite recursion (when checking recursive types) we --- keep track of previously checked types. This, however, is not --- enough for non-regular data types. Hence we also have a counter. -isStrictRec d _ _ | d == 100 = True -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 (c, tys) = repSplitAppTys t' - if isJust (getTyVar_maybe c) then and (map (isStrictRec (d+1) pr') tys) - else case splitTyConApp_maybe t' of - Nothing -> isJust (getTyVar_maybe t) - Just (con,args) -> - case getNameModule con of - Nothing -> False - 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 == "Chan" || name == "O" || name == "Output") -> True - -- If its a built-in type check the set of stable built-in types - | 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) -} - | isFunTyCon con -> True - | isAlgTyCon con -> - case algTyConRhs con of - DataTyCon {data_cons = cons, is_enum = enum} - | enum -> True - | all hasStrictArgs cons -> - and (map check cons) - | otherwise -> False - where check con = case dataConInstSig con args of - (_, _,tys) -> and (map (isStrictRec (d+1) pr') tys) - TupleTyCon {} -> null args - NewTyCon {nt_rhs = ty} -> isStrictRec (d+1) pr' ty - _ -> False - | otherwise -> False - - - - - -hasStrictArgs :: DataCon -> Bool -hasStrictArgs con = all isBanged (dataConImplBangs con) - -userFunction :: Var -> Bool -userFunction v - | typeClassFunction v = True - | otherwise = - case getOccString (getName v) of - (c : _) - | isUpper c || c == '$' || c == ':' -> False - | otherwise -> True - _ -> False - -typeClassFunction :: Var -> Bool -typeClassFunction v = - case getOccString (getName v) of - ('$' : 'c' : _) -> True - ('$' : 'f' : _) -> True - _ -> False - -mkSysLocalFromVar :: MonadUnique m => FastString -> Var -> m Id -mkSysLocalFromVar lit v = mkSysLocalM lit (varMult v) (varType v) - -mkSysLocalFromExpr :: MonadUnique m => FastString -> CoreExpr -> m Id -mkSysLocalFromExpr lit e = mkSysLocalM lit oneDataConTy (exprType e) - - -fromRealSrcSpan :: RealSrcSpan -> SrcSpan -#if __GLASGOW_HASKELL__ >= 904 -fromRealSrcSpan span = RealSrcSpan span Strict.Nothing -#else -fromRealSrcSpan span = RealSrcSpan span Nothing -#endif - -instance Ord SrcSpan where - compare (RealSrcSpan s _) (RealSrcSpan t _) = compare s t - compare RealSrcSpan{} _ = LT - compare _ _ = GT - -noLocationInfo :: SrcSpan -noLocationInfo = UnhelpfulSpan UnhelpfulNoLocationInfo - -mkAlt c args e = Alt c args e -getAlt (Alt c args e) = (c, args, e) diff --git a/src/AsyncRattus/Primitives.hs b/src/AsyncRattus/Primitives.hs deleted file mode 100644 --- a/src/AsyncRattus/Primitives.hs +++ /dev/null @@ -1,21 +0,0 @@ --- | The language primitives of Async Rattus. Note that the typing --- rules for 'delay', 'adv','select' and 'box' are more restrictive --- than the Haskell types that are indicated. The stricter Async --- Rattus typing rules for these primitives are given below. - -{-# LANGUAGE TypeOperators #-} -module AsyncRattus.Primitives - (O - ,Box - ,Select(..) - ,delay - ,adv - ,promote - ,box - ,unbox - ,select - ,never - ,Stable - ,Continuous - ) where -import AsyncRattus.InternalPrimitives diff --git a/src/AsyncRattus/Signal.hs b/src/AsyncRattus/Signal.hs deleted file mode 100644 --- a/src/AsyncRattus/Signal.hs +++ /dev/null @@ -1,412 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS -fplugin=AsyncRattus.Plugin #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE CPP #-} - - --- | Programming with signals. - -module AsyncRattus.Signal - ( map - , mkInputSig - , getInputSig - , filterMap - , filterMapAwait - , filter - , filterAwait - , trigger - , triggerAwait - , mapAwait - , switch - , switchS - , switchAwait - , interleave - , mkSig - , mkBoxSig - , current - , future - , const - , scan - , scanC - , scanAwait - , scanAwaitC - , scanMap - , Sig(..) - , zipWith - , zipWith3 - , zip - , cond - , update - , integral - , derivative - ) - -where - -import AsyncRattus -import AsyncRattus.Channels -import Prelude hiding (map, const, zipWith, zipWith3, zip, filter) -import Data.VectorSpace -import Data.Ratio ((%)) --- TODO: InternalPrimitives is only used to implment instance of --- Continuous. Replace this manual instance declaration with Template --- Haskell. -import AsyncRattus.InternalPrimitives - -infixr 5 ::: - --- | @Sig a@ is a stream of values of type @a@. -data Sig a = !a ::: !(O (Sig a)) - -instance Producer (Sig a) a where - getCurrent p = Just' (current p) - getNext p cb = cb (future p) - -newtype SigMaybe a = SigMaybe (Sig (Maybe' a)) - -instance Producer (SigMaybe a) a where - getCurrent (SigMaybe p) = current p - getNext (SigMaybe p) cb = cb (delay (SigMaybe (adv (future p)))) - --- | Get the current value of a signal. -current :: Sig a -> a -current (x ::: _) = x - - --- | Get the future the signal. -future :: Sig a -> O (Sig a) -future (_ ::: xs) = xs - --- | Apply a function to the value of a signal. -map :: Box (a -> b) -> Sig a -> Sig b -map f (x ::: xs) = unbox f x ::: delay (map f (adv xs)) - --- | Variant of 'getInput' that returns a signal instead of a boxed --- delayed computation. -getInputSig :: IO (Box (O (Sig a)) :* (a -> IO ())) -getInputSig = do (s :* cb) <- getInput - return (mkBoxSig s :* cb) - --- | Turn a producer into a signal. This is a variant of 'mkInput' --- that returns a signal instead of a boxed delayed computation. -mkInputSig :: Producer p a => p -> IO (Box (O (Sig a))) -mkInputSig p = mkBoxSig <$> mkInput p - - --- | This function is essentially the composition of 'filter' with --- 'map'. The signal produced by @filterMap f s@ has the value @v@ --- whenever @s@ has the value @u@ such that @unbox f u = Just' v@. -filterMap :: Box (a -> Maybe' b) -> Sig a -> IO (Box (O (Sig b))) -filterMap f s = mkInputSig (SigMaybe (map f s)) - --- | This function is similar to 'filterMap' but takes a delayed --- signal (type @O (Sig a)@) as an argument instead of a signal (@Sig --- a@). -filterMapAwait :: Box (a -> Maybe' b) -> O (Sig a) -> IO (Box (O (Sig b))) -filterMapAwait f s = mkInputSig (delay (SigMaybe (map f (adv s)))) - --- | Filter the given signal using a predicate. The signal produced by --- @filter p s@ contains only values from @s@ that satisfy the --- predicate @p@. -filter :: Box (a -> Bool) -> Sig a -> IO (Box (O (Sig a))) -filter p = filterMap (box (\ x -> if unbox p x then Just' x else Nothing')) - --- | This function is similar to 'filter' but takes a delayed signal --- (type @O (Sig a)@) as an argument instead of a signal (@Sig a@). -filterAwait :: Box (a -> Bool) -> O (Sig a) -> IO (Box (O (Sig a))) -filterAwait p = filterMapAwait (box (\ x -> if unbox p x then Just' x else Nothing')) - - --- | This function is a variant of 'zipWith'. Whereas @zipWith f xs --- ys@ produces a new value whenever @xs@ or @ys@ produce a new value, --- @trigger f xs ys@ only produces a new value when xs produces a new --- value. --- --- Example: --- --- > xs: 1 2 3 2 --- > ys: 1 0 5 2 --- > --- > zipWith (box (+)) xs ys: 2 3 4 3 8 4 --- > trigger (box (+)) xy ys: 2 3 8 4 - -trigger :: (Stable a, Stable b) => Box (a -> b -> c) -> Sig a -> Sig b -> IO (Box (Sig c)) -trigger f (a ::: as) bs@(b:::_) = do s <- triggerAwait f as bs - return (box (unbox f a b ::: unbox s)) --- | This function is similar to 'trigger' but takes a delayed signal --- (type @O (Sig a)@) as an argument instead of a signal (@Sig a@). -triggerAwait :: Stable b => Box (a -> b -> c) -> O (Sig a) -> Sig b -> IO (Box (O (Sig c))) -triggerAwait f as bs = mkBoxSig <$> mkInput (box SigMaybe `mapO` (trig f as bs)) where - trig :: Stable b => Box (a -> b -> c) -> O (Sig a) -> Sig b -> O (Sig (Maybe' c)) - trig f as (b ::: bs) = - delay (case select as bs of - Fst (a' ::: as') bs' -> Just' (unbox f a' b) ::: trig f as' (b ::: bs') - Snd as' bs' -> Nothing' ::: trig f as' bs' - Both (a' ::: as') (b' ::: bs') -> Just' (unbox f a' b') ::: trig f as' (b' ::: bs') - ) - --- | A version of @map@ for delayed signals. -mapAwait :: Box (a -> b) -> O (Sig a) -> O (Sig b) -mapAwait f d = delay (map f (adv d)) - --- | Turns a boxed delayed computation into a delayed signal. -mkSig :: Box (O a) -> O (Sig a) -mkSig b = delay (adv (unbox b) ::: mkSig b) - --- | Variant of 'mkSig' that returns a boxed delayed signal -mkBoxSig :: Box (O a) -> Box (O (Sig a)) -mkBoxSig b = box (mkSig b) - - --- | Construct a constant signal that never updates. -const :: a -> Sig a -const x = x ::: never - --- | Similar to Haskell's 'scanl'. --- --- > scan (box f) x (v1 ::: v2 ::: v3 ::: ... ) == (x `f` v1) ::: ((x `f` v1) `f` v2) ::: ... --- --- Note: Unlike 'scanl', 'scan' starts with @x `f` v1@, not @x@. - -scan :: (Continuous b) => Box(b -> a -> b) -> b -> Sig a -> Sig b -scan f acc (a ::: as) = acc' ::: delay (scan f (unbox accBox) (adv as)) - where acc' = unbox f acc a - accBox = promote acc' - -scanC :: (Continuous b) => Box(b -> a -> C b) -> b -> Sig a -> C (Sig b) -scanC f acc (a ::: as) = do - acc' <- unbox f acc a - let accBox = promote acc' - fut <- delayC $ delay (scanC f (unbox accBox) (adv as)) - return (acc' ::: fut) - where - --- | Like 'scan', but uses a delayed signal. -scanAwait :: (Continuous b) => Box (b -> a -> b) -> b -> O (Sig a) -> Sig b -scanAwait f acc as = acc ::: delay (scan f (unbox accBox) (adv as)) - where accBox = promote acc - -scanAwaitC :: (Continuous b) => Box (b -> a -> C b) -> b -> O (Sig a) -> C (Sig b) -scanAwaitC f acc as = do - fut <- delayC $ delay (scanC f (unbox accBox) (adv as)) - return (acc ::: fut) - where accBox = promote acc - --- | 'scanMap' is a composition of 'map' and 'scan': --- --- > scanMap f g x === map g . scan f x -scanMap :: (Continuous b) => Box (b -> a -> b) -> Box (b -> c) -> b -> Sig a -> Sig c -scanMap f p acc (a ::: as) = unbox p acc' ::: delay (scanMap f p (unbox accBox) (adv as)) - where acc' = unbox f acc a - accBox = promote acc' - --- | This function allows to switch from one signal to another one --- dynamically. The signal defined by @switch xs ys@ first behaves --- like @xs@, but as soon as @ys@ produces a new value, @switch xs ys@ --- behaves like @ys@. --- --- Example: --- --- > xs: 1 2 3 4 5 6 7 8 9 --- > ys: 1 2 3 4 5 6 --- > --- > switch xs ys: 1 2 3 1 2 4 3 4 5 6 -switch :: Sig a -> O (Sig a) -> Sig a -switch (x ::: xs) d = x ::: delay (case select xs d of - Fst xs' d' -> switch xs' d' - Snd _ d' -> d' - Both _ d' -> d') - --- | This function is similar to 'switch', but the (future) second --- signal may depend on the last value of the first signal. -switchS :: Continuous a => Sig a -> O (a -> Sig a) -> Sig a -switchS (x ::: xs) d = x ::: delay (case select xs d of - Fst xs' d' -> switchS xs' d' - Snd _ f -> f (unbox xBox) - Both _ f -> f (unbox xBox)) - where xBox = promote x - --- | This function is similar to 'switch' but works on delayed signals --- instead of signals. -switchAwait :: O (Sig a) -> O (Sig a) -> O (Sig a) -switchAwait xs ys = delay (case select xs ys of - Fst xs' d' -> switch xs' d' - Snd _ d' -> d' - Both _ d' -> d') - --- | This function interleaves two signals producing a new value @v@ --- whenever either input stream produces a new value @v@. In case the --- input signals produce a new value simultaneously, the function --- argument is used break ties, i.e. to compute the new output value based --- on the two new input values --- --- Example: --- --- > xs: 1 3 5 3 1 3 --- > ys: 0 2 4 --- > --- > interleave (box (+)) xs ys: 1 3 2 5 7 1 3 -interleave :: Box (a -> a -> a) -> O (Sig a) -> O (Sig a) -> O (Sig a) -interleave f xs ys = delay (case select xs ys of - Fst (x ::: xs') ys' -> x ::: interleave f xs' ys' - Snd xs' (y ::: ys') -> y ::: interleave f xs' ys' - Both (x ::: xs') (y ::: ys') -> unbox f x y ::: interleave f xs' ys') - - --- | Takes two signals and updates the first signal using the --- functions produced by the second signal: --- --- Law: --- --- (xs `update` fs) `update` gs = (xs `update` (interleave (box (.)) gs fs)) -update :: (Continuous a) => Sig a -> O (Sig (a -> a)) -> Sig a -update (x ::: xs) fs = x ::: delay - (case select xs fs of - Fst xs' ys' -> update xs' ys' - Snd xs' (f ::: fs') -> update (f (unbox xBox) ::: xs') fs' - Both (x' ::: xs') (f ::: fs') -> update (f x' ::: xs') fs') - where xBox = promote x - - --- | This function is a variant of combines the values of two signals --- using the function argument. @zipWith f xs ys@ produces a new value --- @unbox f x y@ whenever @xs@ or @ys@ produce a new value, where @x@ --- and @y@ are the current values of @xs@ and @ys@, respectively. --- --- Example: --- --- > xs: 1 2 3 2 --- > ys: 1 0 5 2 --- > --- > zipWith (box (+)) xs ys: 2 3 4 3 8 4 - -zipWith :: (Stable a, Stable b) => Box(a -> b -> c) -> Sig a -> Sig b -> Sig c -zipWith f (a ::: as) (b ::: bs) = unbox f a b ::: delay ( - case select as bs of - Fst as' lbs -> zipWith f as' (b ::: lbs) - Snd las bs' -> zipWith f (a ::: las) bs' - Both as' bs' -> zipWith f as' bs' - ) - --- | Variant of 'zipWith' with three signals. -zipWith3 :: forall a b c d. (Stable a, Stable b, Stable c) => Box(a -> b -> c -> d) -> Sig a -> Sig b -> Sig c -> Sig d -zipWith3 f as bs cs = zipWith (box (\f x -> unbox f x)) cds cs - where cds :: Sig (Box (c -> d)) - cds = zipWith (box (\a b -> box (\ c -> unbox f a b c))) as bs - --- | If-then-else lifted to signals. @cond bs xs ys@ produces a stream --- whose value is taken from @xs@ whenever @bs@ is true and from @ys@ --- otherwise. -cond :: Stable a => Sig Bool -> Sig a -> Sig a -> Sig a -cond = zipWith3 (box (\b x y -> if b then x else y)) - - --- | This is a special case of 'zipWith' using the tupling --- function. That is, --- --- > zip = zipWith (box (:*)) -zip :: (Stable a, Stable b) => Sig a -> Sig b -> Sig (a:*b) -zip = zipWith (box (:*)) - --- | Sampling interval (in microseconds) for the 'integral' and --- 'derivative' functions. - -dt :: Int -dt = 20000 - --- | @integral x xs@ computes the integral of the signal @xs@ with the --- constant @x@. For example, if @xs@ is the velocity of an object, --- the signal @integral 0 xs@ describes the distance travelled by that --- object. -integral :: forall a v . (VectorSpace v a, Eq v, Fractional a, Stable v, Stable a) - => v -> Sig v -> Sig v -integral = int - where int cur (x ::: xs) - | x == zeroVector = cur ::: delay (int cur (adv xs)) - | otherwise = cur ::: delay ( - case select xs (unbox (timer dt)) of - Fst xs' _ -> int cur xs' - Snd xs' _ -> int (dtf *^ (cur ^+^ x)) (x ::: xs') - Both (x' ::: xs') _ -> int (dtf *^ (cur ^+^ x')) (x'::: xs')) - -- sampling interval in seconds - dtf :: a - dtf = fromRational (fromIntegral dt % 1000000) - --- | Compute the derivative of a signal. For example, if @xs@ is the --- velocity of an object, the signal @derivative xs@ describes the --- acceleration travelled by that object. -derivative :: forall a v . (VectorSpace v a, Eq v, Fractional a, Stable v, Stable a) - => Sig v -> Sig v -derivative xs = der zeroVector (current xs) xs where - -- inverse sampling interval in seconds - dtf :: a - dtf = fromIntegral dt * 0.000001 - - der :: v -> v -> Sig v -> Sig v - der d last (x:::xs) - | d == zeroVector = zeroVector ::: delay - (let x' ::: xs' = adv xs - in der ((x' ^-^ x) ^/ dtf) x (x' ::: xs')) - | otherwise = d ::: delay ( - case select xs (unbox (timer dt)) of - Fst xs' _ -> der d last xs' - Snd xs' _ -> der ((x ^-^ last) ^/ dtf) x (x ::: xs') - Both (x' ::: xs') _ -> der ((x' ^-^ last) ^/ dtf) x' (x' ::: xs')) - - -instance Continuous a => Continuous (Sig a) where - progressInternal inp (x ::: xs@(Delay cl _)) = - if inputInClock inp cl then (adv' xs inp) - else progressInternal inp x ::: xs - progressAndNext inp (x ::: xs@(Delay cl _)) = - if inputInClock inp cl then let n = adv' xs inp in (n, nextProgress n) - else let (n , cl') = progressAndNext inp x in (n ::: xs , cl `clockUnion` cl') - nextProgress (x ::: (Delay cl _)) = nextProgress x `clockUnion` cl - --- Prevent functions from being inlined too early for the rewrite --- rules to fire. - -{-# NOINLINE [1] map #-} -{-# NOINLINE [1] const #-} -{-# NOINLINE [1] scan #-} -{-# NOINLINE [1] scanMap #-} -{-# NOINLINE [1] zip #-} -{-# NOINLINE [1] update #-} -{-# NOINLINE [1] switch #-} - - -{-# RULES - - "const/switch" forall x xs. - switch (const x) xs = x ::: xs; - - "update/update" forall xs fs gs. - update (update xs fs) gs = update xs (interleave (box (.)) gs fs) ; - - "const/map" forall (f :: Stable b => Box (a -> b)) x. - map f (const x) = let x' = unbox f x in const x' ; - - "map/map" forall f g xs. - map f (map g xs) = map (box (unbox f . unbox g)) xs ; - - "map/scan" forall f p acc as. - 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; - - "scan/scan" forall f g b c as. - scan g c (scan f b as) = - let f' = unbox f; g' = unbox g in - scanMap (box (\ (b:*c) a -> let b' = f' b a in (b':* g' c b'))) (box snd') (b:*c) as ; - - "scan/scanMap" forall f g p b c as. - scan g c (scanMap f p b as) = - let f' = unbox f; g' = unbox g; p' = unbox p in - scanMap (box (\ (b:*c) a -> let b' = f' (p' b) a in (b':* g' c b'))) (box snd') (b:*c) as ; - -#-} - diff --git a/src/AsyncRattus/Strict.hs b/src/AsyncRattus/Strict.hs deleted file mode 100644 --- a/src/AsyncRattus/Strict.hs +++ /dev/null @@ -1,255 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TemplateHaskell #-} - - --- | This module contains strict versions of some standard data --- structures. - - - -module AsyncRattus.Strict - ( List(..), - singleton, - IsList(..), - init', - reverse', - union', - unionBy', - nub', - nubBy', - filter', - delete', - deleteBy', - (+++), - listToMaybe', - map', - zip', - zipWith', - mapMaybe', - (:*)(..), - Maybe'(..), - maybe', - fromMaybe', - fst', - snd', - curry', - uncurry' - )where - -import Prelude hiding (map) -import Data.VectorSpace -import AsyncRattus.Derive -import GHC.Exts (IsList(..)) - -infixr 2 :* --- | Strict pair type. -data a :* b = !a :* !b - -continuous ''(:*) - --- | First projection function. -fst' :: (a :* b) -> a -fst' (a:*_) = a - --- | Second projection function. -snd' :: (a :* b) -> b -snd' (_:*b) = b - -curry' :: ((a :* b) -> c) -> a -> b -> c -curry' f x y = f (x :* y) - -uncurry' :: (a -> b -> c) -> (a :* b) -> c -uncurry' f (x :* y) = f x y - - -instance Functor ((:*) a) where - fmap f (x:*y) = (x :* f y) - -instance (Show a, Show b) => Show (a:*b) where - show (a :* b) = "(" ++ show a ++ " :* " ++ show b ++ ")" - -instance (Eq a, Eq b) => Eq (a :* b) where - (x1 :* y1) == (x2 :* y2) = x1 == x2 && y1 == y2 - - -instance (VectorSpace v a, VectorSpace w a, Floating a, Eq a) => VectorSpace (v :* w) a where - zeroVector = zeroVector :* zeroVector - - a *^ (x :* y) = (a *^ x) :* (a *^ y) - - (x :* y) ^/ a = (x ^/ a) :* (y ^/ a) - - negateVector (x :* y) = (negateVector x) :* (negateVector y) - - (x1 :* y1) ^+^ (x2 :* y2) = (x1 ^+^ x2) :* (y1 ^+^ y2) - - (x1 :* y1) ^-^ (x2 :* y2) = (x1 ^-^ x2) :* (y1 ^-^ y2) - - (x1 :* y1) `dot` (x2 :* y2) = (x1 `dot` x2) + (y1 `dot` y2) - -infixr 8 :! - --- | Strict list type. -data List a = Nil | !a :! !(List a) - -continuous ''List - - -singleton :: a -> List a -singleton x = x :! Nil - -instance Traversable List where - traverse _ Nil = pure Nil - traverse f (x :! xs) = (:!) <$> (f x) <*> (traverse f xs) - -instance IsList (List a) where - type Item (List a) = a - - fromList [] = Nil - fromList (x : xs) = x :! fromList xs - - toList Nil = [] - toList (x :! xs) = x : toList 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 -reverse' l = rev l Nil - where - rev Nil a = a - rev (x:!xs) a = rev xs (x:!a) - --- | Returns @'Nothing''@ on an empty list or @'Just'' a@ where @a@ is the --- first element of the list. -listToMaybe' :: List a -> Maybe' a -listToMaybe' Nil = Nothing' -listToMaybe' (x :! _) = Just' x - --- | Append two lists. -(+++) :: List a -> List a -> List a -(+++) Nil ys = ys -(+++) (x:!xs) ys = x :! xs +++ ys - - -map' :: (a -> b) -> List a -> List b -map' _ Nil = Nil -map' f (x :! xs) = f x :! map' f xs - -zip' :: List a -> List b -> List (a :* b) -zip' Nil _ = Nil -zip' _ Nil = Nil -zip' (x :! xs) (y :! ys) = (x :* y) :! zip' xs ys - -zipWith' :: (a -> b -> c) -> List a -> List b -> List c -zipWith' _ Nil _ = Nil -zipWith' _ _ Nil = Nil -zipWith' f (x :! xs) (y :! ys) = f x y :! zipWith' f xs ys - - --- | A version of 'map' which can throw out elements. In particular, --- the function argument returns something of type @'Maybe'' b@. If --- this is 'Nothing'', no element is added on to the result list. If --- it is @'Just'' b@, then @b@ is included in the result list. -mapMaybe' :: (a -> Maybe' b) -> List a -> List b -mapMaybe' _ Nil = Nil -mapMaybe' f (x:!xs) = - let rs = mapMaybe' f xs in - case f x of - Nothing' -> rs - Just' r -> r:!rs - -union' :: (Eq a) => List a -> List a -> List a -union' = unionBy' (==) - -unionBy' :: (a -> a -> Bool) -> List a -> List a -> List a -unionBy' eq xs ys = xs +++ foldl (flip (deleteBy' eq)) (nubBy' eq ys) xs - -delete' :: (Eq a) => a -> List a -> List a -delete' = deleteBy' (==) - -deleteBy' :: (a -> a -> Bool) -> a -> List a -> List a -deleteBy' _ _ Nil = Nil -deleteBy' eq x (y :! ys) = if x `eq` y then ys else y :! deleteBy' eq x ys - - -nub' :: (Eq a) => List a -> List a -nub' = nubBy' (==) - -nubBy' :: (a -> a -> Bool) -> List a -> List a -nubBy' _ Nil = Nil -nubBy' eq (x:!xs) = x :! nubBy' eq (filter' (\ y -> not (eq x y)) xs) - -filter' :: (a -> Bool) -> List a -> List a -filter' _ Nil = Nil -filter' pred (x :! xs) - | pred x = x :! filter' pred xs - | otherwise = filter' pred xs - -instance Foldable List where - - foldMap f = run where - run Nil = mempty - run (x :! xs) = f x <> run xs - foldr f = run where - run b Nil = b - run b (a :! as) = (run $! (f a b)) as - foldl f = run where - run a Nil = a - run a (b :! bs) = (run $! (f a b)) bs - elem a = run where - run Nil = False - run (x :! xs) - | a == x = True - | otherwise = run xs - - -instance Functor List where - fmap = map' - -instance Eq a => Eq (List a) where - Nil == Nil = True - Nil == _ = False - _ == Nil = False - (x :! xs) == (y :! ys) = if x == y then xs == ys else False - -instance Show a => Show (List a) where - show Nil = "Nil" - show (x :! xs) = show x ++ " :! " ++ show xs - --- | Strict variant of 'Maybe'. -data Maybe' a = Just' !a | Nothing' - -continuous ''Maybe' - -instance Eq a => Eq (Maybe' a) where - Nothing' == Nothing' = True - Just' x == Just' y = x == y - _ == _ = False - -instance Show a => Show (Maybe' a) where - show Nothing' = "Nothing'" - show (Just' x) = "Just' " ++ show x - --- | takes a default value, a function, and a 'Maybe'' value. If the --- 'Maybe'' value is 'Nothing'', the function returns the default --- value. Otherwise, it applies the function to the value inside the --- 'Just'' and returns the result. -maybe' :: b -> (a -> b) -> Maybe' a -> b -maybe' n _ Nothing' = n -maybe' _ f (Just' x) = f x - -fromMaybe' :: a -> Maybe' a -> a -fromMaybe' _ (Just' x) = x -fromMaybe' d Nothing' = d - diff --git a/src/WidgetRattus.hs b/src/WidgetRattus.hs new file mode 100644 --- /dev/null +++ b/src/WidgetRattus.hs @@ -0,0 +1,30 @@ +{-# OPTIONS -fplugin=WidgetRattus.Plugin #-} + + +-- | The bare-bones Asynchronous Rattus language. To program with streams, +-- you can use "WidgetRattus.Stream". + +module WidgetRattus ( + -- * Asynchronous Rattus language primitives + module WidgetRattus.Primitives, + -- * Channels API + module WidgetRattus.Channels, + -- * Strict data types + module WidgetRattus.Strict, + -- * Derive class instance declarations + module WidgetRattus.Derive, + -- * Annotation + WidgetRattus(..), + -- * other + mapO + ) + where + +import WidgetRattus.Plugin +import WidgetRattus.Strict +import WidgetRattus.Primitives +import WidgetRattus.Derive +import WidgetRattus.Channels + +mapO :: Box (a -> b) -> O a -> O b +mapO f later = delay (unbox f (adv later)) diff --git a/src/WidgetRattus/Channels.hs b/src/WidgetRattus/Channels.hs new file mode 100644 --- /dev/null +++ b/src/WidgetRattus/Channels.hs @@ -0,0 +1,79 @@ +{-# OPTIONS -fplugin=WidgetRattus.Plugin #-} + +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module WidgetRattus.Channels ( + timer, + Producer (..), + chan, + C (..), + delayC, + wait, + Chan +) where +import WidgetRattus.InternalPrimitives + +import WidgetRattus.Plugin.Annotation +import WidgetRattus.Strict +import System.IO.Unsafe +import Data.IORef +import Unsafe.Coerce + +-- | A type @p@ satisfying @Producer p a@ is essentially a signal that +-- produces values of type @a@ but it might not produce such values at +-- each tick. +class Producer p a | p -> a where + -- | Get the current value of the producer if any. + getCurrent :: p -> Maybe' a + -- | Get the next state of the producer. Morally, the type of this + -- method should be + -- + -- > getNext :: p -> (exists q. Producer q a => O q) + -- + -- We encode the existential type using continuation-passing style. + getNext :: p -> (forall q. Producer q a => O q -> b) -> b + +instance Producer p a => Producer (O p) a where + getCurrent _ = Nothing' + getNext p cb = cb p + +instance Producer p a => Producer (Box p) a where + getCurrent p = getCurrent (unbox p) + getNext p cb = getNext (unbox p) cb + +newtype C a = C {unC :: IO a} deriving (Functor, Applicative, Monad) + +chan :: C (Chan a) +chan = C (Chan <$> atomicModifyIORef nextFreshChannel (\ x -> (x - 1, x))) + +delayC :: O (C a) -> C (O a) +delayC d = return (delay (unsafePerformIO (unC (adv d)))) + +{-# ANN wait AllowRecursion #-} +wait :: Chan a -> O a +wait (Chan ch) = Delay (singletonClock ch) (lookupInp ch) + +{-# NOINLINE nextFreshChannel #-} +nextFreshChannel :: IORef InputChannelIdentifier +nextFreshChannel = unsafePerformIO (newIORef (-1)) + + + +{-# ANN lookupInp AllowRecursion #-} +lookupInp :: InputChannelIdentifier -> InputValue -> a +lookupInp _ (OneInput _ v) = unsafeCoerce v +lookupInp ch (MoreInputs ch' v more) = if ch' == ch then unsafeCoerce v else lookupInp ch more + +-- | @timer n@ produces a delayed computation that ticks every @n@ +-- milliseconds. In particular @mkSig (timer n)@ is a signal that +-- produces a new value every #n# milliseconds. +timer :: Int -> Box (O ()) +timer d = Box (Delay (singletonClock (d `max` 10)) (\ _ -> ())) diff --git a/src/WidgetRattus/Derive.hs b/src/WidgetRattus/Derive.hs new file mode 100644 --- /dev/null +++ b/src/WidgetRattus/Derive.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ExistentialQuantification #-} + + +module WidgetRattus.Derive (continuous) where + +import WidgetRattus.InternalPrimitives +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import Control.Monad + + +data DataInfo = forall flag . DataInfo Cxt Name [TyVarBndr flag] [Con] [DerivClause] + +{-| + This function provides a list (of the given length) of new names based + on the given string. +-} +newNames :: Int -> String -> Q [Name] +newNames n name = replicateM n (newName name) + + +{-| + This is the @Q@-lifted version of 'abstractNewtype. +-} +abstractNewtypeQ :: Q Info -> Q (Maybe DataInfo) +abstractNewtypeQ = liftM abstractNewtype + + +{-| Apply a class name to type arguments to construct a type class + constraint. +-} + +mkClassP :: Name -> [Type] -> Type +mkClassP name = foldl AppT (ConT name) + + +{-| This function provides the name and the arity of the given data +constructor, and if it is a GADT also its type. +-} +normalCon :: Con -> [(Name,[StrictType], Maybe Type)] +normalCon (NormalC constr args) = [(constr, args, Nothing)] +normalCon (RecC constr args) = [(constr, map (\(_,s,t) -> (s,t)) args, Nothing)] +normalCon (InfixC a constr b) = [(constr, [a,b], Nothing)] +normalCon (ForallC _ _ constr) = normalCon constr +normalCon (GadtC (constr:_) args typ) = [(constr,args,Just typ)] +normalCon (RecGadtC (constr : _) args typ) = [(constr,map dropFst args,Just typ)] + where dropFst (_,x,y) = (x,y) +normalCon _ = error "missing case for 'normalCon'" + +normalCon' :: Con -> [(Name,[Type], Maybe Type)] +normalCon' con = map conv (normalCon con) + where conv (n, ts, t) = (n, map snd ts, t) + +mkInstanceD :: Cxt -> Type -> [Dec] -> Dec +mkInstanceD cxt ty decs = InstanceD Nothing cxt ty decs + +{-| + This function returns the name of a bound type variable +-} +tyVarBndrName (PlainTV n _) = n +tyVarBndrName (KindedTV n _ _) = n + +{-| + This function abstracts away @newtype@ declaration, it turns them into + @data@ declarations. +-} +abstractNewtype :: Info -> Maybe DataInfo +abstractNewtype (TyConI (NewtypeD cxt name args _ constr derive)) + = Just (DataInfo cxt name args [constr] derive) +abstractNewtype (TyConI (DataD cxt name args _ constrs derive)) + = Just (DataInfo cxt name args constrs derive) +abstractNewtype _ = Nothing + +continuous :: Name -> Q [Dec] +continuous fname = do + Just (DataInfo _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname + let argNames = map (VarT . tyVarBndrName) args + complType = foldl AppT (ConT name) argNames + preCond = map (mkClassP ''Continuous . (: [])) argNames + classType = AppT (ConT ''Continuous) complType + let constrs' = concatMap normalCon' constrs + progressAndNextDecl <- funD 'progressAndNext (map genProgressAndNext constrs') + progressInternalDecl <- funD 'progressInternal (map genProgressInternal constrs') + nextProgressDecl <- funD 'nextProgress (map genNextProgress constrs') + return [mkInstanceD preCond classType [progressAndNextDecl,progressInternalDecl,nextProgressDecl]] + where genProgressAndNext (constr, args,_) = do + let n = length args + varNs <- newNames n "x" + varNsR <- newNames n "y" + varNsS <- newNames n "z" + varIn <- newName "_inp" + let pat = ConP constr [] $ map VarP varNs + + progressInternalExp <- [|progressAndNext|] + let lets = zipWith3 (\ x y z -> ValD (TupP [VarP y, VarP z]) (NormalB (progressInternalExp `AppE` VarE varIn `AppE` VarE x)) []) varNs varNsR varNsS + clockUnionExp <- [|clockUnion|] + result <- appsE ( conE constr : (map varE varNsR)) + clock <- if n == 0 then [|emptyClock|] else return (foldl1 (\ x y -> (clockUnionExp `AppE` x) `AppE` y) (map VarE varNsS)) + let body = LetE lets (TupE [Just result, Just clock]) + return $ Clause [VarP varIn, pat] (NormalB body) [] + genProgressInternal (constr, args,_) = do + let n = length args + varNs <- newNames n "x" + varIn <- newName "_inp" + let pat = ConP constr [] $ map VarP varNs + allVars = map varE varNs + inpVar = varE varIn + body <- appsE ( conE constr : (map (\ x -> [|progressInternal $inpVar $x|]) allVars)) + return $ Clause [VarP varIn, pat] (NormalB body) [] + genNextProgress (constr, args,_) = do + let n = length args + varNs <- newNames n "x" + let pat = ConP constr [] $ map VarP varNs + allVars = map varE varNs + body <- if n == 0 then [|emptyClock|] else foldl1 (\ x y -> [|clockUnion $x $y|]) ((map (\ x -> [|nextProgress $x|]) allVars)) + return $ Clause [pat] (NormalB body) [] diff --git a/src/WidgetRattus/Future.hs b/src/WidgetRattus/Future.hs new file mode 100644 --- /dev/null +++ b/src/WidgetRattus/Future.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS -fplugin=WidgetRattus.Plugin #-} + + +-- | Programming with futures. + +module WidgetRattus.Future + ( F(..) + , SigF(..) + , mkSigF + , mkSigF' + , current + , future + , bindF + , mapF + , sync + , syncF + , switchAwait + , switch + , switchS + , filterMap + , filterMapAwait + , filterAwait + , filter + , trigger + , triggerAwait + , map + , mapAwait + , zipWith + , zipWithAwait + , fromSig + , scan + , scanAwait + ) + +where + +import WidgetRattus +import WidgetRattus.Signal (Sig(..)) +import Prelude hiding (map, filter, zipWith) + +newtype OneShot a = OneShot (F a) + +instance Producer (OneShot a) a where + getCurrent (OneShot (Now x)) = Just' x + getCurrent (OneShot (Wait _)) = Nothing' + + getNext (OneShot (Now _)) cb = cb (never :: O (OneShot a)) + getNext (OneShot (Wait x)) cb = cb (delay (OneShot (adv x))) + +instance Producer p a => Producer (F p) a where + getCurrent (Now x) = getCurrent x + getCurrent (Wait _) = Nothing' + + getNext (Now x) cb = getNext x cb + getNext (Wait x) cb = cb x + +instance Producer (SigF a) a where + getCurrent (x :>: _) = Just' x + getNext (_ :>: xs) cb = cb xs + + + +-- | @F a@ will produces a value of type @a@ after zero or more ticks +-- of some clocks +data F a = Now !a | Wait !(O (F a)) + + + +bindF :: F a -> Box (a -> F b) -> F b +bindF (Now x) f = unbox f x +bindF (Wait x) f = Wait (delay (bindF (adv x) f)) + +mapF :: Box (a -> b) -> F a -> F b +mapF f d = d `bindF` (box (\ x -> Now (unbox f x))) + + +sync :: O (F a) -> O (F b) -> O (F a :* F b) +sync x y = delay (case select x y of + Fst x' y' -> (x' :* Wait y') + Snd x' y' -> (Wait x' :* y') + Both x' y' -> (x' :* y')) + +syncF :: (Stable a, Stable b) => F a -> F b -> F (a :* b) +syncF (Now x) (Now y) = Now (x :* y) +syncF (Wait x) (Now y) = Wait (delay (syncA (adv x) y)) +syncF (Now x) (Wait y) = Wait (delay (syncB x (adv y))) +syncF (Wait x) (Wait y) = Wait (delay (case select x y of + Fst x' y' -> syncF x' (Wait y') + Snd x' y' -> syncF (Wait x') y' + Both x' y' -> syncF x' y' + )) + +syncA :: (Stable b) => F a -> b -> F (a :* b) +syncA (Now x) y = Now (x :* y) +syncA (Wait x) y = Wait (delay (syncA (adv x) y)) + + +syncB :: (Stable a) => a -> F b -> F (a :* b) +syncB x (Now y) = Now (x :* y) +syncB x (Wait y) = Wait (delay (syncB x (adv y))) + + +-- | @SigF a@ is a signal of values of type @a@. In contrast to 'Sig', +-- 'SigF' supports the 'filter' and 'filterMap' functions. +data SigF a = !a :>: !(O (F (SigF a))) + + +-- | Get the current value of a signal. +current :: SigF a -> a +current (x :>: _) = x + + +-- | Get the future the signal. +future :: SigF a -> O (F (SigF a)) +future (_ :>: xs) = xs + + +mkSigF :: Box (O a) -> F (SigF a) +mkSigF b = Wait (mkSigF' b) where + +mkSigF' :: Box (O a) -> O (F (SigF a)) +mkSigF' b = delay (Now (adv (unbox b) :>: mkSigF' b)) + + +fromSig :: Sig a -> SigF a +fromSig (x ::: xs) = x :>: delay (Now (fromSig (adv xs))) + + +switchAwait :: F (SigF a) -> F (SigF a) -> F(SigF a) +switchAwait _ (Now ys) = Now ys +switchAwait (Now (x :>: xs)) (Wait ys) = Now (x :>: delay (uncurry' switchAwait (adv (sync xs ys)) )) +switchAwait (Wait xs) (Wait ys) = Wait (delay (uncurry' switchAwait (adv (sync xs ys)) )) + +switch :: SigF a -> F (SigF a) -> SigF a +switch _ (Now ys) = ys +switch (x :>: xs) (Wait ys) = x :>: delay (uncurry' switchAwait (adv (sync xs ys))) + +switchS :: Stable a => SigF a -> F (a -> SigF a) -> SigF a +switchS (x :>: _) (Now f) = f x +switchS (x :>: xs) (Wait ys) = x :>: delay (uncurry' (switchAwaitS x) (adv (sync xs ys))) + +switchAwaitS :: Stable a => a -> F (SigF a) -> F (a -> SigF a) -> F (SigF a) +switchAwaitS _ (Now (x :>: _)) (Now f) = Now (f x) +switchAwaitS _ (Now (x :>: xs)) (Wait ys) = + Now (x :>: delay (uncurry' (switchAwaitS x) (adv (sync xs ys)))) +switchAwaitS x (Wait _) (Now f) = Now (f x) +switchAwaitS x (Wait xs) (Wait ys) = Wait (delay (uncurry' (switchAwaitS x) (adv (sync xs ys)))) + + + +filterMapAwait :: Box (a -> Maybe' b) -> F(SigF a) -> F (SigF b) +filterMapAwait f (Wait xs) = Wait (delay (filterMapAwait f (adv xs))) +filterMapAwait f (Now (x :>: xs)) = case unbox f x of + Just' y -> Now (y :>: delay (filterMapAwait f (adv xs))) + Nothing' -> Wait (delay (filterMapAwait f (adv xs))) + +filterMap :: Box (a -> Maybe' b) -> SigF a -> F (SigF b) +filterMap f xs = filterMapAwait f (Now xs) + + +filterAwait :: Box (a -> Bool) -> F( SigF a) -> F (SigF a) +filterAwait p = filterMapAwait (box (\ x -> if unbox p x then Just' x else Nothing')) + +filter :: Box (a -> Bool) -> SigF a -> F (SigF a) +filter p = filterMap (box (\ x -> if unbox p x then Just' x else Nothing')) + +trigger :: Stable b => Box (a -> b -> c) -> SigF a -> SigF b -> SigF c +trigger f (a :>: as) (b :>: bs) = + unbox f a b :>: + delay (uncurry' (trigger' b f) (adv (sync as bs))) + +triggerAwait :: Stable b => Box (a -> b -> c) -> F (SigF a) -> SigF b -> F (SigF c) +triggerAwait f (Now (a :>: as)) (b :>: bs) + = Now (unbox f a b :>: delay (uncurry' (trigger' b f) (adv (sync as bs)))) +triggerAwait f (Wait as) (b :>: bs) + = Wait (delay (uncurry' (trigger' b f) (adv (sync as bs)))) + +trigger' :: Stable b => b -> Box (a -> b -> c) -> F (SigF a) -> F (SigF b) -> F (SigF c) +trigger' b f (Now (a :>: as)) (Wait bs) = + Now (unbox f a b :>: delay (uncurry' (trigger' b f) (adv (sync as bs)))) +trigger' _ f (Now (a :>: as)) (Now (b :>: bs)) = + Now (unbox f a b :>: delay (uncurry' (trigger' b f) (adv (sync as bs)))) +trigger' b f (Wait as) (Wait bs) = + Wait (delay (uncurry' (trigger' b f) (adv (sync as bs)))) +trigger' _ f (Wait as) (Now (b :>: bs)) = + Wait (delay (uncurry' (trigger' b f) (adv (sync as bs)))) + + +mapAwait :: Box (a -> b) -> F (SigF a) -> F (SigF b) +mapAwait f (Now (x :>: xs)) = Now (unbox f x :>: delay (mapAwait f (adv xs))) +mapAwait f (Wait xs) = Wait (delay (mapAwait f (adv xs))) + +map :: Box (a -> b) -> SigF a -> SigF b +map f (x :>: xs) = unbox f x :>: delay (mapAwait f (adv xs)) + + + +zipWith :: (Stable a, Stable b) => Box(a -> b -> c) -> SigF a -> SigF b -> SigF c +zipWith f (a :>: as) (b :>: bs) = unbox f a b :>: delay (uncurry' (zipWithAwait f a b) (adv (sync as bs))) + +zipWithAwait :: (Stable a, Stable b) => Box(a -> b -> c) -> a -> b -> F (SigF a) -> F (SigF b) -> F (SigF c) +zipWithAwait f _ _ (Now (a :>: as)) (Now (b :>: bs)) = Now (unbox f a b :>: delay (uncurry' (zipWithAwait f a b) (adv (sync as bs)))) +zipWithAwait f _ b (Now (a :>: as)) (Wait bs) = Now (unbox f a b :>: delay (uncurry' (zipWithAwait f a b) (adv (sync as bs)))) +zipWithAwait f a _ (Wait as) (Now (b :>: bs)) = Now (unbox f a b :>: delay (uncurry' (zipWithAwait f a b) (adv (sync as bs)))) +zipWithAwait f a b (Wait as) (Wait bs) = Wait (delay (uncurry' (zipWithAwait f a b) (adv (sync as bs)))) + +scan :: (Stable b) => Box(b -> a -> b) -> b -> SigF a -> SigF b +scan f acc (a :>: as) = acc' :>: delay (scanAwait f acc' (adv as)) + where acc' = unbox f acc a + +scanAwait :: (Stable b) => Box (b -> a -> b) -> b -> F (SigF a) -> F (SigF b) +scanAwait f acc (Now (a :>: as)) = Now (acc' :>: delay (scanAwait f acc' (adv as))) + where acc' = unbox f acc a +scanAwait f acc (Wait as) = Wait (delay (scanAwait f acc (adv as))) diff --git a/src/WidgetRattus/InternalPrimitives.hs b/src/WidgetRattus/InternalPrimitives.hs new file mode 100644 --- /dev/null +++ b/src/WidgetRattus/InternalPrimitives.hs @@ -0,0 +1,264 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +module WidgetRattus.InternalPrimitives where + +import Prelude hiding (Left, Right) +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet +import Data.IORef +import Control.Concurrent.MVar +import System.IO.Unsafe +import System.Mem.Weak +import Control.Monad + +-- An input channel is identified by an integer. The programmer should not know about it. +type InputChannelIdentifier = Int + +type Clock = IntSet + +singletonClock :: InputChannelIdentifier -> Clock +singletonClock = IntSet.singleton + +emptyClock :: Clock +emptyClock = IntSet.empty + +clockUnion :: Clock -> Clock -> Clock +clockUnion = IntSet.union + +channelMember :: InputChannelIdentifier -> Clock -> Bool +channelMember = IntSet.member + +data InputValue where + OneInput :: !InputChannelIdentifier -> !a -> InputValue + MoreInputs :: !InputChannelIdentifier -> !a -> !InputValue -> InputValue + +inputInClock :: InputValue -> Clock -> Bool +inputInClock (OneInput ch _) cl = channelMember ch cl +inputInClock (MoreInputs ch _ more) cl = channelMember ch cl || inputInClock more cl + + +-- | The "later" type modality. A value @v@ of type @O 𝜏@ consists of +-- two components: Its clock, denoted @cl(v)@, and a delayed +-- computation that will produce a value of type @𝜏@ as soon as the +-- clock @cl(v)@ ticks. The clock @cl(v)@ is only used for type +-- checking and is not directly accessible, whereas the delayed +-- computation is accessible via 'adv' and 'select'. + +data O a = Delay !Clock (InputValue -> a) + +-- | The return type of the 'select' primitive. +data Select a b = Fst !a !(O b) | Snd !(O a) !b | Both !a !b + +rattusError pr = error (pr ++ ": Did you forget to mark this as Async Rattus code?") + +-- | This is the constructor for the "later" modality 'O': +-- +-- > Ξ“ βœ“ΞΈ ⊒ t :: 𝜏 +-- > -------------------- +-- > Ξ“ ⊒ delay t :: O 𝜏 +-- +-- The typing rule requires that its argument @t@ typecheck with an +-- additional tick @βœ“ΞΈ@ of some clock @ΞΈ@. +{-# INLINE [1] delay #-} +delay :: a -> O a +delay _ = rattusError "delay" + +extractClock :: O a -> Clock +extractClock (Delay cl _) = cl + +{-# INLINE [1] adv' #-} +adv' :: O a -> InputValue -> a +adv' (Delay _ f) inp = f inp + + +-- | This is the eliminator for the "later" modality 'O': +-- +-- > Ξ“ ⊒ t :: O 𝜏 Ξ“' tick-free +-- > --------------------------------- +-- > Ξ“ βœ“cl(t) Ξ“' ⊒ adv t :: 𝜏 +-- +-- It requires that a tick @βœ“ΞΈ@ is in the context whose clock matches +-- exactly the clock of @t@, i.e. @ΞΈ = cl(t)@. + +{-# INLINE [1] adv #-} +adv :: O a -> a +adv _ = rattusError "adv" + +-- | If we want to eliminate more than one delayed computation, i.e.\ +-- two @s :: O Οƒ@ and @t :: O 𝜏@, we need to use 'select' instead of +-- just 'adv'. +-- +-- > Ξ“ ⊒ s :: O Οƒ Ξ“ ⊒ t :: O 𝜏 Ξ“' tick-free +-- > -------------------------------------------------- +-- > Ξ“ βœ“cl(s)βŠ”cl(t) Ξ“' ⊒ select s t :: Select Οƒ 𝜏 +-- +-- It requires that we have a tick @βœ“ΞΈ@ in the context whose clock +-- matches the union of the clocks of @s@ and @t@, i.e. @ΞΈ = +-- cl(s)βŠ”cl(t)@. The union of two clocks ticks whenever either of the +-- two clocks ticks, i.e. @cl(s)βŠ”cl(t)@, whenever @cl(s)@ or @cl(t)@ +-- ticks. +-- +-- That means there are three possible outcomes, which are reflected +-- in the result type of @select s t@. A value of @Select Οƒ 𝜏@ is +-- either +-- +-- * a value of type @Οƒ@ and a delayed computation of type @O 𝜏@, if +-- @cl(s)@ ticks before @cl(t)@, +-- +-- * a value of type @𝜏@ and a delayed computation of type @O Οƒ@, if +-- @cl(t)@ ticks before @cl(s)@, or +-- +-- * a value of type @Οƒ@ and a value of type @𝜏@, if @cl(s)@ and +-- * @cl(s)@ tick simultaneously. + + +{-# INLINE [1] select #-} +select :: O a -> O b -> Select a b +select _ _ = rattusError "select" + +select' :: O a -> O b -> InputValue -> Select a b +select' a@(Delay clA inpFA) b@(Delay clB inpFB) inp + = if inputInClock inp clA then + if inputInClock inp clB then Both (inpFA inp) (inpFB inp) + else Fst (inpFA inp) b + else Snd a (inpFB inp) + + + +-- | The clock of @never :: O 𝜏@ will never tick, i.e. it will never +-- produce a value of type @𝜏@. With 'never' we can for example +-- implement the constant signal @x ::: never@ of type @Sig a@ for any @x :: +-- a@. +never :: O a +never = Delay emptyClock (error "Trying to adv on the 'never' delayed computation") + +-- | A type is @Stable@ if it is a strict type and the later modality +-- @O@ and function types only occur under @Box@. +-- +-- For example, these types are stable: @Int@, @Box (a -> b)@, @Box (O +-- Int)@, @Box (Sig a -> Sig b)@. +-- +-- But these types are not stable: @[Int]@ (because the list type is +-- not strict), @Int -> Int@, (function type is not stable), @O +-- Int@, @Sig Int@. + +class Stable a where + + + +-- | The "stable" type modality. A value of type @Box a@ is a +-- time-independent computation that produces a value of type @a@. +-- Use 'box' and 'unbox' to construct and consume 'Box'-types. +data Box a = Box a + + +-- | This is the constructor for the "stable" modality 'Box': +-- +-- > Ξ“β˜ ⊒ t :: 𝜏 +-- > -------------------- +-- > Ξ“ ⊒ box t :: Box 𝜏 +-- +-- where Ξ“β˜ is obtained from Ξ“ by removing all ticks and all variables +-- @x :: 𝜏@, where 𝜏 is not a stable type. + +{-# INLINE [1] box #-} +box :: a -> Box a +box x = Box x + + +-- | This is the eliminator for the "stable" modality 'Box': +-- +-- > Ξ“ ⊒ t :: Box 𝜏 +-- > ------------------ +-- > Ξ“ ⊒ unbox t :: 𝜏 +{-# INLINE [1] unbox #-} +unbox :: Box a -> a +unbox (Box d) = d + + +defaultPromote :: Continuous a => a -> Box a +defaultPromote x = unsafePerformIO $ + do r <- newIORef x + r' <- mkWeakIORef r (return ()) + modifyIORef promoteStore (ContinuousData r' :) + return (Box (unsafePerformIO $ readIORef r)) + + +class Continuous p where + -- | Computes the same as 'progressInternal' and 'nextProgress'. In + -- particular @progressAndNext inp v = (progressInternal inp v, + -- nextProgress (progressInternal inp v))@. + progressAndNext :: InputValue -> p -> (p , Clock) + + -- | Progresses the continuous value, given the input value from + -- some channel + progressInternal :: InputValue -> p -> p + -- | Computes the set of channels that the continuous value is + -- depending on. That is if @nextProgress v = cl@ and a new input + -- @inp@ on channel @ch@ arrives, then @progressInternal inp v = v@ + -- if @not (ch `channelMember` cl)@. + nextProgress :: p -> Clock + promoteInternal :: p -> Box p + promoteInternal = defaultPromote + +-- For stable types we can circumvent the "promote store". +instance {-# OVERLAPPABLE #-} Stable a => Continuous a where + progressAndNext _ x = (x , emptyClock) + progressInternal _ x = x + nextProgress _ = emptyClock + promoteInternal = Box + +data ContinuousData where + ContinuousData :: Continuous a => !(Weak (IORef a)) -> ContinuousData + +-- TODO: The list type needs to be replaced by a more efficient +-- mutable data structure. +{-# NOINLINE promoteStore #-} +promoteStore :: IORef [ContinuousData] +promoteStore = unsafePerformIO (newIORef []) + +{-# NOINLINE progressPromoteStoreMutex #-} +progressPromoteStoreMutex :: MVar () +progressPromoteStoreMutex = unsafePerformIO (newMVar ()) + + +-- | Atomic version of 'progressPromoteStore'. + +progressPromoteStoreAtomic :: InputValue -> IO () +progressPromoteStoreAtomic inp = do + takeMVar progressPromoteStoreMutex + progressPromoteStore inp + putMVar progressPromoteStoreMutex () + + +-- | For promote to work, its argument must be stored in the "promote +-- store", and whenenver an input is received on some channel, all +-- values in the "promote store" must be advanced (using +-- 'progressInternal'). + +progressPromoteStore :: InputValue -> IO () +progressPromoteStore inp = do + xs <- atomicModifyIORef promoteStore (\x -> ([],x)) + xs' <- filterM run xs + atomicModifyIORef promoteStore (\x -> (x ++ xs',())) + where run (ContinuousData x) = do + d <- deRefWeak x + case d of + Nothing -> return False + Just x -> modifyIORef' x (progressInternal inp) >> return True + +promote :: Continuous a => a -> Box a +promote x = promoteInternal x + +newtype Chan a = Chan InputChannelIdentifier + +{-# RULES + "unbox/box" forall x. unbox (box x) = x + #-} + + +{-# RULES + "box/unbox" forall x. box (unbox x) = x + #-} diff --git a/src/WidgetRattus/Plugin.hs b/src/WidgetRattus/Plugin.hs new file mode 100644 --- /dev/null +++ b/src/WidgetRattus/Plugin.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE CPP #-} + + +-- | The plugin to make it all work. + +module WidgetRattus.Plugin (plugin, WidgetRattus(..)) where +import WidgetRattus.Plugin.StableSolver +import WidgetRattus.Plugin.ScopeCheck +import WidgetRattus.Plugin.Strictify +import WidgetRattus.Plugin.SingleTick +import WidgetRattus.Plugin.CheckClockCompatibility +import WidgetRattus.Plugin.Utils +import WidgetRattus.Plugin.Annotation +import WidgetRattus.Plugin.Transform + +import Prelude hiding ((<>)) + +import Control.Monad +import Data.Maybe +import Data.List +import Data.Data hiding (tyConName) +import qualified Data.Set as Set +import Data.Set (Set) + +import qualified GHC.LanguageExtensions as LangExt + +import GHC.Plugins +import GHC.Tc.Types + +-- | Use this to enable Asynchronous Rattus' plugin, either by supplying the option +-- @-fplugin=WidgetRattus.Plugin@ directly to GHC, or by including the +-- following pragma in each source file: +-- +-- > {-# OPTIONS -fplugin=WidgetRattus.Plugin #-} +plugin :: Plugin +plugin = defaultPlugin { + installCoreToDos = install, + pluginRecompile = purePlugin, + typeCheckResultAction = typechecked, + 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 + +install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] +install opts todo = case find findSamePass todo of -- check that we don't run the transformation twice + Nothing -> return (strPass : todo) -- (e.g. if the "-fplugin" option is used twice) + _ -> return todo + where name = "Async Rattus strictify" + strPass = CoreDoPluginPass name (strictifyProgram Options{debugMode = dmode}) + dmode = "debug" `elem` opts + findSamePass (CoreDoPluginPass s _) = s == name + findSamePass _ = False + + +-- | Apply the following operations to all Asynchronous Rattus definitions in the +-- program: +-- +-- * Transform into single tick form (see SingleTick module) +-- * Check whether lazy data types are used (see Strictify module) +-- * Transform into call-by-value form (see Strictify module) + +strictifyProgram :: Options -> ModGuts -> CoreM ModGuts +strictifyProgram opts guts = do + newBinds <- mapM (strictify opts guts) (mg_binds guts) + return guts { mg_binds = newBinds } + +strictify :: Options -> ModGuts -> CoreBind -> CoreM CoreBind +strictify opts guts b@(Rec bs) = do + let debug = debugMode opts + tr <- liftM or (mapM (shouldProcessCore guts . fst) bs) + if tr then do + let vs = map fst bs + es' <- mapM (\ (v,e) -> do + processCore <- shouldProcessCore guts v + if not processCore + then do + when debug $ putMsg $ text "Skipping binding: " <> ppr v + return e + else checkAndTransform guts (Set.fromList vs) debug v e + ) bs + when debug $ putMsg $ "Plugin | result of transformation: " <> ppr es' + return (Rec (zip vs es')) + else return b +strictify opts guts b@(NonRec v e) = do + let debug = debugMode opts + when debug $ putMsg $ text "Processing binding: " <> ppr v <> text " | Non-recursive binding" + when debug $ putMsg $ text "Expr: " <> ppr e + processCore <- shouldProcessCore guts v + if not processCore then do + when debug $ putMsg $ text "Skipping binding: " <> ppr v + return b + else do + transformed <- checkAndTransform guts Set.empty debug v e + when debug $ putMsg $ "Plugin | result of transformation: " <> ppr transformed + return $ NonRec v transformed + +checkAndTransform :: ModGuts -> Set Var -> Bool -> Var -> CoreExpr -> CoreM CoreExpr +checkAndTransform guts recursiveSet debug v e = do + when debug $ putMsg $ text "Processing binding: " <> ppr v + when debug $ putMsg $ text "Expr: " <> ppr e + allowRec <- allowRecursion guts v + singleTick <- toSingleTick e + when debug $ putMsg $ text "Single-tick: " <> ppr singleTick + lazy <- allowLazyData guts v + 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} singleTick + transform singleTick + +getModuleAnnotations :: Data a => ModGuts -> [a] +getModuleAnnotations guts = anns' + where anns = filter (\a-> case ann_target a of + ModuleTarget m -> m == (mg_module guts) + _ -> False) (mg_anns guts) + anns' = mapMaybe (fromSerialized deserializeWithData . ann_value) anns + + + + +allowLazyData :: ModGuts -> CoreBndr -> CoreM Bool +allowLazyData guts bndr = do + l <- annotationsOn guts bndr :: CoreM [WidgetRattus] + return (AllowLazyData `elem` l) + +allowRecursion :: ModGuts -> CoreBndr -> CoreM Bool +allowRecursion guts bndr = do + l <- annotationsOn guts bndr :: CoreM [WidgetRattus] + return (AllowRecursion `elem` l) + +expectError :: ModGuts -> CoreBndr -> CoreM Bool +expectError guts bndr = do + l <- annotationsOn guts bndr :: CoreM [InternalAnn] + return $ ExpectError `elem` l + + +shouldProcessCore :: ModGuts -> CoreBndr -> CoreM Bool +shouldProcessCore guts bndr = do + expectScopeError <- expectError guts bndr + return (userFunction bndr && not expectScopeError) + +annotationsOn :: (Data a) => ModGuts -> CoreBndr -> CoreM [a] +annotationsOn guts bndr = do + (_,anns) <- getAnnotations deserializeWithData guts + return $ + lookupWithDefaultUFM anns [] (varName bndr) ++ + getModuleAnnotations guts diff --git a/src/WidgetRattus/Plugin/Annotation.hs b/src/WidgetRattus/Plugin/Annotation.hs new file mode 100644 --- /dev/null +++ b/src/WidgetRattus/Plugin/Annotation.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE DeriveDataTypeable #-} +module WidgetRattus.Plugin.Annotation (WidgetRattus(..), InternalAnn (..)) where + +import Data.Data + +-- | 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 #-} +-- +-- 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 WidgetRattus = AllowLazyData | AllowRecursion deriving (Typeable, Data, Show, Ord, Eq) + + +-- | This annotation type is for internal use only. +data InternalAnn = ExpectError | ExpectWarning deriving (Typeable, Data, Show, Eq, Ord) diff --git a/src/WidgetRattus/Plugin/CheckClockCompatibility.hs b/src/WidgetRattus/Plugin/CheckClockCompatibility.hs new file mode 100644 --- /dev/null +++ b/src/WidgetRattus/Plugin/CheckClockCompatibility.hs @@ -0,0 +1,261 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE CPP #-} + +-- | This module implements the check that the transformed code is +-- typable in the single tick calculus. + +module WidgetRattus.Plugin.CheckClockCompatibility + (checkExpr, CheckExpr (..)) where + +import GHC.Types.Tickish +import GHC.Plugins + +import WidgetRattus.Plugin.Utils +import qualified WidgetRattus.Plugin.PrimExpr as Prim +import Prelude hiding ((<>)) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (isJust) +import Control.Monad (foldM, when) +import Control.Applicative ((<|>)) +import System.Exit (exitFailure) + +type LCtx = Set Var +data HiddenReason = BoxApp | AdvApp | NestedRec Var | FunDef | DelayApp +type Hidden = Map Var HiddenReason + +data TypeError = TypeError SrcSpan SDoc + + +data Ctx = Ctx + { current :: LCtx, + hidden :: Hidden, + earlier :: Maybe LCtx, + srcLoc :: SrcSpan, + recDef :: Set Var, -- ^ recursively defined variables + stableTypes :: Set Var, + allowRecursion :: Bool, + allowGuardedRec :: Bool + } + +hasTick :: Ctx -> Bool +hasTick = isJust . earlier + +stabilize :: HiddenReason -> Ctx -> Ctx +stabilize hr c = c + {current = Set.empty, + earlier = Nothing, + hidden = hidden c `Map.union` Map.fromSet (const hr) ctxHid, + allowGuardedRec = False + } + where ctxHid = maybe (current c) (Set.union (current c)) (earlier c) + +data Scope = Hidden SDoc | Visible + +getScope :: Ctx -> Var -> Scope +getScope c v = + if v `Set.member` recDef c then + if allowGuardedRec c || allowRecursion c || typeClassFunction v 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 -> + 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.") + + FunDef -> Hidden ("Variable " <> ppr v <> " is no longer in scope: It occurs in a function that is defined under a delay, is a of a non-stable type " <> ppr (varType v) <> ", and is bound outside delay") + DelayApp -> Hidden ("Variable " <> ppr v <> " is no longer in scope: It occurs under two occurrences of delay and is a of a non-stable type " <> ppr (varType v)) + Nothing + | maybe False (Set.member v) (earlier c) -> + if isStable (stableTypes c) (varType v) then Visible + else Hidden ("Variable " <> ppr v <> " is no longer in scope:" $$ + "It occurs under delay" $$ "and is of type " <> ppr (varType v) <> ", which is not stable.") + | Set.member v (current c) -> Visible + | otherwise -> Visible + + + +pickFirst :: SrcSpan -> SrcSpan -> SrcSpan +pickFirst s@RealSrcSpan{} _ = s +pickFirst _ s = s + +typeError :: Ctx -> Var -> SDoc -> TypeError +typeError ctx var = TypeError (pickFirst (srcLoc ctx) (nameSrcSpan (varName var))) + +instance Outputable TypeError where + ppr (TypeError srcLoc sdoc) = text "TypeError at " <> ppr srcLoc <> text ": " <> ppr sdoc + +emptyCtx :: CheckExpr -> Ctx +emptyCtx c = + Ctx { current = Set.empty, + earlier = Nothing, + hidden = Map.empty, + srcLoc = noLocationInfo, + recDef = recursiveSet c, + stableTypes = Set.empty, + allowRecursion = allowRecExp c, + allowGuardedRec = False + } + +stabilizeLater :: Ctx -> Ctx +stabilizeLater c = + case earlier c of + Just earl -> c {earlier = Nothing, + hidden = hidden c `Map.union` Map.fromSet (const FunDef) earl} + Nothing -> c + +isStableConstr :: Type -> CoreM (Maybe Var) +isStableConstr t = + case splitTyConApp_maybe t of + Just (con,[args]) -> + case getNameModule con of + Just (name, mod) -> + if isRattModule mod && name == "Stable" + then return (getTyVar_maybe args) + else return Nothing + _ -> return Nothing + _ -> return Nothing + +-- should be equatable +type SymbolicClock = Set Var + +mkClock1 :: Var -> SymbolicClock +mkClock1 = Set.singleton + +mkClock2 :: Var -> Var -> SymbolicClock +mkClock2 v1 v2 = Set.fromList [v1, v2] + +newtype CheckResult = CheckResult{ + -- if present, contains the variable of the primitive applied so we can report its position + -- in case of an error, and the clock for the primitive + prim :: Maybe (Var, SymbolicClock) +} + +instance Outputable CheckResult where + ppr (CheckResult prim) = text "CheckResult {prim = " <> ppr prim <> text "}" + +emptyCheckResult :: CheckResult +emptyCheckResult = CheckResult {prim = Nothing} + +data CheckExpr = CheckExpr{ + recursiveSet :: Set Var, + oldExpr :: Expr Var, + verbose :: Bool, + allowRecExp :: Bool + } + +checkExpr :: CheckExpr -> Expr Var -> CoreM () +checkExpr c e = do + when (verbose c) $ putMsg $ text "checkExpr: " <> ppr e + res <- checkExpr' (emptyCtx c) e + case res of + Right _ -> do when (verbose c) $ putMsgS "checkExpr succeeded." + Left (TypeError src doc) -> + let printErrMsg = if verbose c + then do + printMessage SevError src ("Internal error in Async Rattus Plugin: single tick transformation did not preserve typing." $$ doc) + putMsgS "-------- old --------" + putMsg $ ppr (oldExpr c) + putMsgS "-------- new --------" + putMsg (ppr e) + + else do + printMessage SevError noSrcSpan ("Internal error in Async Rattus Plugin: single tick transformation did not preserve typing." $$ + "Compile with flags \"-fplugin-opt WidgetRattus.Plugin:debug\" and \"-g2\" for detailed information") + in do + printErrMsg + liftIO exitFailure + + +checkExpr' :: Ctx -> Expr Var -> CoreM (Either TypeError CheckResult) +checkExpr' c (App e e') | isType e' || (not $ tcIsLiftedTypeKind $ typeKind $ exprType e') + = checkExpr' c e +checkExpr' c@Ctx{current = cur, earlier = earl} expr@(App e e') = + case Prim.isPrimExpr expr of + Just (Prim.BoxApp _) -> + checkExpr' (stabilize BoxApp c) e' + Just (Prim.DelayApp f _) -> do + let c' = case earl of + Nothing -> c{current = Set.empty, earlier = Just cur, allowGuardedRec = True} + Just earl' -> c{ current = Set.empty, earlier = Just cur, allowGuardedRec = True, + hidden = hidden c `Map.union` Map.fromSet (const DelayApp) earl'} + eRes <- checkExpr' c' e' + case eRes of + Left err -> return $ Left err + Right (CheckResult {prim = Nothing}) -> return $ Left $ typeError c f (text "Each delay must contain an adv or select") + Right _ -> return $ Right emptyCheckResult + Just (Prim.AdvApp f _) | not (hasTick c) -> return $ Left $ typeError c f (text "can only use adv under delay") + Just (Prim.AdvApp f (arg, _)) -> return $ Right $ CheckResult {prim = Just (f, mkClock1 arg)} + Just (Prim.SelectApp f _ _) | not (hasTick c) -> return $ Left $ typeError c f (text "can only use select under delay") + Just (Prim.SelectApp f (arg1, _) (arg2, _))-> return $ Right $ CheckResult {prim = Just (f, mkClock2 arg1 arg2)} + Nothing -> checkBoth c e e' +checkExpr' c (Case e v _ alts) = do + res <- checkExpr' c' e + resAll <- mapM (\(Alt _ _ altE) -> checkExpr' c altE) alts + foldM (fmap return . combine c) res resAll + where c' = addVars [v] c +checkExpr' c (Lam v e) + | isTyVar v || (not $ tcIsLiftedTypeKind $ typeKind $ varType v) = do + is <- isStableConstr (varType v) + let c' = case is of + Nothing -> c + Just t -> c{stableTypes = Set.insert t (stableTypes c)} + checkExpr' c' e + | otherwise = checkExpr' (addVars [v] (stabilizeLater c)) e +checkExpr' _ (Type _) = return $ Right emptyCheckResult +checkExpr' _ (Lit _) = return $ Right emptyCheckResult +checkExpr' _ (Coercion _) = return $ Right emptyCheckResult +checkExpr' c (Tick (SourceNote span _name) e) = + checkExpr' c{srcLoc = fromRealSrcSpan span} e +checkExpr' c (Tick _ e) = checkExpr' c e +checkExpr' c (Cast e _) = checkExpr' c e +checkExpr' c (Let (NonRec _ e1) e2) = do + res1 <- checkExpr' c e1 + res2 <- checkExpr' c e2 + return $ combine c res1 res2 +checkExpr' c (Let (Rec binds) e2) = do + resAll <- mapM (\ (v,e) -> checkExpr' (c' v) e) binds + res <- checkExpr' (addVars vs c) e2 + foldM (fmap return . combine c) res resAll + where vs = map fst binds + ctxHid = maybe (current c) (Set.union (current c)) (earlier c) + c' v = c {current = Set.empty, + earlier = Nothing, + hidden = hidden c `Map.union` + Map.fromSet (const (NestedRec v)) ctxHid, + recDef = recDef c `Set.union` Set.fromList vs } +checkExpr' c (Var v) + | tcIsLiftedTypeKind $ typeKind $ varType v = case getScope c v of + Hidden reason -> return $ Left $ typeError c v reason + Visible -> return $ Right emptyCheckResult + | otherwise = return $ Right emptyCheckResult + +addVars :: [Var] -> Ctx -> Ctx +addVars v c = c{current = Set.fromList v `Set.union` current c } + +checkBoth :: Ctx -> CoreExpr -> CoreExpr -> CoreM (Either TypeError CheckResult) +checkBoth c e e' = do + c1 <- checkExpr' c e + c2 <- checkExpr' c e' + return $ combine c c1 c2 + +-- Combines two CheckResults such that the clocks therein are compatible. +-- If both CheckResults have PrimVars, one is picked arbitrarily. +combine :: Ctx -> Either TypeError CheckResult -> Either TypeError CheckResult -> Either TypeError CheckResult +combine c eRes1 eRes2 = do + res1 <- eRes1 + res2 <- eRes2 + case (res1, res2) of + (CheckResult (Just (_, cl1)), CheckResult (Just (_, cl2))) | cl1 == cl2 -> Right res2 + (CheckResult (Just _), CheckResult (Just (p, _))) -> Left $ typeError c p "Only one adv/select allowed in a delay" + (CheckResult maybeP, CheckResult maybeP') -> Right $ CheckResult {prim = maybeP <|> maybeP'} diff --git a/src/WidgetRattus/Plugin/Dependency.hs b/src/WidgetRattus/Plugin/Dependency.hs new file mode 100644 --- /dev/null +++ b/src/WidgetRattus/Plugin/Dependency.hs @@ -0,0 +1,385 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# 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 +-- (mutual) recursive. To this end, this module also provides +-- functions to compute, bound variables and variable occurrences. + +module WidgetRattus.Plugin.Dependency (dependency, HasBV (..),printBinds) where + + +import GHC.Plugins +import GHC.Data.Bag +import GHC.Hs.Type + + +import GHC.Hs.Extension +import GHC.Hs.Expr +import GHC.Hs.Pat +import GHC.Hs.Binds + +#if __GLASGOW_HASKELL__ >= 904 +import GHC.Parser.Annotation +#else +import Language.Haskell.Syntax.Extension +import GHC.Parser.Annotation +#endif + + +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Graph +import Data.Maybe +import Data.Either +import Prelude hiding ((<>)) + + + +-- | Compute the dependencies of a bag of bindings, returning a list +-- of the strongly-connected components. +dependency :: Bag (LHsBindLR GhcTc GhcTc) -> [SCC (LHsBindLR GhcTc GhcTc, Set Var)] +dependency binds = map AcyclicSCC noDeps ++ catMaybes (map filterJust (stronglyConnComp (concat deps))) + where (deps,noDeps) = partitionEithers $ map mkDep $ bagToList binds + mkDep :: GenLocated l (HsBindLR GhcTc GhcTc) -> + Either [(Maybe (GenLocated l (HsBindLR GhcTc GhcTc), Set Var), Name, [Name])] + (GenLocated l (HsBindLR GhcTc GhcTc), Set Var) + mkDep b = + let dep = map varName $ Set.toList (getFV b) + vars = getBV b in + case Set.toList vars of + (v:vs) -> Left ((Just (b,vars), varName v , dep) : map (\ v' -> (Nothing, varName v' , dep)) vs) + [] -> Right (b,vars) + filterJust (AcyclicSCC Nothing) = Nothing -- this should not happen + filterJust (AcyclicSCC (Just b)) = Just (AcyclicSCC b) + filterJust (CyclicSCC bs) = Just (CyclicSCC (catMaybes bs)) + + +printBinds (AcyclicSCC bind) = liftIO (putStr "acyclic bind: ") >> printBind (fst bind) >> liftIO (putStrLn "") +printBinds (CyclicSCC binds) = liftIO (putStr "cyclic binds: ") >> mapM_ (printBind . fst) binds >> liftIO (putStrLn "") + + +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 _ = return () + + +-- | Computes the variables that are bound by a given piece of syntax. + +class HasBV a where + getBV :: a -> Set Var + +instance HasBV (HsBindLR GhcTc GhcTc) where + getBV (FunBind{fun_id = L _ v}) = Set.singleton v + getBV (PatBind {pat_lhs = pat}) = getBV pat + getBV (VarBind {var_id = v}) = Set.singleton v + getBV PatSynBind{} = Set.empty +#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) +#endif + +instance HasBV a => HasBV (GenLocated b a) where + getBV (L _ e) = getBV e + +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 + +getConBV (PrefixCon _ ps) = getBV ps +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__ < 904 +instance HasBV CoPat where + getBV CoPat {co_pat_inner = p} = getBV p +#else +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) +#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'] + _ -> 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 + getBV (ConPat {pat_args = con}) = getConBV con + getBV (SigPat _ p _) = getBV p + +#if __GLASGOW_HASKELL__ < 904 +instance HasBV NoExtCon where + getBV _ = Set.empty +#endif + +-- | Syntax that may contain variables. +class HasFV a where + -- | Compute the set of variables occurring in the given piece of + -- syntax. The name falsely suggests that returns free variables, + -- but in fact it returns all variable occurrences, no matter + -- whether they are free or bound. + getFV :: a -> Set Var + +instance HasFV a => HasFV (GenLocated b a) where + getFV (L _ e) = getFV e + +instance HasFV a => HasFV [a] where + getFV es = foldMap getFV es + +instance HasFV a => HasFV (Bag a) where + getFV es = foldMap getFV es + +instance HasFV Var where + getFV v = Set.singleton v + +instance HasFV a => HasFV (MatchGroup GhcTc a) where + getFV MG {mg_alts = alts} = getFV alts + +instance HasFV a => HasFV (Match GhcTc a) where + getFV Match {m_grhss = rhss} = getFV rhss + +instance HasFV (HsTupArg GhcTc) where + getFV (Present _ e) = getFV e + getFV Missing {} = Set.empty + +instance HasFV a => HasFV (GRHS GhcTc a) where + getFV (GRHS _ g b) = getFV g `Set.union` getFV b + +instance HasFV a => HasFV (GRHSs GhcTc a) where + getFV GRHSs {grhssGRHSs = rhs, grhssLocalBinds = lbs} = + getFV rhs `Set.union` getFV lbs + + +instance HasFV (HsLocalBindsLR GhcTc GhcTc) where + getFV (HsValBinds _ bs) = getFV bs + getFV (HsIPBinds _ bs) = getFV bs + getFV EmptyLocalBinds {} = Set.empty + +instance HasFV (HsValBindsLR GhcTc GhcTc) where + getFV (ValBinds _ b _) = getFV b + getFV (XValBindsLR b) = getFV b + +instance HasFV (NHsValBindsLR GhcTc) where + getFV (NValBinds bs _) = foldMap (getFV . snd) bs + +instance HasFV (HsBindLR GhcTc GhcTc) where + getFV FunBind {fun_matches = ms} = getFV ms + getFV PatBind {pat_rhs = rhs} = getFV rhs + getFV VarBind {var_rhs = rhs} = getFV rhs + 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 + +instance HasFV (IPBind GhcTc) where + getFV (IPBind _ _ e) = getFV e + +instance HasFV (HsIPBinds GhcTc) where + getFV (IPBinds _ bs) = getFV bs + +instance HasFV (ApplicativeArg GhcTc) where + getFV ApplicativeArgOne { arg_expr = e } = getFV e + getFV ApplicativeArgMany {app_stmts = es, final_expr = e} = getFV es `Set.union` getFV e + +instance HasFV (ParStmtBlock GhcTc GhcTc) where + getFV (ParStmtBlock _ es _ _) = getFV es + +instance HasFV a => HasFV (StmtLR GhcTc GhcTc a) where + getFV (LastStmt _ e _ _) = getFV e + getFV (BindStmt _ _ e) = getFV e + 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 + + +instance HasFV (HsRecFields GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))) where + getFV HsRecFields{rec_flds = fs} = getFV fs + +#if __GLASGOW_HASKELL__ >= 904 +instance HasFV (HsFieldBind o (GenLocated SrcSpanAnnA (HsExpr GhcTc))) where +#else +instance HasFV (HsRecField' o (GenLocated SrcSpanAnnA (HsExpr GhcTc))) where +#endif + 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 + +instance HasFV (HsCmd GhcTc) where + getFV (HsCmdArrApp _ e1 e2 _ _) = getFV e1 `Set.union` getFV e2 + 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 (HsCmdCase _ _ mg) = getFV mg + getFV (HsCmdIf _ _ e1 e2 e3) = getFV e1 `Set.union` getFV e2 `Set.union` getFV e3 + getFV (HsCmdDo _ cmd) = getFV cmd +#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 +#else + getFV (HsCmdLamCase _ mg) = getFV mg +#endif + getFV (XCmd e) = getFV e + + +instance (HasFV a, HasFV b) => HasFV (Either a b) where + getFV (Left x) = getFV x + getFV (Right x) = getFV x + +#if __GLASGOW_HASKELL__ >= 908 +instance HasFV (LHsRecUpdFields GhcTc) where + getFV RegularRecUpdFields {recUpdFields = x} = getFV x + getFV OverloadedRecUpdFields {olRecUpdFields = x} = getFV x +#endif + +instance HasFV (HsCmdTop GhcTc) where + getFV (HsCmdTop _ cmd) = getFV cmd + +instance HasFV (HsExpr GhcTc) where + getFV (HsVar _ v) = getFV v + getFV HsUnboundVar {} = Set.empty + getFV HsOverLabel {} = Set.empty + getFV HsIPVar {} = Set.empty + getFV HsOverLit {} = Set.empty + getFV HsLit {} = Set.empty + getFV (HsLam _ 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 (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 (HsDo _ _ e) = getFV e + 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` getFV fs + getFV (RecordCon {rcon_flds = fs}) = getFV fs + getFV (ArithSeq _ _ e) = getFV e +#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 (XExpr e) = getFV e +#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 +#else + getFV (HsAppType _ e _) = getFV e + getFV (ExprWithTySig _ e _) = getFV e +#endif + getFV (HsIf _ e1 e2 e3) = getFV e1 `Set.union` getFV e2 `Set.union` getFV e3 + getFV (HsPragE _ _ e) = getFV e + + +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 diff --git a/src/WidgetRattus/Plugin/PrimExpr.hs b/src/WidgetRattus/Plugin/PrimExpr.hs new file mode 100644 --- /dev/null +++ b/src/WidgetRattus/Plugin/PrimExpr.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE OverloadedStrings #-} + +module WidgetRattus.Plugin.PrimExpr ( + Prim (..), + PrimInfo (..), + function, + prim, + isPrimExpr +) where + +import Data.Map (Map) +import qualified Data.Map as Map +import GHC.Plugins +import WidgetRattus.Plugin.Utils +import Prelude hiding ((<>)) + +data Prim = Delay | Adv | Box | Select + +-- DelayApp has the following fields: Var = delay f, T1 = value type, T2 = later type (O v a) +-- AdvApp has the following fields: Var = adv f, TypedArg = var and type for arg +data PrimInfo = DelayApp Var Type | AdvApp Var TypedArg | BoxApp Var | SelectApp Var TypedArg TypedArg + +type TypedArg = (Var, Type) + +data PartialPrimInfo = PartialPrimInfo { + primPart :: Prim, + functionPart :: Var, + args :: [Var], + typeArgs :: [Type] +} + +instance Outputable PartialPrimInfo where + ppr (PartialPrimInfo Delay f _ typeArgs) = text "PartialPrimInfo { prim = Delay, function = " <> ppr f <> text "args = (not printing since it should be undefined) , typeArgs = " <> ppr typeArgs + ppr (PartialPrimInfo prim f args typeArgs) = text "PartialPrimInfo { prim = " <> ppr prim <> text ", function = " <> ppr f <> text ", args = " <> ppr args <> text ", typeArgs = " <> ppr typeArgs + +instance Outputable Prim where + ppr Delay = "delay" + ppr Adv = "adv" + ppr Select = "select" + ppr Box = "box" + +instance Outputable PrimInfo where + ppr (DelayApp f _) = text "DelayApp - function " <> ppr f + ppr (BoxApp f) = text "BoxApp - function " <> ppr f + ppr (AdvApp f arg) = text "AdvApp - function " <> ppr f <> text " | arg " <> ppr arg + ppr (SelectApp f arg arg2) = text "SelectApp - function " <> ppr f <> text " | arg " <> ppr arg <> text " | arg2 " <> ppr arg2 + +primMap :: Map FastString Prim +primMap = Map.fromList + [("delay", Delay), + ("adv", Adv), + ("select", Select), + ("box", Box) + ] + + +isPrim :: Var -> Maybe Prim +isPrim v = case getNameModule v of + Just (name, mod) | isRattModule mod -> Map.lookup name primMap + _ -> Nothing + +createPartialPrimInfo :: Prim -> Var -> PartialPrimInfo +createPartialPrimInfo prim function = + PartialPrimInfo { + primPart = prim, + functionPart = function, + args = [], + typeArgs = [] + } + +function :: PrimInfo -> Var +function (DelayApp f _) = f +function (BoxApp f) = f +function (AdvApp f _) = f +function (SelectApp f _ _) = f + +prim :: PrimInfo -> Prim +prim (DelayApp {}) = Delay +prim (BoxApp _) = Box +prim (AdvApp {}) = Adv +prim (SelectApp {}) = Select + +validatePartialPrimInfo :: PartialPrimInfo -> Maybe PrimInfo +validatePartialPrimInfo (PartialPrimInfo Select f [arg2V, argV] [arg2T, argT]) = Just $ SelectApp f (argV, argT) (arg2V, arg2T) +validatePartialPrimInfo (PartialPrimInfo Delay f [_] [argT]) = Just $ DelayApp f argT +validatePartialPrimInfo (PartialPrimInfo {primPart = Box, functionPart = f}) = Just $ BoxApp f +validatePartialPrimInfo (PartialPrimInfo Adv f [argV] [argT]) = Just $ AdvApp f (argV, argT) +validatePartialPrimInfo _ = Nothing + +isPrimExpr :: Expr Var -> Maybe PrimInfo +isPrimExpr expr = isPrimExpr' expr >>= validatePartialPrimInfo + +isPrimExpr' :: Expr Var -> Maybe PartialPrimInfo +isPrimExpr' (App e (Type t)) = case mPPI of + Just pPI@(PartialPrimInfo {typeArgs = tArgs}) -> Just pPI {typeArgs = t : tArgs} + Nothing -> Nothing + where mPPI = isPrimExpr' e +isPrimExpr' (App e e') = + case isPrimExpr' e of + Just partPrimInfo@(PartialPrimInfo { primPart = Delay, args = args}) -> Just partPrimInfo {args = undefined : args} + Just partPrimInfo@(PartialPrimInfo { args = args}) -> Just partPrimInfo {args = maybe args (:args) (getMaybeVar e')} + _ -> Nothing +isPrimExpr' (Var v) = case isPrim v of + Just p -> Just $ createPartialPrimInfo p v + Nothing -> Nothing +isPrimExpr' (Tick _ e) = isPrimExpr' e +isPrimExpr' (Lam v e) + | isTyVar v || (not $ tcIsLiftedTypeKind $ typeKind $ varType v) = isPrimExpr' e +isPrimExpr' _ = Nothing diff --git a/src/WidgetRattus/Plugin/ScopeCheck.hs b/src/WidgetRattus/Plugin/ScopeCheck.hs new file mode 100644 --- /dev/null +++ b/src/WidgetRattus/Plugin/ScopeCheck.hs @@ -0,0 +1,812 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE CPP #-} + + + +-- | This module implements the source plugin that checks the variable +-- scope of of Async Rattus programs. + +module WidgetRattus.Plugin.ScopeCheck (checkAll) where + +import WidgetRattus.Plugin.Utils +import WidgetRattus.Plugin.Dependency +import WidgetRattus.Plugin.Annotation + +import Control.Monad.Trans.State.Strict +import Data.IORef + +import Prelude hiding ((<>)) + +import GHC.Parser.Annotation +import GHC.Plugins +import GHC.Tc.Types +import GHC.Data.Bag +import GHC.Tc.Types.Evidence +import GHC.Hs.Extension +import GHC.Hs.Expr +import GHC.Hs.Pat +import GHC.Hs.Binds + +import Data.Graph +import qualified Data.Set as Set +import qualified Data.Map as Map +import Data.Set (Set) +import Data.Map (Map) +import Data.List +import Data.List.NonEmpty (NonEmpty(..),(<|),nonEmpty) +import System.Exit +import Data.Either +import Data.Maybe + +import Data.Data hiding (tyConName) + +import Control.Monad + +type ErrorMsg = (Severity,SrcSpan,SDoc) +type ErrorMsgsRef = IORef [ErrorMsg] + +-- | The current context for scope checking +data Ctxt = Ctxt + { + errorMsgs :: ErrorMsgsRef, + -- | Variables that are in scope now (i.e. occurring in the typing + -- context but not to the left of a tick) + current :: LCtxt, + -- | Variables that are in the typing context, but to the left of a + -- tick + earlier :: Either NoTickReason (NonEmpty LCtxt), + -- | Variables that have fallen out of scope. The map contains the + -- reason why they have fallen out of scope. + hidden :: Hidden, + -- -- | Same as 'hidden' but for recursive variables. + -- hiddenRec :: Hidden, + -- | The current location information. + srcLoc :: SrcSpan, + -- | If we are in the body of a recursively defined function, this + -- field contains the variables that are defined recursively + -- (could be more than one due to mutual recursion or because of a + -- recursive pattern definition) and the location of the recursive + -- definition. + recDef :: Maybe RecDef, + -- | Type variables with a 'Stable' constraint attached to them. + stableTypes :: Set Var, + -- | A mapping from variables to the primitives that they are + -- defined equal to. For example, a program could contain @let + -- mydel = delay in mydel 1@, in which case @mydel@ is mapped to + -- 'Delay'. + primAlias :: Map Var Prim, + -- | Allow general recursion. + allowRecursion :: Bool} + + + +-- | The starting context for checking a top-level definition. For +-- 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) -> Bool -> Ctxt +emptyCtxt em mvar allowRec = + Ctxt { errorMsgs = em, + current = Set.empty, + earlier = Left NoDelay, + hidden = Map.empty, + srcLoc = noLocationInfo, + recDef = mvar, + primAlias = Map.empty, + stableTypes = Set.empty, + allowRecursion = allowRec} + +-- | A local context, consisting of a set of variables. +type LCtxt = Set Var + +-- | The recursively defined variables + the position where the +-- recursive definition starts +type RecDef = (Set Var, SrcSpan) + + + + +data StableReason = StableRec SrcSpan | StableBox deriving Show + +-- | Indicates, why a variable has fallen out of scope. +data HiddenReason = Stabilize StableReason | FunDef | DelayApp | AdvApp | SelectApp deriving Show + +-- | Indicates, why there is no tick +data NoTickReason = NoDelay | TickHidden HiddenReason deriving Show + +-- | Hidden context, containing variables that have fallen out of +-- context along with the reason why they have. +type Hidden = Map Var HiddenReason + +-- | The 5 primitive Asynchronous Rattus operations. +data Prim = Delay | Adv | Select | Box | Unbox deriving Show + +-- | This constraint is used to pass along the context implicitly via +-- an implicit parameter. +type GetCtxt = ?ctxt :: Ctxt + + +type CheckM = StateT ([Maybe (Prim, SrcSpan)]) TcM + +-- | This type class is implemented for each AST type @a@ for which we +-- can check whether it adheres to the scoping rules of Asynchronous Rattus. +class Scope a where + -- | Check whether the argument is a scope correct piece of syntax + -- in the given context. + check :: GetCtxt => a -> CheckM Bool + +-- | This is a variant of 'Scope' for syntax that can also bind +-- variables. +class ScopeBind a where + -- | 'checkBind' checks whether its argument is scope-correct and in + -- addition returns the the set of variables bound by it. + checkBind :: GetCtxt => a -> CheckM (Bool,Set Var) + + +-- | set the current context. +setCtxt :: Ctxt -> (GetCtxt => a) -> a +setCtxt c a = let ?ctxt = c in a + + +-- | modify the current context. +modifyCtxt :: (Ctxt -> Ctxt) -> (GetCtxt => a) -> (GetCtxt => a) +modifyCtxt f a = + let newc = f ?ctxt in + let ?ctxt = newc in a + + + + +getLocAnn' :: SrcSpanAnn' b -> SrcSpan +getLocAnn' = locA + + +updateLoc :: SrcSpanAnn' b -> (GetCtxt => a) -> (GetCtxt => a) +updateLoc src = modifyCtxt (\c -> c {srcLoc = getLocAnn' src}) + + +-- | Check all definitions in the given module. If Scope errors are +-- found, the current execution is halted with 'exitFailure'. +checkAll :: TcGblEnv -> TcM () +checkAll env = do + 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 + if res then return () else liftIO exitFailure + + +printAccErrMsgs :: [ErrorMsg] -> TcM () +printAccErrMsgs msgs = mapM_ printMsg (sortOn (\(_,l,_)->l) msgs) + where printMsg (sev,loc,doc) = printMessage sev loc doc + + + + +instance Scope a => Scope (GenLocated SrcSpan a) where + check (L l x) = (\c -> c {srcLoc = l}) `modifyCtxt` check x + +instance Scope a => Scope (GenLocated (SrcSpanAnn' b) a) where + check (L l x) = updateLoc l $ check x + +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 (Match GhcTc (GenLocated SrcAnno (HsExpr GhcTc))) where + check Match{m_pats=ps,m_grhss=rhs} = addVars (getBV ps) `modifyCtxt` check rhs + +instance Scope (Match GhcTc (GenLocated SrcAnno (HsCmd GhcTc))) where + check Match{m_pats=ps,m_grhss=rhs} = addVars (getBV ps) `modifyCtxt` check rhs + + +instance Scope (MatchGroup GhcTc (GenLocated SrcAnno (HsExpr GhcTc))) where + check MG {mg_alts = alts} = check alts + + +instance Scope (MatchGroup GhcTc (GenLocated SrcAnno (HsCmd GhcTc))) where + check MG {mg_alts = alts} = check alts + + +instance Scope a => ScopeBind (StmtLR GhcTc GhcTc a) where + checkBind (LastStmt _ b _ _) = ( , Set.empty) <$> check b + checkBind (BindStmt _ p b) = do + let vs = getBV p + let c' = addVars vs ?ctxt + r <- setCtxt c' (check b) + return (r,vs) + checkBind (BodyStmt _ b _ _) = ( , Set.empty) <$> check b + checkBind (LetStmt _ bs) = checkBind bs + checkBind ParStmt{} = notSupported "monad comprehensions" + checkBind TransStmt{} = notSupported "monad comprehensions" + checkBind ApplicativeStmt{} = notSupported "applicative do notation" + checkBind RecStmt{} = notSupported "recursive do notation" + +instance ScopeBind a => ScopeBind [a] where + checkBind [] = return (True,Set.empty) + checkBind (x:xs) = do + (r,vs) <- checkBind x + (r',vs') <- addVars vs `modifyCtxt` (checkBind xs) + return (r && r',vs `Set.union` vs') + +instance ScopeBind a => ScopeBind (GenLocated SrcSpan a) where + checkBind (L l x) = (\c -> c {srcLoc = l}) `modifyCtxt` checkBind x + +instance ScopeBind a => ScopeBind (GenLocated (SrcSpanAnn' b) a) where + checkBind (L l x) = updateLoc l $ checkBind x + +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') + +checkRec :: GetCtxt => LHsBindLR GhcTc GhcTc -> CheckM Bool +checkRec b = liftM2 (&&) (checkPatBind b) (check b) + +checkPatBind :: GetCtxt => LHsBindLR GhcTc GhcTc -> CheckM Bool +checkPatBind (L l b) = updateLoc l $ checkPatBind' b + +checkPatBind' :: GetCtxt => HsBindLR GhcTc GhcTc -> CheckM Bool +checkPatBind' PatBind{} = do + printMessage' SevError ("(Mutual) recursive pattern binding definitions are not supported in Asynchronous Rattus") + return False +#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 + + +-- | Check the scope of a list of (mutual) recursive bindings. The +-- second argument is the set of variables defined by the (mutual) +-- recursive bindings +checkRecursiveBinds :: GetCtxt => [LHsBindLR GhcTc GhcTc] -> Set Var -> CheckM (Bool, Set Var) +checkRecursiveBinds bs vs = do + res <- fmap and (mapM check' bs) + return (res, vs) + 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, + earlier = Left (TickHidden $ Stabilize $ StableRec l), + hidden = hidden c `Map.union` + (Map.fromSet (const (Stabilize (StableRec l))) ctxHid), + recDef = maybe (Just (vs,l)) (\(vs',_) -> Just (Set.union vs' vs,l)) (recDef c) + -- TODO fix location info of recDef (needs one location for each var) + } + + +instance ScopeBind (SCC (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var)) where + checkBind (AcyclicSCC (b,vs)) = (, vs) <$> check b + checkBind (CyclicSCC bs) = checkRecursiveBinds (map fst bs) (foldMap snd bs) + +instance ScopeBind (HsValBindsLR GhcTc GhcTc) where + checkBind (ValBinds _ bs _) = checkBind (dependency bs) + + checkBind (XValBindsLR (NValBinds binds _)) = checkBind binds + + +instance ScopeBind (HsBindLR GhcTc GhcTc) where + checkBind b = (, getBV b) <$> check b + + +-- | Compute the set of variables defined by the given Haskell binder. +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 + + +-- Check nested bindings +instance ScopeBind (RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))) where + checkBind (NonRecursive, bs) = checkBind $ bagToList bs + checkBind (Recursive, bs) = checkRecursiveBinds bs' (foldMap getAllBV bs') + where bs' = bagToList bs + + +instance ScopeBind (HsLocalBindsLR GhcTc GhcTc) where + checkBind (HsValBinds _ bs) = checkBind bs + checkBind HsIPBinds {} = notSupported "implicit parameters" + checkBind EmptyLocalBinds{} = return (True,Set.empty) + +type SrcAnno = SrcSpanAnnA + +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) + +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) + +instance Show Var where + show v = getOccString v + + +tickHidden :: HiddenReason -> SDoc +tickHidden FunDef = "a function definition" +tickHidden DelayApp = "a nested application of delay" +tickHidden AdvApp = "an application of adv" +tickHidden SelectApp = "an application of select" +tickHidden (Stabilize StableBox) = "an application of box" +tickHidden (Stabilize (StableRec src)) = "a nested recursive definition (at " <> ppr src <> ")" + +isSelect :: GetCtxt => LHsExpr GhcTc -> Bool +isSelect e = + case isPrimExpr e of + Just (Select, _) -> True + _ -> False + +instance Scope (HsExpr GhcTc) where + check (HsVar _ (L _ v)) + | Just p <- isPrim v = + case p of + Unbox -> return True + _ -> printMessageCheck SevError ("Defining an alias for " <> ppr v <> " is not allowed") + | otherwise = case getScope v of + Hidden reason -> printMessageCheck SevError reason + Visible -> return True + ImplUnboxed -> return True + -- printMessageCheck SevWarning + -- (ppr v <> text " is an external temporal function used under delay, which may cause time leaks.") + check (HsApp _ (L _ (HsApp _ f arg)) arg2) | isSelect f = + case earlier ?ctxt of + Right (er :| ers) -> do + res <- get + case res of + Just _ : _ -> printMessageCheck SevError ("only one adv or select may be used in the scope of a delay.") + Nothing : pre -> do put pre + b1 <- mod `modifyCtxt` check arg + b2 <- mod `modifyCtxt` check arg2 + modify (Just (Select, srcLoc ?ctxt) :) + return $ b1 && b2 + _ -> error "Asynchronous Rattus: internal error" + where mod c = c{earlier = case nonEmpty ers of + Nothing -> Left $ TickHidden SelectApp + Just ers' -> Right ers', + current = er, + hidden = hidden ?ctxt `Map.union` + Map.fromSet (const SelectApp) (current ?ctxt)} + Left NoDelay -> printMessageCheck SevError "select may only be used in the scope of a delay." + Left (TickHidden hr) -> printMessageCheck SevError ("select may only be used in the scope of a delay. " + <> " There is a delay, but its scope is interrupted by " <> tickHidden hr <> ".") + check (HsApp _ e1 e2) = + case isPrimExpr e1 of + Just (p,_) -> case p of + Box -> do + ch <- stabilize StableBox `modifyCtxt` check e2 + return ch + Unbox -> check e2 + Delay -> do modify (Nothing :) + b <- (\c -> c{current = Set.empty, + earlier = case earlier c of + Left _ -> Right (current c :| []) + Right cs -> Right (current c <| cs)}) + `modifyCtxt` check e2 + res <- get + case res of + Nothing : _ -> printMessageCheck SevError "No adv or select found in the scope of this occurrence of delay" + _ : pre -> put pre >> return b + _ -> error "Asynchronous Rattus: internal error" + Adv -> case earlier ?ctxt of + Right (er :| ers) -> do + res <- get + case res of + Just _ : _ -> printMessageCheck SevError ("only one adv or select may be used in the scope of a delay.") + Nothing : pre -> do put pre + b <- mod `modifyCtxt` check e2 + modify (Just (Adv,srcLoc ?ctxt) :) + return b + _ -> error "Asynchronous Rattus: internal error" + where mod c = c{earlier = case nonEmpty ers of + Nothing -> Left $ TickHidden AdvApp + Just ers' -> Right ers', + current = er, + hidden = hidden ?ctxt `Map.union` + Map.fromSet (const AdvApp) (current ?ctxt)} + Left NoDelay -> printMessageCheck SevError ("adv may only be used in the scope of a delay.") + Left (TickHidden hr) -> printMessageCheck SevError ("adv may only be used in the scope of a delay. " + <> " There is a delay, but its scope is interrupted by " <> tickHidden hr <> ".") + Select -> printMessageCheck SevError ("select must be fully applied") + _ -> 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 HsLit{} = return True + check (OpApp _ e1 e2 e3) = and <$> mapM check [e1,e2,e3] + check (HsLam _ 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 (NegApp _ e _) = check e + check (ExplicitSum _ _ _ e) = check e + check (HsMultiIf _ e) = check e + check (ExplicitList _ e) = check e + check HsProjection {} = return True + check HsGetField {gf_expr = e} = check e + check RecordUpd { rupd_expr = e, rupd_flds = fs} = (&&) <$> check e <*> check fs + check RecordCon { rcon_flds = f} = check f + check (ArithSeq _ _ e) = check e +#if __GLASGOW_HASKELL__ >= 906 + check HsTypedSplice{} = notSupported "Template Haskell" + check HsUntypedSplice{} = notSupported "Template Haskell" +#else + check HsSpliceE{} = notSupported "Template Haskell" +#endif + check (HsProc _ _ e) = check e + check (HsStatic _ e) = check e + check (HsDo _ _ e) = fst <$> checkBind e + check (XExpr e) = check e +#if __GLASGOW_HASKELL__ >= 906 + check (HsAppType _ e _ _) = check e + check (ExprWithTySig _ e _) = check e +#else + check (HsAppType _ e _) = check e + check (ExprWithTySig _ e _) = check e +#endif + check (HsPragE _ _ e) = check e + check (HsIf _ e1 e2 e3) = and <$> mapM check [e1,e2,e3] + + +instance (Scope a, Scope b) => Scope (Either a b) where + check (Left x) = check x + check (Right x) = check x + + +#if __GLASGOW_HASKELL__ >= 908 +instance Scope (LHsRecUpdFields GhcTc) where + check RegularRecUpdFields {recUpdFields = x} = check x + check OverloadedRecUpdFields {olRecUpdFields = x} = check x +#endif + + +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 + +instance Scope (HsCmdTop GhcTc) where + check (HsCmdTop _ e) = check e + +instance Scope (HsCmd GhcTc) where + check (HsCmdArrApp _ e1 e2 _ _) = (&&) <$> check e1 <*> check e2 + check (HsCmdDo _ e) = fst <$> checkBind e + 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 (HsCmdLamCase _ e) = check e + 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 + check (XCmd (HsWrap _ e)) = check e + + +instance Scope (ArithSeqInfo GhcTc) where + check (From e) = check e + check (FromThen e1 e2) = (&&) <$> check e1 <*> check e2 + check (FromTo e1 e2) = (&&) <$> check e1 <*> check e2 + check (FromThenTo e1 e2 e3) = (&&) <$> ((&&) <$> check e1 <*> check e2) <*> check e3 + +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 + check Missing{} = return True + +instance Scope (HsBindLR GhcTc GhcTc) where +#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, + fun_ext = wrapper} = + mod `modifyCtxt` check matches + where mod c = c { stableTypes= stableTypes c `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 + check PatSynBind {} = return True -- pattern synonyms are not supported + + +-- | Checks whether the given type is a type constraint of the form +-- @Stable a@ for some type variable @a@. In that case it returns the +-- type variable @a@. +isStableConstr :: Type -> Maybe TyVar +isStableConstr t = + case splitTyConApp_maybe t of + Just (con,[args]) -> + case getNameModule con of + Just (name, mod) -> + if isRattModule mod && name == "Stable" + then (getTyVar_maybe args) + else Nothing + _ -> Nothing + _ -> 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) +stableConstrFromWrapper _ = [] + + +-- | Given a type @(C1, ... Cn) => t@, this function returns the list +-- of type variables @[a1,...,am]@ for which there is a constraint +-- @Stable ai@ among @C1, ... Cn@. +extractStableConstr :: Type -> [TyVar] +extractStableConstr = mapMaybe isStableConstr . map irrelevantMult . fst . splitFunTys . snd . splitForAllTys' + + +getSCCLoc :: SCC (LHsBindLR GhcTc GhcTc, Set Var) -> SrcSpan +getSCCLoc (AcyclicSCC (L l _ ,_)) = getLocAnn' l +getSCCLoc (CyclicSCC ((L l _,_ ) : _)) = getLocAnn' l +getSCCLoc _ = noLocationInfo + +checkSCC' :: Module -> AnnEnv -> SCC (LHsBindLR GhcTc GhcTc, Set Var) -> TcM (Bool, [ErrorMsg]) +checkSCC' mod anEnv scc = do + err <- liftIO (newIORef []) + let allowRec = AllowRecursion `Set.member` getAnn mod anEnv scc + res <- checkSCC allowRec err scc + msgs <- liftIO (readIORef err) + 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.")]) + else if any (\(s,_,_) -> case s of SevWarning -> True; _ -> False) msgs + then return (res, filter (\(s,_,_) -> case s of SevWarning -> False; _ -> True) msgs) + else return (False,[(SevError, getSCCLoc scc, "Warning was expected, but typechecking produced no warning.")]) + else if ExpectError `Set.member` anns + then if res + then return (False,[(SevError, getSCCLoc scc, "Error was expected, but typechecking produced no error.")]) + else return (True,[]) + else return (res, msgs) +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 a + checkVar v = + 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 + + + +-- | Checks a top-level definition group, which is either a single +-- non-recursive definition or a group of (mutual) recursive +-- definitions. + +checkSCC :: Bool -> ErrorMsgsRef -> SCC (LHsBindLR GhcTc GhcTc, Set Var) -> TcM Bool +checkSCC allowRec errm (AcyclicSCC (b,_)) = setCtxt (emptyCtxt errm Nothing allowRec) (evalStateT (check b) []) + +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)) allowRec) (evalStateT (checkRec b) []) + +-- | Stabilizes the given context, i.e. remove all non-stable types +-- and any tick. This is performed on checking 'box', and +-- guarded recursive definitions. To provide better error messages a +-- reason has to be given as well. +stabilize :: StableReason -> Ctxt -> Ctxt +stabilize sr c = c + {current = Set.empty, + earlier = Left $ TickHidden hr, + hidden = hidden c `Map.union` Map.fromSet (const hr) ctxHid} + where ctxHid = either (const $ current c) (foldl' Set.union (current c)) (earlier c) + hr = Stabilize sr + +data VarScope = Hidden SDoc | Visible | ImplUnboxed + + +-- | This function checks whether the given variable is in scope. +getScope :: GetCtxt => Var -> VarScope +getScope v = + case ?ctxt of + 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") + Left (TickHidden hr) -> Hidden ("The (mutually) recursive call to " <> ppr v <> " must occur in the scope of a delay. " + <> "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)) || 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.") + Just (Stabilize StableBox) -> + if (isStable (stableTypes ?ctxt) (varType v)) then Visible + else 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.") + Just AdvApp -> Hidden ("Variable " <> ppr v <> " is no longer in scope: It occurs under adv.") + Just SelectApp -> Hidden ("Variable " <> ppr v <> " is no longer in scope: It occurs under select.") + Just DelayApp -> Hidden ("Variable " <> ppr v <> " is no longer in scope due to repeated application of delay") + Just FunDef -> if (isStable (stableTypes ?ctxt) (varType v)) then Visible + else Hidden ("Variable " <> ppr v <> " is no longer in scope: It occurs in a function that is defined under a delay, is a of a non-stable type " <> ppr (varType v) <> ", and is bound outside delay") + Nothing + | either (const False) (any (Set.member v)) (earlier ?ctxt) -> + if isStable (stableTypes ?ctxt) (varType v) then Visible + else Hidden ("Variable " <> ppr v <> " is no longer in scope:" $$ + "It occurs under delay" $$ "and is of type " <> ppr (varType v) <> ", which is not stable.") + | Set.member v (current ?ctxt) -> Visible + | isTemporal (varType v) && isRight (earlier ?ctxt) && userFunction v + -> ImplUnboxed + | otherwise -> Visible + +-- | A map from the syntax of a primitive of Asynchronous Rattus to 'Prim'. +primMap :: Map FastString Prim +primMap = Map.fromList + [("Delay", Delay), + ("delay", Delay), + ("adv", Adv), + ("select", Select), + ("box", Box), + ("unbox", Unbox)] + + +-- | Checks whether a given variable is in fact an Asynchronous Rattus primitive. +isPrim :: GetCtxt => Var -> Maybe Prim +isPrim v + | Just p <- Map.lookup v (primAlias ?ctxt) = Just p + | otherwise = do + (name,mod) <- getNameModule v + if isRattModule mod then Map.lookup name primMap + else Nothing + + +-- | Checks whether a given expression is in fact a Asynchronous Rattus primitive. +isPrimExpr :: GetCtxt => LHsExpr GhcTc -> Maybe (Prim,Var) +isPrimExpr (L _ e) = isPrimExpr' e where + isPrimExpr' :: GetCtxt => HsExpr GhcTc -> Maybe (Prim,Var) + isPrimExpr' (HsVar _ (L _ v)) = fmap (,v) (isPrim v) +#if __GLASGOW_HASKELL__ >= 906 + isPrimExpr' (HsAppType _ e _ _) = isPrimExpr e +#else + isPrimExpr' (HsAppType _ e _) = isPrimExpr e +#endif + + isPrimExpr' (XExpr (WrapExpr (HsWrap _ e))) = isPrimExpr' e + isPrimExpr' (XExpr (ExpansionExpr (HsExpanded _ e))) = isPrimExpr' e + isPrimExpr' (HsPragE _ _ e) = isPrimExpr e +#if __GLASGOW_HASKELL__ < 904 + isPrimExpr' (HsTick _ _ 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 + + +-- | This type class provides default implementations for 'check' and +-- 'checkBind' for Haskell syntax that is not supported. These default +-- implementations simply print an error message. +class NotSupported a where + notSupported :: GetCtxt => SDoc -> CheckM a + +instance NotSupported Bool where + notSupported doc = printMessageCheck SevError ("Asynchronous Rattus does not support " <> doc) + +instance NotSupported (Bool,Set Var) where + notSupported doc = (,Set.empty) <$> notSupported doc + + +-- | Add variables to the current context. +addVars :: Set Var -> Ctxt -> Ctxt +addVars vs c = c{current = vs `Set.union` current c } + +-- | Print a message with the current location. +printMessage' :: GetCtxt => Severity -> SDoc -> CheckM () +printMessage' sev doc = + liftIO (modifyIORef (errorMsgs ?ctxt) ((sev ,srcLoc ?ctxt, doc) :)) + +-- | Print a message with the current location. Returns 'False', if +-- the severity is 'SevError' and otherwise 'True. +printMessageCheck :: GetCtxt => Severity -> SDoc -> CheckM Bool +printMessageCheck sev doc = printMessage' sev doc >> + case sev of + SevError -> return False + _ -> return True diff --git a/src/WidgetRattus/Plugin/SingleTick.hs b/src/WidgetRattus/Plugin/SingleTick.hs new file mode 100644 --- /dev/null +++ b/src/WidgetRattus/Plugin/SingleTick.hs @@ -0,0 +1,226 @@ +-- | This module implements the translation from the multi-tick +-- calculus to the single tick calculus. + +{-# LANGUAGE CPP #-} + +module WidgetRattus.Plugin.SingleTick + (toSingleTick) where + +#if __GLASGOW_HASKELL__ >= 900 +import GHC.Plugins +#else +import GhcPlugins +#endif + + +import WidgetRattus.Plugin.Utils +import Prelude hiding ((<>)) +import Control.Monad.Trans.Writer.Strict +import Control.Monad.Trans.Class +import Data.List + +-- | Transform the given expression from the multi-tick calculus into +-- the single tick calculus form. +toSingleTick :: CoreExpr -> CoreM CoreExpr +toSingleTick (Let (Rec bs) e) = do + e' <- toSingleTick e + bs' <- mapM (mapM toSingleTick) bs + return (Let (Rec bs') e') +toSingleTick (Let (NonRec b e1) e2) = do + e1' <- toSingleTick e1 + e2' <- toSingleTick e2 + return (Let (NonRec b e1') e2') +toSingleTick (Case e b ty alts) = do + e' <- toSingleTick e + 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 + return (Cast e' c) +toSingleTick (Tick t e) = do + e' <- toSingleTick e + return (Tick t e') +toSingleTick (Lam x e) = do + (e', advs) <- runWriterT (extractAdv' e) + advs' <- mapM (\ (x,a,b) -> fmap (\b' -> (x,a,b')) (toSingleTick b)) advs + return (foldLets' advs' (Lam x e')) +toSingleTick (App e1 e2) + | isDelayApp e1 = do + (e2', advs) <- runWriterT (extractAdv e2) + advs' <- mapM (mapM toSingleTick) advs + return (foldLets advs' (App e1 e2')) + | otherwise = do + e1' <- toSingleTick e1 + e2' <- toSingleTick e2 + return (App e1' e2') + +toSingleTick e@Type{} = return e +toSingleTick e@Var{} = return e +toSingleTick e@Lit{} = return e +toSingleTick e@Coercion{} = return e + +foldLets :: [(Id,CoreExpr)] -> CoreExpr -> CoreExpr +foldLets ls e = foldl' (\e' (x,b) -> Let (NonRec x b) e') e ls + +foldLets' :: [(Id,CoreExpr,CoreExpr)] -> CoreExpr -> CoreExpr +foldLets' ls e = foldl' (\e' (x,a,b) -> Let (NonRec x (App a b)) e') e ls + +extractAdvApp :: CoreExpr -> CoreExpr -> WriterT [(Id,CoreExpr)] CoreM CoreExpr +extractAdvApp e1 e2 + | isVar e2 = return (App e1 e2) + | otherwise = do + x <- lift (mkSysLocalFromExpr (fsLit "adv") e2) + tell [(x,e2)] + return (App e1 (Var x)) + +-- removes casts and ticks from a tree +filterTree :: CoreExpr -> CoreExpr +filterTree (Cast e _) = filterTree e +filterTree (Tick _ e) = filterTree e +filterTree e = e + + +extractSelectApp :: CoreExpr -> CoreExpr -> WriterT [(Id,CoreExpr)] CoreM CoreExpr +extractSelectApp e1 e2 + | isVar e' && isVar e2 = return (App e1 e2) + | isVar e2 = do + x <- lift (mkSysLocalFromExpr (fsLit "selectFreshVar") e') + tell [(x, e')] + return (App (App e (Var x)) e2) + | isVar e' = do + x <- lift (mkSysLocalFromExpr (fsLit "selectFreshVar") e2) + tell [(x, e2)] + return (App e1 (Var x)) + | otherwise = do + x <- lift (mkSysLocalFromExpr (fsLit "selectFreshVar") e') + y <- lift (mkSysLocalFromExpr (fsLit "selectFreshVar") e2) + tell [(x, e')] + tell [(y, e2)] + return (App (App e (Var x)) (Var y)) + where (App e e') = filterTree e1 + + +-- This is used to pull adv out of delayed terms. The writer monad +-- returns mappings from fresh variables to terms that occur as +-- argument of adv. +-- +-- That is, occurrences of @adv t@ are replaced with @adv x@ (for some +-- fresh variable @x@) and the pair @(x,t)@ is returned in the +-- writer monad. +extractAdv :: CoreExpr -> WriterT [(Id,CoreExpr)] CoreM CoreExpr +extractAdv (App expr@(App e _) e2) | isSelectApp e = extractSelectApp expr e2 +extractAdv e@(App e1 e2) + | isAdvApp e1 = extractAdvApp e1 e2 + | isSelectApp e1 = extractSelectApp e1 e2 + | isDelayApp e1 = do + (e2', advs) <- lift $ runWriterT (extractAdv e2) + advs' <- mapM (mapM extractAdv) advs + return (foldLets advs' (App e1 e2')) + | isBoxApp e1 = lift $ toSingleTick e + | otherwise = do + e1' <- extractAdv e1 + e2' <- extractAdv e2 + return (App e1' e2') +extractAdv (Lam x e) = do + (e', advs) <- lift $ runWriterT (extractAdv' e) + advs' <- mapM (\ (x,a,b) -> fmap (\b' -> (x,b')) (extractAdvApp a b)) advs + return (foldLets advs' (Lam x e')) +extractAdv (Case e b ty alts) = do + e' <- extractAdv e + 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 + return (Cast e' c) +extractAdv (Tick t e) = do + e' <- extractAdv e + return (Tick t e') +extractAdv e@(Let Rec{} _) = lift $ toSingleTick e +extractAdv (Let (NonRec b e1) e2) = do + e1' <- extractAdv e1 + e2' <- extractAdv e2 + return (Let (NonRec b e1') e2') +extractAdv e@Type{} = return e +extractAdv e@Var{} = return e +extractAdv e@Lit{} = return e +extractAdv e@Coercion{} = return e + +-- This is used to pull adv out of lambdas. The writer monad returns +-- mappings from fresh variables to occurrences of adv and the term it +-- is applied to. +-- +-- That is occurrences of @adv t@ are replaced with a fresh variable +-- @x@ and the triple @(x,adv,t)@ is returned in the writer monad. +-- For select a b, the triple @(x, select a, b) is returned in the writer monad. +extractAdv' :: CoreExpr -> WriterT [(Id,CoreExpr,CoreExpr)] CoreM CoreExpr +extractAdv' e@(App e1 e2) + | isAdvApp e1 = do + x <- lift (mkSysLocalFromExpr (fsLit "adv") e) + tell [(x,e1,e2)] + return (Var x) + | isSelectApp e1 = do + x <- lift (mkSysLocalFromExpr (fsLit "select") e) + tell [(x,e1,e2)] + return (Var x) + | isDelayApp e1 = do + (e2', advs) <- lift $ runWriterT (extractAdv e2) + advs' <- mapM (mapM extractAdv') advs + return (foldLets advs' (App e1 e2')) + | isBoxApp e1 = lift $ toSingleTick e + | otherwise = do + e1' <- extractAdv' e1 + e2' <- extractAdv' e2 + return (App e1' e2') +extractAdv' (Lam x e) = do + e' <- extractAdv' e + return (Lam x e') +extractAdv' (Case e b ty alts) = do + e' <- extractAdv' e + 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 + return (Cast e' c) +extractAdv' (Tick t e) = do + e' <- extractAdv' e + return (Tick t e') +extractAdv' e@(Let Rec{} _) = lift $ toSingleTick e +extractAdv' (Let (NonRec b e1) e2) = do + e1' <- extractAdv' e1 + e2' <- extractAdv' e2 + return (Let (NonRec b e1') e2') +extractAdv' e@Type{} = return e +extractAdv' e@Var{} = return e +extractAdv' e@Lit{} = return e +extractAdv' e@Coercion{} = return e + + + +isDelayApp :: CoreExpr -> Bool +isDelayApp = isPrimApp (== "delay") + +isBoxApp :: CoreExpr -> Bool +isBoxApp = isPrimApp (\occ -> occ == "Box" || occ == "box") + +isAdvApp :: CoreExpr -> Bool +isAdvApp = isPrimApp (== "adv") + +isSelectApp :: CoreExpr -> Bool +isSelectApp = isPrimApp (== "select") + +isPrimApp :: (String -> Bool) -> CoreExpr -> Bool +isPrimApp p (App e e') + | isType e' || not (tcIsLiftedTypeKind(typeKind (exprType e'))) = isPrimApp p e + | otherwise = False +isPrimApp p (Cast e _) = isPrimApp p e +isPrimApp p (Tick _ e) = isPrimApp p e +isPrimApp p (Var v) = isPrimVar p v +isPrimApp _ _ = False + +isPrimVar :: (String -> Bool) -> Var -> Bool +isPrimVar p v = maybe False id $ do + let name = varName v + mod <- nameModule_maybe name + let occ = getOccString name + return (p occ + && moduleNameString (moduleName mod) == "WidgetRattus.InternalPrimitives") diff --git a/src/WidgetRattus/Plugin/StableSolver.hs b/src/WidgetRattus/Plugin/StableSolver.hs new file mode 100644 --- /dev/null +++ b/src/WidgetRattus/Plugin/StableSolver.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} + + +-- | This module implements a constraint solver plugin for the +-- 'Stable' type class. + +module WidgetRattus.Plugin.StableSolver (tcStable) where + +import WidgetRattus.Plugin.Utils + ( getNameModule, isRattModule, isStable ) + +import Prelude hiding ((<>)) + +import GHC.Plugins + (Type, Var, CommandLineOption,tyConSingleDataCon, + mkCoreConApps,getTyVar_maybe) +import GHC.Core +import GHC.Tc.Types.Evidence +import GHC.Core.Class +import GHC.Tc.Types +import GHC.Tc.Types.Constraint + +import Data.Set (Set) +import qualified Data.Set as Set +#if __GLASGOW_HASKELL__ >= 904 +import GHC.Types.Unique.FM +#endif + + + +-- | Constraint solver plugin for the 'Stable' type class. +tcStable :: [CommandLineOption] -> Maybe TcPlugin +tcStable _ = Just $ TcPlugin + { tcPluginInit = return () + , tcPluginSolve = \ () -> stableSolver + , tcPluginStop = \ () -> return () +#if __GLASGOW_HASKELL__ >= 904 + , tcPluginRewrite = \ () -> emptyUFM +#endif + } + + +wrap :: Class -> Type -> EvTerm +wrap cls ty = EvExpr appDc + where + tyCon = classTyCon cls + dc = tyConSingleDataCon tyCon + appDc = mkCoreConApps dc [Type ty] + +solveStable :: Set Var -> (Type, (Ct,Class)) -> Maybe (EvTerm, Ct) +solveStable c (ty,(ct,cl)) + | 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 + Just evs -> return $ TcPluginOk evs [] + Nothing -> return $ TcPluginOk [] [] + + where +#if __GLASGOW_HASKELL__ >= 908 + filterCt ct@(CDictCan (DictCt {di_cls = cl, di_tys = [ty]})) +#else + filterCt ct@(CDictCan {cc_class = cl, cc_tyargs = [ty]}) +#endif + = case getNameModule cl of + Just (name,mod) + | isRattModule mod && name == "Stable" -> [(ty,(ct,cl))] + _ -> [] + filterCt _ = [] + filterTypeVar ty = case getTyVar_maybe ty of + Just v -> [v] + Nothing -> [] diff --git a/src/WidgetRattus/Plugin/Strictify.hs b/src/WidgetRattus/Plugin/Strictify.hs new file mode 100644 --- /dev/null +++ b/src/WidgetRattus/Plugin/Strictify.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} +module WidgetRattus.Plugin.Strictify + (checkStrictData, SCxt (..)) where +import Prelude hiding ((<>)) +import Control.Monad +import WidgetRattus.Plugin.Utils + +import GHC.Plugins +import GHC.Types.Tickish + +data SCxt = SCxt {srcSpan :: SrcSpan} + +-- | 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) + | ignoreArgument 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.")) + checkStrictData ss e1 + checkStrictData ss e2 +checkStrictData _ss _ = return () + +isLit :: CoreExpr -> Bool +isLit Lit{} = True +isLit (App (Var v) Lit{}) + | Just (name,mod) <- getNameModule v = mod == "GHC.CString" && name == "unpackCString#" +isLit _ = False + + +ignoreArgument :: CoreExpr -> Bool +ignoreArgument (Var v) = + case getNameModule v of + Just (name, mod) -> + ((mod == "GHC.Exts" || mod == "GHC.IsList") && (name == "fromList" || name == "fromListN")) || + (mod == "Data.String" && name == "fromString") || + (mod == "GHC.Stack.Types" && name == "pushCallStack") || + (mod == "Data.Text.Internal" && name == "pack") + _ -> False +ignoreArgument (App x _) = ignoreArgument x +ignoreArgument _ = False + +isDeepseqForce :: CoreExpr -> Bool +isDeepseqForce (App (App (App (Var v) _) _) _) = + case getNameModule v of + Just (name, mod) -> mod == "Control.DeepSeq" && name == "force" + _ -> False +isDeepseqForce _ = False diff --git a/src/WidgetRattus/Plugin/Transform.hs b/src/WidgetRattus/Plugin/Transform.hs new file mode 100644 --- /dev/null +++ b/src/WidgetRattus/Plugin/Transform.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE TupleSections #-} +module WidgetRattus.Plugin.Transform ( + transform +) where + +import GHC.Core.Opt.Monad +import GHC.Plugins +import WidgetRattus.Plugin.PrimExpr +import WidgetRattus.Plugin.Utils +import Data.Maybe (fromJust) +import Prelude hiding ((<>)) +import Data.Functor ((<&>)) +import Control.Applicative ((<|>)) +import Data.Tuple (swap) + +data Ctx = Ctx { + fresh :: Maybe Var +} + +emptyCtx :: Ctx +emptyCtx = Ctx { + fresh = Nothing +} + +replaceVar :: Var -> Var -> Expr Var -> Expr Var +replaceVar match rep (Var v) = if v == match then Var rep else Var v +replaceVar match rep (App e e') = App (replaceVar match rep e) (replaceVar match rep e') +replaceVar match rep (Tick _ e) = replaceVar match rep e +replaceVar match rep (Lam v e) = Lam (if v == match then rep else v) (replaceVar match rep e) +replaceVar match rep (Let (NonRec b e') e) = + Let (NonRec newB (replaceVar match rep e')) (replaceVar match rep e) + where newB = if b == match then rep else b +replaceVar match rep (Cast e _) = replaceVar match rep e +replaceVar match rep (Case e b t alts) = + Case newExpr newB t (map (\(Alt con binds expr) -> Alt con (map (\v -> if v == match then rep else v) binds) (replaceVar match rep expr)) alts) + where newExpr = replaceVar match rep e + newB = if b == match then rep else b +replaceVar _ _ e = e + +transformPrim :: Ctx -> Expr Var -> CoreM (Expr Var, PrimInfo) +transformPrim ctx expr@(App e e') = case isPrimExpr expr of + Just primInfo@(AdvApp f _) -> do + varAdv' <- adv'Var + let newE = replaceVar f varAdv' e + return (App (App newE e') (Var (fromJust $ fresh ctx)), primInfo) + Just primInfo@(SelectApp f _ _) -> do + varSelect' <- select'Var + let newE = replaceVar f varSelect' e + return (App (App newE e') (Var (fromJust $ fresh ctx)), primInfo) + Just (DelayApp _ t) -> do + bigDelayVar <- bigDelay + inputValueV <- inputValueVar + let inputValueType = mkTyConTy inputValueV + inpVar <- mkSysLocalM (fsLit "inpV") inputValueType inputValueType + let ctx' = ctx {fresh = Just inpVar} + (newExpr, maybePrimInfo) <- transform' ctx' e' + let primInfo = fromJust maybePrimInfo + let lambdaExpr = Lam inpVar newExpr + clockCode <- constructClockExtractionCode primInfo + return (App (App (App (Var bigDelayVar) (Type t)) clockCode) lambdaExpr, primInfo) + Just primInfo -> do + error $ showSDocUnsafe $ text "transformPrim: Cannot transform " <> ppr (prim primInfo) + Nothing -> error "Cannot transform non-prim applications" +transformPrim _ _ = do + error "Cannot transform anything else than prim applications" + + +transform :: CoreExpr -> CoreM CoreExpr +transform expr = fst <$> transform' emptyCtx expr + +transform' :: Ctx -> CoreExpr -> CoreM (CoreExpr, Maybe PrimInfo) +transform' ctx expr@(App e e') = case isPrimExpr expr of + Just (BoxApp _) -> do + (newExpr, primInfo) <- transform' ctx e' + return (App e newExpr, primInfo) + (Just _) -> do + (newExpr, primInfo) <- transformPrim ctx expr + return (newExpr, Just primInfo) + Nothing -> do + (newExpr, primInfo) <- transform' ctx e + (newExpr', primInfo') <- transform' ctx e' + return (App newExpr newExpr', primInfo <|> primInfo') +transform' ctx (Lam b rhs) = do + (newExpr, primInfo) <- transform' ctx rhs + return (Lam b newExpr, primInfo) +transform' ctx (Let (NonRec b rhs) e) = do + (newRhs, primInfo) <- transform' ctx rhs + (newExpr, primInfo') <- transform' ctx e + return (Let (NonRec b newRhs) newExpr, primInfo <|> primInfo') +transform' ctx (Let (Rec binds) e) = do + transformedBinds <- mapM (\(b, bindE) -> fmap (b,) (transform' ctx bindE)) binds + (e', mPi) <- transform' ctx e + let primInfos = map (\(_, (_, p)) -> p) transformedBinds + let firstPrimInfo = foldl (<|>) mPi primInfos + newBinds <- mapM (\(b, (e, _)) -> return (b, e)) transformedBinds + return (Let (Rec newBinds) e', firstPrimInfo) +transform' ctx (Case e b t alts) = do + -- The checking pass has ensured that there are not advances on different + -- clocks. Thus we can just pick the first PrimInfo we find. + (expr, primInfo) <- transform' ctx e + + -- For each alternative, transform it and save the maybePrimInfo-value + transformed <- mapM (\(Alt con binds expr) -> transform' ctx expr <&> fmap (Alt con binds) . swap) alts + + -- Of all the primInfos we have, pick the first one. This is safe because + -- the checking pass has ensured that the clocks of all primitives. + let firstPrimInfo = foldl (\acc (p, _) -> acc <|> p) primInfo transformed + let alts' = map snd transformed + return (Case expr b t alts', firstPrimInfo) +transform' ctx (Cast e c) = do (e' , p) <- transform' ctx e; return (Cast e' c, p) +transform' ctx (Tick t e) = do (e' , p) <- transform' ctx e; return (Tick t e', p) +transform' _ e = return (e, Nothing) + +constructClockExtractionCode :: PrimInfo -> CoreM CoreExpr +constructClockExtractionCode (AdvApp _ arg) = createClockCode arg +constructClockExtractionCode (SelectApp _ arg arg2) = clockUnion arg arg2 +constructClockExtractionCode primInfo = error $ "Cannot construct clock for prim " ++ showSDocUnsafe (ppr (prim primInfo)) + + +createClockCode :: (Var, Type) -> CoreM CoreExpr +createClockCode (argV, argT) = do + extractClock <- extractClockVar + return $ App (App (Var extractClock) (Type argT)) (Var argV) + +-- Generate code for union of two clocks. +-- clockUnion (aVar, aType) (bVar, bType) returns the AST for: +-- Set.union (extractClock aVar) (extractClock bVar) + +clockUnion :: (Var,Type) -> (Var, Type) -> CoreM CoreExpr +clockUnion arg arg2 = do + clock1Code <- createClockCode arg + clock2Code <- createClockCode arg2 + unionVar' <- unionVar + return $ + App + ( + App + ( + (Var unionVar') + ) + clock1Code + ) + clock2Code diff --git a/src/WidgetRattus/Plugin/Utils.hs b/src/WidgetRattus/Plugin/Utils.hs new file mode 100644 --- /dev/null +++ b/src/WidgetRattus/Plugin/Utils.hs @@ -0,0 +1,384 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP #-} + +module WidgetRattus.Plugin.Utils ( + printMessage, + Severity(..), + isRattModule, + adv'Var, + select'Var, + bigDelay, + inputValueVar, + extractClockVar, + unionVar, + isGhcModule, + getNameModule, + isStable, + isStrict, + isTemporal, + userFunction, + typeClassFunction, + getVar, + getMaybeVar, + getModuleFS, + isVar, + isType, + mkSysLocalFromVar, + mkSysLocalFromExpr, + fromRealSrcSpan, + noLocationInfo, + mkAlt, + getAlt, + splitForAllTys') + where + +#if __GLASGOW_HASKELL__ >= 908 +import GHC.Types.Error (ResolvedDiagnosticReason (..)) +#endif + +#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 +import Control.Concurrent.MVar (readMVar) +#else +import Data.IORef (readIORef) +#endif +import GHC.Utils.Logger +import GHC.Plugins +import GHC.Utils.Error hiding (errorMsg) +import GHC.Utils.Monad + + +import GHC.Types.Name.Cache (NameCache(nsNames), lookupOrigNameCache, OrigNameCache) +import qualified GHC.Types.Name.Occurrence as Occurrence +import GHC.Types.TyThing + +import Prelude hiding ((<>)) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Char +import Data.Maybe + + +getMaybeVar :: CoreExpr -> Maybe Var +getMaybeVar (App e e') + | isType e' || not (tcIsLiftedTypeKind (typeKind (exprType e'))) = getMaybeVar e + | otherwise = Nothing +getMaybeVar (Cast e _) = getMaybeVar e +getMaybeVar (Tick _ e) = getMaybeVar e +getMaybeVar (Var v) = Just v +getMaybeVar _ = Nothing + +getVar :: CoreExpr -> Var +getVar = fromJust . getMaybeVar + +isVar :: CoreExpr -> Bool +isVar = isJust . getMaybeVar + +isType Type {} = True +isType (App e _) = isType e +isType (Cast e _) = isType e +isType (Tick _ e) = isType e +isType _ = False + +#if __GLASGOW_HASKELL__ >= 906 +isFunTyCon = isArrowTyCon +repSplitAppTys = splitAppTysNoView +#endif + + +printMessage :: (HasDynFlags m, MonadIO m, HasLogger m) => + Severity -> SrcSpan -> SDoc -> m () +printMessage sev loc doc = do +#if __GLASGOW_HASKELL__ >= 908 + logger <- getLogger + liftIO $ putLogMsg logger (logFlags logger) + (MCDiagnostic sev (if sev == SevError then ResolvedDiagnosticReason ErrorWithoutFlag else ResolvedDiagnosticReason WarningWithoutFlag) Nothing) loc doc +#elif __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 +#else + dflags <- getDynFlags + logger <- getLogger + liftIO $ putLogMsg logger dflags NoReason sev loc doc +#endif + +instance Ord FastString where + compare = uniqCompareFS + +{- +****************************************************** +* Extracting variables * +****************************************************** +-} + + +origNameCache :: CoreM OrigNameCache +origNameCache = do + hscEnv <- getHscEnv +#if __GLASGOW_HASKELL__ >= 904 + let nameCache = hsc_NC hscEnv + liftIO $ readMVar (nsNames nameCache) +#else + nameCache <- liftIO $ readIORef (hsc_NC hscEnv) + return $ nsNames nameCache +#endif + + +getNamedThingFromModuleAndOccName :: String -> OccName -> CoreM TyThing +getNamedThingFromModuleAndOccName moduleName occName = do + origNameCache <- origNameCache + case filter ((moduleName ==) . unpackFS . getModuleFS) (moduleEnvKeys origNameCache) of + mod : _ -> lookupThing $ fromJust $ lookupOrigNameCache origNameCache mod occName + _ -> error ( ("internal error: cannot find module " ++ moduleName ++ "; " ++ show (map (unpackFS . getModuleFS) $ moduleEnvKeys origNameCache))) + +getVarFromModule :: String -> String -> CoreM Var +getVarFromModule moduleName = fmap tyThingId . getNamedThingFromModuleAndOccName moduleName . mkOccName Occurrence.varName + +getTyConFromModule :: String -> String -> CoreM TyCon +getTyConFromModule moduleName = fmap tyThingTyCon . getNamedThingFromModuleAndOccName moduleName . mkOccName Occurrence.tcName + +adv'Var :: CoreM Var +adv'Var = getVarFromModule "WidgetRattus.InternalPrimitives" "adv'" + +select'Var :: CoreM Var +select'Var = getVarFromModule "WidgetRattus.InternalPrimitives" "select'" + +bigDelay :: CoreM Var +bigDelay = getVarFromModule "WidgetRattus.InternalPrimitives" "Delay" + +inputValueVar :: CoreM TyCon +inputValueVar = getTyConFromModule "WidgetRattus.InternalPrimitives" "InputValue" + +extractClockVar :: CoreM Var +extractClockVar = getVarFromModule "WidgetRattus.InternalPrimitives" "extractClock" + +unionVar :: CoreM Var +unionVar = getVarFromModule "WidgetRattus.InternalPrimitives" "clockUnion" + +rattModules :: Set FastString +rattModules = Set.fromList ["WidgetRattus.InternalPrimitives","WidgetRattus.Channels"] + +getModuleFS :: Module -> FastString +getModuleFS = moduleNameFS . moduleName + +isRattModule :: FastString -> Bool +isRattModule = (`Set.member` rattModules) + +ghcModules :: Set FastString +ghcModules = Set.fromList ["GHC.Types","GHC.Word","GHC.Int"] + +isGhcModule :: FastString -> Bool +isGhcModule = (`Set.member` ghcModules) + +getNameModule :: NamedThing a => a -> Maybe (FastString, FastString) +getNameModule v = do + let name = getName v + mod <- nameModule_maybe name + return (getOccFS name,moduleNameFS (moduleName mod)) + + +-- | The set of stable built-in types. +ghcStableTypes :: Set FastString +ghcStableTypes = Set.fromList ["Word", "Word8", "Word16","Word32", "Word64","Int","Int8","Int16","Int32","Int64","Bool","Float","Double","Char", "IO"] + +isGhcStableType :: FastString -> Bool +isGhcStableType = (`Set.member` ghcStableTypes) + + +newtype TypeCmp = TC Type + +instance Eq TypeCmp where + (TC t1) == (TC t2) = eqType t1 t2 + +instance Ord TypeCmp where + compare (TC t1) (TC t2) = nonDetCmpType t1 t2 + +isTemporal :: Type -> Bool +isTemporal t = isTemporalRec 0 Set.empty t + + +isTemporalRec :: Int -> Set TypeCmp -> Type -> Bool +isTemporalRec d _ _ | d == 100 = False +isTemporalRec _ pr t | Set.member (TC t) pr = False +isTemporalRec d pr t = do + let pr' = Set.insert (TC t) pr + case splitTyConApp_maybe t of + Nothing -> False + Just (con,args) -> + case getNameModule con of + Nothing -> False + Just (name,mod) + -- If it's a Rattus type constructor check if it's a box + | isRattModule mod && (name == "Box" || name == "O") -> True + | isFunTyCon con -> or (map (isTemporalRec (d+1) pr') args) + | isAlgTyCon con -> + case algTyConRhs con of + DataTyCon {data_cons = cons} -> or (map check cons) + where check con = case dataConInstSig con args of + (_, _,tys) -> or (map (isTemporalRec (d+1) pr') tys) + _ -> or (map (isTemporalRec (d+1) pr') args) + _ -> False + + +-- | Check whether the given type is stable. This check may use +-- 'Stable' constraints from the context. + +isStable :: Set Var -> Type -> Bool +isStable c t = isStableRec c 0 Set.empty t + +-- | Check whether the given type is stable. This check may use +-- 'Stable' constraints from the context. + +isStableRec :: Set Var -> Int -> Set TypeCmp -> Type -> Bool +-- To prevent infinite recursion (when checking recursive types) we +-- keep track of previously checked types. This, however, is not +-- enough for non-regular data types. Hence we also have a counter. +isStableRec _ d _ _ | d == 100 = True +isStableRec _ _ pr t | Set.member (TC t) pr = True +isStableRec c d pr t = do + let pr' = Set.insert (TC t) pr + case splitTyConApp_maybe t of + Nothing -> case getTyVar_maybe t of + Just v -> -- if it's a type variable, check the context + v `Set.member` c + Nothing -> False + Just (con,args) -> + 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" || name == "Chan") -> True + -- If its a built-in type check the set of stable built-in types + | 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) -} + | isAlgTyCon con -> + case algTyConRhs con of + DataTyCon {data_cons = cons, is_enum = enum} + | enum -> True + | all hasStrictArgs cons -> + and (map check cons) + | otherwise -> False + where check con = case dataConInstSig con args of + (_, _,tys) -> and (map (isStableRec c (d+1) pr') tys) + TupleTyCon {} -> null args + _ -> False + _ -> False + + + +isStrict :: Type -> Bool +isStrict t = isStrictRec 0 Set.empty t + +splitForAllTys' :: Type -> ([TyCoVar], Type) +splitForAllTys' = splitForAllTyCoVars + +-- | Check whether the given type is stable. This check may use +-- 'Stable' constraints from the context. + +isStrictRec :: Int -> Set TypeCmp -> Type -> Bool +-- To prevent infinite recursion (when checking recursive types) we +-- keep track of previously checked types. This, however, is not +-- enough for non-regular data types. Hence we also have a counter. +isStrictRec d _ _ | d == 100 = True +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 (c, tys) = repSplitAppTys t' + if isJust (getTyVar_maybe c) then all (isStrictRec (d+1) pr') tys + else case splitTyConApp_maybe t' of + Nothing -> isJust (getTyVar_maybe t) + Just (con,args) -> + case getNameModule con of + Nothing -> False + Just (name,mod) + | (mod == "GHC.Internal.IsList" || mod == "GHC.IsList" || mod == "GHC.Exts") && name == "Item" -> all (isStrictRec (d+1) pr') args + | 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 == "Chan" || name == "O" || name == "Output") -> True + -- If its a built-in type check the set of stable built-in types + | 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) -} + | isFunTyCon con -> True + | isAlgTyCon con -> + case algTyConRhs con of + DataTyCon {data_cons = cons, is_enum = enum} + | enum -> True + | all hasStrictArgs cons -> + all check cons + | otherwise -> False + where check con = case dataConInstSig con args of + (_, _,tys) -> all (isStrictRec (d+1) pr') tys + TupleTyCon {} -> null args + NewTyCon {nt_rhs = ty} -> isStrictRec (d+1) pr' ty + _ -> False + | otherwise -> False + + + + + +hasStrictArgs :: DataCon -> Bool +hasStrictArgs con = all isBanged (dataConImplBangs con) + +userFunction :: Var -> Bool +userFunction v + | typeClassFunction v = True + | otherwise = + case getOccString (getName v) of + (c : _) + | isUpper c || c == '$' || c == ':' -> False + | otherwise -> True + _ -> False + +typeClassFunction :: Var -> Bool +typeClassFunction v = + case getOccString (getName v) of + ('$' : 'c' : _) -> True + ('$' : 'f' : _) -> True + _ -> False + +mkSysLocalFromVar :: MonadUnique m => FastString -> Var -> m Id +mkSysLocalFromVar lit v = mkSysLocalM lit (varMult v) (varType v) + +mkSysLocalFromExpr :: MonadUnique m => FastString -> CoreExpr -> m Id +mkSysLocalFromExpr lit e = mkSysLocalM lit oneDataConTy (exprType e) + + +fromRealSrcSpan :: RealSrcSpan -> SrcSpan +#if __GLASGOW_HASKELL__ >= 904 +fromRealSrcSpan span = RealSrcSpan span Strict.Nothing +#else +fromRealSrcSpan span = RealSrcSpan span Nothing +#endif + +instance Ord SrcSpan where + compare (RealSrcSpan s _) (RealSrcSpan t _) = compare s t + compare RealSrcSpan{} _ = LT + compare _ _ = GT + +noLocationInfo :: SrcSpan +noLocationInfo = UnhelpfulSpan UnhelpfulNoLocationInfo + +mkAlt c args e = Alt c args e +getAlt (Alt c args e) = (c, args, e) diff --git a/src/WidgetRattus/Primitives.hs b/src/WidgetRattus/Primitives.hs new file mode 100644 --- /dev/null +++ b/src/WidgetRattus/Primitives.hs @@ -0,0 +1,21 @@ +-- | The language primitives of Async Rattus. Note that the typing +-- rules for 'delay', 'adv','select' and 'box' are more restrictive +-- than the Haskell types that are indicated. The stricter Async +-- Rattus typing rules for these primitives are given below. + +{-# LANGUAGE TypeOperators #-} +module WidgetRattus.Primitives + (O + ,Box + ,Select(..) + ,delay + ,adv + ,promote + ,box + ,unbox + ,select + ,never + ,Stable + ,Continuous + ) where +import WidgetRattus.InternalPrimitives diff --git a/src/WidgetRattus/Signal.hs b/src/WidgetRattus/Signal.hs new file mode 100644 --- /dev/null +++ b/src/WidgetRattus/Signal.hs @@ -0,0 +1,492 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS -fplugin=WidgetRattus.Plugin #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedLists #-} + + +-- | Programming with signals. + +module WidgetRattus.Signal + ( map + , mapAwait + , switch + , switchS + , switchR + , trigger + , triggerAwait + , triggerM + , triggerAwaitM + , buffer + , bufferAwait + , switchAwait + , interleave + , mapInterleave + , interleaveAll + , mkSig + , mkBoxSig + , current + , future + , const + , jump + , jumping + , stop + , scan + , scanC + , scanAwait + , scanAwaitC + , scanMap + , Sig(..) + , zipWith + , zipWith3 + , zip + , cond + , update + , integral + , derivative + ) + +where + +import WidgetRattus +import Prelude hiding (map, const, zipWith, zipWith3, zip, filter) +import Data.VectorSpace +import Data.Ratio ((%)) +-- TODO: InternalPrimitives is only used to implment instance of +-- Continuous. Replace this manual instance declaration with Template +-- Haskell. +import WidgetRattus.InternalPrimitives + +infixr 5 ::: + +-- | @Sig a@ is a stream of values of type @a@. +data Sig a = !a ::: !(O (Sig a)) + +instance Producer (Sig a) a where + getCurrent p = Just' (current p) + getNext p cb = cb (future p) + +newtype SigMaybe a = SigMaybe (Sig (Maybe' a)) + +instance Producer (SigMaybe a) a where + getCurrent (SigMaybe p) = current p + getNext (SigMaybe p) cb = cb (delay (SigMaybe (adv (future p)))) + +-- | Get the current value of a signal. +current :: Sig a -> a +current (x ::: _) = x + + +-- | Get the future the signal. +future :: Sig a -> O (Sig a) +future (_ ::: xs) = xs + +-- | Apply a function to the value of a signal. +map :: Box (a -> b) -> Sig a -> Sig b +map f (x ::: xs) = unbox f x ::: delay (map f (adv xs)) + +-- | A version of @map@ for delayed signals. +mapAwait :: Box (a -> b) -> O (Sig a) -> O (Sig b) +mapAwait f d = delay (map f (adv d)) + +-- | Turns a boxed delayed computation into a delayed signal. +mkSig :: Box (O a) -> O (Sig a) +mkSig b = delay (adv (unbox b) ::: mkSig b) + +-- | Variant of 'mkSig' that returns a boxed delayed signal +mkBoxSig :: Box (O a) -> Box (O (Sig a)) +mkBoxSig b = box (mkSig b) + + +-- | Construct a constant signal that never updates. +const :: a -> Sig a +const x = x ::: never + +-- | Similar to Haskell's 'scanl'. +-- +-- > scan (box f) x (v1 ::: v2 ::: v3 ::: ... ) == (x `f` v1) ::: ((x `f` v1) `f` v2) ::: ... +-- +-- Note: Unlike 'scanl', 'scan' starts with @x `f` v1@, not @x@. + +scan :: (Stable b) => Box(b -> a -> b) -> b -> Sig a -> Sig b +scan f acc (a ::: as) = acc' ::: delay (scan f acc' (adv as)) + where acc' = unbox f acc a + +-- | A variant of 'scan' that works with the 'C' monad. + +scanC :: (Stable b) => Box(b -> a -> C b) -> b -> Sig a -> C (Sig b) +scanC f acc (a ::: as) = do + acc' <- unbox f acc a + fut <- delayC $ delay (scanC f acc' (adv as)) + return (acc' ::: fut) + where + +-- | 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)) + +-- | A variant of 'scanAwait' that works with the 'C' monad. + +scanAwaitC :: (Stable b) => Box (b -> a -> C b) -> b -> O (Sig a) -> C (Sig b) +scanAwaitC f acc as = do + fut <- delayC $ delay (scanC f acc (adv as)) + return (acc ::: fut) + +-- | 'scanMap' is a composition of 'map' and 'scan': +-- +-- > scanMap f g x === map g . scan f x +scanMap :: (Stable b) => Box (b -> a -> b) -> Box (b -> c) -> b -> Sig a -> Sig c +scanMap f p acc (a ::: as) = unbox p acc' ::: delay (scanMap f p acc' (adv as)) + where acc' = unbox f acc a + +-- | @jump (box f) xs@ first behaves like @xs@, but as soon as @f x = +-- Just xs'@ for a (current or future) value @x@ of @xs@, it behaves +-- like @xs'@. + +jump :: Box (a -> Maybe' (Sig a)) -> Sig a -> Sig a +jump f (x ::: xs) = case unbox f x of + Just' xs' -> xs' + Nothing' -> x ::: delay (jump f (adv xs)) + + +-- | Similar to 'jump', but it can jump repeatedly. That is, @jumping +-- (box f) xs@ first behaves like @xs@, but every time @f x = Just +-- xs'@ for a (current or future) value @x@ of @jumping (box f) xs@, +-- it behaves like @xs'@. + +jumping :: Box (a -> Maybe' (Sig a)) -> Sig a -> Sig a +jumping f (x ::: xs) = case unbox f x of + Just' (x' ::: xs') -> x' ::: delay (jumping f (adv xs')) + Nothing' -> x ::: delay (jumping f (adv xs)) + +-- | Stops as soon as the the predicate becomes true for the current +-- value. That is, @stop (box p) xs@ first behaves as @xs@, but as +-- soon as @f x = True@ for some (current or future) value @x@ of +-- @xs@, then it behaves as @const x@. +stop :: Box (a -> Bool) -> Sig a -> Sig a +stop p = jump (box (\ x -> if unbox p x then Just' (const x) else Nothing')) + +-- | This function allows to switch from one signal to another one +-- dynamically. The signal defined by @switch xs ys@ first behaves +-- like @xs@, but as soon as @ys@ produces a new value, @switch xs ys@ +-- behaves like @ys@. +-- +-- Example: +-- +-- > xs: 1 2 3 4 5 6 7 8 9 +-- > ys: 1 2 3 4 5 6 +-- > +-- > switch xs ys: 1 2 3 1 2 4 3 4 5 6 +switch :: Sig a -> O (Sig a) -> Sig a +switch (x ::: xs) d = x ::: delay (case select xs d of + Fst xs' d' -> switch xs' d' + Snd _ d' -> d' + Both _ d' -> d') + +-- | This function is similar to 'switch', but the (future) second +-- signal may depend on the last value of the first signal. +switchS :: Stable a => Sig a -> O (a -> Sig a) -> Sig a +switchS (x ::: xs) d = x ::: delay (case select xs d of + Fst xs' d' -> switchS xs' d' + Snd _ f -> f x + Both _ f -> f x) + +-- | This function is similar to 'switch' but works on delayed signals +-- instead of signals. +switchAwait :: O (Sig a) -> O (Sig a) -> O (Sig a) +switchAwait xs ys = delay (case select xs ys of + Fst xs' d' -> switch xs' d' + Snd _ d' -> d' + Both _ d' -> d') + +-- | Variant of 'switchS' that repeatedly switches. The output signal +-- @switch xs ys@ first behaves like @xs@, but whenever @ys@ produces +-- a value @f@, the signal switches to @f v@ where @v@ is the previous +-- value of the output signal. +-- +-- 'switchS' can be considered a special case of 'switchR' that only +-- makes a single switch. That is we have the following: +-- +-- > switchS xs ys = switchR (delay (const (adv xs))) ys +switchR :: Stable a => Sig a -> O (Sig (a -> Sig a)) -> Sig a +switchR sig steps = switchS sig + (delay (let step ::: steps' = adv steps in \ x -> switchR (step x) steps')) + +-- | This function interleaves two signals producing a new value @v@ +-- whenever either input stream produces a new value @v@. In case the +-- input signals produce a new value simultaneously, the function +-- argument is used break ties, i.e. to compute the new output value based +-- on the two new input values +-- +-- Example: +-- +-- > xs: 1 3 5 3 1 3 +-- > ys: 0 2 4 +-- > +-- > interleave (box (+)) xs ys: 1 3 2 5 7 1 3 +interleave :: Box (a -> a -> a) -> O (Sig a) -> O (Sig a) -> O (Sig a) +interleave f xs ys = delay (case select xs ys of + Fst (x ::: xs') ys' -> x ::: interleave f xs' ys' + Snd xs' (y ::: ys') -> y ::: interleave f xs' ys' + Both (x ::: xs') (y ::: ys') -> unbox f x y ::: interleave f xs' ys') + + +-- | This is the composition of 'mapAwait' and 'interleave'. That is, +-- +-- > mapInterleave f g xs ys = mapAwait f (interleave xs ys) +mapInterleave :: Box (a -> a) -> Box (a -> a -> a) -> O (Sig a) -> O (Sig a) -> O (Sig a) +mapInterleave g f xs ys = delay (case select xs ys of + Fst (x ::: xs') ys' -> unbox g x ::: mapInterleave g f xs' ys' + Snd xs' (y ::: ys') -> unbox g y ::: mapInterleave g f xs' ys' + Both (x ::: xs') (y ::: ys') -> unbox g (unbox f x y) ::: mapInterleave g f xs' ys') + + +{-# ANN interleaveAll AllowRecursion #-} +interleaveAll :: Box (a -> a -> a) -> List (O (Sig a)) -> O (Sig a) +interleaveAll _ Nil = error "interleaveAll: List must be nonempty" +interleaveAll _ [s] = s +interleaveAll f (x :! xs) = interleave f x (interleaveAll f xs) + + +-- | Takes two signals and updates the first signal using the +-- functions produced by the second signal: +-- +-- Law: +-- +-- > (xs `update` fs) `update` gs = (xs `update` (interleave (box (.)) gs fs)) +update :: (Stable a) => Sig a -> O (Sig (a -> a)) -> Sig a +update (x ::: xs) fs = x ::: delay + (case select xs fs of + Fst xs' ys' -> update xs' ys' + Snd xs' (f ::: fs') -> update (f x ::: xs') fs' + Both (x' ::: xs') (f ::: fs') -> update (f x' ::: xs') fs') + + +-- | This function is a variant of combines the values of two signals +-- using the function argument. @zipWith f xs ys@ produces a new value +-- @unbox f x y@ whenever @xs@ or @ys@ produce a new value, where @x@ +-- and @y@ are the current values of @xs@ and @ys@, respectively. +-- +-- Example: +-- +-- > xs: 1 2 3 2 +-- > ys: 1 0 5 2 +-- > +-- > zipWith (box (+)) xs ys: 2 3 4 3 8 4 + +zipWith :: (Stable a, Stable b) => Box(a -> b -> c) -> Sig a -> Sig b -> Sig c +zipWith f (a ::: as) (b ::: bs) = unbox f a b ::: delay ( + case select as bs of + Fst as' lbs -> zipWith f as' (b ::: lbs) + Snd las bs' -> zipWith f (a ::: las) bs' + Both as' bs' -> zipWith f as' bs' + ) + +-- | Variant of 'zipWith' with three signals. +zipWith3 :: forall a b c d. (Stable a, Stable b, Stable c) => Box(a -> b -> c -> d) -> Sig a -> Sig b -> Sig c -> Sig d +zipWith3 f as bs cs = zipWith (box (\f x -> unbox f x)) cds cs + where cds :: Sig (Box (c -> d)) + cds = zipWith (box (\a b -> box (\ c -> unbox f a b c))) as bs + +-- | If-then-else lifted to signals. @cond bs xs ys@ produces a stream +-- whose value is taken from @xs@ whenever @bs@ is true and from @ys@ +-- otherwise. +cond :: Stable a => Sig Bool -> Sig a -> Sig a -> Sig a +cond = zipWith3 (box (\b x y -> if b then x else y)) + + +-- | This is a special case of 'zipWith' using the tupling +-- function. That is, +-- +-- > zip = zipWith (box (:*)) +zip :: (Stable a, Stable b) => Sig a -> Sig b -> Sig (a:*b) +zip = zipWith (box (:*)) + +-- | This function is a variant of 'trigger' that works on a delayed +-- input signal. To this end, 'triggerAwait' takes an additional +-- argument that is the initial value of output signal. +-- +-- Example: +-- +-- > xs: 1 0 5 2 +-- > ys: 5 1 2 3 2 +-- > +-- > triggerAwait (box (+)) 0 xy ys: 0 2 2 2 3 8 4 + +triggerAwait :: (Stable b, Stable c) => Box (a -> b -> c) -> c -> O (Sig a) -> Sig b -> Sig c +triggerAwait f c as (b ::: bs) = c ::: + delay (case select as bs of + Fst (a' ::: as') bs' -> triggerAwait f (unbox f a' b) as' (b ::: bs') + Snd as' bs' -> triggerAwait f c as' bs' + Both (a' ::: as') (b' ::: bs') -> triggerAwait f (unbox f a' b') as' (b' ::: bs')) + + +-- | This function is a variant of 'triggerAwait' that only produces a +-- value when the first signal ticks; otherwise it produces +-- @Nothing'@. +-- +-- Example: +-- +-- > xs: 1 0 5 2 +-- > ys: 5 1 2 3 2 +-- > +-- > triggerAwaitM (box plus) xy ys: 2 N N 3 8 4 where plus x y = +-- Just' (x+y) + +triggerAwaitM :: Stable b => Box (a -> b -> Maybe' c) -> O (Sig a) -> Sig b -> O (Sig (Maybe' c)) +triggerAwaitM f as (b ::: bs) = + delay (case select as bs of + Fst (a' ::: as') bs' -> unbox f a' b ::: triggerAwaitM f as' (b ::: bs') + Snd as' bs' -> Nothing' ::: triggerAwaitM f as' bs' + Both (a' ::: as') (b' ::: bs') -> unbox f a' b' ::: triggerAwaitM f as' (b' ::: bs')) + +-- | This function is a variant of 'zipWith'. Whereas @zipWith f xs +-- ys@ produces a new value whenever @xs@ or @ys@ produce a new value, +-- @trigger f xs ys@ only produces a new value when xs produces a new +-- value, otherwise it just repeats the previous value. +-- +-- Example: +-- +-- > xs: 1 0 5 2 +-- > ys: 1 2 3 2 +-- > +-- > zipWith (box (+)) xs ys: 2 3 4 3 8 4 +-- > trigger (box (+)) xy ys: 2 2 2 3 8 4 + +trigger :: (Stable b, Stable c) => Box (a -> b -> c) -> Sig a -> Sig b -> Sig c +trigger f (a:::as) bs@(b ::: _) = triggerAwait f (unbox f a b) as bs + +-- | This function is a variant of 'trigger' that only produces a +-- value when the first signal ticks; otherwise it produces +-- @Nothing'@. +-- +-- Example: +-- +-- > xs: 1 0 5 2 +-- > ys: 1 2 3 2 +-- > +-- > zipWith (box plus) xs ys: 2 3 4 3 8 4 +-- > trigger (box plus) xy ys: 2 N N 3 8 4 +-- where +-- > plus x y = Just' (x+y) + +triggerM :: Stable b => Box (a -> b -> Maybe' c) -> Sig a -> Sig b -> Sig (Maybe' c) +triggerM f (a:::as) bs@(b ::: _) = unbox f a b ::: triggerAwaitM f as bs + + +-- Buffer takes an initial value and a signal as input and returns a signal that +-- is always one tick behind the input signal. +buffer :: Stable a => a -> Sig a -> Sig a +buffer x (y ::: ys) = x ::: delay (buffer y (adv ys)) + +-- Like buffer but works for delayed signals +bufferAwait :: Stable a => a -> O (Sig a) -> O (Sig a) +bufferAwait x xs = delay (buffer x (adv xs)) + +-- | Sampling interval (in microseconds) for the 'integral' and +-- 'derivative' functions. + +dt :: Int +dt = 20000 + +-- | @integral x xs@ computes the integral of the signal @xs@ with the +-- constant @x@. For example, if @xs@ is the velocity of an object, +-- the signal @integral 0 xs@ describes the distance travelled by that +-- object. +integral :: forall a v . (VectorSpace v a, Eq v, Fractional a, Stable v, Stable a) + => v -> Sig v -> Sig v +integral = int + where int cur (x ::: xs) + | x == zeroVector = cur ::: delay (int cur (adv xs)) + | otherwise = cur ::: delay ( + case select xs (unbox (timer dt)) of + Fst xs' _ -> int cur xs' + Snd xs' _ -> int (dtf *^ (cur ^+^ x)) (x ::: xs') + Both (x' ::: xs') _ -> int (dtf *^ (cur ^+^ x')) (x'::: xs')) + -- sampling interval in seconds + dtf :: a + dtf = fromRational (fromIntegral dt % 1000000) + +-- | Compute the derivative of a signal. For example, if @xs@ is the +-- velocity of an object, the signal @derivative xs@ describes the +-- acceleration travelled by that object. +derivative :: forall a v . (VectorSpace v a, Eq v, Fractional a, Stable v, Stable a) + => Sig v -> Sig v +derivative xs = der zeroVector (current xs) xs where + -- inverse sampling interval in seconds + dtf :: a + dtf = fromIntegral dt * 0.000001 + + der :: v -> v -> Sig v -> Sig v + der d last (x:::xs) + | d == zeroVector = zeroVector ::: delay + (let x' ::: xs' = adv xs + in der ((x' ^-^ x) ^/ dtf) x (x' ::: xs')) + | otherwise = d ::: delay ( + case select xs (unbox (timer dt)) of + Fst xs' _ -> der d last xs' + Snd xs' _ -> der ((x ^-^ last) ^/ dtf) x (x ::: xs') + Both (x' ::: xs') _ -> der ((x' ^-^ last) ^/ dtf) x' (x' ::: xs')) + + +instance Continuous a => Continuous (Sig a) where + progressInternal inp (x ::: xs@(Delay cl _)) = + if inputInClock inp cl then (adv' xs inp) + else progressInternal inp x ::: xs + progressAndNext inp (x ::: xs@(Delay cl _)) = + if inputInClock inp cl then let n = adv' xs inp in (n, nextProgress n) + else let (n , cl') = progressAndNext inp x in (n ::: xs , cl `clockUnion` cl') + nextProgress (x ::: (Delay cl _)) = nextProgress x `clockUnion` cl + +-- Prevent functions from being inlined too early for the rewrite +-- rules to fire. + +{-# NOINLINE [1] map #-} +{-# NOINLINE [1] const #-} +{-# NOINLINE [1] scan #-} +{-# NOINLINE [1] scanMap #-} +{-# NOINLINE [1] zip #-} +{-# NOINLINE [1] update #-} +{-# NOINLINE [1] switch #-} +{-# NOINLINE [1] interleave #-} +{-# NOINLINE [1] mapAwait #-} + + +{-# RULES + + "const/switch" forall x xs. + switch (const x) xs = x ::: xs; + + "update/update" forall xs fs gs. + update (update xs fs) gs = update xs (interleave (box (.)) gs fs) ; + + "const/map" forall (f :: Stable b => Box (a -> b)) x. + map f (const x) = let x' = unbox f x in const x' ; + + "map/map" forall f g xs. + map f (map g xs) = map (box (unbox f . unbox g)) xs ; + + "map/scan" forall f p acc as. + map p (scan f acc as) = scanMap f p acc as ; + + "mapAwait/interleave" forall f g xs ys. + mapAwait f (interleave g xs ys) = mapInterleave f g xs ys ; + + "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; + + "scan/scan" forall f g b c as. + scan g c (scan f b as) = + let f' = unbox f; g' = unbox g in + scanMap (box (\ (b:*c) a -> let b' = f' b a in (b':* g' c b'))) (box snd') (b:*c) as ; + + "scan/scanMap" forall f g p b c as. + scan g c (scanMap f p b as) = + let f' = unbox f; g' = unbox g; p' = unbox p in + scanMap (box (\ (b:*c) a -> let b' = f' (p' b) a in (b':* g' c b'))) (box snd') (b:*c) as ; + +#-} + diff --git a/src/WidgetRattus/Strict.hs b/src/WidgetRattus/Strict.hs new file mode 100644 --- /dev/null +++ b/src/WidgetRattus/Strict.hs @@ -0,0 +1,275 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TemplateHaskell #-} + + +-- | This module contains strict versions of some standard data +-- structures. + + + +module WidgetRattus.Strict + ( List(..), + singleton, + IsList(..), + init', + reverse', + union', + unionBy', + nub', + nubBy', + filter', + delete', + deleteBy', + (+++), + listToMaybe', + map', + zip', + zipWith', + mapMaybe', + concatMap', + (:*)(..), + Maybe'(..), + maybe', + fromMaybe', + isJust', + fst', + snd', + curry', + uncurry', + toText, + readMaybe', + splitOn' + )where + +import Prelude hiding (map) +import Data.VectorSpace +import WidgetRattus.Derive +import WidgetRattus.Plugin.Annotation +import GHC.Exts (IsList(..)) +import Data.Text hiding (foldl, singleton) +import Text.Read (readMaybe) + +infixr 2 :* +-- | Strict pair type. +data a :* b = !a :* !b + +continuous ''(:*) + +-- | First projection function. +fst' :: (a :* b) -> a +fst' (a:*_) = a + +-- | Second projection function. +snd' :: (a :* b) -> b +snd' (_:*b) = b + +curry' :: ((a :* b) -> c) -> a -> b -> c +curry' f x y = f (x :* y) + +uncurry' :: (a -> b -> c) -> (a :* b) -> c +uncurry' f (x :* y) = f x y + + +instance Functor ((:*) a) where + fmap f (x:*y) = (x :* f y) + +instance (Show a, Show b) => Show (a:*b) where + show (a :* b) = "(" ++ show a ++ " :* " ++ show b ++ ")" + +instance (Eq a, Eq b) => Eq (a :* b) where + (x1 :* y1) == (x2 :* y2) = x1 == x2 && y1 == y2 + + +instance (VectorSpace v a, VectorSpace w a, Floating a, Eq a) => VectorSpace (v :* w) a where + zeroVector = zeroVector :* zeroVector + + a *^ (x :* y) = (a *^ x) :* (a *^ y) + + (x :* y) ^/ a = (x ^/ a) :* (y ^/ a) + + negateVector (x :* y) = (negateVector x) :* (negateVector y) + + (x1 :* y1) ^+^ (x2 :* y2) = (x1 ^+^ x2) :* (y1 ^+^ y2) + + (x1 :* y1) ^-^ (x2 :* y2) = (x1 ^-^ x2) :* (y1 ^-^ y2) + + (x1 :* y1) `dot` (x2 :* y2) = (x1 `dot` x2) + (y1 `dot` y2) + +infixr 8 :! + +-- | Strict list type. +data List a = Nil | !a :! !(List a) + +continuous ''List + + +singleton :: a -> List a +singleton x = x :! Nil + +instance Traversable List where + traverse _ Nil = pure Nil + traverse f (x :! xs) = (:!) <$> (f x) <*> (traverse f xs) + +instance IsList (List a) where + type Item (List a) = a + + fromList [] = Nil + fromList (x : xs) = x :! fromList xs + + toList Nil = [] + toList (x :! xs) = x : toList 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 +reverse' l = rev l Nil + where + rev Nil a = a + rev (x:!xs) a = rev xs (x:!a) + +-- | Returns @'Nothing''@ on an empty list or @'Just'' a@ where @a@ is the +-- first element of the list. +listToMaybe' :: List a -> Maybe' a +listToMaybe' Nil = Nothing' +listToMaybe' (x :! _) = Just' x + +-- | Append two lists. +(+++) :: List a -> List a -> List a +(+++) Nil ys = ys +(+++) (x:!xs) ys = x :! xs +++ ys + + +map' :: (a -> b) -> List a -> List b +map' _ Nil = Nil +map' f (x :! xs) = f x :! map' f xs + +concatMap' :: (a -> List b) -> List a -> List b +concatMap' _ Nil = Nil +concatMap' f (x :! xs) = f x +++ concatMap' f xs + +zip' :: List a -> List b -> List (a :* b) +zip' Nil _ = Nil +zip' _ Nil = Nil +zip' (x :! xs) (y :! ys) = (x :* y) :! zip' xs ys + +zipWith' :: (a -> b -> c) -> List a -> List b -> List c +zipWith' _ Nil _ = Nil +zipWith' _ _ Nil = Nil +zipWith' f (x :! xs) (y :! ys) = f x y :! zipWith' f xs ys + + +-- | A version of 'map' which can throw out elements. In particular, +-- the function argument returns something of type @'Maybe'' b@. If +-- this is 'Nothing'', no element is added on to the result list. If +-- it is @'Just'' b@, then @b@ is included in the result list. +mapMaybe' :: (a -> Maybe' b) -> List a -> List b +mapMaybe' _ Nil = Nil +mapMaybe' f (x:!xs) = + let rs = mapMaybe' f xs in + case f x of + Nothing' -> rs + Just' r -> r:!rs + +isJust' :: Maybe' a -> Bool +isJust' (Just' _) = True +isJust' Nothing' = False + +union' :: (Eq a) => List a -> List a -> List a +union' = unionBy' (==) + +unionBy' :: (a -> a -> Bool) -> List a -> List a -> List a +unionBy' eq xs ys = xs +++ foldl (flip (deleteBy' eq)) (nubBy' eq ys) xs + +delete' :: (Eq a) => a -> List a -> List a +delete' = deleteBy' (==) + +deleteBy' :: (a -> a -> Bool) -> a -> List a -> List a +deleteBy' _ _ Nil = Nil +deleteBy' eq x (y :! ys) = if x `eq` y then ys else y :! deleteBy' eq x ys + + +nub' :: (Eq a) => List a -> List a +nub' = nubBy' (==) + +nubBy' :: (a -> a -> Bool) -> List a -> List a +nubBy' _ Nil = Nil +nubBy' eq (x:!xs) = x :! nubBy' eq (filter' (\ y -> not (eq x y)) xs) + +filter' :: (a -> Bool) -> List a -> List a +filter' _ Nil = Nil +filter' pred (x :! xs) + | pred x = x :! filter' pred xs + | otherwise = filter' pred xs + +instance Foldable List where + + foldMap f = run where + run Nil = mempty + run (x :! xs) = f x <> run xs + foldr f = run where + run b Nil = b + run b (a :! as) = (run $! (f a b)) as + foldl f = run where + run a Nil = a + run a (b :! bs) = (run $! (f a b)) bs + elem a = run where + run Nil = False + run (x :! xs) + | a == x = True + | otherwise = run xs + + +instance Functor List where + fmap = map' + +instance Eq a => Eq (List a) where + Nil == Nil = True + Nil == _ = False + _ == Nil = False + (x :! xs) == (y :! ys) = if x == y then xs == ys else False + +instance Show a => Show (List a) where + show Nil = "Nil" + show (x :! xs) = show x ++ " :! " ++ show xs + +-- | Strict variant of 'Maybe'. +data Maybe' a = Just' !a | Nothing' deriving (Show, Eq, Ord) + +continuous ''Maybe' + +-- | takes a default value, a function, and a 'Maybe'' value. If the +-- 'Maybe'' value is 'Nothing'', the function returns the default +-- value. Otherwise, it applies the function to the value inside the +-- 'Just'' and returns the result. +maybe' :: b -> (a -> b) -> Maybe' a -> b +maybe' n _ Nothing' = n +maybe' _ f (Just' x) = f x + +fromMaybe' :: a -> Maybe' a -> a +fromMaybe' _ (Just' x) = x +fromMaybe' d Nothing' = d + + +{-# ANN toText AllowLazyData #-} +toText :: Show a => a -> Text +toText x = pack (show x) + +{-# ANN readMaybe' AllowLazyData #-} +readMaybe' :: Read a => Text -> Maybe' a +readMaybe' x = case readMaybe (unpack x) of + Just x -> Just' x + Nothing -> Nothing' + +splitOn' :: Text -> Text -> List Text +splitOn' x y = fromList (splitOn x y) diff --git a/src/WidgetRattus/Widgets.hs b/src/WidgetRattus/Widgets.hs new file mode 100644 --- /dev/null +++ b/src/WidgetRattus/Widgets.hs @@ -0,0 +1,217 @@ +{-# OPTIONS -fplugin=WidgetRattus.Plugin #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE TypeOperators #-} + + +module WidgetRattus.Widgets + ( Displayable (..) + , IsWidget (..) + , Widgets (..) + , Widget + , HStack + , VStack + , TextDropdown + , tddCurr + , tddEvent + , tddList + , Popup + , popCurr + , popEvent + , popChild + , Slider + , sldCurr + , sldEvent + , sldMin + , sldMax + , Button + , btnContent + , btnClick + , Label + , labText + , TextField + , tfContent + , tfInput + , mkButton + , mkTextField + , addInputSigTF + , mkLabel + , mkHStack + , mkConstHStack + , mkVStack + , mkConstVStack + , mkTextDropdown + , mkPopup + , mkSlider + , mkProgressBar + , btnOnClick + , btnOnClickSig + , setInputSigTF + , textFieldOnInput + , textFieldOnInputSig + , runApplication + ) where + +import WidgetRattus +import WidgetRattus.Widgets.InternalTypes +import WidgetRattus.Signal +import Data.Text +import WidgetRattus.InternalPrimitives +import System.IO.Unsafe +import Control.Concurrent hiding (Chan) +import Data.IntSet as IntSet +import Prelude hiding (const) + +import qualified Monomer as M + +-- The identity function. +instance Displayable Text where + display x = x + +-- Convert Int to Text via String. +instance Displayable Int where + display x = toText x + + +-- Functions for constructing Async Rattus widgets. +mkButton :: (Displayable a) => Sig a -> C Button +mkButton t = do + c <- chan + return Button{btnContent = t, btnClick = c} + +mkTextField :: Text -> C TextField +mkTextField txt = do + c <- chan + let sig = txt ::: mkSig (box (wait c)) + return TextField{tfContent = sig, tfInput = c} + +mkLabel :: (Displayable a) => Sig a -> C Label +mkLabel t = do + return Label{labText = t} + +class Widgets ws where + toWidgetList :: ws -> List Widget + +instance {-# OVERLAPPABLE #-} IsWidget w => Widgets w where + toWidgetList w = [ mkWidget w ] + +instance {-# OVERLAPPING #-} (Widgets w, Widgets v) => Widgets (w :* v) where + toWidgetList (w :* v) = toWidgetList w +++ toWidgetList v + + +instance {-# OVERLAPPING #-} (Widgets w) => Widgets (List w) where + toWidgetList w = concatMap' toWidgetList w + + +mkHStack :: IsWidget a => Sig(List a) -> C HStack +mkHStack wl = do + return (HStack wl) + +mkConstHStack :: Widgets ws => ws -> C HStack +mkConstHStack w = mkHStack (const (toWidgetList w)) + +mkVStack :: IsWidget a => Sig(List a) -> C VStack +mkVStack wl = do + return (VStack wl) + +mkConstVStack :: Widgets ws => ws -> C VStack +mkConstVStack w = mkVStack (const (toWidgetList w)) + +mkTextDropdown :: Sig (List Text) -> Text -> C TextDropdown +mkTextDropdown opts init = do + c <- chan + let curr = init ::: mkSig (box (wait c)) + return TextDropdown{tddCurr = curr, tddEvent = c, tddList = opts} + +mkPopup :: Sig Bool -> Sig Widget -> C Popup +mkPopup b w = do + c <- chan + let sig = current b ::: interleave (box (\x _ -> x)) (future b) (mkSig (box (wait c))) + return Popup{popCurr = sig, popEvent = c, popChild = w} + +mkSlider :: Int -> Sig Int -> Sig Int -> C Slider +mkSlider start min max = do + c <- chan + let curr = start ::: mkSig (box (wait c)) + return Slider{sldCurr = curr, sldEvent = c, sldMin = min, sldMax = max} + +mkProgressBar :: Sig Int -> Sig Int -> Sig Int -> C Slider +mkProgressBar min max curr = do + c <- chan + let boundedCurrent = WidgetRattus.Signal.zipWith (box Prelude.min) curr max + return Slider{sldCurr = boundedCurrent, sldEvent = c, sldMin = min, sldMax = max} + + +-- Helper function that takes a Button and returns a boxed delayed computation. +-- The delayed computation is defined from the buttons input channel. +btnOnClick :: Button -> Box(O()) +btnOnClick btn = + let ch = btnClick btn + in box (wait ch) + +-- Function that constructs a delayed signal from a Button. +btnOnClickSig :: Button -> O (Sig ()) +btnOnClickSig btn = mkSig (btnOnClick btn) + +-- Creates a new textfield whose contents are determined by +-- the input signal. +-- Therefore user input will only be shown if the input signal +-- ticks in response to user input on the textfield. +-- Note: the input TF and output TF share an input channel +-- Hence if both are part of a GUI they will be written to simultaneously +setInputSigTF :: TextField -> Sig Text -> TextField +setInputSigTF tf sig = tf{tfContent = sig} + +-- Uses the input signal to create a new textfield +-- The returned textfield updates in response to the input signal +-- as well as the content signal of the original textfield. +-- Note: the input TF and output TF share an input channel +-- Hence if both are part of a GUI they will be written to simultaneously +addInputSigTF :: TextField -> O (Sig Text) -> TextField +addInputSigTF tf sig = + let leaved = current (tfContent tf) ::: interleave (box (\x _ -> x)) (future (tfContent tf)) sig + in tf{tfContent = leaved, tfInput = tfInput tf} + +-- Helper function that takes a TextField and returns a boxed delayed computation. +-- The delayed computation is defined from the Textfields input channel. +textFieldOnInput :: TextField -> Box(O Text) +textFieldOnInput tf = + let ch = tfInput tf + in box (wait ch) + +-- Function that constructs a delayed signal from a Textfield. +textFieldOnInputSig :: TextField -> O (Sig Text) +textFieldOnInputSig tf = mkSig (textFieldOnInput tf) + + +-- Function which creates a timed event. Associated clock will be part of the AppModel. +mkTimerEvent :: Int -> (AppEvent -> IO ()) -> IO () +mkTimerEvent n cb = (threadDelay n >> cb (AppEvent (Chan n) ())) >> return () + + +-- runApplication takes as input a widget and starts the GUI applicaiton +-- by calling Monomer's startApp function. +{-# ANN runApplication AllowLazyData #-} +runApplication :: IsWidget a => C a -> IO () +runApplication (C w) = do + w' <- w + M.startApp (AppModel w' emptyClock) handler builder config + where builder _ (AppModel w _) = mkWidgetNode w `M.styleBasic` [M.padding 3] + handler _ _ (AppModel w cl) (AppEvent (Chan ch) d) = + let inp = OneInput ch d in unsafePerformIO $ do + progressPromoteStoreAtomic inp + let (w' , cl') = progressAndNext inp w + let activeTimers = if ch > 0 then IntSet.delete ch cl else cl + let newTimers = IntSet.filter (> 0) cl' `IntSet.difference` activeTimers + let timers = Prelude.map (M.Producer . mkTimerEvent) (IntSet.toList newTimers) + return (M.Model (AppModel w' (newTimers `IntSet.union` activeTimers)) : M.Request M.RenderOnce : timers ) + config = [ + M.appWindowTitle "GUI Application", + M.appTheme M.lightTheme, + M.appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf", + M.appInitEvent (AppEvent (Chan 1) ()) + ] diff --git a/src/WidgetRattus/Widgets/InternalTypes.hs b/src/WidgetRattus/Widgets/InternalTypes.hs new file mode 100644 --- /dev/null +++ b/src/WidgetRattus/Widgets/InternalTypes.hs @@ -0,0 +1,122 @@ + +{-# OPTIONS -fplugin=WidgetRattus.Plugin #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE GADTs #-} + + +module WidgetRattus.Widgets.InternalTypes where + +import WidgetRattus +import WidgetRattus.InternalPrimitives +import WidgetRattus.Signal +import Data.Text + +import qualified Monomer as M +{-# ANN module AllowLazyData #-} + +-- The Displayable typeclass is used to define the display function. +-- The display function is used to convert a datatype to Text. +class Stable a => Displayable a where + display :: a -> Text + +-- The AppModel datatype used to contain the Widget passed to runApplication. +-- The associated clock is a set of timers. +-- Any timers created with mkTimerEvent will be added to the clock. +data AppModel where + AppModel :: IsWidget a => !a -> !Clock -> AppModel + + + +instance (Eq AppModel) where + _ == _ = False + + +-- AppEvent data type used to convert channels into events. +data AppEvent where + AppEvent :: !(Chan a) -> !a -> AppEvent + +-- The IsWidget typeclass is used to define the mkWidgetNode function. +class Continuous a => IsWidget a where + mkWidgetNode :: a -> M.WidgetNode AppModel AppEvent + + mkWidget :: a -> Widget + mkWidget w = Widget w (WidgetRattus.Signal.const True) + + + setEnabled :: a -> Sig Bool -> Widget + setEnabled = Widget + +-- Custom data types for widgets. +data Widget where + Widget :: IsWidget a => !a -> !(Sig Bool) -> Widget + +data HStack where + HStack :: IsWidget a => !(Sig (List a)) -> HStack + +data VStack where + VStack :: IsWidget a => !(Sig (List a)) -> VStack + +data TextDropdown = TextDropdown {tddCurr :: !(Sig Text), tddEvent :: !(Chan Text), tddList :: !(Sig (List Text))} + +data Popup = Popup {popCurr :: !(Sig Bool), popEvent :: !(Chan Bool), popChild :: !(Sig Widget)} + +data Slider = Slider {sldCurr :: !(Sig Int), sldEvent :: !(Chan Int), sldMin :: !(Sig Int), sldMax :: !(Sig Int)} + +data Button where + Button :: (Displayable a) => {btnContent :: !(Sig a) , btnClick :: !(Chan ())} -> Button + + +data Label where + Label :: (Displayable a) => {labText :: !(Sig a)} -> Label + +data TextField = TextField {tfContent :: !(Sig Text), tfInput :: !(Chan Text)} + +-- Template Haskell code for generating instances of Continous. +continuous ''Button +continuous ''TextField +continuous ''Label +continuous ''Widget +continuous ''HStack +continuous ''VStack +continuous ''TextDropdown +continuous ''Popup +continuous ''Slider + +-- isWidget Instance declerations for Widgets. +-- Here widgget data types are passed to Monomer constructors. +instance IsWidget Button where + mkWidgetNode Button{btnContent = txt ::: _ , btnClick = click} = + M.button (display txt) (AppEvent click ()) + +instance IsWidget TextField where + mkWidgetNode TextField{tfContent = txt ::: _, tfInput = inp} = + M.textFieldV txt (AppEvent inp) + +instance IsWidget Label where + mkWidgetNode Label{labText = txt ::: _} = M.label (display txt) + + +instance IsWidget HStack where + mkWidgetNode (HStack ws) = M.hstack_ [ M.childSpacing_ 2] (reverse' $ fmap mkWidgetNode (current ws)) + +instance IsWidget VStack where + mkWidgetNode (VStack ws) = M.vstack_ [ M.childSpacing_ 2] (reverse' $ fmap mkWidgetNode (current ws)) + +instance IsWidget TextDropdown where + mkWidgetNode TextDropdown{tddList = opts ::: _, tddCurr = curr ::: _, tddEvent = ch} + = M.textDropdownV curr (AppEvent ch) opts + +instance IsWidget Popup where + mkWidgetNode Popup{popCurr = curr ::: _, popEvent = ch, popChild = child} + = M.popupV curr (AppEvent ch) (mkWidgetNode (current child)) + +instance IsWidget Slider where + mkWidgetNode Slider{sldCurr = curr ::: _, sldEvent = ch, sldMin = min ::: _, sldMax = max ::: _} + = M.hsliderV curr (AppEvent ch) min max + +instance IsWidget Widget where + mkWidgetNode (Widget w (e ::: _)) = M.nodeEnabled (mkWidgetNode w) e + + mkWidget w = w + + setEnabled (Widget w _) es = Widget w es diff --git a/test/IllTyped.hs b/test/IllTyped.hs --- a/test/IllTyped.hs +++ b/test/IllTyped.hs @@ -2,10 +2,10 @@ module Main (module Main) where -import AsyncRattus -import AsyncRattus.Signal as S +import WidgetRattus +import WidgetRattus.Signal as S import Prelude -import AsyncRattus.Plugin.Annotation (InternalAnn (..)) +import WidgetRattus.Plugin.Annotation (InternalAnn (..)) {-# ANN loopIndirect ExpectError #-} diff --git a/test/WellTyped.hs b/test/WellTyped.hs --- a/test/WellTyped.hs +++ b/test/WellTyped.hs @@ -1,11 +1,11 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE StrictData #-} -{-# OPTIONS -fplugin=AsyncRattus.Plugin #-} +{-# OPTIONS -fplugin=WidgetRattus.Plugin #-} module Main (module Main) where -import AsyncRattus -import AsyncRattus.Signal +import WidgetRattus +import WidgetRattus.Signal import Data.Set as Set import Data.Text