From f2055a788f286984c775ffa5a9ea431b1b8ed78c Mon Sep 17 00:00:00 2001 From: Jens Nolte Date: Mon, 18 Dec 2023 01:53:38 +0100 Subject: [PATCH] quasar-web-client: Fix duplicate port in URI Co-authored-by: Jan Beinke --- examples/Midi.hs | 36 ++++ quasar-midi/README.md | 1 + quasar-midi/quasar-midi.cabal | 67 +++++++ quasar-midi/src/Quasar/Midi.hs | 162 +++++++++++++++++ quasar-midi/src/Quasar/Midi/Aseq2jsonPath.hs | 19 ++ quasar-prometheus/quasar-prometheus.cabal | 75 ++++++++ quasar-prometheus/src/Quasar/Prometheus.hs | 174 +++++++++++++++++++ quasar-prometheus/test/Spec.hs | 3 + quasar-web-client/src/main.ts | 2 +- quasar/src/Quasar/Handshake.hs | 20 +++ quasar/src/Quasar/Observable/Extra.hs | 7 + quasar/src/Quasar/Observable/Poll.hs | 14 ++ quasar/src/Quasar/Observable/V3.hs | 166 ++++++++++++++++++ 13 files changed, 745 insertions(+), 1 deletion(-) create mode 100644 examples/Midi.hs create mode 100644 quasar-midi/README.md create mode 100644 quasar-midi/quasar-midi.cabal create mode 100644 quasar-midi/src/Quasar/Midi.hs create mode 100644 quasar-midi/src/Quasar/Midi/Aseq2jsonPath.hs create mode 100644 quasar-prometheus/quasar-prometheus.cabal create mode 100644 quasar-prometheus/src/Quasar/Prometheus.hs create mode 100644 quasar-prometheus/test/Spec.hs create mode 100644 quasar/src/Quasar/Handshake.hs create mode 100644 quasar/src/Quasar/Observable/Extra.hs create mode 100644 quasar/src/Quasar/Observable/Poll.hs create mode 100644 quasar/src/Quasar/Observable/V3.hs diff --git a/examples/Midi.hs b/examples/Midi.hs new file mode 100644 index 00000000..db2b82a2 --- /dev/null +++ b/examples/Midi.hs @@ -0,0 +1,36 @@ +module Main (main) where + +import Quasar.Midi +import Control.Concurrent (forkIO, threadDelay) +import Data.String (fromString) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Lazy qualified as TL +import Network.Wai.Handler.Warp +import Quasar +import Quasar.Observable.Core +import Quasar.Observable.Lift +import Quasar.Observable.List as ObservableList +import Quasar.Observable.Map as ObservableMap +import Quasar.Observable.ObservableVar +import Quasar.Prelude +import Quasar.Web +import Quasar.Web.Server (toWaiApplication) +import System.IO (hPutStrLn, stderr) + +main :: IO () +main = runQuasarAndExit do + --midi <- startMidi + + let rootDiv = domElement "div" mempty (ObservableList.fromList [ + "hello world!" + ]) + + liftIO $ runSettings settings $ toWaiApplication rootDiv + where + port :: Port + port = 9013 + settings = + setBeforeMainLoop (hPutStrLn stderr ("Listening on port " <> show port)) $ + setPort port + defaultSettings diff --git a/quasar-midi/README.md b/quasar-midi/README.md new file mode 100644 index 00000000..3d2eaf9f --- /dev/null +++ b/quasar-midi/README.md @@ -0,0 +1 @@ +# quasar-midi diff --git a/quasar-midi/quasar-midi.cabal b/quasar-midi/quasar-midi.cabal new file mode 100644 index 00000000..51555e39 --- /dev/null +++ b/quasar-midi/quasar-midi.cabal @@ -0,0 +1,67 @@ +cabal-version: 3.0 + +name: quasar-midi +version: 0.1.0.0 +license: BSD-2-Clause +build-type: Simple +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/queezle42/quasar + +common shared-properties + default-extensions: + AllowAmbiguousTypes + ApplicativeDo + BangPatterns + BlockArguments + DataKinds + DefaultSignatures + DerivingStrategies + DuplicateRecordFields + FunctionalDependencies + GADTs + LambdaCase + MagicHash + NoImplicitPrelude + NoStarIsType + OverloadedRecordDot + OverloadedStrings + QuasiQuotes + TemplateHaskellQuotes + TypeFamilies + ViewPatterns + default-language: GHC2021 + ghc-options: + -Weverything + -Wno-all-missed-specialisations + -Wno-missing-deriving-strategies + -Wno-missing-import-lists + -Wno-missing-kind-signatures + -Wno-missing-safe-haskell-mode + -Wno-unsafe + -Werror=incomplete-patterns + -Werror=missing-fields + -Werror=missing-home-modules + -Werror=missing-methods + +library + import: shared-properties + build-depends: + aeson, + base <5, + bytestring, + containers, + nyan-interpolation, + process, + quasar, + text, + utf8-string, + exposed-modules: + Quasar.Midi + other-modules: + Quasar.Midi.Aseq2jsonPath + hs-source-dirs: + src diff --git a/quasar-midi/src/Quasar/Midi.hs b/quasar-midi/src/Quasar/Midi.hs new file mode 100644 index 00000000..5c804362 --- /dev/null +++ b/quasar-midi/src/Quasar/Midi.hs @@ -0,0 +1,162 @@ +module Quasar.Midi ( + startMidi, +) where + +import Data.Aeson +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BSL +import Data.ByteString.UTF8 qualified as Utf8 +import Data.Map.Strict qualified as Map +import Data.Text +import Quasar.Midi.Aseq2jsonPath (aseq2jsonPath) +import Quasar.Observable.Core +import Quasar.Observable.Lift (liftObservable) +import Quasar.Observable.Map (ObservableMap, ObservableMapVar) +import Quasar.Observable.Map qualified as ObservableMap +import Quasar.Observable.ObservableVar +import Quasar.Observable.Subject (readSubjectIO) +import Quasar.Prelude +import System.IO +import System.Process +import Quasar.MonadQuasar +import Quasar.MonadQuasar.Misc (runQuasarAndExit) +import Quasar.Async (async_) + +data MidiSource = MidiSource { + clientName :: Text, + name :: Text, + channels :: ObservableMap Load '[SomeException] Word8 MidiChannel +} + +data MidiSourceVar = MidiSourceVar { + clientName :: Text, + name :: Text, + channels :: ObservableMapVar Word8 MidiChannelVar +} + +readonlyMidiSource :: MidiSourceVar -> MidiSource +readonlyMidiSource var = MidiSource { + clientName = var.clientName, + name = var.name, + channels = readonlyMidiChannel <$> ObservableMap.liftObservableMap (ObservableMap.toObservableMap var.channels) +} + +data MidiChannel = MidiChannel { + params :: ObservableMap Load '[SomeException] Word8 Word8, + notes :: ObservableMap Load '[SomeException] Word8 MidiNote +} + +data MidiChannelVar = MidiChannelVar { + params :: ObservableMapVar Word8 Word8, + notes :: ObservableMapVar Word8 MidiNoteVar +} + +readonlyMidiChannel :: MidiChannelVar -> MidiChannel +readonlyMidiChannel var = MidiChannel { + params = ObservableMap.liftObservableMap (ObservableMap.toObservableMap var.params), + notes = readonlyMidiNote <$> ObservableMap.liftObservableMap (ObservableMap.toObservableMap var.notes) +} + +data MidiNote = MidiNote { + velocity :: Word8, + aftertouch :: Observable Load '[SomeException] Word8 +} + +data MidiNoteVar = MidiNoteVar { + velocity :: Word8, + aftertouch :: ObservableVar NoLoad '[] Word8 +} + +readonlyMidiNote :: MidiNoteVar -> MidiNote +readonlyMidiNote var = MidiNote { + velocity = var.velocity, + aftertouch = liftObservable (toObservable var.aftertouch) +} + +data MidiEvent + = MidiSourceStart Text Text Text -- source clientName name + | MidiSourceExit Text -- source + | MidiControlChange Text Word8 Word8 Word8 -- source channel param value + | MidiSystemExclusive Text [Word8] -- source raw + | MidiNoteOn Text Word8 Word8 Word8 -- source channel note velocity + | MidiNoteOff Text Word8 Word8 Word8 -- source channel note velocity + | MidiAftertouch Text Word8 Word8 Word8 -- source channel note velocity + | MidiStart Text -- source + | MidiContinue Text -- source + | MidiStop Text -- source + | MidiTimingClock Text -- source + deriving (Show, Eq) + +instance FromJSON MidiEvent where + parseJSON = withObject "MidiEvent" \x -> do + eventType :: Text <- x .: "eventType" + case eventType of + "source-start" -> MidiSourceStart <$> x .: "source" <*> x .: "clientName" <*> x .: "name" + "source-exit" -> MidiSourceExit <$> x .: "source" + "control-change" -> MidiControlChange <$> x .: "source" <*> x .: "channel" <*> x .: "param" <*> x .: "value" + "note-on" -> MidiNoteOn <$> x .: "source" <*> x .: "channel" <*> x .: "note" <*> x .: "velocity" + "note-off" -> MidiNoteOff <$> x .: "source" <*> x .: "channel" <*> x .: "note" <*> x .: "velocity" + "polyphonic-key-pressure" -> MidiAftertouch <$> x .: "source" <*> x .: "channel" <*> x .: "note" <*> x .: "velocity" + "system-exclusive" -> MidiSystemExclusive <$> x .: "source" <*> x .: "raw" + "start" -> MidiStart <$> x .: "source" + "continue" -> MidiContinue <$> x .: "source" + "stop" -> MidiStop <$> x .: "source" + "timing-clock" -> MidiTimingClock <$> x .: "source" + _ -> fail $ "unknown eventType: " <> show eventType + +startMidi :: QuasarIO (ObservableMap Load '[SomeException] Text MidiSource) +startMidi = do + aseq2jsonRead <- liftIO do + (aseq2jsonRead, aseq2jsonWrite) <- createPipe + hSetBuffering aseq2jsonRead LineBuffering + let processConfig = (proc aseq2jsonPath []) { + close_fds = True, + std_in = NoStream, + std_out = UseHandle aseq2jsonWrite + } + (Nothing, Nothing, Nothing, process) <- createProcess processConfig + pure aseq2jsonRead + var <- ObservableMap.newVarIO mempty + async_ $ liftIO $ forever do + line <- BS.hGetLine aseq2jsonRead + case eitherDecode (BSL.fromStrict line) of + Right event -> handleMessage var event + Left msg -> hPutStrLn stderr $ "Failed to parse: " <> Utf8.toString line <> "\n" <> msg + pure (readonlyMidiSource <$> ObservableMap.liftObservableMap (ObservableMap.toObservableMap var)) + +handleMessage :: ObservableMapVar Text MidiSourceVar -> MidiEvent -> IO () +handleMessage var (MidiSourceStart source clientName name) = atomicallyC do + channels <- ObservableMap.newVar mempty + ObservableMap.insertVar var source (MidiSourceVar clientName name channels) +handleMessage var (MidiSourceExit source) = atomicallyC do + ObservableMap.deleteVar var source +handleMessage var (MidiControlChange source channel param value) = atomicallyC do + getChannel var source channel >>= mapM_ \midiChannel -> do + ObservableMap.insertVar midiChannel.params param value +handleMessage var (MidiTimingClock _source) = pure () +handleMessage var event = print event + +getChannel :: ObservableMapVar Text MidiSourceVar -> Text -> Word8 -> STMc NoRetry '[] (Maybe MidiChannelVar) +getChannel var source channel = do + getSource var source >>= mapM \midiSource -> do + midiChannels <- ObservableMap.readVar midiSource.channels + case Map.lookup channel midiChannels of + Just midiChannel -> pure midiChannel + Nothing -> do + midiChannel <- newMidiChannel + ObservableMap.insertVar midiSource.channels channel midiChannel + pure midiChannel + +newMidiChannel :: STMc NoRetry '[] MidiChannelVar +newMidiChannel = do + params <- ObservableMap.newVar mempty + notes <- ObservableMap.newVar mempty + pure MidiChannelVar { + params, + notes + } + +getSource :: ObservableMapVar Text MidiSourceVar -> Text -> STMc NoRetry '[] (Maybe MidiSourceVar) +getSource var source = do + midiSources <- ObservableMap.readVar var + pure (Map.lookup source midiSources) diff --git a/quasar-midi/src/Quasar/Midi/Aseq2jsonPath.hs b/quasar-midi/src/Quasar/Midi/Aseq2jsonPath.hs new file mode 100644 index 00000000..104e7de0 --- /dev/null +++ b/quasar-midi/src/Quasar/Midi/Aseq2jsonPath.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE CPP #-} + +module Quasar.Midi.Aseq2jsonPath ( + aseq2jsonPath, +) where + +import Data.String (String) + +#ifdef QUASAR_MIDI_ASEQ2JSON +import Text.Interpolation.Nyan (int) +#endif + +aseq2jsonPath :: String + +#ifdef QUASAR_MIDI_ASEQ2JSON +aseq2jsonPath = [int||QUASAR_MIDI_ASEQ2JSON|]; +#else +aseq2jsonPath = "aseq2json"; +#endif diff --git a/quasar-prometheus/quasar-prometheus.cabal b/quasar-prometheus/quasar-prometheus.cabal new file mode 100644 index 00000000..ebac633b --- /dev/null +++ b/quasar-prometheus/quasar-prometheus.cabal @@ -0,0 +1,75 @@ +cabal-version: 3.0 + +name: quasar-prometheus +version: 0.1.0.0 +license: BSD-2-Clause +build-type: Simple + +source-repository head + type: git + location: https://github.com/queezle42/quasar + +common shared-properties + default-extensions: + AllowAmbiguousTypes + ApplicativeDo + BangPatterns + BlockArguments + DataKinds + DefaultSignatures + DerivingStrategies + DuplicateRecordFields + FunctionalDependencies + GADTs + LambdaCase + MagicHash + NoImplicitPrelude + NoStarIsType + OverloadedRecordDot + OverloadedStrings + QuasiQuotes + TemplateHaskellQuotes + TypeFamilies + ViewPatterns + default-language: GHC2021 + ghc-options: + -Weverything + -Wno-all-missed-specialisations + -Wno-missing-deriving-strategies + -Wno-missing-import-lists + -Wno-missing-kind-signatures + -Wno-missing-safe-haskell-mode + -Wno-unsafe + -Werror=incomplete-patterns + -Werror=missing-fields + -Werror=missing-home-modules + -Werror=missing-methods + +library + import: shared-properties + build-depends: + base <5, + containers, + quasar, + text, + exposed-modules: + Quasar.Prometheus + other-modules: + hs-source-dirs: + src + +test-suite quasar-prometheus-test + import: shared-properties + type: exitcode-stdio-1.0 + ghc-options: + -threaded + -rtsopts + "-with-rtsopts=-N" + build-depends: + base <5, + hspec, + quasar-prometheus, + main-is: Spec.hs + other-modules: + hs-source-dirs: + test diff --git a/quasar-prometheus/src/Quasar/Prometheus.hs b/quasar-prometheus/src/Quasar/Prometheus.hs new file mode 100644 index 00000000..06be72cf --- /dev/null +++ b/quasar-prometheus/src/Quasar/Prometheus.hs @@ -0,0 +1,174 @@ +module Quasar.Prometheus ( + -- Metric(..), + -- MetricType(..), + -- ToMetric(..), + -- + -- Gauge, + -- createGauge, + -- + -- Counter, + -- newCounter, + -- incCounter, + -- incCounterBy, + -- + -- MetricRegistry, + -- DuplicateMetricException, + -- newMetricRegistry, + -- registerMetric, + -- registerGlobalMetric, + -- renderMetric, + -- renderMetrics, +) where + +import Quasar.Observable.Core +import Quasar.Observable.Map (ObservableMap) +import Quasar.Observable.Map qualified as ObservableMap +import Quasar.Prelude +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Lazy qualified as TL + + +type Name = Text +type HelpText = Text +type LabelSet = Map Text Text + +data MetricType + = CounterMetric + | GaugeMetric + | HistogrammMetric + deriving (Eq, Ord, Show) + +data MetricException + = MetricTypeMissmatch Name + | DuplicateLabel Name LabelSet + | CannotMergeMetric Name + deriving Show +instance Exception MetricException + +data Metric = Metric MetricType HelpText (ObservableMap NoLoad '[MetricException] LabelSet Double) + +type IntermediateMetricLabels = ObservableMap NoLoad '[MetricException] LabelSet Double +type IntermediateMetric = Observable NoLoad '[MetricException] Metric + +--instance HasIndex Name Metric where +-- TODO IndexMap +newtype MetricSet = MetricSet (ObservableMap NoLoad '[MetricException] Name Metric) + +singleton :: Name -> Metric -> MetricSet +singleton name metric = MetricSet (ObservableMap.singleton name metric) + +instance Monoid MetricSet where + mempty = MetricSet ObservableMap.empty + +instance Semigroup MetricSet where + MetricSet x <> MetricSet y = MetricSet (ObservableMap.unionWithKey mergeMetric x y) + where + --mergeMetric' :: Name -> Metric -> Metric -> Observable '[MetricException] Metric + --mergeMetric' name m1 m2 = + -- case mergeMetric name m1 m2 of + -- Left ex -> throwC ex + -- Right x -> pure x + mergeMetric :: Name -> Metric -> Metric -> Either MetricException Metric + mergeMetric name (Metric metricTypeX helpX instancesX) (Metric metricTypeY helpY instancesY) + | metricTypeX /= metricTypeY = Left (MetricTypeMissmatch name) + | metricTypeX == HistogrammMetric = Left (CannotMergeMetric name) + | otherwise = undefined -- TODO merge labelsets + +renderMetrics :: MetricSet -> Observable NoLoad '[MetricException] TL.Text +renderMetrics = undefined + +--renderMetricDebugUi :: MetricSet -> WebUi +--renderMetricDebugUi = undefined + +formatMetrics :: Map Name (MetricType, HelpText, Map LabelSet Double) -> TL.Text +formatMetrics = undefined + +formatMetric :: Name -> MetricType -> HelpText -> Map LabelSet Double -> TL.Text +formatMetric = undefined + + +class ToMetricSet a where + toMetricSet :: a -> MetricSet + +instance ToMetricSet MetricSet where + toMetricSet = id + + +-- type Name = Text +-- type HelpText = Text +-- type LabelSet = Map Text Text +-- +-- data MetricType +-- = CounterMetric +-- | GaugeMetric +-- +-- data Gauge = Gauge Metric (ObservableMapVar LabelSet Double) +-- +-- newGauge :: MonadSTMc NoRetry '[] m => Name -> HelpText -> m Gauge +-- newGauge name helpText = do +-- var <- newObservableMapVar +-- pure $ Gauge (Metric GaugeMetric name helpText (toObservableMap var)) var +-- +-- setGauge :: MonadSTMc NoRetry '[] m => Gauge -> LabelSet -> Double -> m () +-- setGauge = undefined +-- +-- +-- data Counter = Counter Metric (ObservableMapVar LabelSet Double) +-- +-- newCounter :: MonadSTMc NoRetry '[] m => Name -> HelpText -> m Counter +-- newCounter name helpText = do +-- var <- newObservableMapVar +-- pure $ Counter (Metric CounterMetric name helpText (toObservableMap var)) var +-- +-- +-- incCounter :: MonadSTMc NoRetry '[] m => Counter -> LabelSet -> m () +-- incCounter counter label = incCounterBy counter label 1 +-- +-- incCounterBy :: MonadSTMc NoRetry '[] m => Counter -> LabelSet -> Word32 -> m () +-- incCounterBy (Counter _ var) label = undefined +-- +-- class ToMetric a where +-- toMetric :: a -> Metric +-- +-- instance ToMetric Metric where +-- toMetric = id +-- +-- instance ToMetric Gauge where +-- toMetric (Gauge metric _) = metric +-- +-- instance ToMetric Counter where +-- toMetric (Counter metric _) = metric +-- +-- newtype MetricRegistry = MetricRegistry (ObservableMapVar Text Metric) +-- instance ToObservable (Map Text Metric) MetricRegistry where +-- toObservable (MetricRegistry var) = toObservable var +-- instance ToObservableMap Text Metric MetricRegistry where +-- toObservableMap (MetricRegistry var) = toObservableMap var +-- +-- data DuplicateMetricException = DuplicateMetricException +-- deriving Show +-- instance Exception DuplicateMetricException +-- +-- newMetricRegistry :: MonadSTMc NoRetry '[] m => m MetricRegistry +-- newMetricRegistry = undefined +-- +-- registerMetric :: IsMetric a => MetricRegistry -> a -> STMc NoRetry '[DuplicateMetricException] Disposer +-- registerMetric = undefined +-- +-- registerMetric_ :: IsMetric a => MetricRegistry -> a -> STMc NoRetry '[DuplicateMetricException] () +-- registerMetric_ = undefined +-- +-- registerGlobalMetric :: IsMetric a => a -> STMc NoRetry '[DuplicateMetricException] Disposer +-- registerGlobalMetric = undefined +-- +-- registerGlobalMetric_ :: IsMetric a => a -> STMc NoRetry '[DuplicateMetricException] () +-- registerGlobalMetric_ = undefined +-- +-- renderMetric :: IsMetric a => a -> m TL.Text +-- renderMetric = undefined +-- +-- renderMetrics :: MetricRegistry -> m TL.Text +-- renderMetrics = undefined diff --git a/quasar-prometheus/test/Spec.hs b/quasar-prometheus/test/Spec.hs new file mode 100644 index 00000000..e286043c --- /dev/null +++ b/quasar-prometheus/test/Spec.hs @@ -0,0 +1,3 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +{-# OPTIONS_GHC -Wno-missing-export-lists #-} +{-# OPTIONS_GHC -Wno-prepositive-qualified-module #-} diff --git a/quasar-web-client/src/main.ts b/quasar-web-client/src/main.ts index 08a14f85..aced7bdf 100644 --- a/quasar-web-client/src/main.ts +++ b/quasar-web-client/src/main.ts @@ -201,7 +201,7 @@ class QuasarWebClient { if (websocketAddress == null) { const protocol = window.location.protocol == "https:" ? "wss" : "ws"; - this.websocketAddress = `${protocol}://${window.location.host}:${window.location.port}/ws`; + this.websocketAddress = `${protocol}://${window.location.host}/ws`; } else { this.websocketAddress = websocketAddress; diff --git a/quasar/src/Quasar/Handshake.hs b/quasar/src/Quasar/Handshake.hs new file mode 100644 index 00000000..7c86c2ca --- /dev/null +++ b/quasar/src/Quasar/Handshake.hs @@ -0,0 +1,20 @@ +module Quasar.Handshake ( + Handshake, + newHandshakePair, + fulfillHandshake, +) where + + + + +data Handshake a b + +instance Future b (Handshake a b) where + +instance NetworkRootReference (Handshake a b) where + +newHandshakePair :: MonadSTMc NoRetry '[] (Handshake a b, Handshake b a) +newHandshakePair = undefined + +fulfillHandshake :: Handshake a b -> a -> STMc NoRetry '[] () +fulfillHandshake = undefined diff --git a/quasar/src/Quasar/Observable/Extra.hs b/quasar/src/Quasar/Observable/Extra.hs new file mode 100644 index 00000000..c4ae10f1 --- /dev/null +++ b/quasar/src/Quasar/Observable/Extra.hs @@ -0,0 +1,7 @@ +module Quasar.Observable.Extra ( +) where + +import Quasar.Observable.Core +import Quasar.Observable.Lift +import Quasar.Prelude + diff --git a/quasar/src/Quasar/Observable/Poll.hs b/quasar/src/Quasar/Observable/Poll.hs new file mode 100644 index 00000000..e3cad0e4 --- /dev/null +++ b/quasar/src/Quasar/Observable/Poll.hs @@ -0,0 +1,14 @@ +module Quasar.Observable.Poll ( + pollObservable, + PollConfig, +) where + +import Quasar.Observable.Core +import Quasar.Prelude + + +data PollConfig = PollConfig { +} + +pollObservable :: PollConfig -> IO a -> Observable +pollObservable = undefined diff --git a/quasar/src/Quasar/Observable/V3.hs b/quasar/src/Quasar/Observable/V3.hs new file mode 100644 index 00000000..42eae7aa --- /dev/null +++ b/quasar/src/Quasar/Observable/V3.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE UndecidableInstances #-} + +#if MIN_VERSION_GLASGOW_HASKELL(9,6,1,0) +{-# LANGUAGE TypeData #-} +#endif + +module Quasar.Observable.V3 ( +) where + +import Control.Applicative +import Control.Monad.Catch (MonadThrow(..), MonadCatch(..), bracket, fromException) +import Control.Monad.Except +import Data.Binary (Binary) +import Data.String (IsString(..)) +import Data.Type.Equality ((:~:)(Refl)) +import GHC.Records (HasField(..)) +import Quasar.Future +import Quasar.Prelude +import Quasar.Resources.Disposer +import Quasar.Utils.Fix + +-- * Existing type shims/copies + +type Loading :: LoadKind -> Type +data Loading canLoad where + Live :: Loading canLoad + Loading :: Loading Load + + +type ObservableContainer :: (Type -> Type) -> Type -> Constraint +class ObservableContainer c v where + type Delta c :: Type -> Type + type DeltaContext c + type ValidatedDelta c :: Type -> Type + +-- | Downstream change, information about the last change that was sent to an +-- observer. +type LastChange :: LoadKind -> Type +data LastChange canLoad where + LastChangeCleared :: LastChange Load + LastChangeAvailable :: Loading canLoad -> LastChange Load + +-- * V3 + +#if MIN_VERSION_GLASGOW_HASKELL(9,6,1,0) + +type data LoadKind = Load | NoLoad +type data ContextKind = NoContext | Validated | Evaluated +type data PendingKind = Pending | NotPending +type data ChangeKind = Change | NoChange + +#else + +data LoadKind = Load | NoLoad +type Load = 'Load +type NoLoad = 'NoLoad + +data ContextKind = NoContext | Validated | Evaluated +type NoContext = 'NoContext +type Validated = 'Validated +type Evaluated = 'Evaluated + +data PendingKind = Pending | NotPending +type Pending = 'Pending +type NotPending = 'NotPending + +data ChangeKind = Change | NoChange +type Change = 'Change +type NoChange = 'NoChange + +#endif + +type LoadingP :: PendingKind -> LoadKind -> Type +data LoadingP pending canLoad where + LiveP :: LoadingP pending canLoad + LoadingP :: LoadingP Pending Load + +instance HasField "loading" (LoadingP pending canLoad) (Loading canLoad) where + getField LiveP = Live + getField LoadingP = Loading + + +type ObservableDelta :: ContextKind -> (Type -> Type) -> Type -> Type +data ObservableDelta ctx c v where + NoContextDelta :: Delta c v -> ObservableDelta NoContext c v + ValidatedDelta :: ValidatedDelta c v -> ObservableDelta Validated c v + EvaluatedDelta :: Delta c v -> c v -> ObservableDelta Evaluated c v + +type ObservableInfo :: ContextKind -> (Type -> Type) -> Type -> Type +data ObservableInfo ctx c v where + NoContextInfo :: ObservableInfo NoContext c v + ValidatedInfo :: DeltaContext c -> ObservableInfo Validated c v + EvaluatedInfo :: c v -> ObservableInfo Evaluated c v + +type ObservableData :: ChangeKind -> PendingKind -> ContextKind -> LoadKind -> (Type -> Type) -> Type -> Type +data ObservableData change pending ctx canLoad c v where + ObservableCleared :: ObservableData change pending ctx Load c v + ObservableUnchanged :: Loading canLoad -> ObservableInfo ctx c v -> ObservableData Change pending ctx Load c v + ObservableReplace :: LoadingP pending canLoad -> c v -> ObservableData change pending ctx canLoad c v + --ObservableEx :: LoadingP pending canLoad -> Ex exceptions -> ObservableData change pending ctx canLoad c v + ObservableDelta :: LoadingP pending canLoad -> ObservableDelta ctx c v -> ObservableData Change pending ctx canLoad c v + + +-- | A "normal" change that can be applied to an observer. +type PlainChange = ObservableData Change NotPending NoContext +type ValidatedChange = ObservableData Change NotPending Validated +type EvaluatedChange = ObservableData Change NotPending Evaluated +type PendingChange = ObservableData Change Pending Validated +type EvaluatedPendingChange = ObservableData Change Pending Evaluated +type PlainUpdate = ObservableData Change NotPending NoContext NoLoad +type ValidatedUpdate = ObservableData Change NotPending Validated NoLoad +type ObservableState = ObservableData NoChange NotPending NoContext +type ObserverState = ObservableData NoChange Pending NoContext + + +testPlainChangeCtors :: PlainChange Load Identity v -> () +testPlainChangeCtors ObservableCleared = () +testPlainChangeCtors (ObservableUnchanged Loading NoContextInfo) = () +testPlainChangeCtors (ObservableUnchanged Live NoContextInfo) = () +testPlainChangeCtors (ObservableReplace LiveP _new) = () +testPlainChangeCtors (ObservableDelta LiveP _delta) = () + +testValidatedChangeCtors :: ValidatedChange Load Identity v -> () +testValidatedChangeCtors ObservableCleared = () +testValidatedChangeCtors (ObservableUnchanged Loading (ValidatedInfo _)) = () +testValidatedChangeCtors (ObservableUnchanged Live (ValidatedInfo _)) = () +testValidatedChangeCtors (ObservableReplace LiveP _new) = () +testValidatedChangeCtors (ObservableDelta LiveP _delta) = () + +testPendingChangeCtors :: PendingChange Load Identity v -> () +testPendingChangeCtors ObservableCleared = () +testPendingChangeCtors (ObservableUnchanged Loading (ValidatedInfo _)) = () +testPendingChangeCtors (ObservableUnchanged Live (ValidatedInfo _)) = () +testPendingChangeCtors (ObservableReplace LoadingP _new) = () +testPendingChangeCtors (ObservableDelta LoadingP _delta) = () +testPendingChangeCtors (ObservableReplace LiveP _new) = () +testPendingChangeCtors (ObservableDelta LiveP _delta) = () + +testEvaluatedPendingChangeCtors :: EvaluatedPendingChange Load Identity v -> () +testEvaluatedPendingChangeCtors ObservableCleared = () +testEvaluatedPendingChangeCtors (ObservableUnchanged Loading (EvaluatedInfo _)) = () +testEvaluatedPendingChangeCtors (ObservableUnchanged Live (EvaluatedInfo _)) = () +testEvaluatedPendingChangeCtors (ObservableReplace LoadingP _new) = () +testEvaluatedPendingChangeCtors (ObservableDelta LoadingP _delta) = () +testEvaluatedPendingChangeCtors (ObservableReplace LiveP _new) = () +testEvaluatedPendingChangeCtors (ObservableDelta LiveP _delta) = () + +testValidatedUpdate :: ValidatedUpdate Identity v -> () +testValidatedUpdate (ObservableDelta LiveP _delta) = () +testValidatedUpdate (ObservableReplace LiveP _new) = () + +testPlainUpdateCtors :: PlainUpdate Identity v -> () +testPlainUpdateCtors (ObservableReplace LiveP _new) = () +testPlainUpdateCtors (ObservableDelta LiveP _delta) = () + +testObserverStateCtors :: ObserverState Load Identity v -> () +testObserverStateCtors ObservableCleared = () +testObserverStateCtors (ObservableReplace LoadingP _new) = () +testObserverStateCtors (ObservableReplace LiveP _new) = () + +testObservableStateCtors :: ObservableState Load Identity v -> () +testObservableStateCtors ObservableCleared = () +testObservableStateCtors (ObservableReplace LiveP _new) = ()