Update for modern fourmolu
This commit is contained in:
parent
d542cedbab
commit
46f0774857
54
flake.lock
54
flake.lock
|
|
@ -60,12 +60,15 @@
|
|||
}
|
||||
},
|
||||
"flake-utils": {
|
||||
"inputs": {
|
||||
"systems": "systems"
|
||||
},
|
||||
"locked": {
|
||||
"lastModified": 1667395993,
|
||||
"narHash": "sha256-nuEHfE/LcWyuSWnS8t12N1wc105Qtau+/OdUAjtQ0rA=",
|
||||
"lastModified": 1685518550,
|
||||
"narHash": "sha256-o2d0KcvaXzTrPRIo0kOLV0/QXHhDQ5DTi+OxcjO8xqY=",
|
||||
"owner": "numtide",
|
||||
"repo": "flake-utils",
|
||||
"rev": "5aed5285a952e0b949eb3ba02c12fa4fcfef535f",
|
||||
"rev": "a1720a10a6cfe8234c0e93907ffe81be440f4cef",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
|
|
@ -134,11 +137,11 @@
|
|||
]
|
||||
},
|
||||
"locked": {
|
||||
"lastModified": 1683638468,
|
||||
"narHash": "sha256-tQEaGZfZ2Hpw+XIVEHaJ8FaF1yNQyMDDhUyIQ7LTIEg=",
|
||||
"lastModified": 1685764721,
|
||||
"narHash": "sha256-CIy1iwQTEKfZRrid4gBLA+r/LPGA9IUFo0lKJVyECGI=",
|
||||
"owner": "Mic92",
|
||||
"repo": "nix-index-database",
|
||||
"rev": "219067a5e3cf4b9581c8b4fcfc59ecd5af953d07",
|
||||
"rev": "669ca1f2e2bc401abab6b837ae9c51503edc9b49",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
|
|
@ -191,11 +194,11 @@
|
|||
},
|
||||
"nixos-hardware": {
|
||||
"locked": {
|
||||
"lastModified": 1684899633,
|
||||
"narHash": "sha256-NtwerXX8UFsoNy6k+DukJMriWtEjQtMU/Urbff2O2Dg=",
|
||||
"lastModified": 1686396027,
|
||||
"narHash": "sha256-gE+csxJoXuNn5ZnlgNj0GnMQ2y4heBtDqkB1af8vfjU=",
|
||||
"owner": "NixOS",
|
||||
"repo": "nixos-hardware",
|
||||
"rev": "4cc688ee711159b9bcb5a367be44007934e1a49d",
|
||||
"rev": "70d5f55faee9c1e141e32e6be1e77d13e5a570db",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
|
|
@ -227,11 +230,11 @@
|
|||
},
|
||||
"nixos-stable": {
|
||||
"locked": {
|
||||
"lastModified": 1685620773,
|
||||
"narHash": "sha256-iQ+LmporQNdLz8uMJdP62TaAWeLUwl43/MYUBtWqulM=",
|
||||
"lastModified": 1686331006,
|
||||
"narHash": "sha256-hElRDWUNG655aqF0awu+h5cmDN+I/dQcChRt2tGuGGU=",
|
||||
"owner": "NixOS",
|
||||
"repo": "nixpkgs",
|
||||
"rev": "f0ba8235153dd2e25cf06cbf70d43efdd4443592",
|
||||
"rev": "85bcb95aa83be667e562e781e9d186c57a07d757",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
|
|
@ -242,11 +245,11 @@
|
|||
},
|
||||
"nixos-unstable": {
|
||||
"locked": {
|
||||
"lastModified": 1685655444,
|
||||
"narHash": "sha256-6EujQNAeaUkWvpEZZcVF8qSfQrNVWFNNGbUJxv/A5a8=",
|
||||
"lastModified": 1686319658,
|
||||
"narHash": "sha256-tGWdoUAqKnE866mYFlEfc2a99kxFy31hOQJH5YQKrTQ=",
|
||||
"owner": "NixOS",
|
||||
"repo": "nixpkgs",
|
||||
"rev": "e635192892f5abbc2289eaac3a73cdb249abaefd",
|
||||
"rev": "ae766d59b07c450e0f1de8a1bfd6529089f40849",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
|
|
@ -264,11 +267,11 @@
|
|||
"nixpkgs-stable": []
|
||||
},
|
||||
"locked": {
|
||||
"lastModified": 1685361114,
|
||||
"narHash": "sha256-4RjrlSb+OO+e1nzTExKW58o3WRwVGpXwj97iCta8aj4=",
|
||||
"lastModified": 1686213770,
|
||||
"narHash": "sha256-Re6xXLEqQ/HRnThryumyGzEf3Uv0Pl4cuG50MrDofP8=",
|
||||
"owner": "cachix",
|
||||
"repo": "pre-commit-hooks.nix",
|
||||
"rev": "ca2fdbf3edda2a38140184da6381d49f8206eaf4",
|
||||
"rev": "182af51202998af5b64ddecaa7ff9be06425399b",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
|
|
@ -313,6 +316,21 @@
|
|||
"type": "git",
|
||||
"url": "ssh://git@hera.m-0.eu/config-secrets"
|
||||
}
|
||||
},
|
||||
"systems": {
|
||||
"locked": {
|
||||
"lastModified": 1681028828,
|
||||
"narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
|
||||
"owner": "nix-systems",
|
||||
"repo": "default",
|
||||
"rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "nix-systems",
|
||||
"repo": "default",
|
||||
"type": "github"
|
||||
}
|
||||
}
|
||||
},
|
||||
"root": "root",
|
||||
|
|
|
|||
|
|
@ -75,7 +75,7 @@ runWithoutConnectivity :: Eff (Ping : es) a -> Eff es a
|
|||
runWithoutConnectivity = Eff.interpret $ \_ -> \case
|
||||
CheckConnectivity _ -> pure False
|
||||
|
||||
runWithPing :: Eff.IOE :> es => Eff (Ping : es) a -> Eff es a
|
||||
runWithPing :: (Eff.IOE :> es) => Eff (Ping : es) a -> Eff es a
|
||||
runWithPing = Eff.interpret $ \_ -> \case
|
||||
CheckConnectivity host_name -> do
|
||||
liftIO $ ping `Exception.catch` \(_ :: Shh.Failure) -> pure False
|
||||
|
|
@ -96,7 +96,7 @@ commaList = Text.intercalate ","
|
|||
builderLine :: (Text, Natural, Natural) -> Text
|
||||
builderLine (hostName, maxJobs, speed_factor) = [i|ssh-ng://#{hostName} #{commaList systems} - #{maxJobs} #{speed_factor} #{commaList supportedFeatures} - -|]
|
||||
|
||||
testBuilders :: Ping :> es => [(Text, Reachable)] -> Eff es [Text]
|
||||
testBuilders :: (Ping :> es) => [(Text, Reachable)] -> Eff es [Text]
|
||||
testBuilders =
|
||||
fmap (fmap fst) . filterM \case
|
||||
(_, Always) -> pure True
|
||||
|
|
@ -121,7 +121,7 @@ main = do
|
|||
[host', "--force"] -> (into host', False, False)
|
||||
[host', "--without-connection"] -> (into host', True, False)
|
||||
_ -> error [i|Unknown arguments: #{args}|]
|
||||
builder_tries :: Ping :> es => Eff es [Text]
|
||||
builder_tries :: (Ping :> es) => Eff es [Text]
|
||||
builder_tries = testBuilders $ fromMaybe (error [i|#{host} not found in builderConfigs.|]) $ Map.lookup (into host) builderConfigs
|
||||
builders <- if allow_empty && host == "zeus" then pure [] else Eff.runEff $ (if withoutConnection then runWithoutConnectivity else runWithPing) builder_tries
|
||||
(path, handle) <- IO.openTempFile "/tmp" "machines"
|
||||
|
|
|
|||
|
|
@ -30,7 +30,7 @@ serveSnaplet :: ((R BackendRoute -> Snap ()) -> IO b) -> IO ()
|
|||
serveSnaplet serve = do
|
||||
config <- readConfig Nothing
|
||||
backendRequestQueue <- newTQueueIO
|
||||
let backendSnaplet :: MonadSnap m => R BackendRoute -> m ()
|
||||
let backendSnaplet :: (MonadSnap m) => R BackendRoute -> m ()
|
||||
backendSnaplet = \case
|
||||
BackendRouteSocket :/ (_, params) -> serveWebsocket config backendRequestQueue params
|
||||
BackendRouteMissing :/ () -> pass
|
||||
|
|
@ -39,7 +39,7 @@ serveSnaplet serve = do
|
|||
(serve backendSnaplet)
|
||||
|
||||
serveWebsocket ::
|
||||
MonadSnap m =>
|
||||
(MonadSnap m) =>
|
||||
BackendConfig ->
|
||||
TQueue LocalBackendRequest ->
|
||||
Map Text (Maybe Text) ->
|
||||
|
|
|
|||
|
|
@ -27,14 +27,14 @@ frontend =
|
|||
, _frontend_body = void $ D.prerender pass frontendBody
|
||||
}
|
||||
|
||||
frontendBody :: WidgetJSM t m => m ()
|
||||
frontendBody :: (WidgetJSM t m) => m ()
|
||||
frontendBody =
|
||||
D.dyn_ . fmap (maybe pass mainWidget)
|
||||
=<< remoteBackendWidget (wrap D.never) Nothing
|
||||
|
||||
css = cssAsText (static @"MaterialIcons-Regular-Outlined.otf")
|
||||
|
||||
frontendHead :: ObeliskWidget js t route m => m ()
|
||||
frontendHead :: (ObeliskWidget js t route m) => m ()
|
||||
frontendHead = do
|
||||
D.el "title" $ D.text "Kassandra 2 Webversion"
|
||||
D.elAttr "style" mempty . D.text $ css
|
||||
|
|
|
|||
|
|
@ -29,7 +29,7 @@ import Kassandra.Types (StandardWidget, Widget, getAppState)
|
|||
import Reflex qualified as R
|
||||
import Reflex.Dom qualified as D
|
||||
|
||||
agendaWidget :: StandardWidget t m r e => m ()
|
||||
agendaWidget :: (StandardWidget t m r e) => m ()
|
||||
agendaWidget = do
|
||||
appState <- getAppState
|
||||
let calendarEvents = appState ^. #calendarEvents
|
||||
|
|
@ -56,7 +56,7 @@ agendaWidget = do
|
|||
br
|
||||
calendarListWidget uid todoList
|
||||
|
||||
calendarListWidget :: StandardWidget t m r e => Text -> CalendarList -> m ()
|
||||
calendarListWidget :: (StandardWidget t m r e) => Text -> CalendarList -> m ()
|
||||
calendarListWidget uid calendarList = do
|
||||
listWithGaps widget gapWidget (pure (entries calendarList))
|
||||
newTaskEvent <- createTextWidget (button "selector" $ D.text "New Task")
|
||||
|
|
@ -78,7 +78,7 @@ calendarListWidget uid calendarList = do
|
|||
where
|
||||
updateOnList upd = (#entries %~ upd . Seq.filter (isNothing . flip NESeq.elemIndexL toInsert)) calendarList
|
||||
|
||||
printEventTime :: Widget t m => EventTime -> m ()
|
||||
printEventTime :: (Widget t m) => EventTime -> m ()
|
||||
printEventTime (SimpleEvent start end) = do
|
||||
showstart <- switchToCurrentZone (start ^. #time)
|
||||
showend <- switchToCurrentZone (end ^. #time)
|
||||
|
|
|
|||
|
|
@ -10,11 +10,11 @@ import Reflex qualified as R
|
|||
import Reflex.Dom qualified as D
|
||||
import Relude.Extra.Bifunctor (secondF)
|
||||
|
||||
br :: D.DomBuilder t m => m ()
|
||||
br :: (D.DomBuilder t m) => m ()
|
||||
br = D.el "br" pass
|
||||
|
||||
stateWidget ::
|
||||
Widget t m =>
|
||||
(Widget t m) =>
|
||||
state ->
|
||||
(state -> m (R.Event t a, R.Event t state)) ->
|
||||
m (R.Event t a)
|
||||
|
|
@ -24,9 +24,9 @@ stateWidget initialState widget = do
|
|||
where
|
||||
stateToWorkflow = D.Workflow . secondF (fmap stateToWorkflow) . widget
|
||||
|
||||
icon :: Widget t m => Text -> Text -> m ()
|
||||
icon :: (Widget t m) => Text -> Text -> m ()
|
||||
icon cssClass = D.elClass "i" ("material-icons icon " <> cssClass) . D.text
|
||||
|
||||
button :: Widget t m => Text -> m () -> m (R.Event t ())
|
||||
button :: (Widget t m) => Text -> m () -> m (R.Event t ())
|
||||
button cssClass =
|
||||
fmap (D.domEvent D.Click . fst) . D.elClass' "span" ("button " <> cssClass)
|
||||
|
|
|
|||
|
|
@ -60,7 +60,7 @@ sortEventTimes lhs rhs = case (lhs, rhs) of
|
|||
(SimpleEvent startTimeLhs _, AllDayEvent startDayRhs _) -> case compare (tzTimeDay startTimeLhs) startDayRhs of EQ -> GT; a -> a
|
||||
(_, _) -> EQ
|
||||
|
||||
switchToCurrentZone :: MonadIO m => ZonedTime -> m ZonedTime
|
||||
switchToCurrentZone :: (MonadIO m) => ZonedTime -> m ZonedTime
|
||||
switchToCurrentZone time = do
|
||||
let inUtc = zonedTimeToUTC time
|
||||
zone <- liftIO $ getTimeZone inUtc
|
||||
|
|
|
|||
|
|
@ -37,7 +37,7 @@ data Severity = Debug | Info | Warning | Error deriving stock (Show, Read, Eq, O
|
|||
class ReflexLoggable l where
|
||||
useLogString :: (Text -> a -> Text) -> l a -> l a
|
||||
|
||||
instance R.Reflex t => ReflexLoggable (R.Dynamic t) where
|
||||
instance (R.Reflex t) => ReflexLoggable (R.Dynamic t) where
|
||||
useLogString f d =
|
||||
let e' = traceEventWith (toString . f "updated Dynamic") $ updated d
|
||||
getV0 = do
|
||||
|
|
@ -45,7 +45,7 @@ instance R.Reflex t => ReflexLoggable (R.Dynamic t) where
|
|||
Trace.trace (toString $ f "initialized Dynamic" x) $ return x
|
||||
in unsafeBuildDynamic getV0 e'
|
||||
|
||||
instance R.Reflex t => ReflexLoggable (R.Event t) where
|
||||
instance (R.Reflex t) => ReflexLoggable (R.Event t) where
|
||||
useLogString f e = traceEventWith (toString . f "triggered Event") e
|
||||
|
||||
logR ::
|
||||
|
|
@ -108,7 +108,7 @@ traceID = unsafePerformIO . newMVar $ 0
|
|||
setLogLevel :: Maybe Severity -> IO ()
|
||||
setLogLevel = void . swapMVar logLevel
|
||||
|
||||
severeEnough :: MonadIO m => Severity -> m Bool
|
||||
severeEnough :: (MonadIO m) => Severity -> m Bool
|
||||
severeEnough severity = severeEnough' <$> readMVar logLevel
|
||||
where
|
||||
severeEnough' (Just minSeverity) | minSeverity <= severity = True
|
||||
|
|
|
|||
|
|
@ -34,7 +34,7 @@ import Reflex.Dom qualified as D
|
|||
tellSelected :: (MonadIO m, WriteApp t m e) => R.Event t (Seq DefinitionElement) -> m ()
|
||||
tellSelected = tellSingleton . fmap (_Typed @AppStateChange % _Typed @SelectState #) <=< logRShow Info
|
||||
|
||||
insertArea :: StandardWidget t m r e => R.Dynamic t (Seq DefinitionElement) -> m () -> m (R.Event t (NESeq DefinitionElement))
|
||||
insertArea :: (StandardWidget t m r e) => R.Dynamic t (Seq DefinitionElement) -> m () -> m (R.Event t (NESeq DefinitionElement))
|
||||
insertArea blacklistD areaW = do
|
||||
selectStateD <- getSelectState
|
||||
let dropActive = do
|
||||
|
|
@ -53,7 +53,7 @@ insertArea blacklistD areaW = do
|
|||
R.switchHold R.never evEv
|
||||
|
||||
taskDropArea ::
|
||||
StandardWidget t m r e =>
|
||||
(StandardWidget t m r e) =>
|
||||
R.Dynamic t (Seq UUID) ->
|
||||
m () ->
|
||||
(R.Event t (NESeq TaskInfos) -> R.Event t (NESeq Task)) ->
|
||||
|
|
@ -72,7 +72,7 @@ taskDropArea blacklistD areaW handler = do
|
|||
<$> handler droppedTaskEvent
|
||||
|
||||
childDropArea ::
|
||||
StandardWidget t m r e =>
|
||||
(StandardWidget t m r e) =>
|
||||
SortPosition t ->
|
||||
R.Dynamic t (Seq UUID) ->
|
||||
m () ->
|
||||
|
|
|
|||
|
|
@ -45,7 +45,7 @@ import Reflex.Dom qualified as D
|
|||
|
||||
data AdhocContext = NoContext | AgendaEvent Text CalendarList | AgendaList Text (Set Text)
|
||||
|
||||
selectWidget :: StandardWidget t m r e => DefinitionElement -> m ()
|
||||
selectWidget :: (StandardWidget t m r e) => DefinitionElement -> m ()
|
||||
selectWidget definitionElement = do
|
||||
(dragEl, _) <- D.elClass' "span" "button" $ icon "" "filter_list"
|
||||
selectStateB <- toggleContainElement definitionElement <<$>> R.current <$> getSelectState
|
||||
|
|
@ -55,14 +55,14 @@ selectWidget definitionElement = do
|
|||
toggleContainElement entry selectedTasks =
|
||||
Seq.findIndexL (== entry) selectedTasks & maybe (selectedTasks |> entry) (`Seq.deleteAt` selectedTasks)
|
||||
|
||||
listElementWidget :: StandardWidget t m r e => AdhocContext -> ListItem -> m ()
|
||||
listElementWidget :: (StandardWidget t m r e) => AdhocContext -> ListItem -> m ()
|
||||
listElementWidget context = \case
|
||||
TaskwarriorTask uuid -> uuidWidget taskTreeWidget (pure uuid)
|
||||
AdHocTask t -> adhocTaskWidget t context
|
||||
HabiticaTask _ -> error "HabiticaTasks are not yet supported"
|
||||
Mail _ -> error "Mails are not yet supported"
|
||||
|
||||
configListWidget :: forall t m r e. StandardWidget t m r e => AdhocContext -> Text -> Maybe Natural -> m ()
|
||||
configListWidget :: forall t m r e. (StandardWidget t m r e) => AdhocContext -> Text -> Maybe Natural -> m ()
|
||||
configListWidget context name limit = do
|
||||
D.text name >> br
|
||||
namedListQueries <- getAppState ^. mapping (#uiConfig % mapping #configuredLists)
|
||||
|
|
@ -72,7 +72,7 @@ configListWidget context name limit = do
|
|||
f (NamedListQuery x query) | x == name = Just query
|
||||
f _ = Nothing
|
||||
|
||||
queryWidget :: StandardWidget t m r e => AdhocContext -> ListQuery -> m ()
|
||||
queryWidget :: (StandardWidget t m r e) => AdhocContext -> ListQuery -> m ()
|
||||
queryWidget context els = smartSimpleList ((>> br) . definitionElementWidget context) (pure els)
|
||||
|
||||
tasksToShow :: Text -> TaskState -> Seq TaskInfos
|
||||
|
|
@ -81,7 +81,7 @@ tasksToShow tag = filter inList . fromList . HashMap.elems
|
|||
inList :: TaskInfos -> Bool
|
||||
inList ((^. #task) -> task) = tag `Set.member` (task ^. #tags) && has (#status % #_Pending) task
|
||||
|
||||
definitionElementWidget :: StandardWidget t m r e => AdhocContext -> DefinitionElement -> m ()
|
||||
definitionElementWidget :: (StandardWidget t m r e) => AdhocContext -> DefinitionElement -> m ()
|
||||
definitionElementWidget context el = do
|
||||
selectWidget el
|
||||
el & \case
|
||||
|
|
@ -107,7 +107,7 @@ definitionElementWidget context el = do
|
|||
(HabiticaList list) -> D.text "HabiticaList not implemented"
|
||||
Mails -> D.text "Mails not implemented"
|
||||
|
||||
adhocTaskWidget :: StandardWidget t m r e => Text -> AdhocContext -> m ()
|
||||
adhocTaskWidget :: (StandardWidget t m r e) => Text -> AdhocContext -> m ()
|
||||
adhocTaskWidget description = \case
|
||||
AgendaEvent uid calendarList -> do
|
||||
changeDoneStatus <- checkBox (completed calendarList)
|
||||
|
|
@ -124,5 +124,5 @@ adhocTaskWidget description = \case
|
|||
checkBox completed = if description `Set.member` completed then (False <$) <$> button "" (D.text "[x]") else (True <$) <$> button "" (D.text "[ ]")
|
||||
text = D.text [i| #{description}|]
|
||||
|
||||
tellList :: StandardWidget t m r e => Text -> D.Event t CalendarList -> m ()
|
||||
tellList :: (StandardWidget t m r e) => Text -> D.Event t CalendarList -> m ()
|
||||
tellList uid listEvent = tellSingleton $ (_Typed @AppStateChange % _Typed @DataChange #) . SetEventList uid <$> listEvent
|
||||
|
|
|
|||
|
|
@ -37,7 +37,7 @@ listsWidget = do
|
|||
buttons <- D.dyn $ mapM listButton <$> lists
|
||||
buttonSum <- R.switchHold R.never $ R.leftmost . toList <$> buttons
|
||||
R.holdDyn Nothing (Just <$> buttonSum)
|
||||
listButton :: Widget t m => Text -> m (R.Event t Text)
|
||||
listButton :: (Widget t m) => Text -> m (R.Event t Text)
|
||||
listButton tag =
|
||||
fmap ((tag <$) . D.domEvent D.Click . fst)
|
||||
. D.elClass' "a" "selector"
|
||||
|
|
@ -45,7 +45,7 @@ listsWidget = do
|
|||
$ tag
|
||||
|
||||
listWidget ::
|
||||
forall t m r e. StandardWidget t m r e => R.Dynamic t Text -> m ()
|
||||
forall t m r e. (StandardWidget t m r e) => R.Dynamic t Text -> m ()
|
||||
listWidget list = D.dyn_ (innerRenderList <$> list)
|
||||
where
|
||||
innerRenderList :: Text -> m ()
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@ data LocalBackendRequest = LocalBackendRequest
|
|||
makeLabels ''LocalBackendRequest
|
||||
|
||||
localClientSocket ::
|
||||
WidgetIO t m =>
|
||||
(WidgetIO t m) =>
|
||||
TQueue LocalBackendRequest ->
|
||||
UserConfig ->
|
||||
m (ClientSocket t m)
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ import Kassandra.Types (WidgetIO)
|
|||
import Reflex qualified as R
|
||||
|
||||
localBackendWidget ::
|
||||
WidgetIO t m =>
|
||||
(WidgetIO t m) =>
|
||||
TQueue LocalBackendRequest ->
|
||||
NamedBackend UserConfig ->
|
||||
m (R.Dynamic t (Maybe (StateProvider t m)))
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
module Kassandra.LogWidget (logWidget) where
|
||||
|
||||
logWidget :: Monad m => m ()
|
||||
logWidget :: (Monad m) => m ()
|
||||
logWidget = pass
|
||||
|
|
|
|||
|
|
@ -40,7 +40,7 @@ import Kassandra.Util (lookupTasks, stillTodo, tellNewTask)
|
|||
import Reflex qualified as R
|
||||
import Reflex.Dom qualified as D
|
||||
|
||||
mainWidget :: WidgetIO t m => StateProvider t m -> m ()
|
||||
mainWidget :: (WidgetIO t m) => StateProvider t m -> m ()
|
||||
mainWidget stateProvider = do
|
||||
-- TODO: Use ui Config
|
||||
liftIO $ setLogLevel $ Just Info
|
||||
|
|
@ -72,7 +72,7 @@ mainWidget stateProvider = do
|
|||
stateChanges <- logR Info (\a -> [i|StateChange: #{a}|]) stateChanges'
|
||||
pass
|
||||
|
||||
infoFooter :: StandardWidget t m r e => m ()
|
||||
infoFooter :: (StandardWidget t m r e) => m ()
|
||||
infoFooter = D.divClass "footer" $ do
|
||||
selectedState <- getSelectState
|
||||
D.dyn_ $
|
||||
|
|
@ -92,7 +92,7 @@ infoFooter = D.divClass "footer" $ do
|
|||
completed = countTasks #_Completed taskList
|
||||
in [i|#{pending} pending and #{completed} completed tasks. Kassandra-ToDo-Management|]
|
||||
|
||||
taskDiagnosticsWidget :: StandardWidget t m r e => m ()
|
||||
taskDiagnosticsWidget :: (StandardWidget t m r e) => m ()
|
||||
taskDiagnosticsWidget = do
|
||||
tasks <- getTasks
|
||||
D.dynText $ do
|
||||
|
|
@ -109,7 +109,7 @@ taskDiagnosticsWidget = do
|
|||
Just uuid -> "Found a loop for uuid " <> show uuid
|
||||
Nothing -> "" -- everything fine
|
||||
|
||||
widgets :: StandardWidget t m r e => Seq (Text, m ())
|
||||
widgets :: (StandardWidget t m r e) => Seq (Text, m ())
|
||||
widgets =
|
||||
fromList
|
||||
[ ("Agenda", agendaWidget)
|
||||
|
|
@ -118,7 +118,7 @@ widgets =
|
|||
, ("Logs", logWidget)
|
||||
]
|
||||
|
||||
widgetSwitcher :: forall t m r e. StandardWidget t m r e => m ()
|
||||
widgetSwitcher :: forall t m r e. (StandardWidget t m r e) => m ()
|
||||
widgetSwitcher = do
|
||||
uiConfigD <- getAppState ^. mapping #uiConfig
|
||||
D.el "div" . D.dyn_ $ uiConfigD <&> withUIConfig
|
||||
|
|
@ -159,7 +159,7 @@ filterInbox now tasks events =
|
|||
&& not (taskInfos ^. #blocked)
|
||||
&& not ((taskInfos ^. #uuid) `Set.member` scheduledEvents)
|
||||
|
||||
getInboxTasks :: StandardWidget t m r e => m (D.Dynamic t (Seq TaskInfos))
|
||||
getInboxTasks :: (StandardWidget t m r e) => m (D.Dynamic t (Seq TaskInfos))
|
||||
getInboxTasks = do
|
||||
appState <- getAppState
|
||||
timeDyn <- zonedTimeToUTC <<$>> getTime
|
||||
|
|
@ -167,7 +167,7 @@ getInboxTasks = do
|
|||
tasks <- getTasks
|
||||
R.holdUniqDyn $ filterInbox <$> timeDyn <*> tasks <*> calendarEvents
|
||||
|
||||
nextWidget :: StandardWidget t m r e => m ()
|
||||
nextWidget :: (StandardWidget t m r e) => m ()
|
||||
nextWidget = do
|
||||
inboxTasks <- getInboxTasks
|
||||
unsortedTasks <-
|
||||
|
|
|
|||
|
|
@ -43,7 +43,7 @@ loginStateKey = "LoginState"
|
|||
|
||||
remoteBackendWidget ::
|
||||
forall t m.
|
||||
WidgetJSM t m =>
|
||||
(WidgetJSM t m) =>
|
||||
CloseEvent t ->
|
||||
Maybe (RemoteBackend PasswordConfig) ->
|
||||
m (R.Dynamic t (Maybe (StateProvider t m)))
|
||||
|
|
@ -129,11 +129,11 @@ remoteBackendWidget closeEvent mayBackend = D.divClass "remoteBackend" $ do
|
|||
|
||||
data WebSocketState = WebSocketError Text | Connecting deriving stock (Show)
|
||||
|
||||
getStorage :: WidgetJSM t m => m Storage
|
||||
getStorage :: (WidgetJSM t m) => m Storage
|
||||
getStorage = getLocalStorage =<< currentWindowUnchecked
|
||||
|
||||
webClientSocket ::
|
||||
WidgetJSM t m => CloseEvent t -> RemoteBackend Text -> m (ClientSocket t m)
|
||||
(WidgetJSM t m) => CloseEvent t -> RemoteBackend Text -> m (ClientSocket t m)
|
||||
webClientSocket closeEvent backend@RemoteBackend{url, user, password} = do
|
||||
refreshEvent <- button "selector" $ D.text "Refresh Tasks"
|
||||
let wsUrl = maybe "ws://localhost:8000" ("ws" <>) $ stripPrefix "http" url -- TODO: Warn user about missing http
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ import Reflex qualified as R
|
|||
import Reflex.Dom qualified as D
|
||||
|
||||
backendSelector ::
|
||||
Widget t m => NonEmpty (NamedBackend a) -> m (R.Dynamic t (NamedBackend a))
|
||||
(Widget t m) => NonEmpty (NamedBackend a) -> m (R.Dynamic t (NamedBackend a))
|
||||
backendSelector backends = D.el "div" $ do
|
||||
buttons <- forM backends $ \backend -> do
|
||||
fmap ((backend <$) . D.domEvent D.Click . fst)
|
||||
|
|
|
|||
|
|
@ -96,9 +96,9 @@ maxOrder = -minOrder
|
|||
minDist = 10 ** (-6)
|
||||
minTouchedDist = 10 ** (-3)
|
||||
|
||||
tasksSorted :: Show a => Double -> Seq (a, SortState) -> Bool
|
||||
tasksSorted :: (Show a) => Double -> Seq (a, SortState) -> Bool
|
||||
tasksSorted = isSortedOn (newValue . (^. _2))
|
||||
isSortedOn :: Show a => (a -> Double) -> Double -> Seq a -> Bool
|
||||
isSortedOn :: (Show a) => (a -> Double) -> Double -> Seq a -> Bool
|
||||
isSortedOn f delta = \case
|
||||
IsEmpty -> True
|
||||
IsNonEmpty (_ :<|| IsEmpty) -> True
|
||||
|
|
@ -169,7 +169,7 @@ insertBefore list toInsert = \case
|
|||
type InsertEvent t = R.Event t (NESeq Task, Maybe UUID)
|
||||
|
||||
saveSorting ::
|
||||
R.Reflex t =>
|
||||
(R.Reflex t) =>
|
||||
R.Behavior t SortMode ->
|
||||
R.Behavior t (Seq Task) ->
|
||||
InsertEvent t ->
|
||||
|
|
|
|||
|
|
@ -40,7 +40,7 @@ type StateProvider t m = R.Event t (NESeq DataChange) -> m (R.Dynamic t DataStat
|
|||
|
||||
type ClientSocket t m = R.Event t (NESeq SocketRequest) -> m (R.Dynamic t (R.Event t SocketMessage))
|
||||
|
||||
makeStateProvider :: forall t m. WidgetIO t m => ClientSocket t m -> StateProvider t m
|
||||
makeStateProvider :: forall t m. (WidgetIO t m) => ClientSocket t m -> StateProvider t m
|
||||
makeStateProvider clientSocket dataChangeEvents = do
|
||||
let fanEvent :: (b -> Maybe a) -> R.Event t (NESeq b) -> R.Event t (NESeq a)
|
||||
fanEvent decons = R.fmapMaybe (nonEmptySeq . mapMaybe decons . toSeq)
|
||||
|
|
@ -63,13 +63,13 @@ makeStateProvider clientSocket dataChangeEvents = do
|
|||
tasksStateDyn <- buildTaskInfosMap <<$>> holdTasks (localChanges <> ((^? #_TaskUpdates) <$?> remoteChanges))
|
||||
pure (DataState <$> tasksStateDyn <*> uiConfig <*> calendarData)
|
||||
|
||||
createToChangeEvent :: WidgetIO t m => D.Event t (NESeq (Text, Task -> Task)) -> m (D.Event t (NESeq Task))
|
||||
createToChangeEvent :: (WidgetIO t m) => D.Event t (NESeq (Text, Task -> Task)) -> m (D.Event t (NESeq Task))
|
||||
createToChangeEvent = R.performEvent . fmap (liftIO . mapM (\(desc, properties) -> properties <$> createTask desc))
|
||||
|
||||
holdTasks :: WidgetIO t m => R.Event t (NESeq Task) -> m (R.Dynamic t (HashMap UUID Task))
|
||||
holdTasks :: (WidgetIO t m) => R.Event t (NESeq Task) -> m (R.Dynamic t (HashMap UUID Task))
|
||||
holdTasks = R.foldDyn foldTasks mempty
|
||||
|
||||
foldTasks :: Foldable t => t Task -> HashMap UUID Task -> HashMap UUID Task
|
||||
foldTasks :: (Foldable t) => t Task -> HashMap UUID Task -> HashMap UUID Task
|
||||
foldTasks = flip (foldr (\task -> HashMap.insert (task ^. #uuid) task))
|
||||
|
||||
buildChildrenMap :: HashMap a Task -> HashMap UUID (Seq a)
|
||||
|
|
|
|||
|
|
@ -63,14 +63,14 @@ type HaveTask m r = Have m r TaskInfos
|
|||
instance LabelOptic "taskInfos" A_Lens (a, TaskInfos) (a, TaskInfos) TaskInfos TaskInfos where
|
||||
labelOptic = _2
|
||||
|
||||
getTaskInfos :: HaveTask m r => m TaskInfos
|
||||
getTaskInfos :: (HaveTask m r) => m TaskInfos
|
||||
getTaskInfos = ask ^. mapping typed
|
||||
|
||||
getChildren :: TaskWidget t m r e => m (R.Dynamic t (Seq TaskInfos))
|
||||
getChildren :: (TaskWidget t m r e) => m (R.Dynamic t (Seq TaskInfos))
|
||||
getChildren = getTaskInfos ^. mapping #children >>= lookupTasksM
|
||||
|
||||
taskTreeWidget ::
|
||||
forall t m r e. StandardWidget t m r e => R.Dynamic t TaskInfos -> m ()
|
||||
forall t m r e. (StandardWidget t m r e) => R.Dynamic t TaskInfos -> m ()
|
||||
taskTreeWidget taskInfosD = do
|
||||
log Debug "Creating Tasktree Widget"
|
||||
(appState :: AppState t) <- getAppState
|
||||
|
|
@ -120,12 +120,12 @@ taskWidget taskInfos' = D.divClass "task" $ do
|
|||
selectWidget
|
||||
dropChildWidget
|
||||
|
||||
pathWidget :: TaskWidget t m r e => m ()
|
||||
pathWidget :: (TaskWidget t m r e) => m ()
|
||||
pathWidget = do
|
||||
parents <- getTaskInfos ^. mapping #parents >>= lookupTasksM ^. mapping (mapping (mapping (mapping #description)))
|
||||
D.dyn_ $ flip whenJust showPath . nonEmptySeq <$> parents
|
||||
where
|
||||
showPath :: TaskWidget t m r e => NESeq Text -> m ()
|
||||
showPath :: (TaskWidget t m r e) => NESeq Text -> m ()
|
||||
showPath parents = D.elClass "span" "parentPath" $ do
|
||||
br
|
||||
makePath parents
|
||||
|
|
@ -219,7 +219,7 @@ dropChildWidget = do
|
|||
(icon "dropHere plusTwo" "schedule")
|
||||
$ fmap (fmap ((#depends %~ Set.insert (taskInfos ^. #uuid)) . (^. #task)))
|
||||
|
||||
tagsWidget :: forall t m r e. TaskWidget t m r e => m ()
|
||||
tagsWidget :: forall t m r e. (TaskWidget t m r e) => m ()
|
||||
tagsWidget = do
|
||||
task <- getTaskInfos ^. mapping #task
|
||||
forM_ (task ^. #tags) $ \tag -> D.elClass "span" "tag" $ do
|
||||
|
|
@ -229,16 +229,16 @@ tagsWidget = do
|
|||
tagEvent <- createTextWidget . button "edit" $ icon "" "add_box"
|
||||
tellTask $ (\tag -> #tags %~ Set.insert tag $ task) <$> tagEvent
|
||||
|
||||
getNewUDA :: forall t m r e. TaskWidget t m r e => m UDA
|
||||
getNewUDA :: forall t m r e. (TaskWidget t m r e) => m UDA
|
||||
getNewUDA = one . ("partof",) . toJSON <$> getTaskInfos ^. mapping #uuid
|
||||
|
||||
addChildWidget :: TaskWidget t m r e => m ()
|
||||
addChildWidget :: (TaskWidget t m r e) => m ()
|
||||
addChildWidget = do
|
||||
descriptionEvent <- createTextWidget . button "edit" $ icon "" "add_task"
|
||||
newUDA <- getNewUDA
|
||||
tellNewTask $ (,#uda .~ newUDA) <$> descriptionEvent
|
||||
|
||||
childrenWidget :: forall t m r e. TaskTreeWidget t m r e => R.Dynamic t TaskInfos -> m ()
|
||||
childrenWidget :: forall t m r e. (TaskTreeWidget t m r e) => R.Dynamic t TaskInfos -> m ()
|
||||
childrenWidget taskInfosD = do
|
||||
expandedTasks <- getExpandedTasks
|
||||
showChildren <-
|
||||
|
|
@ -262,7 +262,7 @@ childrenWidget taskInfosD = do
|
|||
taskList (sortModeD ^. #current) sortedList blacklist taskWidget
|
||||
|
||||
taskList ::
|
||||
StandardWidget t m r e =>
|
||||
(StandardWidget t m r e) =>
|
||||
R.Behavior t SortMode ->
|
||||
R.Dynamic t (Seq TaskInfos) ->
|
||||
R.Dynamic t (Seq UUID) ->
|
||||
|
|
@ -280,7 +280,7 @@ taskList mode tasksD blacklistD elementWidget =
|
|||
partialSortPosition = SortPosition mode (tasksD ^. mapping (mapping #task) % #current)
|
||||
uuidsD = tasksD ^. mapping (mapping #uuid)
|
||||
|
||||
uuidWidget :: StandardWidget t m r e => (R.Dynamic t TaskInfos -> m ()) -> R.Dynamic t UUID -> m ()
|
||||
uuidWidget :: (StandardWidget t m r e) => (R.Dynamic t TaskInfos -> m ()) -> R.Dynamic t UUID -> m ()
|
||||
uuidWidget widget uuid = do
|
||||
maybeCurrentTaskD <- R.maybeDyn =<< R.holdUniqDyn =<< lookupTaskM uuid
|
||||
D.dyn_ $
|
||||
|
|
@ -289,19 +289,19 @@ uuidWidget widget uuid = do
|
|||
widget
|
||||
<$> maybeCurrentTaskD
|
||||
|
||||
waitWidget :: forall t m r e. TaskWidget t m r e => m ()
|
||||
waitWidget :: forall t m r e. (TaskWidget t m r e) => m ()
|
||||
waitWidget = do
|
||||
task <- getTaskInfos ^. mapping #task
|
||||
event <- getTaskInfos >>= ((^. #wait) >>> dateSelectionWidget "wait")
|
||||
tellTask $ flip (#wait .~) task <$> event
|
||||
|
||||
dueWidget :: TaskWidget t m r e => m ()
|
||||
dueWidget :: (TaskWidget t m r e) => m ()
|
||||
dueWidget = do
|
||||
task <- getTaskInfos ^. mapping #task
|
||||
event <- dateSelectionWidget "due" $ task ^. #due
|
||||
tellTask $ flip (#due .~) task <$> event
|
||||
|
||||
selectWidget :: TaskWidget t m r e => m ()
|
||||
selectWidget :: (TaskWidget t m r e) => m ()
|
||||
selectWidget = do
|
||||
uuid <- getTaskInfos ^. mapping (#task % #uuid)
|
||||
(dragEl, _) <- D.elClass' "span" "button" $ icon "" "filter_list"
|
||||
|
|
@ -312,31 +312,31 @@ selectWidget = do
|
|||
toggleContainUUID ((#_ListElement % #_TaskwarriorTask #) -> entry) selectedTasks =
|
||||
Seq.findIndexL (== entry) selectedTasks & maybe (selectedTasks |> entry) (`Seq.deleteAt` selectedTasks)
|
||||
|
||||
descriptionWidget :: TaskWidget t m r e => m ()
|
||||
descriptionWidget :: (TaskWidget t m r e) => m ()
|
||||
descriptionWidget = do
|
||||
task <- getTaskInfos ^. mapping #task
|
||||
event <- lineWidget $ task ^. #description
|
||||
tellTask $ flip (#description .~) task <$> event
|
||||
|
||||
tellStatusByTime ::
|
||||
TaskWidget t m r e => ((UTCTime -> Status) -> R.Event t a -> m ())
|
||||
(TaskWidget t m r e) => ((UTCTime -> Status) -> R.Event t a -> m ())
|
||||
tellStatusByTime handler ev = do
|
||||
time <- getTime
|
||||
tellStatus $ handler . zonedTimeToUTC <$> R.tag (R.current time) ev
|
||||
|
||||
tellStatus :: TaskWidget t m r e => R.Event t Status -> m ()
|
||||
tellStatus :: (TaskWidget t m r e) => R.Event t Status -> m ()
|
||||
tellStatus ev = do
|
||||
task <- getTaskInfos ^. mapping #task
|
||||
tellTask $ flip (#status .~) task <$> ev
|
||||
|
||||
parentButton :: forall t m r e. TaskWidget t m r e => m ()
|
||||
parentButton :: forall t m r e. (TaskWidget t m r e) => m ()
|
||||
parentButton = do
|
||||
task <- getTaskInfos ^. mapping #task
|
||||
when (isn't (#partof % _Nothing) task) $ do
|
||||
event <- button "edit" (icon "" "layers_clear")
|
||||
tellTask $ (#partof .~ Nothing $ task) <$ event
|
||||
|
||||
deleteButton :: forall t m r e. TaskWidget t m r e => m ()
|
||||
deleteButton :: forall t m r e. (TaskWidget t m r e) => m ()
|
||||
deleteButton = do
|
||||
task <- getTaskInfos ^. mapping #task
|
||||
deleteWidget $ task ^. #status
|
||||
|
|
@ -348,14 +348,14 @@ deleteButton = do
|
|||
deleteWidget _ =
|
||||
button "edit" (icon "" "delete") >>= tellStatusByTime Status.Deleted
|
||||
|
||||
completedWidget :: forall t m r e. TaskWidget t m r e => m ()
|
||||
completedWidget :: forall t m r e. (TaskWidget t m r e) => m ()
|
||||
completedWidget = do
|
||||
status <- getTaskInfos ^. mapping (#task % #status)
|
||||
whenJust (status ^? #_Completed) $ \time -> do
|
||||
event <- dateSelectionWidget "completed" $ Just time
|
||||
tellStatus $ maybe Status.Pending Status.Completed <$> event
|
||||
|
||||
statusWidget :: forall t m r e. TaskWidget t m r e => m ()
|
||||
statusWidget :: forall t m r e. (TaskWidget t m r e) => m ()
|
||||
statusWidget = do
|
||||
status <- getTaskInfos <&> (\t -> (t ^. #status, t ^. #blocked))
|
||||
widget . widgetState $ status
|
||||
|
|
@ -395,7 +395,7 @@ statusWidget = do
|
|||
("delete", "show", Just ("done", "hide", const Status.Pending))
|
||||
(Status.Recurring{}, _) -> ("repeat", "show", Nothing)
|
||||
|
||||
collapseButton :: forall t m r e. TaskWidget t m r e => m ()
|
||||
collapseButton :: forall t m r e. (TaskWidget t m r e) => m ()
|
||||
collapseButton = do
|
||||
taskInfos <- getTaskInfos
|
||||
hasChildren <-
|
||||
|
|
|
|||
|
|
@ -14,17 +14,17 @@ import Kassandra.Types (Widget)
|
|||
import Reflex qualified as R
|
||||
import Reflex.Dom qualified as D
|
||||
|
||||
lineWidget :: Widget t m => Text -> m (R.Event t Text)
|
||||
lineWidget :: (Widget t m) => Text -> m (R.Event t Text)
|
||||
lineWidget text = enterTextWidget text (showText text)
|
||||
|
||||
createTextWidget :: Widget t m => m (R.Event t ()) -> m (R.Event t Text)
|
||||
createTextWidget :: (Widget t m) => m (R.Event t ()) -> m (R.Event t Text)
|
||||
createTextWidget = enterTextWidget ""
|
||||
|
||||
enterTextWidget :: Widget t m => Text -> m (R.Event t ()) -> m (R.Event t Text)
|
||||
enterTextWidget :: (Widget t m) => Text -> m (R.Event t ()) -> m (R.Event t Text)
|
||||
enterTextWidget text altLabel = stateWidget False (selectWidget text altLabel)
|
||||
|
||||
selectWidget ::
|
||||
Widget t m =>
|
||||
(Widget t m) =>
|
||||
Text ->
|
||||
m (R.Event t ()) ->
|
||||
Bool ->
|
||||
|
|
@ -37,13 +37,13 @@ selectWidget _ altLabel False = do
|
|||
pure (R.never, True <$ editEvent)
|
||||
|
||||
-- ! Takes a dynamic text and fires an event, when the user wants to edit it.
|
||||
showText :: Widget t m => Text -> m (R.Event t ())
|
||||
showText :: (Widget t m) => Text -> m (R.Event t ())
|
||||
showText text = do
|
||||
D.text text
|
||||
button "edit slimButton" $ icon "" "edit"
|
||||
|
||||
-- ! Prompts the user for a text edit and fires an event, when the user confirms the result. Nothing is cancelation.
|
||||
editText :: Widget t m => Text -> m (R.Event t (Maybe Text))
|
||||
editText :: (Widget t m) => Text -> m (R.Event t (Maybe Text))
|
||||
editText text = D.elClass "span" "activeEdit" $ do
|
||||
textinput <-
|
||||
D.inputElement $ D.def & lensVL D.inputElementConfig_initialValue .~ text
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@ myParseTime ((^. unpacked) -> t) =
|
|||
$ t
|
||||
|
||||
inputDateWidget ::
|
||||
forall t m. Widget t m => ZonedTime -> m (R.Event t (Maybe ZonedTime))
|
||||
forall t m. (Widget t m) => ZonedTime -> m (R.Event t (Maybe ZonedTime))
|
||||
inputDateWidget time = do
|
||||
textMayEvent <-
|
||||
editText @t @m . myFormatTime $ time :: m (R.Event t (Maybe Text))
|
||||
|
|
@ -43,7 +43,7 @@ inputDateWidget time = do
|
|||
|
||||
dateSelectionWidget ::
|
||||
forall t m r e.
|
||||
StandardWidget t m r e =>
|
||||
(StandardWidget t m r e) =>
|
||||
Text ->
|
||||
Maybe UTCTime ->
|
||||
m (R.Event t (Maybe UTCTime))
|
||||
|
|
@ -79,7 +79,7 @@ selectTimeWidget label time False = do
|
|||
pure (R.never, True <$ editEvent)
|
||||
|
||||
showTime ::
|
||||
forall t m. Widget t m => Text -> Maybe ZonedTime -> m (R.Event t ())
|
||||
forall t m. (Widget t m) => Text -> Maybe ZonedTime -> m (R.Event t ())
|
||||
showTime label = maybe create showWithButton
|
||||
where
|
||||
showWithButton time = do
|
||||
|
|
|
|||
|
|
@ -106,7 +106,7 @@ getIsExpanded ::
|
|||
(Widget t m, HaveTaskTree t m r) => UUID -> m (R.Dynamic t Bool)
|
||||
getIsExpanded uuid = R.holdUniqDyn . fmap (member uuid) =<< getExpandedTasks
|
||||
|
||||
getExpandedTasks :: HaveTaskTree t m r => m (TaskTreeState t)
|
||||
getExpandedTasks :: (HaveTaskTree t m r) => m (TaskTreeState t)
|
||||
getExpandedTasks = asks (^. typed)
|
||||
|
||||
getAppState :: (MonadReader r m, HasType (AppState t) r) => m (AppState t)
|
||||
|
|
|
|||
|
|
@ -36,7 +36,7 @@ import Reflex.Dom qualified as D
|
|||
stillTodo :: TaskInfos -> Bool
|
||||
stillTodo = has (#status % #_Pending)
|
||||
|
||||
tellToggle :: TaskTreeWidget t m r e => R.Event t UUID -> m ()
|
||||
tellToggle :: (TaskTreeWidget t m r e) => R.Event t UUID -> m ()
|
||||
tellToggle ev = do
|
||||
expandedTasks <- getExpandedTasks <&> view #current
|
||||
tellSingleton $
|
||||
|
|
@ -46,12 +46,12 @@ tellToggle ev = do
|
|||
expandedTasks
|
||||
ev
|
||||
|
||||
tellTask :: WriteApp t m e => R.Event t Task -> m ()
|
||||
tellTask :: (WriteApp t m e) => R.Event t Task -> m ()
|
||||
tellTask =
|
||||
tellSingleton
|
||||
. fmap (_Typed @AppStateChange % _Typed @DataChange % #_ChangeTask #)
|
||||
|
||||
tellNewTask :: WriteApp t m e => R.Event t (Text, Task -> Task) -> m ()
|
||||
tellNewTask :: (WriteApp t m e) => R.Event t (Text, Task -> Task) -> m ()
|
||||
tellNewTask =
|
||||
tellSingleton
|
||||
. fmap (_Typed @AppStateChange % _Typed @DataChange % #_CreateTask #)
|
||||
|
|
@ -63,11 +63,11 @@ tellSingleton = R.tellEvent . fmap one
|
|||
lookupTask :: TaskState -> UUID -> Maybe TaskInfos
|
||||
lookupTask tasks uuid = tasks ^. at uuid
|
||||
|
||||
lookupTasks :: Filterable f => TaskState -> f UUID -> f TaskInfos
|
||||
lookupTasks :: (Filterable f) => TaskState -> f UUID -> f TaskInfos
|
||||
lookupTasks tasks = mapMaybe (lookupTask tasks)
|
||||
|
||||
lookupTaskM ::
|
||||
StandardWidget t m r e =>
|
||||
(StandardWidget t m r e) =>
|
||||
R.Dynamic t UUID ->
|
||||
m (R.Dynamic t (Maybe TaskInfos))
|
||||
lookupTaskM uuid = getTasks <&> \tasks -> R.zipDynWith lookupTask tasks uuid
|
||||
|
|
@ -80,11 +80,11 @@ lookupTasksDynM ::
|
|||
lookupTasksDynM uuids =
|
||||
getTasks <&> \tasks -> flip lookupTasks <$> uuids <*> tasks
|
||||
|
||||
defDyn :: Widget t m => a -> R.Dynamic t (m a) -> m (R.Dynamic t a)
|
||||
defDyn :: (Widget t m) => a -> R.Dynamic t (m a) -> m (R.Dynamic t a)
|
||||
defDyn defVal = R.holdDyn defVal <=< D.dyn
|
||||
|
||||
defDynDyn ::
|
||||
Widget t m =>
|
||||
(Widget t m) =>
|
||||
R.Dynamic t a ->
|
||||
R.Dynamic t (m (R.Dynamic t a)) ->
|
||||
m (R.Dynamic t a)
|
||||
|
|
|
|||
|
|
@ -165,7 +165,7 @@ newCache = atomically $ Cache <$> STM.new <*> STM.new <*> STM.new
|
|||
|
||||
makeLabels ''Cache
|
||||
|
||||
foldToSeq :: Monad m => SerialT m a -> m (Seq a)
|
||||
foldToSeq :: (Monad m) => SerialT m a -> m (Seq a)
|
||||
foldToSeq = S.foldl' (|>) mempty
|
||||
|
||||
setList :: Cache -> Text -> CalendarList -> IO ()
|
||||
|
|
@ -183,11 +183,11 @@ setList cache uid list = do
|
|||
now <- getCurrentTime
|
||||
setModificationTime (dropFileName filename) now
|
||||
where
|
||||
insertList :: Traversable m => m VCalendar -> Maybe (m VCalendar)
|
||||
insertList :: (Traversable m) => m VCalendar -> Maybe (m VCalendar)
|
||||
insertList cals = if modified then Just ret else Nothing
|
||||
where
|
||||
(ret, modified) = runState (insertListS cals) False
|
||||
insertListS :: Traversable m => m VCalendar -> State Bool (m VCalendar)
|
||||
insertListS :: (Traversable m) => m VCalendar -> State Bool (m VCalendar)
|
||||
insertListS = mapM \calendar -> do
|
||||
newEvents <- forM (vcEvents calendar) \event ->
|
||||
if uidValue (veUID event) == toLazy uid
|
||||
|
|
@ -222,7 +222,7 @@ unmaskICSText = maybe "" (uncurry f) . LBS.uncons
|
|||
w 59 rest = ";" <> unmaskICSText rest
|
||||
w _ rest = unmaskICSText rest
|
||||
|
||||
tasksFieldName :: IsString t => t
|
||||
tasksFieldName :: (IsString t) => t
|
||||
tasksFieldName = "X-KASSANDRA-TASKS"
|
||||
|
||||
isTasksOther :: OtherProperty -> Bool
|
||||
|
|
|
|||
|
|
@ -70,7 +70,7 @@ instance FromDhall LocalBackend
|
|||
instance FromDhall TaskwarriorOption
|
||||
instance FromDhall UserConfig
|
||||
instance FromDhall AccountConfig
|
||||
instance FromDhall b => FromDhall (NamedBackend b)
|
||||
instance (FromDhall b) => FromDhall (NamedBackend b)
|
||||
|
||||
postComposeMayDecoder :: Text -> (a -> Maybe b) -> Decoder a -> Decoder b
|
||||
postComposeMayDecoder err f dec =
|
||||
|
|
@ -83,7 +83,7 @@ instance FromDhall UUID where
|
|||
autoWith =
|
||||
postComposeMayDecoder "Text was no valid UUID" UUID.fromText . autoWith
|
||||
|
||||
instance FromDhall a => FromDhall (NonEmpty a) where
|
||||
instance (FromDhall a) => FromDhall (NonEmpty a) where
|
||||
autoWith = postComposeMayDecoder "List was empty" nonEmpty . autoWith
|
||||
|
||||
instance FromDhall (PasswordHash Argon2) where
|
||||
|
|
@ -96,10 +96,10 @@ data DhallLoadConfig = DhallLoadConfig
|
|||
}
|
||||
deriving stock (Show, Eq, Ord)
|
||||
|
||||
dhallType :: forall a. FromDhall a => Text
|
||||
dhallType :: forall a. (FromDhall a) => Text
|
||||
dhallType = fromRight "" . validationToEither $ pretty <$> expected (auto @a)
|
||||
|
||||
loadDhallConfig :: FromDhall a => DhallLoadConfig -> Maybe Text -> IO a
|
||||
loadDhallConfig :: (FromDhall a) => DhallLoadConfig -> Maybe Text -> IO a
|
||||
loadDhallConfig loadConfig givenConfigFile = do
|
||||
let defFile = defaultFile loadConfig
|
||||
defConf = defaultConfig loadConfig
|
||||
|
|
@ -112,9 +112,9 @@ loadDhallConfig loadConfig givenConfigFile = do
|
|||
]
|
||||
input auto $ maybe defConf (\name -> [i|(#{defConf}) // #{name}|]) filename
|
||||
|
||||
doesPathExist :: ToString a => a -> IO Bool
|
||||
doesPathExist :: (ToString a) => a -> IO Bool
|
||||
doesPathExist (fromFilePath . toString -> (FsPath path)) = doesFileExist path
|
||||
|
||||
firstJustM :: Monad m => [m (Maybe a)] -> m (Maybe a)
|
||||
firstJustM :: (Monad m) => [m (Maybe a)] -> m (Maybe a)
|
||||
firstJustM [] = pure Nothing
|
||||
firstJustM (a : as) = a >>= \x -> if isJust x then pure x else firstJustM as
|
||||
|
|
|
|||
|
|
@ -64,7 +64,7 @@ standalone = do
|
|||
=<< backendSelector (backends config)
|
||||
|
||||
standaloneWidget ::
|
||||
WidgetJSM t m =>
|
||||
(WidgetJSM t m) =>
|
||||
TQueue LocalBackendRequest ->
|
||||
R.Dynamic t (NamedBackend StandaloneAccount) ->
|
||||
m (R.Dynamic t (Maybe (StateProvider t m)))
|
||||
|
|
|
|||
|
|
@ -46,16 +46,16 @@ import Kassandra.LocalBackend (
|
|||
userConfig,
|
||||
)
|
||||
|
||||
foldToSeq :: Monad m => SerialT m a -> m (Seq a)
|
||||
foldToSeq :: (Monad m) => SerialT m a -> m (Seq a)
|
||||
foldToSeq = S.foldl' (|>) mempty
|
||||
|
||||
waitTillFalse :: MonadIO m => TVar Bool -> m ()
|
||||
waitTillFalse :: (MonadIO m) => TVar Bool -> m ()
|
||||
waitTillFalse boolTvar = (atomically . whenM (readTVar boolTvar)) retry
|
||||
concurrentWhileTrue :: TVar Bool -> IO a -> IO ()
|
||||
concurrentWhileTrue boolTvar action = race_ action (waitTillFalse boolTvar)
|
||||
lookupTMap :: (Ord k, MonadIO f) => k -> TVar (Map k a) -> f (Maybe a)
|
||||
lookupTMap key tvarMap = Map.lookup key <$> readTVarIO tvarMap
|
||||
insertOrAddTMap :: Ord k => k -> e -> TVar (Map k (Seq e)) -> STM Bool
|
||||
insertOrAddTMap :: (Ord k) => k -> e -> TVar (Map k (Seq e)) -> STM Bool
|
||||
insertOrAddTMap key entry tvarMap =
|
||||
stateTVar tvarMap \theMap ->
|
||||
second (\x -> Map.insert key x theMap) $
|
||||
|
|
@ -95,7 +95,7 @@ handleRequest req cache mapVar =
|
|||
, say "Client registered on backend"
|
||||
]
|
||||
|
||||
removeClientFromMap :: MonadIO m => LocalBackendRequest -> TVar ClientMap -> m ()
|
||||
removeClientFromMap :: (MonadIO m) => LocalBackendRequest -> TVar ClientMap -> m ()
|
||||
removeClientFromMap req mapVar = atomically (modifyTVar' mapVar updateMap)
|
||||
where
|
||||
key = localBackend . userConfig $ req
|
||||
|
|
|
|||
|
|
@ -123,7 +123,7 @@ unwrapMatrixErrorT action = do
|
|||
liftIO $ Exception.throwIO matrix_error
|
||||
Right response -> pure response
|
||||
|
||||
unwrapMatrixError :: MonadIO m => Matrix.MatrixIO a -> m a
|
||||
unwrapMatrixError :: (MonadIO m) => Matrix.MatrixIO a -> m a
|
||||
unwrapMatrixError = liftIO . unwrapMatrixErrorT
|
||||
|
||||
git :: Config -> [String] -> Process.ProcessConfig () () ()
|
||||
|
|
@ -273,8 +273,8 @@ getMissingAuthorSubscriptions pr_key author = do
|
|||
^. AuthorSubscriptionGithubLogin
|
||||
==. SQL.val author
|
||||
SQL.&&. author_sub
|
||||
^. AuthorSubscriptionUser
|
||||
`notIn` SQL.subSelectList users_subscribed_to_this_pr
|
||||
^. AuthorSubscriptionUser
|
||||
`notIn` SQL.subSelectList users_subscribed_to_this_pr
|
||||
)
|
||||
pure author_sub
|
||||
pure $ fmap (authorSubscriptionUser . Persist.entityVal) author_subs
|
||||
|
|
@ -470,9 +470,9 @@ deleteUnusedQueries = SQL.delete do
|
|||
sub <- SQL.from $ SQL.table @Subscription
|
||||
pure (sub ^. SubscriptionUser)
|
||||
&&. (query ^. QueryUser)
|
||||
`notIn` SQL.subList_select do
|
||||
sub <- SQL.from $ SQL.table @AuthorSubscription
|
||||
pure (sub ^. AuthorSubscriptionUser)
|
||||
`notIn` SQL.subList_select do
|
||||
sub <- SQL.from $ SQL.table @AuthorSubscription
|
||||
pure (sub ^. AuthorSubscriptionUser)
|
||||
|
||||
leaveEmptyRooms :: App ()
|
||||
leaveEmptyRooms = do
|
||||
|
|
|
|||
|
|
@ -208,7 +208,7 @@ processMessage msg = do
|
|||
<$> tryRight (mapLeft ("Could not decode message " <>) $ decode textPart)
|
||||
pure $ Message{date, headers = hdrs, body = either TextBody id msgEither}
|
||||
|
||||
tryHdr :: MonadIO m => ByteString -> Notmuch.Message n a -> m (Maybe Text)
|
||||
tryHdr :: (MonadIO m) => ByteString -> Notmuch.Message n a -> m (Maybe Text)
|
||||
tryHdr h msg =
|
||||
((\x -> if x /= "" then Just x else Nothing) . decodeUtf8 =<<)
|
||||
<$> Notmuch.messageHeader h msg
|
||||
|
|
|
|||
|
|
@ -36,7 +36,7 @@ infixl 9 %
|
|||
f % g = g . f
|
||||
|
||||
infixl 9 %>
|
||||
(%>) :: Functor f => (a -> f b) -> (b -> c) -> a -> f c
|
||||
(%>) :: (Functor f) => (a -> f b) -> (b -> c) -> a -> f c
|
||||
f %> g = fmap g . f
|
||||
|
||||
infixl 9 %>>
|
||||
|
|
@ -55,7 +55,7 @@ missingExecutables :: IO [FilePath]
|
|||
modes :: [Mode]
|
||||
modes = enumFrom Klausur
|
||||
|
||||
getMode :: R.MonadHeadlessApp t m => Notify.WatchManager -> FilePath -> m (R.Dynamic t Mode)
|
||||
getMode :: (R.MonadHeadlessApp t m) => Notify.WatchManager -> FilePath -> m (R.Dynamic t Mode)
|
||||
getMode watch_manager home = do
|
||||
content_event <- watchFileContents watch_manager home ".mode"
|
||||
R.holdDyn Klausur $
|
||||
|
|
@ -68,7 +68,7 @@ hush = \case
|
|||
Left _ -> Nothing
|
||||
Right x -> Just x
|
||||
|
||||
watchDir :: R.MonadHeadlessApp t m => Notify.WatchManager -> FilePath -> Bool -> Notify.ActionPredicate -> m (R.Event t Notify.Event)
|
||||
watchDir :: (R.MonadHeadlessApp t m) => Notify.WatchManager -> FilePath -> Bool -> Notify.ActionPredicate -> m (R.Event t Notify.Event)
|
||||
watchDir watch_manager path recursive predicate = do
|
||||
let watch = if recursive then Notify.watchTree else Notify.watchDir
|
||||
R.newEventWithLazyTriggerWithOnComplete \callback -> do
|
||||
|
|
@ -78,7 +78,7 @@ watchDir watch_manager path recursive predicate = do
|
|||
atomically $ putTMVar finish_callback cb
|
||||
pure $ void $ Async.async $ join $ atomically $ takeTMVar finish_callback
|
||||
|
||||
watchFile :: R.MonadHeadlessApp t m => Notify.WatchManager -> FilePath -> FilePath -> m (R.Event t ())
|
||||
watchFile :: (R.MonadHeadlessApp t m) => Notify.WatchManager -> FilePath -> FilePath -> m (R.Event t ())
|
||||
watchFile watch_manager dir file = do
|
||||
start <- R.getPostBuild
|
||||
watchDir
|
||||
|
|
@ -89,7 +89,7 @@ watchFile watch_manager dir file = do
|
|||
<&> void
|
||||
% (<> start)
|
||||
|
||||
watchFileContents :: R.MonadHeadlessApp t m => Notify.WatchManager -> FilePath -> FilePath -> m (R.Event t Text)
|
||||
watchFileContents :: (R.MonadHeadlessApp t m) => Notify.WatchManager -> FilePath -> FilePath -> m (R.Event t Text)
|
||||
watchFileContents watch_manager dir file = do
|
||||
event_event <- watchFile watch_manager dir file
|
||||
content_event <- performEventThreaded event_event \_ ->
|
||||
|
|
@ -121,13 +121,13 @@ data Module t m a
|
|||
= OldModule ((a -> IO ()) -> IO Void)
|
||||
| Module (m (R.Event t a, IO ()))
|
||||
|
||||
eventModule :: forall t m a. R.MonadHeadlessApp t m => m (R.Event t a) -> Module t m a
|
||||
eventModule :: forall t m a. (R.MonadHeadlessApp t m) => m (R.Event t a) -> Module t m a
|
||||
eventModule = \event_action -> Module $ fmap (,pass) event_action
|
||||
|
||||
separator :: Text
|
||||
separator = "\n$color1$hr\n"
|
||||
|
||||
writeVars :: R.MonadHeadlessApp t m => [R.Event t (Maybe Text)] -> m ()
|
||||
writeVars :: (R.MonadHeadlessApp t m) => [R.Event t (Maybe Text)] -> m ()
|
||||
writeVars vars = do
|
||||
writeEvent <-
|
||||
vars
|
||||
|
|
@ -144,7 +144,7 @@ writeVars vars = do
|
|||
%>> writeFileText "/run/user/1000/status-bar"
|
||||
R.performEvent_ writeEvent
|
||||
|
||||
runModules :: R.MonadHeadlessApp t m => [Module t m (Maybe Text)] -> m ()
|
||||
runModules :: (R.MonadHeadlessApp t m) => [Module t m (Maybe Text)] -> m ()
|
||||
runModules modules = do
|
||||
(vars, actions) <-
|
||||
unzip <$> forM modules \case
|
||||
|
|
@ -172,18 +172,18 @@ simpleModeModule delay mode action = eventModule do
|
|||
<&> (\event -> R.leftmost [R.updated mode, R.tag (R.current mode) event])
|
||||
performEventThreaded tick action
|
||||
|
||||
tickEvent :: R.MonadHeadlessApp t m => Int -> m (R.Event t ())
|
||||
tickEvent :: (R.MonadHeadlessApp t m) => Int -> m (R.Event t ())
|
||||
tickEvent delay =
|
||||
R.tickLossyFromPostBuildTime (realToFrac delay / realToFrac oneSecond)
|
||||
<&> void
|
||||
|
||||
withColor :: Monad m => Text -> Text -> m (Maybe Text)
|
||||
withColor :: (Monad m) => Text -> Text -> m (Maybe Text)
|
||||
withColor color content = pure $ Just (withColor' color content)
|
||||
|
||||
withColor' :: Text -> Text -> Text
|
||||
withColor' color content = [i|${color \##{color}}#{content}|]
|
||||
|
||||
when' :: Monad m => Bool -> m (Maybe a) -> m (Maybe a)
|
||||
when' :: (Monad m) => Bool -> m (Maybe a) -> m (Maybe a)
|
||||
when' cond result = if cond then result else pure Nothing
|
||||
|
||||
playerCTLFormat :: String
|
||||
|
|
@ -192,7 +192,7 @@ playerCTLFormat = "@{{status}} {{title}} | {{album}} | {{artist}}"
|
|||
data EventRunnerState a = Idle | Running | NextWaiting a
|
||||
|
||||
-- Call IO action in a separate thread. If multiple events fire never run two actions in parallel and if more than one action queues up, only run the latest.
|
||||
performEventThreaded :: R.MonadHeadlessApp t m => R.Event t a -> (a -> IO b) -> m (R.Event t b)
|
||||
performEventThreaded :: (R.MonadHeadlessApp t m) => R.Event t a -> (a -> IO b) -> m (R.Event t b)
|
||||
performEventThreaded event action = do
|
||||
runnerState <- liftIO $ newTVarIO Idle
|
||||
R.performEventAsync $
|
||||
|
|
@ -210,7 +210,7 @@ performEventThreaded event action = do
|
|||
NextWaiting{} -> (False, NextWaiting input)
|
||||
when run $ void $ Async.async $ runner input
|
||||
|
||||
playerModule :: forall t m. R.MonadHeadlessApp t m => FilePath -> Module t m (Maybe Text)
|
||||
playerModule :: forall t m. (R.MonadHeadlessApp t m) => FilePath -> Module t m (Maybe Text)
|
||||
playerModule home = Module do
|
||||
(event, trigger) <- R.newTriggerEvent
|
||||
pure (event, listenToPlayer trigger)
|
||||
|
|
|
|||
|
|
@ -108,7 +108,7 @@ menu = runMenu True
|
|||
promptLabel :: (Char, MenuEntry a) -> [Char]
|
||||
promptLabel (c, option) = toUpper c : (": " <> getLabel option)
|
||||
|
||||
confirm :: Character :<: m => Text -> Wizard m Bool
|
||||
confirm :: (Character :<: m) => Text -> Wizard m Bool
|
||||
confirm prompt =
|
||||
menu Nothing $ Menu prompt [Option "Yes" True, Option "No" False]
|
||||
|
||||
|
|
@ -135,8 +135,8 @@ getLineWithDefaultAndSuggestions prompt startInput completions =
|
|||
match = filter (isInfixOf $ reverse before)
|
||||
prewritten = fromMaybe "" startInput
|
||||
|
||||
runHaskeline :: MonadIO m => Wizard Haskeline a -> m (Maybe a)
|
||||
runHaskeline :: (MonadIO m) => Wizard Haskeline a -> m (Maybe a)
|
||||
runHaskeline = liftIO . runInputT defaultSettings . run
|
||||
|
||||
runClearingHaskeline :: MonadIO m => Wizard Haskeline a -> m (Maybe a)
|
||||
runClearingHaskeline :: (MonadIO m) => Wizard Haskeline a -> m (Maybe a)
|
||||
runClearingHaskeline = liftIO . runInputT defaultSettings . runClearing . run
|
||||
|
|
|
|||
Loading…
Reference in a new issue