spacekitteh
commented
4 years ago Neat!
Also, some of those effects look pretty interesting; are you up for putting any of them in polysemy-zoo?
Closed isovector closed 3 years ago
spacekitteh
commented
4 years ago Neat!
Also, some of those effects look pretty interesting; are you up for putting any of them in polysemy-zoo?
ocharles
commented
4 years ago Can we see the other side? That is, the .hs for this core?
isovector
commented
4 years ago @ocharles it's a big project I'm working on for https://www.patreon.com/designandinterpretation, so I'm not ready releasing it in it's full glory yet. But here's the meat, sans interpreters:
handleCommand
:: Members
'[ ContentStore (AST v)
, HashNaming
, Output Message
, ScratchMgr v
, State (LastLoadedSnippets v)
] r
=> Command
-> Sem r ()
handleCommand (RenameName src dst) =
runError (renameName src dst) >>= \case
Left err -> output $ LookupFailure err
Right () -> output $ Renamed src dst
handleCommand (LoadSnippet name) =
runError (loadSnippet name) >>= \case
Left err -> output $ LookupFailure err
Right () -> output $ WroteSnippet name
handleCommand ReloadScratch =
reloadScratch >>= \case
Just snippets -> do
put $ LastLoadedSnippets snippets
output $ LoadedSnippets $ fmap fst snippets
Nothing -> do
put $ LastLoadedSnippets []
output SnippetLoadError
handleCommand (CommitSnippet name) = do
LastLoadedSnippets snippets <- get
case lookup name snippets of
Just ast -> do
commitSnippet [(name, ast)]
output $ CommittedSnippets [name]
Nothing -> output $ UnknownSnippet name
handleCommand Quit = pure ()
{-# INLINABLE handleCommand #-}
runAsDaemon
:: Member (Input i) r
=> (i -> Sem r Bool)
-> (i -> Sem r ())
-> Sem r ()
runAsDaemon should_quit action = do
i <- input
should_quit i >>= \case
True -> pure ()
False -> do
action i
runAsDaemon should_quit action
{-# INLINABLE runAsDaemon #-}
daemon
:: Members
'[ ContentStore (AST v)
, HashNaming
, Input Command
, Output Message
, ScratchMgr v
, State (LastLoadedSnippets v)
] r
=> Sem r ()
daemon = runAsDaemon (pure . (== Quit)) handleCommand
{-# INLINABLE daemon #-}
main :: IO ()
main = runFinal
$ embedToFinal
$ traceToIO
$ runInputSem (embed readLn)
$ inputToFileWatch scratch
$ runInputViaInfiniteStream inputStream
$ runOutputSem (embed . putStrLn . messageToString)
$ filesystemToIO
$ debugTraceEffect @Filesystem
$ runMarkdownSubsystemsToFilesystem scratch
$ evalState (LastLoadedSnippets mempty)
$ daemon
{-# SPECIALIZE
daemon :: Sem '[ State (LastLoadedSnippets [Block])
, ContentStore (AST [Block])
, ScratchMgr [Block]
, LanguageProvider [Block]
, Serdes [Block]
, HashNaming
, Filesystem
, Output Message
, Input Command
, Input Event
, Input Command
, Trace
, Embed IO
, Final IO
] ()
#-}
I just finished writing a real program, and have some core to look at. This thing has an explicit
SPECIALIZEpragma on the mainSementry point. This is with loopbreaker turned off (because it's broken.... @TheMatten ;) ), but it looks like most of the core should get specialized away with GHC 8.10's !668.Thought I'd share; this is way more promising than I was expecting.